git.fiddlerwoaroof.com
Browse code

Import to github.

Yale AI Dept authored on 14/07/1993 18:08:00
Showing 390 changed files
Copyright
History View file @ 4e98702
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,18 @@
1 
+Copyright (c) 1991 Yale University Computer Science Department
2 
+
3 
+Yale Haskell System Version 2.0-beta
4 
+
5 
+Permission to copy this software, to redistribute it, and to use it for any
6 
+purpose is granted, subject to the following restrictions and understandings.
7 
+
8 
+1. Any copy made of this software must include this copyright notice in full.
9 
+2. All materials developed as a consequence of the use of this software
10 
+   shall duly acknowledge such use, in accordance with the usual standards
11 
+   of acknowledging credit in academic research.
12 
+3. Yale has made no warrantee or representation that the operation of
13 
+   this software will be error-free, and Yale is under no obligation to
14 
+   provide any services, by way of maintenance, update, or otherwise.
15 
+4. In conjunction with products arising from the use of this material,
16 
+   there shall be no use of the name of the Yale University nor of any
17 
+   adaptation thereof in any advertising, promotional, or sales literature
18 
+   without prior written consent from Yale in each case.
README
History View file @ 4e98702
0 19 
new file mode 100644
... ... 
@@ -0,0 +1,37 @@
1 
+This is the main directory for the 2.x release of Yale Haskell.  This
2 
+file contains some basic information about how the system is organized
3 
+and put together.
4 
+
5 
+You should set the variable $HASKELL and source the haskell-setup
6 
+script in this directory before attempting to use Yale Haskell.
7 
+
8 
+If you are rebuilding from the source release, see the scripts and
9 
+README files in the $HASKELL/com area.  You also need to modify
10 
+the haskell-development script.
11 
+
12 
+Yale-specific information:
13 
+
14 
+Source files in this directory area are under RCS control.  Use the
15 
+`rci' and `rco' aliases (from haskell-development) to check things in
16 
+and out.  By convention, each directory containing source files should
17 
+have subdirectories named RCS (for RCS files), t (for compiled T
18 
+files), lucid (for compiled Lucid CL files), and cmu (for compiled CMU
19 
+CL files).
20 
+
21 
+Each subdirectory containing source files should also have a file that
22 
+defines a compilation unit for that subdirectory.  (See
23 
+support/compile.scm for information about the compilation unit
24 
+utility.)  support/system.scm loads all the compilation unit definitions.
25 
+
26 
+To load the system into Common Lisp, you need to load the file
27 
+support/cl-support/cl-init.lisp.  This will automagically compile any
28 
+outdated or missing files.  However, you need to type in an
29 
+(in-package "MUMBLE-USER") once it finishes.
30 
+
31 
+Don't try to load the system into T.  It's broken!  See
32 
+support/t-support/t-init.t.
33 
+
34 
+All system-dependent code goes in either support/cl-support or
35 
+support/t-support.  For information about the mumble compatibility
36 
+package used as the implementation language for the rest of the
37 
+system, see support/mumble.txt.
ast/README
History View file @ 4e98702
0 38 
new file mode 100644
... ... 
@@ -0,0 +1,29 @@
1 
+This directory defines the primary data structures used in the compiler
2 
+using the `define-struct' macro defined in the struct directory.
3 
+
4 
+Structures are divided into the following catagories:
5 
+
6 
+Basic structures: (basic-structs)
7 
+  References to variables, data constructors, classes, type constructors
8 
+    All references contain the name of the object referred to and a
9 
+    field that will receive the actual definition object when scoping
10 
+    has been resolved.
11 
+  Fixity: (l | n | r, Int)
12 
+
13 
+Module structures: (module-structs)
14 
+  The module ast, import & export related ast's, and fixity definition.
15 
+
16 
+Type system structures: (type-structs)
17 
+  The representation of data types and the type related declarations:
18 
+  type, data, class, and instance.
19 
+
20 
+Value declarations: (valdef-structs)
21 
+
22 
+Expressions: (expr-structs)
23 
+
24 
+Definitions: (definition-structs)
25 
+
26 
+Flic structures: (flic-structs)
27 
+
28 
+
29 
+
ast/ast-td.scm
History View file @ 4e98702
0 30 
new file mode 100644
... ... 
@@ -0,0 +1,20 @@
1 
+;;; ast-td.scm -- define ast type descriptor object
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  6 Oct 1992
5 
+;;;
6 
+
7 
+
8 
+;;; Give the type descriptors for AST nodes extra slots to hold walker
9 
+;;; functions.
10 
+
11 
+(define-struct ast-td
12 
+  (include type-descriptor)
13 
+  (slots
14 
+    (cfn-walker (type (maybe procedure)) (default '#f))
15 
+    (cfn-simple-transform-walker (type (maybe procedure)) (default '#f))
16 
+    (depend-walker (type (maybe procedure)) (default '#f))
17 
+    (ast-to-flic-walker (type (maybe procedure)) (default '#f))
18 
+    (scope-walker (type (maybe procedure)) (default '#f))
19 
+    (type-walker (type (maybe procedure)) (default '#f))
20 
+    (collect-pattern-vars-walker (type (maybe procedure)) (default '#f))))
ast/ast.scm
History View file @ 4e98702
0 21 
new file mode 100644
... ... 
@@ -0,0 +1,33 @@
1 
+;;; ast.scm -- compilation unit definition for ast definitions
2 
+;;;
3 
+;;; author :  John
4 
+;;; date   :  10 Dec 1991
5 
+;;;
6 
+
7 
+
8 
+(define-compilation-unit ast
9 
+  (source-filename "$Y2/ast/")
10 
+  (unit ast-td
11 
+    (source-filename "ast-td"))
12 
+  (unit modules
13 
+    (source-filename "modules.scm")
14 
+    (require ast-td))
15 
+  (unit type-structs
16 
+    (source-filename "type-structs.scm")
17 
+    (require ast-td modules))
18 
+  (unit tc-structs
19 
+    (source-filename "tc-structs.scm")
20 
+    (require ast-td modules))
21 
+  (unit valdef-structs
22 
+    (source-filename "valdef-structs.scm")
23 
+    (require ast-td modules))
24 
+  (unit definitions
25 
+    (source-filename "definitions.scm")
26 
+    (require ast-td modules))
27 
+  (unit exp-structs
28 
+    (source-filename "exp-structs.scm")
29 
+    (require ast-td modules))
30 
+  (unit predicates
31 
+    (require ast-td modules type-structs valdef-structs definitions
32 
+	     exp-structs tc-structs)
33 
+    (source-filename "predicates.scm")))
ast/definitions.scm
History View file @ 4e98702
0 34 
new file mode 100644
... ... 
@@ -0,0 +1,209 @@
1 
+;;; File: ast/definitions.scm   Author: John
2 
+
3 
+;;; this file contains definitions for the named entities in the
4 
+;;; system.  These are used in both the front and back ends of the
5 
+;;; compiler.  These are created early in the compilation process
6 
+;;; (import/export) and filled in during compilation.  Binary interface
7 
+;;; files are just tables mapping names to definitions.
8 
+
9 
+;;; All definitions have these fields for managing name spaces.  All
10 
+;;; names are uniquified; this requires adding `;' to the front of data
11 
+;;; constructors to separate them from type constructors.  Module names
12 
+;;; do not have a `definition' data structure - the `module' structure
13 
+;;; serves the same purpose.
14 
+
15 
+;;; Definitions are found in two places: the symbol tables which are part of
16 
+;;; the module structure and the -ref nodes in the ast structure.  The -ref
17 
+;;; nodes have two fields: a name (from the parser) and a field which will
18 
+;;; point to the associated definition after name resolution.  Name resolution
19 
+;;; happens in a number of different places: top level definitions are
20 
+;;; resolved during import-export, type declarations are resolved during
21 
+;;; type declaration analysis, and everything else is resolved during scoping
22 
+;;; (alpha conversion).  The parser generates pre-resolved -ref nodes when
23 
+;;; parsing some constructs.  These refs denote pre-defined language
24 
+;;; constructs, such as lists, tuples, or prelude functions.
25 
+
26 
+;;; A special set of definitions constitutes the `core' of Haskell.  These
27 
+;;; definitions are pre-allocated and are filled in during the compilation
28 
+;;; of the Prelude.  This allows the bootstrap of the system.
29 
+
30 
+
31 
+;;; All defs require name, unit, and module args to make.
32 
+;;; Other slots should all have appropriate defaults.
33 
+
34 
+(define-struct def
35 
+  (slots
36 
+   ;; the uniquified name (from the definition)
37 
+   (name (type symbol))
38 
+   ;; compilation unit defined in
39 
+   (unit (type symbol))
40 
+   ;; name of the defining module
41 
+   (module (type symbol))
42 
+   ;; used by the closure check
43 
+   (exported? (type bool) (default '#f) (bit #t))
44 
+   ;; for symbols in `core' Haskell; special case for IO
45 
+   (core? (type bool) (default '#f) (bit #t))
46 
+   ;; Always a core sym.  Used to avoid putting in sym table
47 
+   (prelude? (type bool) (default '#f) (bit #t))
48 
+   ))
49 
+
50 
+
51 
+
52 
+;;; Variable information
53 
+
54 
+(define-struct var
55 
+  (include def)
56 
+  (predicate var?)
57 
+  (slots
58 
+   ;; inferred during type inference
59 
+   (type             (type (maybe ntype))     (default '#f))
60 
+   ;; type affixed by sign-decl or class decl
61 
+   (signature        (type (maybe ntype))     (default '#f))
62 
+   (interface-type   (type (maybe ntype))     (default '#f))
63 
+   ;; most variables have no fixity information.
64 
+   (fixity           (type (maybe fixity))    (default '#f))
65 
+   ;; The following attributes are used by the backend
66 
+   (selector-fn?     (type bool)              (default '#f) (bit #t))
67 
+   (force-strict?    (type bool)              (default '#f) (bit #t))
68 
+   (force-inline?    (type bool)              (default '#f) (bit #t))
69 
+   (toplevel?        (type bool)              (default '#f) (bit #t))
70 
+   (simple?          (type bool)              (default '#f) (bit #t))
71 
+   (strict?          (type bool)              (default '#f) (bit #t))
72 
+   (optimized-refs?  (type bool)              (default '#f) (bit #t))
73 
+   (standard-refs?   (type bool)              (default '#f) (bit #t))
74 
+   (single-ref       (type (maybe int))       (default '#f))
75 
+   (arity            (type int)               (default 0))
76 
+   (referenced       (type int)               (default 0))
77 
+   (value            (type (maybe flic-exp))  (default '#f))
78 
+   (fullname         (type (maybe symbol))    (default '#f))
79 
+   (inline-value     (type (maybe flic-exp))  (default '#f))
80 
+   ;; Only function bindings use these slots
81 
+   (strictness       (type (list bool))       (default '()))
82 
+   (complexity       (type (maybe int))       (default '#f))
83 
+   (optimized-entry  (type (maybe symbol))    (default '#f))
84 
+   (annotations      (type (list annotation-value)) (default '()))
85 
+   (fn-referenced    (type int)               (default 0))
86 
+   (arg-invariant-value  (type (maybe flic-exp))  (default '#f))
87 
+   (arg-invariant?   (type bool)              (default '#f) (bit #t))
88 
+   ))
89 
+
90 
+
91 
+;;; This defines an individual class method
92 
+
93 
+(define-struct method-var
94 
+  (include var)
95 
+  (predicate method-var?)
96 
+  (slots
97 
+   (class (type class) (uninitialized? #t))
98 
+   (default (type (maybe var)) (uninitialized? #t))
99 
+   (method-signature (type signature) (uninitialized? #t))))
100 
+
101 
+
102 
+;;; A data constructor
103 
+
104 
+(define-struct con
105 
+  (include def)
106 
+  (predicate con?)
107 
+  (slots
108 
+   ;; These slots are initialized in the type declaration phase
109 
+   (arity (type int) (uninitialized? #t))
110 
+   (types (type (list type)) (uninitialized? #t))
111 
+   (slot-strict? (type (list bool)) (default '()))
112 
+   (tag (type int) (uninitialized? #t))
113 
+   (alg (type algdata) (uninitialized? #t))
114 
+   (infix? (type bool) (bit #t) (default '#f))
115 
+   (signature (type ntype) (uninitialized? #t))
116 
+   ;; Assigned during import-export phase
117 
+   (fixity (type (maybe fixity)) (default '#f))
118 
+   (lisp-fns (type t) (default '()))
119 
+   ))
120 
+
121 
+
122 
+;;; Definitions used by the type system.
123 
+
124 
+(define-struct tycon-def
125 
+  (include def)
126 
+  (slots
127 
+   (arity (type integer) (default -1))))
128 
+
129 
+(define-struct synonym
130 
+  (include tycon-def)
131 
+  (predicate synonym?)
132 
+  (slots
133 
+   ;; These slots are explicitly initialized in the type declaration phase.
134 
+   (args (type (list symbol)) (uninitialized? #t))
135 
+   (body (type type) (uninitialized? #t))  ; stored in ast form
136 
+   ))
137 
+
138 
+(define-struct algdata
139 
+  (include tycon-def)
140 
+  (predicate algdata?)
141 
+  (slots
142 
+   ;; These slots are initialized explicitly in the type declaration phase
143 
+   ;; number of constructors
144 
+   (n-constr (type int) (uninitialized? #t))
145 
+   (constrs (type (list con)) (uninitialized? #t))
146 
+   (context (type (list context)) (uninitialized? #t))
147 
+   ;; arguments to tycon
148 
+   (tyvars (type (list symbol)) (uninitialized? #t))
149 
+   ;; signature for the type as a whole
150 
+   (signature (type (maybe ntype)) (default '#f))
151 
+   ;; classes this algdata is an instance of
152 
+   (classes (type (list class)) (uninitialized? #t))
153 
+   ;; true if all constructors have 0 arity
154 
+   (enum? (type bool) (bit #t) (uninitialized? #t))
155 
+   ;; true when only constructor
156 
+   (tuple? (type bool) (bit #t) (uninitialized? #t))
157 
+   ;; true for `tuple-syntax' tuples.
158 
+   (real-tuple? (type bool) (bit #t) (uninitialized? #t))
159 
+   ;; instances to derive
160 
+   (deriving (type (list class)) (uninitialized? #t))
161 
+   (export-to-lisp? (type bool) (default '#f) (bit #t))
162 
+   (implemented-by-lisp? (type bool) (default '#f) (bit #t))
163 
+   ))
164 
+
165 
+(define-struct class
166 
+  (include def)
167 
+  (predicate class?)
168 
+  (slots
169 
+   ;; These slots are initialized in the import-export phase
170 
+   (method-vars (type (list method-var)) (uninitialized? #t))
171 
+   ;; These slots are explicitly initialized in the type declaration phase
172 
+   ;; immediate superclasses
173 
+   (super (type (list class)) (uninitialized? #t))
174 
+   ;; all superclasses
175 
+   (super* (type (list class)) (uninitialized? #t))
176 
+   ;; name of class type variable
177 
+   (tyvar (type symbol) (uninitialized? #t))
178 
+   (instances (type (list instance)) (uninitialized? #t))
179 
+   (kind (type (enum standard numeric other)) (uninitialized? #t))
180 
+   (n-methods (type int) (uninitialized? #t))
181 
+   (dict-size (type int) (uninitialized? #t))
182 
+   (selectors (type (list (tuple method-var var))) (uninitialized? #t))
183 
+   ))
184 
+
185 
+;;; Since instances are not named there is no need to include def.
186 
+
187 
+(define-struct instance
188 
+  (include ast-node)
189 
+  (slots
190 
+   ;; These slots always have initializers supplied with MAKE.
191 
+   (algdata (type algdata))
192 
+   (tyvars (type (list symbol)))
193 
+   (class (type class))
194 
+   (context (type (list context)))
195 
+   (gcontext (type (list (list class))))
196 
+   (dictionary (type var))
197 
+
198 
+   ;; Explicitly initialized during the type declaration phase.
199 
+   (methods (type (list (tuple method-var var))) (uninitialized? #t))
200 
+
201 
+   ;; These slots usually default on creation.
202 
+   (decls (type (list decl)) (default '()))
203 
+   ;; used during verification of derived instances
204 
+   (ok? (type bool) (bit #t) (default #f))
205 
+   ;; marks magically generated tuple instances
206 
+   (special? (type bool) (bit #t) (default #f))
207 
+   (suppress-readers? (type bool) (bit #t) (default #f))
208 
+   ))
209 
+
ast/exp-structs.scm
History View file @ 4e98702
0 210 
new file mode 100644
... ... 
@@ -0,0 +1,386 @@
1 
+;;; File: ast/exp-structs     Author: John
2 
+
3 
+;;; These ast structures define the expression syntax
4 
+
5 
+
6 
+;;; This is simplified; there are additional rules for associativity and
7 
+;;; precedence.
8 
+;;;
9 
+;;; <exp>  -> <lambda-exp>
10 
+;;;        -> <let-exp>
11 
+;;;        -> <if-exp>
12 
+;;;        -> <case-exp>
13 
+;;;        -> <signature-exp>
14 
+;;;        -> <exp> <op> <exp>           ; treated like <fn-app>
15 
+;;;        -> - <exp>
16 
+;;;        -> <fn-app>
17 
+;;;        -> <aexp>
18 
+;;;
19 
+
20 
+(define-struct exp
21 
+  (include ast-node))
22 
+
23 
+
24 
+;;; <lambda-exp> -> \ <apat> ... <apat> -> <exp>
25 
+
26 
+(define-struct lambda
27 
+  (include exp)
28 
+  (slots
29 
+   (pats (type (list pattern)))
30 
+   (body (type exp))))
31 
+
32 
+;;; <let-exp> -> let { <decls> [;] } in <exp>
33 
+
34 
+(define-struct let
35 
+  (include exp)
36 
+  (slots
37 
+   (decls (type (list decl)))
38 
+   (body (type exp))))
39 
+
40 
+;;; <if-exp> -> if <exp> then <exp> else <exp>
41 
+
42 
+(define-struct if
43 
+  (include exp)
44 
+  (slots
45 
+   (test-exp (type exp))
46 
+   (then-exp (type exp))
47 
+   (else-exp (type exp))))
48 
+
49 
+
50 
+;;; <case-exp> -> case <exp> of { <alts> [;] }
51 
+;;;
52 
+;;; <alts>     -> <alt> ; ... ; <alt>
53 
+;;;
54 
+;;; <alt>      -> <pat> -> exp  [where { <decls> [;] } ]
55 
+;;;            -> <pat> <gdpat> [where { <decls> [;] } ]
56 
+
57 
+(define-struct case
58 
+  (include exp)
59 
+  (slots
60 
+   (exp (type exp))
61 
+   (alts (type (list alt)))))
62 
+
63 
+(define-struct alt
64 
+  (include ast-node)
65 
+  (slots
66 
+   (pat (type pattern))
67 
+   ;; defined in valdef-structs
68 
+   (rhs-list (type (list guarded-rhs)))
69 
+   (where-decls (type (list decl)))
70 
+   ;; used internally by cfn
71 
+   (test (type (maybe exp)) (default '#f))
72 
+   ))
73 
+
74 
+;;; <signature-exp> -> <exp> :: [<context> =>] <atype>
75 
+
76 
+(define-struct exp-sign
77 
+  (include exp)
78 
+  (slots
79 
+   (exp (type exp))
80 
+   (signature (type signature))))
81 
+
82 
+
83 
+;;; <fn-app> -> <exp> <aexp>
84 
+
85 
+(define-struct app
86 
+  (include exp)
87 
+  (predicate app?)
88 
+  (slots
89 
+   (fn (type exp))
90 
+   (arg (type exp))))
91 
+
92 
+;;; <aexp> -> <var>                                var-ref
93 
+;;;        -> <con>                                con-ref
94 
+;;;        -> <literal>                            const
95 
+;;;        -> ()                                   constructor is Unit
96 
+;;;        -> ( <exp> )
97 
+;;;        -> ( <exp> , ... , <exp> )              constructor is a tuple
98 
+;;;        -> [ <exp> , ... , <exp> ]              list
99 
+;;;        -> <sequence>
100 
+;;;        -> [exp> | <qual> , ... , <qual>]       list-comp
101 
+;;;        -> ( <exp> <op> )                       section-r
102 
+;;;        -> ( <op> <exp> )                       section-l
103 
+;;;
104 
+
105 
+(define-struct aexp
106 
+  (include exp))
107 
+
108 
+
109 
+(define-struct var-ref
110 
+  (include aexp)
111 
+  (predicate var-ref?)
112 
+  (slots
113 
+   (name (type symbol))
114 
+   (var (type def))
115 
+   (infix? (type bool) (bit #t))))
116 
+
117 
+(define-struct con-ref
118 
+  (include aexp)
119 
+  (predicate con-ref?)
120 
+  (slots
121 
+   (name (type symbol))
122 
+   (con (type def))
123 
+   (infix? (type bool) (bit #t))))
124 
+
125 
+(define-struct const
126 
+  (include aexp)
127 
+  (slots
128 
+   (overloaded? (type bool) (default '#t) (bit #t))))
129 
+
130 
+(define-struct integer-const
131 
+  (include const)
132 
+  (predicate integer-const?)
133 
+  (slots
134 
+   (value (type integer))))
135 
+
136 
+(define-struct float-const
137 
+  (include const)
138 
+  (predicate float-const?)
139 
+  (slots
140 
+   (numerator (type integer))
141 
+   (denominator (type integer))
142 
+   (exponent (type integer))))
143 
+
144 
+(define-struct char-const
145 
+  (include const)
146 
+  (predicate char-const?)
147 
+  (slots
148 
+   (value (type char))))
149 
+
150 
+(define-struct string-const
151 
+  (include const)
152 
+  (predicate string-const?)
153 
+  (slots
154 
+   (value (type string))))
155 
+
156 
+(define-struct list-exp
157 
+  (include aexp)
158 
+  (slots
159 
+   (exps (type (list exp)))))
160 
+
161 
+
162 
+;;; <sequence> -> [ <exp> .. ]                  sequence
163 
+;;;            -> [ <exp>, <exp> .. ]           sequence-then
164 
+;;;            -> [ <exp> .. <exp> ]            sequence-to
165 
+;;;            -> [ <exp>, <exp> .. <exp> ]     sequence-then-to
166 
+
167 
+(define-struct sequence
168 
+  (include aexp)
169 
+  (slots
170 
+   (from (type exp))))
171 
+
172 
+(define-struct sequence-to
173 
+  (include aexp)
174 
+  (slots
175 
+   (from (type exp))
176 
+   (to (type exp))))
177 
+
178 
+
179 
+(define-struct sequence-then
180 
+  (include aexp)
181 
+  (slots
182 
+   (from (type exp))
183 
+   (then (type exp))))
184 
+
185 
+(define-struct sequence-then-to
186 
+  (include aexp)
187 
+  (slots
188 
+   (from (type exp))
189 
+   (then (type exp))
190 
+   (to (type exp))))
191 
+
192 
+(define-struct list-comp
193 
+  (include aexp)
194 
+  (slots
195 
+   (exp (type exp))
196 
+   (quals (type (list qual)))))
197 
+
198 
+;;; Op on left
199 
+(define-struct section-l
200 
+  (include aexp)
201 
+  (slots
202 
+   (exp (type exp))
203 
+   (op (type exp))))  ; either con-ref or var-ref
204 
+
205 
+(define-struct section-r
206 
+  (include aexp)
207 
+  (slots
208 
+   (exp (type exp))
209 
+   (op (type exp))))  ; either con-ref or var-ref
210 
+
211 
+;;; <qual> -> <pat> <- <exp>
212 
+;;;        -> <exp>
213 
+
214 
+(define-struct qual
215 
+  (include ast-node))
216 
+
217 
+(define-struct qual-generator
218 
+  (include qual)
219 
+  (slots
220 
+   (pat (type pattern))
221 
+   (exp (type exp))))
222 
+
223 
+(define-struct qual-filter
224 
+  (include qual)
225 
+  (slots
226 
+   (exp (type exp))))
227 
+
228 
+
229 
+;;; This is used as the guard slot in a guarded-rhs to represent lack of a
230 
+;;; guard.  This is the same as True.
231 
+
232 
+(define-struct omitted-guard ; same as True; should print in the guardless form
233 
+  (include exp))
234 
+
235 
+
236 
+;;; These structures are used by the precedence parser.
237 
+
238 
+(define-struct pp-exp-list  ; list of expressions & ops for the prec parser
239 
+  (include exp)
240 
+  (slots
241 
+   (exps (type (list exp)))))
242 
+
243 
+;; This is a place holder for unary negation in pp-exp expressions.  It is
244 
+;; changed to call the negate function by the prec parser
245 
+
246 
+(define-struct negate
247 
+  (include exp)
248 
+  (predicate negate?))
249 
+
250 
+;; Note: operators are var / con structures with infix? set to #t
251 
+
252 
+;;; The following ast nodes do not directly correspond to Haskell syntax.
253 
+;;; They are generated during internal code transformations.
254 
+
255 
+;;; This returns a number (an Int) associated with the constructor of a
256 
+;;; value.
257 
+
258 
+(define-struct con-number
259 
+  (include exp)
260 
+  (slots
261 
+    (type (type algdata))
262 
+    (value (type exp))))
263 
+
264 
+;;; This selects a value (denoted by the Int in slot) from a data object
265 
+;;; created by a specified constructor.
266 
+
267 
+(define-struct sel
268 
+  (include exp)
269 
+  (slots
270 
+    (constructor (type con))
271 
+    (slot (type int))
272 
+    (value (type exp))))
273 
+
274 
+;;; This returns True if the data value was built with the designated
275 
+;;; constructor
276 
+
277 
+(define-struct is-constructor
278 
+  (include exp)
279 
+  (slots
280 
+   (constructor (type con))
281 
+   (value (type exp))))
282 
+
283 
+;;; this is for the type checker only.  It turns off
284 
+;;; type checking for the argument.
285 
+
286 
+(define-struct cast
287 
+  (include exp)
288 
+  (slots
289 
+   (exp (type exp))))
290 
+
291 
+;; this is used as the body of the let generated by
292 
+;; dependency analysis
293 
+
294 
+(define-struct void
295 
+  (include exp)
296 
+  (predicate void?))
297 
+
298 
+
299 
+;;; These structures are for the type checker.  They serve as a placeholder
300 
+;;; for values which will evaluate to methods or dictionaries.
301 
+
302 
+(define-struct placeholder
303 
+  (include exp)
304 
+  (predicate placeholder?)
305 
+  (slots
306 
+   (exp (type (maybe exp)))
307 
+   (tyvar (type ntype))
308 
+   (overloaded-var (type exp))
309 
+   (enclosing-decls (type (list decl)))))
310 
+
311 
+(define-struct method-placeholder
312 
+  (include placeholder)
313 
+  (predicate method-placeholder?)
314 
+  (slots
315 
+   ;; the method to be dispatched
316 
+   (method (type method-var))
317 
+   ))
318 
+
319 
+(define-struct dict-placeholder
320 
+  (include placeholder)
321 
+  (predicate dict-placeholder?)
322 
+  (slots
323 
+   ;; the class of dictionary needed
324 
+   (class (type class))))
325 
+
326 
+(define-struct recursive-placeholder
327 
+  (include exp)
328 
+  (slots
329 
+   (var (type var))
330 
+   (enclosing-decls (type (list decl)))
331 
+   ;; this holds the code associated with recursive
332 
+   ;; functions or variables.  This code instantiates
333 
+   ;; the recursive context if necessary.
334 
+   (exp (type (maybe exp)))
335 
+   ))
336 
+
337 
+;;; This is used in primitive modules only.  It holds the definition of
338 
+;;; a lisp level primitive.
339 
+
340 
+(define-struct prim-definition
341 
+  (include exp)
342 
+  (slots
343 
+   (lisp-name (type symbol))
344 
+   (atts (type (list (tuple symbol t))))))
345 
+
346 
+;;; This is used by the type checker to hang on to the original
347 
+;;; version of a program for message printing.  This is removed by
348 
+;;; the cfn pass.
349 
+
350 
+(define-struct save-old-exp
351 
+  (include exp)
352 
+  (slots
353 
+   (old-exp (type exp))
354 
+   (new-exp (type exp))))
355 
+
356 
+
357 
+;;; This is used for type checking overloaded methods.
358 
+
359 
+(define-struct overloaded-var-ref
360 
+  (include exp)
361 
+  (slots
362 
+    (var (type var))
363 
+    (sig (type ntype))))
364 
+
365 
+
366 
+
367 
+;;; These are used by the CFN.
368 
+
369 
+
370 
+(define-struct case-block
371 
+  (include exp)
372 
+  (slots
373 
+    (block-name (type symbol))
374 
+    (exps       (type (list exp)))))
375 
+
376 
+(define-struct return-from
377 
+  (include exp)
378 
+  (slots
379 
+    (block-name (type symbol))
380 
+    (exp        (type exp))))
381 
+
382 
+(define-struct and-exp
383 
+  (include exp)
384 
+  (slots
385 
+    (exps       (type (list exp)))))
386 
+
ast/modules.scm
History View file @ 4e98702
0 387 
new file mode 100644
... ... 
@@ -0,0 +1,252 @@
1 
+;;;  File: ast/module-structs   Author: John
2 
+
3 
+;;; This contains AST structures which define the basic module structure.
4 
+;;; This is just the skeleton module structure: module, imports, exports,
5 
+;;; fixity, and default decls.
6 
+
7 
+;;; AST nodes defined in the file:
8 
+;;;  module  import-decl  entity  entity-module  entity-var  entity-con
9 
+;;;  entity-class  entity-abbreviated  entity-datatype  fixity-decl
10 
+
11 
+
12 
+
13 
+;;; All AST structs inherit from ast-node.  Not instantiated directly.
14 
+;;; The line-number is a back pointer to the source code.
15 
+
16 
+(define-struct ast-node
17 
+  (type-template ast-td)
18 
+  (slots
19 
+   (line-number (type (maybe source-pointer)) (default '#f))))
20 
+
21 
+(define-struct source-pointer
22 
+  (slots
23 
+   (line (type int))
24 
+   (file (type string))))
25 
+
26 
+;;; <module> -> module <modid> [<exports>] where <body>
27 
+;;;          -> <body>
28 
+;;;
29 
+;;; <exports> -> ( <export>, ... <export> )
30 
+;;;
31 
+;;; <body>   -> { [<impdecls>;] [[<fixdecls>;] <topdecls> [;]] }
32 
+;;;          -> { <impdecls> [;] }
33 
+;;;
34 
+;;; <impdecls> -> <impdecl> ; ... ; <impdecl>
35 
+;;;
36 
+;;; <fixdecls> -> <fix> ; ... ; <fix>
37 
+;;;
38 
+;;; <topdecls> -> <topdecl> ; ... ; <topdecl>
39 
+;;;
40 
+;;; <topdecl> -> <synonym-decl>
41 
+;;;           -> <algdata-decl>
42 
+;;;           -> <class-decl>
43 
+;;;           -> <instance-decl>
44 
+;;;           -> <default-decl>
45 
+;;;           -> <sign-decl>
46 
+;;;           -> <valdef>
47 
+
48 
+;;; The module struct is used to represent the program internally.  Binary
49 
+;;; files containing interface information contain these structures.
50 
+;;; Most compiler passes operate on this structure.  A table maps module
51 
+;;; names to this structure.  Within the module structure, local names are
52 
+;;; mapped to definitions.
53 
+
54 
+;;; Modules are also used to represent interfaces & primitives.
55 
+;;; Some of the module fields may be blank for non-standard modules.
56 
+
57 
+(define-struct module
58 
+  (include ast-node)
59 
+  (slots
60 
+
61 
+    ;; These slots are required.
62 
+
63 
+    (name (type symbol))
64 
+    (type (type (enum standard interface extension)))
65 
+    (prelude? (type bool) (default '#f))  ; True when symbols define the core
66 
+    (interface-module (type (maybe module)) (default '#f))
67 
+        ; link to previously compiled interface
68 
+
69 
+    ;; The unit is filled in by the compilation system
70 
+
71 
+    (unit (type symbol) (default '*undefined*))
72 
+
73 
+    ;; The following slots are defined at parse time.
74 
+    ;; After a module is dumped, these are all empty.
75 
+
76 
+    ;; <exports>, list of exported names
77 
+    (exports (type (list entity)) (default '()))
78 
+    ;; <impdecls>, local import decls
79 
+    (imports (type (list import-decl)) (default '()))
80 
+    ;; <fixdecls>, local fixity decls
81 
+    (fixities (type (list fixity-decl)) (default '()))
82 
+    ;; <synonym-decl>, local type synonym decls
83 
+    (synonyms (type (list synonym-decl)) (default '()))
84 
+    ;; <algdata-decl>, local data decls
85 
+    (algdatas (type (list data-decl)) (default '()))
86 
+    ;; <class-decl>, local class decls
87 
+    (classes (type (list class-decl)) (default '()))
88 
+    ;; <instance-decl>, local instance decls
89 
+    (instances (type (list instance-decl)) (default '()))
90 
+    ;; <default-decl>, default types
91 
+    (annotations (type (list annotation)) (default '()))
92 
+    (default (type (maybe default-decl)) (default '#f))
93 
+    ;; signatures, pattern, function bindings
94 
+    (decls (type (list decl)) (default '()))
95 
+
96 
+    ;; These slots are filled in by the type-declaration-analysis phase
97 
+    ;; after conversion to definition form
98 
+
99 
+    (synonym-defs (type (list synonym)) (default '()))
100 
+    (alg-defs (type (list algdata)) (default '()))
101 
+    (class-defs (type (list class)) (default '()))
102 
+    (instance-defs (type (list instance)) (default '()))
103 
+
104 
+
105 
+    ;; The import-export stage creates a set of tables which are used for
106 
+    ;; imports and exports and local name resolution.  All of these tables
107 
+    ;; are indexed by names.  These tables always deal with definitions.
108 
+    ;; Every variable, type, class, instance, and synonym is converted into
109 
+    ;; a definition.  Blank definitions are created early (in import/export)
110 
+    ;; and different aspects of the definitions are filled in as compilation
111 
+    ;; progresses.  The type-related definitions are filled in during
112 
+    ;; declaration analysis.  Only definitions are saved when a module is
113 
+    ;; written to a file; the ast information is not retained.
114 
+
115 
+    ;; Used to avoid copy of Prelude symbols.
116 
+    (uses-standard-prelude? (type bool) (default '#f))
117 
+    ;; maps symbols in scope to definitions
118 
+    (symbol-table (type (table symbol def)) (default (make-table)))
119 
+    ;; maps names onto groups.
120 
+    (export-table (type (table symbol (list (tuple symbol def))))
121 
+		  (default (make-table)))
122 
+    ;; Note: symbol groups are found in classes and data decls.  An
123 
+    ;; entire group is denoted by the (..) abbreviation in an entity.
124 
+    ;; maps local names onto declared fixities
125 
+    (fixity-table (type (table symbol fixity)) (default (make-table)))
126 
+    ;; maps defs to local names
127 
+    (inverted-symbol-table (type (table symbol symbol)) (default (make-table)))
128 
+    ;; Used internally during import-export
129 
+    (fresh-exports (type (list (list (tuple symbol def)))) (default '()))
130 
+    (exported-modules (type (list module)) (default '()))
131 
+
132 
+    ;; These slots are used to support incremental compilation.
133 
+
134 
+    ;; vars defined in the module
135 
+    (vars (type (list var)) (default '()))
136 
+    ;; for incremental compilation
137 
+    (inherited-env (type (maybe module)) (default '#f))
138 
+    ;; The following slots are for interfaces only
139 
+    ;; These store renaming mappings defined in the import decls of
140 
+    ;; the interface.  Maps local name onto (module, original name).
141 
+    (interface-imports (type (list (tuple symbol (typle symbol symbol))))
142 
+		       (default '()))
143 
+    (interface-codefile (type (list string)) (default '()))
144 
+    ))
145 
+
146 
+
147 
+;;; <impdecl> -> import <modid> [<impspec>] [renaming <renamings>]
148 
+;;;
149 
+;;; <impspec> -> ( <import> , ... , <import> )
150 
+;;;           -> hiding ( <import> , ... , <import> )
151 
+;;;
152 
+;;; <import>  -> <entity>
153 
+;;;
154 
+;;; <renamings> -> ( <renaming>, ... , <renaming> )
155 
+;;;
156 
+;;; <renaming>  -> <varid> to <varid>
157 
+;;;             -> <conid> to <conid>
158 
+
159 
+(define-struct import-decl
160 
+  (include ast-node)
161 
+  (slots
162 
+   ;; <modid>, module imported from
163 
+   (module-name (type symbol))
164 
+   ;; all: import Foo; by-name: import Foo(x) import Foo()
165 
+   (mode (type (enum all by-name)))
166 
+   ;; <impspec>, for mode = all this is the hiding list
167 
+   (specs (type (list entity)))
168 
+   ;; <renamings>, alist maps symbol -> symbol
169 
+   (renamings (type (list renaming)))
170 
+   ;; place to put corresponding module-ast; filled in by import/export.
171 
+   (module (type module) (uninitialized? #t))
172 
+   ))
173 
+
174 
+
175 
+;;; <entity> -> <modid> ..                              entity-module
176 
+;;           -> <varid>                                 entity-var
177 
+;;;          -> <tycon>                                 entity-con
178 
+;;;          -> <tycon> (..)                            entity-abbreviated
179 
+;;;          -> <tycon> ( <conid> , ... , <conid>)      entity-datatype
180 
+;;;          -> <tycls> (..)                            entity-abbreviated
181 
+;;;                note: this is indistinguishable from tycon (..)
182 
+;;;          -> <tycls> ( <varid> , ... , <varid>)      entity-class
183 
+
184 
+(define-struct entity
185 
+  (include ast-node)
186 
+  (slots
187 
+    (name (type symbol))))
188 
+
189 
+(define-struct entity-module
190 
+  (include entity)
191 
+  (predicate entity-module?)
192 
+  (slots
193 
+    ;; a direct pointer to the referenced module added later
194 
+    (module (type module) (uninitialized? #t))
195 
+    ))
196 
+
197 
+(define-struct entity-var
198 
+  (include entity)
199 
+  (predicate entity-var?))
200 
+
201 
+(define-struct entity-con
202 
+  (include entity)
203 
+  (predicate entity-con?))
204 
+
205 
+(define-struct entity-abbreviated
206 
+  (include entity)
207 
+  (predicate entity-abbreviated?))
208 
+
209 
+(define-struct entity-class
210 
+  (include entity)
211 
+  (predicate entity-class?)
212 
+  (slots
213 
+    (methods (type (list symbol)))))
214 
+
215 
+(define-struct entity-datatype
216 
+  (include entity)
217 
+  (predicate entity-datatype?)
218 
+  (slots
219 
+    (constructors (type (list symbol)))))
220 
+
221 
+(define-struct renaming
222 
+  (include ast-node)
223 
+  (slots
224 
+    (from (type symbol))
225 
+    (to (type symbol))
226 
+    (referenced? (type bool))))
227 
+
228 
+
229 
+;;; <fix> -> infixl [<digit>] <ops>
230 
+;;;       -> infixr [<digit>] <ops>
231 
+;;;       -> infix  [<digit>] <ops>
232 
+;;;
233 
+;;; <ops> -> <op> , ... , <op>
234 
+;;;
235 
+;;; <op>  -> <varop>
236 
+;;;       -> <conop>
237 
+
238 
+;;; Not sure where to put this decl - jcp
239 
+(define-struct fixity
240 
+  (include ast-node)
241 
+  (slots
242 
+    (associativity (type (enum l n r)))
243 
+    (precedence (type int))))
244 
+
245 
+(define-struct fixity-decl
246 
+  (include ast-node)
247 
+  (slots
248 
+    (fixity (type fixity))
249 
+    ;; <ops>
250 
+    (names (type (list symbol)))
251 
+    ))
252 
+
ast/predicates.scm
History View file @ 4e98702
0 253 
new file mode 100644
... ... 
@@ -0,0 +1,18 @@
1 
+;;; predicates.scm -- various useful predicates, collected from other places
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  19 Mar 1992
5 
+;;;
6 
+
7 
+
8 
+;;; Some predicates on patterns (used by CFN)
9 
+
10 
+(define-integrable (var-or-wildcard-pat? p)
11 
+  (or (is-type? 'wildcard-pat p)
12 
+      (is-type? 'var-pat p)))
13 
+
14 
+(define-integrable (irrefutable-pat? p)
15 
+  (or (is-type? 'wildcard-pat p)
16 
+      (is-type? 'var-pat p)
17 
+      (is-type? 'irr-pat p)))
18 
+
ast/tc-structs.scm
History View file @ 4e98702
0 19 
new file mode 100644
... ... 
@@ -0,0 +1,62 @@
1 
+;;; These structures are used by the type checker for the internal
2 
+;;; representation of type information.  These are referred to in
3 
+;;; general as `ntype' structures.  Conversions are required between
4 
+;;; ast types and ntypes.
5 
+
6 
+(define-struct ntype
7 
+  (include ast-node))
8 
+
9 
+(define-struct ntycon
10 
+  (include ntype)
11 
+  (predicate ntycon?)
12 
+  (slots
13 
+   (tycon (type def))
14 
+   (args (type (list ntype)))))
15 
+
16 
+(define-struct ntyvar
17 
+  (include ntype)
18 
+  (predicate ntyvar?)
19 
+  (slots
20 
+   ;; non-instantiated tyvars use #f for a value.
21 
+   (value (type (maybe ntype)))
22 
+   ;; could be encoded in value.
23 
+   (context (type (list class)) (default ()))
24 
+   (read-only? (type bool) (default #f) (bit #t))
25 
+   (dict-params (type (list (tuple valdef (list (tuple class var))))))
26 
+   ))
27 
+
28 
+;;; This is used only at the top level of a type during letrec type
29 
+;;; checking.
30 
+
31 
+(define-struct recursive-type
32 
+  (include ntype)
33 
+  (predicate recursive-type?)
34 
+  (slots
35 
+   (type (type ntype))
36 
+   (placeholders (type (list exp)))))
37 
+
38 
+;;; Gtypes are generalized types which can be copied quickly & stored in
39 
+;;; interfaces.  They may contain monomorphic type variables which will not
40 
+;;; be copied.
41 
+
42 
+(define-struct gtype
43 
+  (include ntype)
44 
+  (predicate gtype?)
45 
+  (slots
46 
+   (context (type (list (list class))))
47 
+   (type (type ntype))))
48 
+
49 
+;;; These tyvars just index a list of pre-allocated tyvars.
50 
+
51 
+(define-struct gtyvar
52 
+  (include ntype)
53 
+  (predicate gtyvar?)
54 
+  (slots
55 
+   (varnum (type int))))
56 
+
57 
+(define-struct const-type
58 
+  (include ntype)
59 
+  (predicate const-type?)
60 
+  (slots
61 
+   (type (type ntype))))
62 
+
ast/type-structs.scm
History View file @ 4e98702
0 63 
new file mode 100644
... ... 
@@ -0,0 +1,159 @@
1 
+;;;  File: ast/type-structs   Author: John
2 
+
3 
+;;; This contains AST structures for the type-related declarations,
4 
+;;; including `data', `class', `instance', and `type' decls.  Basic type
5 
+;;; syntax is also defined here.
6 
+
7 
+;;; Structures declared here:
8 
+;;;  type  type-var  type-con  context  signature  synonym-decl
9 
+;;;  data-decl  class-decl  instance-decl
10 
+
11 
+
12 
+;;; <type>  -> <atype>
13 
+;;;         -> <type> -> <type>                              ***
14 
+;;;         -> <tycon> <atype> ... <atype>                   tycon
15 
+;;;
16 
+;;; <atype> -> <tyvar>                                       tyvar
17 
+;;;         -> <tycon>                                       tycon
18 
+;;;         -> ()                                            ***
19 
+;;;         -> ( <type> )                                    grouping syntax
20 
+;;;         -> ( <type> , ... , <type>)                      ***
21 
+;;;         -> [ <type> ]                                    ***
22 
+;;; *** Special <tycon> cases
23 
+
24 
+;;; Type with no context - either a tyvar or a constructor
25 
+(define-struct type
26 
+  (include ast-node))
27 
+
28 
+(define-struct tyvar
29 
+  (include type)
30 
+  (predicate tyvar?)
31 
+  (slots
32 
+   (name (type symbol))))
33 
+
34 
+(define-struct tycon
35 
+  (include type)
36 
+  (predicate tycon?)
37 
+  (slots
38 
+   (name (type symbol))
39 
+   (def (type def))
40 
+   (args (type (list type)))))
41 
+
42 
+;;; <signature> -> [<context> =>] <type>
43 
+;;;
44 
+;;; <context> -> <class>
45 
+;;;           -> (<class> , ... , <class>)
46 
+
47 
+;;; A single class, variable pair
48 
+(define-struct context
49 
+  (include ast-node)
50 
+  (slots
51 
+   (class (type class-ref))
52 
+   (tyvar (type symbol))))
53 
+
54 
+
55 
+;;; Type + context
56 
+(define-struct signature
57 
+  (include type)
58 
+  (slots
59 
+   (context (type (list context)))
60 
+   (type (type type))))
61 
+
62 
+
63 
+;;; Major type declarations.  Note: no explicit structures for <simple>
64 
+;;; or <inst> are needed - these are just special cases of type.
65 
+
66 
+;;; <synonym-decl> -> type <simple> = <type>
67 
+;;;
68 
+;;; <simple> -> <tycon> <tyvar> ... <tyvar>
69 
+
70 
+(define-struct synonym-decl
71 
+  (include ast-node)
72 
+  (slots
73 
+   (simple (type type))
74 
+   (body (type type))))
75 
+
76 
+
77 
+;;; <aldata-decl> -> data [<context> => ] <simple> = <constrs>
78 
+;;;                    [deriving <tycls> | ( <tycls> , ... <tycls>) ]
79 
+;;;
80 
+;;; <constrs>     -> <constr> | ... | <constr>
81 
+;;;
82 
+
83 
+(define-struct data-decl
84 
+  (include ast-node)
85 
+  (slots
86 
+   (context (type (list context)))
87 
+   (simple (type type))
88 
+   (constrs (type (list constr)))
89 
+   (deriving (type (list class-ref)))
90 
+   (annotations (type (list annotation-value)))))
91 
+
92 
+;;; <constr>      -> <con> <atype> ... <atype>
93 
+;;;               -> <type> <conop> <type>
94 
+
95 
+(define-struct constr
96 
+  (include ast-node)
97 
+  (slots
98 
+   (constructor (type con-ref))  ; this con-ref has an infix? flag.
99 
+   (types (type (list (tuple type (list annotation-value)))))))
100 
+
101 
+
102 
+;;; <class-decl> -> class [<context> => ] <class> [where { <cbody> [;] } ]
103 
+;;;
104 
+;;; <cbody> -> [<csigns> ; ] [ <valdefs> ]
105 
+;;;
106 
+;;; <csigns> -> <signdecl> ; ... ; <signdecl>
107 
+
108 
+(define-struct class-decl
109 
+  (include ast-node)
110 
+  (slots
111 
+   (class (type class-ref))
112 
+   (super-classes (type (list context)))
113 
+   (class-var (type symbol))              ; name of type var for this class in decls
114 
+   (decls (type (list decl)))))           ; <cbody>
115 
+
116 
+
117 
+;;; <instance-decl> -> instance [<context> =>] <tycls> <inst>
118 
+;;;                      [where { <valdefs> [;] } ]
119 
+;;;
120 
+;;; <inst> -> <tycon>
121 
+;;;        -> ( <tycon> <tyvar> ... <tyvar> )
122 
+;;;        -> ( <tyvar> , ... , <tyvar>)
123 
+;;;        -> ()
124 
+;;;        -> [ <tyvar> ]
125 
+;;;        -> ( <tyvar> -> <tyvar>)
126 
+;;;
127 
+
128 
+(define-struct instance-decl
129 
+  (include ast-node)
130 
+  (slots
131 
+   ;; <context>
132 
+   (context (type (list context)))
133 
+   ;; <tycls>
134 
+   (class (type class-ref))
135 
+   ;;
136 
+   (simple (type type))
137 
+   ;; <valdefs>
138 
+   (decls (type (list valdef)))
139 
+   ))
140 
+
141 
+
142 
+
143 
+;;; <default-decl> -> default <type>
144 
+;;;                -> default ( <type> , ... , <type> )
145 
+
146 
+(define-struct default-decl
147 
+  (include ast-node)
148 
+  (slots
149 
+   (types (type (list type)))))
150 
+
151 
+
152 
+;;; <tycls> -> <aconid>
153 
+
154 
+(define-struct class-ref
155 
+  (include ast-node)
156 
+  (slots
157 
+   (name (type symbol))
158 
+   (class (type def))))
159 
+
ast/valdef-structs.scm
History View file @ 4e98702
0 160 
new file mode 100644
... ... 
@@ -0,0 +1,276 @@
1 
+;;; File: ast/valdef-structs    Author: John
2 
+
3 
+;;; Ast structure for local declarations
4 
+
5 
+;;; <decl> -> <signdecl>
6 
+;;;        -> <valdef>
7 
+
8 
+;;; decl contains value declarations and type signatures.(
9 
+;;; type related decls are topdecls and are separated from
10 
+;;; these decls.
11 
+
12 
+(define-struct decl
13 
+  (include ast-node))
14 
+
15 
+
16 
+
17 
+;;; <signdecl> -> <vars> :: [<context> =>] <type>
18 
+;;;
19 
+;;; <vars>     -> <var> , ... , <var>
20 
+;;;
21 
+
22 
+(define-struct signdecl ; this affixes a signature to a list of variables
23 
+  (include decl)
24 
+  (predicate signdecl?)
25 
+  (slots
26 
+   (vars (type (list var-ref)))
27 
+   (signature (type signature))))
28 
+
29 
+;;; This is introduced into decl lists by dependency analysis
30 
+(define-struct recursive-decl-group
31 
+  (include decl)
32 
+  (slots
33 
+   ;; none of these are recursive decl groups
34 
+   (decls (type (list decl)))
35 
+   ))
36 
+
37 
+;;; <valdef>  -> <lhs> = <exp> [where { <decls> [;] }]
38 
+;;;           -> <lhs> <gdrhs> [where { <decls> [;] }]
39 
+;;;
40 
+;;; <lhs>     -> <apat>
41 
+;;;           -> <funlhs>
42 
+;;;
43 
+;;; <funlhs>  -> <afunlhs>
44 
+;;;           -> <pat> <varop> <pat>
45 
+;;;           -> <lpat> <varop> <pat>
46 
+;;;           -> <pat> <varop> <rpat>
47 
+;;;
48 
+;;; <afunlhs> -> <var> <apat>
49 
+;;;           -> ( <funlhs> ) <apat>    (infix operator with more than 2 args)
50 
+;;;           -> <afunlhs> <apat>       (multiple argument pattern)
51 
+
52 
+(define-struct valdef  ; this defines values.
53 
+  (include decl)
54 
+  (predicate valdef?)
55 
+  (slots
56 
+   ;; this pattern contains all new variables defined.
57 
+   ;; For a function definition the pattern will always
58 
+   ;; be a simple variable.
59 
+   (lhs (type pattern))
60 
+   ;; this is a list of right hand sides.
61 
+   ;; for a pattern definition, this list is always a singleton.  For
62 
+   ;; a function definition, there is a member for every successive
63 
+   ;; alternative for the function.
64 
+   (definitions (type (list single-fun-def)))
65 
+   ;; this is used internally by dependency analysis
66 
+   (depend-val (type int) (uninitialized? #t))
67 
+   ;; this is filled in by the type phase
68 
+   (dictionary-args (type (list var)) (uninitialized? #t))
69 
+   ;; used for defaulting
70 
+   (module (type symbol) (default '|Prelude|))
71 
+   ))
72 
+
73 
+(define-struct single-fun-def
74 
+  (include ast-node)
75 
+  (slots
76 
+   ;; this list is always empty for pattern definition
77 
+   ;; and always non-empty for function definition.
78 
+   ;; The length of this list is the arity of the function.
79 
+   ;; All single-fun-defs for a function have the same arity.
80 
+   (args (type (list pattern)))
81 
+   ;; <gdrhs>, this contains a list of guard , expression pairs
82 
+   (rhs-list (type (list guarded-rhs)))
83 
+   ;; this contains declarations local to the
84 
+   ;; single fun def.  It scopes over the args.  The
85 
+   ;; guarded-rhs may refer to these values.
86 
+   (where-decls (type (list decl)))
87 
+   ;; true when declared in infix style.  Used for printing
88 
+   ;; and to check precs in prec parsing.
89 
+   (infix? (type bool) (bit #t))
90 
+   ))
91 
+
92 
+
93 
+
94 
+;;; <gdrhs>   -> <gd> = <exp> [<gdrhs>]
95 
+;;;
96 
+;;; <gd>      -> | <exp>
97 
+
98 
+(define-struct guarded-rhs ; a single guarded expression.  A special expression
99 
+  (include ast-node)
100 
+  (slots
101 
+   ;; node - omitted-guard - is used when no guard given
102 
+   (guard (type exp))
103 
+   (rhs (type exp))))
104 
+
105 
+
106 
+;;; Some examples of the above:
107 
+;;; (a,b) | z>y = (z,y)
108 
+;;;       | otherwise = (1,2)
109 
+;;;   where z = x-2
110 
+;;;
111 
+;;;  valdef:
112 
+;;;    lhs = (a,b)
113 
+;;;    definitions =
114 
+;;;       [single-fun-def:
115 
+;;;         args = []
116 
+;;;         rhs-list = [guarded-rhs: guard = z>y
117 
+;;;                                  rhs = (z,y),
118 
+;;;                     guarded-rhs: guard = otherwise
119 
+;;;                                  rhs = (1,2)]
120 
+;;;         where-decls = [valdef: lhs = z
121 
+;;;                                definitions =
122 
+;;;                                   [single-fun-def:
123 
+;;;                                      args = []
124 
+;;;                                      rhs-list = [guarded-rhs:
125 
+;;;                                                    guard = omitted-guard
126 
+;;;                                                    exp = x-2]
127 
+;;;                                      where-decls = []]]]
128 
+;;;
129 
+;;;  fact 0 = 1
130 
+;;;  fact (n+1) = (n+1)*fact n
131 
+;;;
132 
+;;;  valdef:
133 
+;;;    lhs = fact
134 
+;;;    definitions =
135 
+;;;       [single-fun-def:
136 
+;;;         args = [0]
137 
+;;;         rhs-list = [guarded-rhs: guard = omitted-guard
138 
+;;;                                  rhs = 1]
139 
+;;;         where-decls = [],
140 
+;;;        single-fun-def:
141 
+;;;         args = [n+1]
142 
+;;;         rhs-list = [guarded-rhs: guard = omitted-guard
143 
+;;;                                  rhs = (n+1)*fact n]
144 
+;;;         where-decls = []]
145 
+
146 
+
147 
+
148 
+
149 
+;;; Definitions for patterns
150 
+
151 
+;;; This is a simplification; the real syntax is complicated by
152 
+;;; rules for precedence and associativity.
153 
+;;;
154 
+;;; <pat>   -> <pat> <conop> <pat>           pcon
155 
+;;;         -> <pat> + <integer>             plus-pat
156 
+;;;         -> - <integer-or-float>          *** ???  const-pat?
157 
+;;;         -> <apat>
158 
+;;;         -> <con> <apat> .... <apat>      pcon
159 
+;;;
160 
+;;; <apat>  -> <var>                         var-pat
161 
+;;;         -> <var> @ <apat>                as-pat
162 
+;;;         -> <con>                         *** ??? var-pat?
163 
+;;;         -> <literal>                     const-pat
164 
+;;;         -> _                             wildcard-pat
165 
+;;;         -> ()                            pcon special case
166 
+;;;         -> ( <pat> )                     (grouping syntax)
167 
+;;;         -> ( <pat> , ... , <pat> )       pcon special case
168 
+;;;         -> [ <pat> , ... , <pat> ]       list-pat
169 
+;;;         -> ~ <apat>                      irr-pat
170 
+
171 
+(define-struct pattern
172 
+  (include ast-node))
173 
+
174 
+(define-struct apat
175 
+  (include pattern))
176 
+
177 
+(define-struct as-pat  ;; var@pat
178 
+  (include apat)
179 
+  (slots
180 
+   (var (type var-ref))
181 
+   (pattern (type pattern))))
182 
+
183 
+(define-struct irr-pat ;; ~pat
184 
+  (include apat)
185 
+  (slots
186 
+   (pattern (type pattern))))
187 
+
188 
+(define-struct var-pat  ;; v
189 
+  (include apat)
190 
+  (predicate var-pat?)
191 
+  (slots
192 
+   (var (type var-ref))))
193 
+
194 
+(define-struct wildcard-pat  ;; _
195 
+  (include apat)
196 
+  (predicate wildcard-pat?))
197 
+
198 
+(define-struct const-pat  ;; literal
199 
+  (include apat)
200 
+  (predicate const-pat?)
201 
+  (slots
202 
+   (value (type const))
203 
+   ;; this is the code that actually performs the match.
204 
+   ;; it's filled in by type phase.
205 
+   (match-fn (type exp) (uninitialized? #t))))
206 
+
207 
+(define-struct plus-pat  ;; p+k
208 
+  (include pattern)
209 
+  (slots
210 
+   (pattern (type pattern))
211 
+   (k (type integer))
212 
+   ;; code to check for match, filled in by type phase
213 
+   (match-fn (type exp) (uninitialized? #t))
214 
+   ;; code to bind result, filled in by type phase
215 
+   (bind-fn (type exp) (uninitialized? #t))
216 
+   ))
217 
+
218 
+(define-struct pcon      ;; con pat1 pat2 ...
219 
+  (include pattern)      ;; pat1 con pat2
220 
+  (predicate pcon?)
221 
+  (slots
222 
+   (name (type symbol))
223 
+   (con (type def))
224 
+   (pats (type (list pattern)))
225 
+   (infix? (type bool) (bit #t))))
226 
+
227 
+(define-struct list-pat   ;; [p1,p2,...]
228 
+  (include apat)
229 
+  (slots
230 
+   (pats (type (list pattern)))))
231 
+
232 
+;;; The following structs deal with prec parsing of patterns.
233 
+
234 
+(define-struct pp-pat-list
235 
+  (include pattern)
236 
+  (slots
237 
+   (pats (type (list pattern)))))
238 
+
239 
+(define-struct pp-pat-plus
240 
+  (include pattern)
241 
+  (predicate pp-pat-plus?))
242 
+
243 
+(define-struct pp-pat-negated
244 
+  (include pattern)
245 
+  (predicate pp-pat-negated?))
246 
+
247 
+
248 
+
249 
+;;; Structs for annotations
250 
+
251 
+(define-struct annotation
252 
+  (include decl)
253 
+  (predicate annotation?))
254 
+
255 
+(define-struct annotation-decl
256 
+  (include annotation)
257 
+  (predicate annotation-decl?)
258 
+  (slots
259 
+   (names (type (list symbol)))
260 
+   (annotations (type (list annotation-value)))))
261 
+
262 
+(define-struct annotation-value
263 
+  (include annotation)
264 
+  (predicate annotation-value?)
265 
+  (slots
266 
+   (name (type symbol))
267 
+   (args (type (list t)))))
268 
+
269 
+;;; This is a list of annotations placed in where decls lists in the same
270 
+;;; manner a signdecls.
271 
+
272 
+(define-struct annotation-decls
273 
+  (include annotation)
274 
+  (predicate annotation-decls?)
275 
+  (slots
276 
+    (annotations (type (list annotation)))))
backend/README
History View file @ 4e98702
0 277 
new file mode 100644
... ... 
@@ -0,0 +1,10 @@
1 
+This directory contains the files for the compiler backend.  All of these
2 
+phases operate on FLIC code.
3 
+
4 
+optimize -- performs various tweaks to compact the code and make it faster.
5 
+  also includes a postpass to fill in some additional structure slots.
6 
+
7 
+strictness -- attaches strictness information to functions and decides
8 
+  whether locally-bound variables have a boxed or unboxed representation.
9 
+
10 
+codegen -- generates Lisp code from the optimized FLIC code.
backend/backend.scm
History View file @ 4e98702
0 11 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+;;; backend.scm -- compilation unit for code generator stuff
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  13 May 1992
5 
+;;;
6 
+
7 
+
8 
+(define-compilation-unit backend
9 
+  (source-filename "$Y2/backend/")
10 
+  (require flic)
11 
+  (unit optimize
12 
+	(source-filename "optimize.scm"))
13 
+  (unit strictness
14 
+	(source-filename "strictness.scm"))
15 
+  (unit box
16 
+	(source-filename "box.scm"))
17 
+  (unit codegen
18 
+	(source-filename "codegen.scm"))
19 
+  (unit interface-codegen
20 
+	(source-filename "interface-codegen.scm")))
21 
+
backend/box.scm
History View file @ 4e98702
0 22 
new file mode 100644
... ... 
@@ -0,0 +1,417 @@
1 
+;;; box.scm -- determine which expressions need to be boxed
2 
+;;;
3 
+;;; author  :  Sandra Loosemore
4 
+;;; date    :  03 Apr 1993
5 
+;;;
6 
+;;;
7 
+;;; This phase determines whether expressions need to be boxed or unboxed.
8 
+;;;
9 
+;;; In the case of an expression that needs to be boxed, it determines
10 
+;;; whether it can be evaluated eagerly and boxed or whether a delay
11 
+;;; must be constructed.
12 
+;;;
13 
+;;; In the case of an expression that needs to be unboxed, it determines
14 
+;;; whether it is already known to have been evaluated and can simply
15 
+;;; be unboxed instead of checking for a delay that must be forced.
16 
+;;;
17 
+;;; This phase may mark previously non-strict variables as strict if their
18 
+;;; initializers can be evaluated eagerly.  However, doing this evaluation
19 
+;;; eagerly never causes any other non-strict variables to be forced,
20 
+;;; so there is no need to propagate this strictness information backwards
21 
+;;; (as happens in the var-strictness-walk pass).
22 
+
23 
+
24 
+;;;======================================================================
25 
+;;; Top-level function
26 
+;;;======================================================================
27 
+
28 
+
29 
+;;; Complexity computation
30 
+
31 
+(define-integrable delay-complexity 10)
32 
+(define-integrable unbox-complexity 1)
33 
+(define-integrable box-complexity 2)
34 
+(define-integrable sel-complexity 1)
35 
+(define-integrable is-constructor-complexity 1)
36 
+(define-integrable pack-complexity 2)
37 
+(define-integrable con-number-complexity 1)
38 
+
39 
+(define (add-complexity c1 c2)
40 
+  (cond ((not c1)
41 
+	 '#f)
42 
+	((not c2)
43 
+	 '#f)
44 
+	(else
45 
+	 ;; *** We might want to establish an arbitrary cutoff here.
46 
+	 ;; *** e.g., if complexity > N then set it to '#f.
47 
+	 (the fixnum (+ (the fixnum c1) (the fixnum c2))))))
48 
+
49 
+
50 
+
51 
+;;; The second argument to the walker is a list of things
52 
+;;; that are known to have been forced already.
53 
+;;; The third argument is a list of variables that have not yet
54 
+;;; been initialized.
55 
+;;; Walkers return two values:  a new value for already-forced and
56 
+;;; the complexity of the expression.
57 
+
58 
+;;; This helper function sets the unboxed? and cheap? bits for the
59 
+;;; code generator, and adjusts the basic complexity to account for
60 
+;;; forces, boxes, and delays.
61 
+;;;
62 
+;;; The basic decision tree for the code generator should be:
63 
+;;; if unboxed?
64 
+;;;    then if strict-result?
65 
+;;;            then generate x                                   (1)
66 
+;;;            else if cheap?
67 
+;;;                    then generate (unbox x)                   (2)
68 
+;;;                    else generate (force x)                   (3)
69 
+;;;    else if strict-result?
70 
+;;;            then if cheap?
71 
+;;;                    then generate (box x)                     (4)
72 
+;;;                    else generate (delay x)                   (5)
73 
+;;;            else if cheap?
74 
+;;;                    then generate x                           (6)
75 
+;;;                    then generate (delay (force x))           (7)
76 
+;;; See function do-codegen in codegen.scm.
77 
+
78 
+
79 
+(define (do-box-analysis object already-forced uninitialized unboxed?)
80 
+  (setf (flic-exp-unboxed? object) unboxed?)
81 
+  (multiple-value-bind (result complexity)
82 
+      (box-analysis object already-forced uninitialized)
83 
+    (setf complexity
84 
+	  (if unboxed?
85 
+	      ;; If the expression returns a boxed value and we want
86 
+	      ;; an unboxed one, we may need to do a force.
87 
+	      (if (flic-exp-strict-result? object)
88 
+		  (begin                                       ; case (1)
89 
+		    ;; this flic-exp-cheap? bit is used only by
90 
+		    ;; exp-would-be-cheap? below -- not by codegen
91 
+		    (setf (flic-exp-cheap? object)
92 
+			  (if complexity '#t '#f))
93 
+		    complexity)
94 
+		  (if (already-forced? object already-forced)
95 
+		      (begin                                   ; case (2)
96 
+			(setf (flic-exp-cheap? object) '#t)
97 
+			(add-complexity complexity unbox-complexity))
98 
+		      (begin                                   ; case (3)
99 
+			(setf (flic-exp-cheap? object) '#f)
100 
+			'#f)))
101 
+	      ;; We want a boxed value.  If the expression already
102 
+	      ;; returns a boxed value, return its complexity directly;
103 
+	      ;; otherwise return the cost of either boxing or delaying it.
104 
+	      (if (flic-exp-strict-result? object)
105 
+		  (if complexity
106 
+		      (begin                                   ; case (4)
107 
+			(setf (flic-exp-cheap? object) '#t)
108 
+			(add-complexity complexity box-complexity))
109 
+		      (begin                                   ; case (5)
110 
+			(setf (flic-exp-cheap? object) '#f)
111 
+			delay-complexity))
112 
+		  (if complexity
113 
+		      (begin
114 
+			(setf (flic-exp-cheap? object) '#t)    ; case (6)
115 
+			complexity)
116 
+		      (begin                                   ; case (7)
117 
+		        (setf (flic-exp-cheap? object) '#f)
118 
+			delay-complexity)))
119 
+	    ))
120 
+    (values
121 
+      (if unboxed?
122 
+	  (note-already-forced object result)
123 
+	  result)
124 
+      complexity)))
125 
+
126 
+
127 
+
128 
+
129 
+;;;======================================================================
130 
+;;; Code walk
131 
+;;;======================================================================
132 
+
133 
+
134 
+(define *local-function-calls* '())
135 
+
136 
+(define-flic-walker box-analysis (object already-forced uninitialized))
137 
+
138 
+(define-box-analysis flic-lambda (object already-forced uninitialized)
139 
+  (do-box-analysis (flic-lambda-body object) already-forced uninitialized '#t)
140 
+  (values already-forced 0))
141 
+
142 
+(define-box-analysis flic-let (object already-forced uninitialized)
143 
+  (let ((bindings    (flic-let-bindings object)))
144 
+    (dynamic-let ((*local-function-calls*  (dynamic *local-function-calls*)))
145 
+      (dolist (var bindings)
146 
+	;; Note local functions
147 
+	(when (and (not (var-toplevel? var))
148 
+		   (is-type? 'flic-lambda (var-value var))
149 
+		   (not (var-standard-refs? var)))
150 
+	  (push (cons var '()) (dynamic *local-function-calls*))))
151 
+      (multiple-value-bind (already-forced complexity)
152 
+	  (box-analysis-let-aux object already-forced uninitialized)
153 
+	(dolist (var bindings)
154 
+	  ;; Go back and reexamine local functions to see whether
155 
+	  ;; we can make more arguments strict, based on the values
156 
+	  ;; the function is actually called with.
157 
+	  (let ((stuff  (assq var (dynamic *local-function-calls*))))
158 
+	    (when stuff
159 
+	      (maybe-make-more-arguments-strict var (cdr stuff)))))
160 
+	(values already-forced complexity)))))
161 
+
162 
+(define (box-analysis-let-aux object already-forced uninitialized)
163 
+  (let ((recursive?  (flic-let-recursive? object))
164 
+	(bindings    (flic-let-bindings object))
165 
+	(body        (flic-let-body object)))
166 
+    (when recursive? (setf uninitialized (append bindings uninitialized)))
167 
+    (dolist (var bindings)
168 
+      (let* ((value   (var-value var))
169 
+	     (strict? (var-strict? var))
170 
+	     (result  (do-box-analysis value already-forced uninitialized
171 
+				       strict?)))
172 
+	(cond (strict?
173 
+	       ;; Propagate information about things forced.
174 
+	       (setf already-forced result))
175 
+	      ((and (flic-exp-cheap? value)
176 
+		    (flic-exp-strict-result? value))
177 
+	       ;; The value expression is cheap unboxed value, so mark
178 
+	       ;; the variable as strict.
179 
+	       (setf (var-strict? var) '#t)
180 
+	       (setf (flic-exp-unboxed? value) '#t))))
181 
+      (when recursive? (pop uninitialized)))
182 
+    ;; *** Could be smarter about computing complexity.
183 
+    (values
184 
+      (do-box-analysis body already-forced uninitialized '#t)
185 
+      '#f)))
186 
+
187 
+(define (maybe-make-more-arguments-strict var calls)
188 
+  (setf (var-strictness var)
189 
+	(maybe-make-more-arguments-strict-aux
190 
+	  (flic-lambda-vars (var-value var))
191 
+	  calls)))
192 
+
193 
+(define (maybe-make-more-arguments-strict-aux vars calls)
194 
+  (if (null? vars)
195 
+      '()
196 
+      (let ((var  (car vars)))
197 
+	;; If the variable is not already strict, check to see
198 
+	;; whether it's always called with "cheap" arguments.
199 
+	(when (and (not (var-strict? var))
200 
+		   (every-1 (lambda (call)
201 
+			      (exp-would-be-cheap? (car call) var))
202 
+			    calls))
203 
+	  (setf (var-strict? var) '#t)
204 
+	  (dolist (call calls)
205 
+	    (setf (flic-exp-unboxed? (car call)) '#t)))
206 
+	(cons (var-strict? var)
207 
+	      (maybe-make-more-arguments-strict-aux
208 
+	       (cdr vars)
209 
+	       (map (function cdr) calls))))
210 
+    ))
211 
+
212 
+
213 
+;;; Look for one special fixed-point case: argument used as counter-type
214 
+;;; variable.  Otherwise ignore fixed points.
215 
+
216 
+(define (exp-would-be-cheap? exp var)
217 
+  (or (and (flic-exp-cheap? exp)
218 
+	   (flic-exp-strict-result? exp))
219 
+      (and (is-type? 'flic-ref exp)
220 
+	   (eq? (flic-ref-var exp) var))
221 
+      (and (is-type? 'flic-app exp)
222 
+	   (is-type? 'flic-ref (flic-app-fn exp))
223 
+	   (var-complexity (flic-ref-var (flic-app-fn exp)))
224 
+	   (every-1 (lambda (a) (exp-would-be-cheap? a var))
225 
+		    (flic-app-args exp)))
226 
+      ))
227 
+
228 
+
229 
+
230 
+(define-box-analysis flic-app (object already-forced uninitialized)
231 
+  (let ((fn         (flic-app-fn object))
232 
+	(args       (flic-app-args object))
233 
+	(saturated? (flic-app-saturated? object)))
234 
+    (cond ((and saturated? (is-type? 'flic-ref fn))
235 
+	   (let* ((var    (flic-ref-var fn))
236 
+		  (stuff  (assq var (dynamic *local-function-calls*))))
237 
+	     (when stuff
238 
+	       (push args (cdr stuff)))
239 
+	     (box-analysis-app-aux
240 
+	       (var-strictness var) (var-complexity var)
241 
+	       args already-forced uninitialized)))
242 
+	  ((and saturated? (is-type? 'flic-pack fn))
243 
+	   (box-analysis-app-aux
244 
+	     (con-slot-strict? (flic-pack-con fn)) pack-complexity
245 
+	     args already-forced uninitialized))
246 
+	  (else
247 
+	   ;; The function is going to be forced but all the arguments
248 
+	   ;; are non-strict.
249 
+	   (dolist (a args)
250 
+	     (do-box-analysis a already-forced uninitialized '#f))
251 
+	   (values
252 
+	     (do-box-analysis fn already-forced uninitialized '#t)
253 
+	     '#f))
254 
+	  )))
255 
+
256 
+
257 
+
258 
+;;; Propagation of already-forced information depends on whether or
259 
+;;; not the implementation evaluates function arguments in left-to-right
260 
+;;; order.  If not, we can still propagate this information upwards.
261 
+
262 
+(define (box-analysis-app-aux
263 
+	   strictness complexity args already-forced uninitialized)
264 
+  (let ((result   already-forced))
265 
+    (dolist (a args)
266 
+      (let ((strict?  (pop strictness)))
267 
+	(multiple-value-bind (new-result new-complexity)
268 
+	    (do-box-analysis a already-forced uninitialized strict?)
269 
+	  (when strict?
270 
+	    (setf result
271 
+		  (if left-to-right-evaluation
272 
+		      (setf already-forced new-result)
273 
+		      (union-already-forced
274 
+		        new-result already-forced result))))
275 
+	  (setf complexity (add-complexity complexity new-complexity)))))
276 
+    (values result complexity)))
277 
+
278 
+
279 
+(define-box-analysis flic-ref (object already-forced uninitialized)
280 
+  (values
281 
+    already-forced
282 
+    (if (memq (flic-ref-var object) uninitialized)
283 
+	'#f
284 
+	0)))
285 
+
286 
+(define-box-analysis flic-const (object already-forced uninitialized)
287 
+  (declare (ignore object uninitialized))
288 
+  (values already-forced 0))
289 
+
290 
+(define-box-analysis flic-pack (object already-forced uninitialized)
291 
+  (declare (ignore object uninitialized))
292 
+  (values already-forced 0))
293 
+
294 
+
295 
+;;; For case-block and and, already-forced information can be propagated
296 
+;;; sequentially in the clauses.  But only the first expression is
297 
+;;; guaranteed to be evaluated, so only it can propagate the information
298 
+;;; outwards.
299 
+
300 
+(define-box-analysis flic-case-block (object already-forced uninitialized)
301 
+  (values
302 
+    (box-analysis-sequence
303 
+      (flic-case-block-exps object) already-forced uninitialized)
304 
+    '#f))
305 
+
306 
+(define-box-analysis flic-and (object already-forced uninitialized)
307 
+  (values
308 
+    (box-analysis-sequence
309 
+      (flic-and-exps object) already-forced uninitialized)
310 
+    '#f))
311 
+
312 
+(define (box-analysis-sequence exps already-forced uninitialized)
313 
+  (let ((result
314 
+	  (setf already-forced
315 
+		(do-box-analysis
316 
+		  (car exps) already-forced uninitialized '#t))))
317 
+    (dolist (e (cdr exps))
318 
+      (setf already-forced
319 
+	    (do-box-analysis e already-forced uninitialized '#t)))
320 
+    (values result already-forced)))
321 
+
322 
+
323 
+(define-box-analysis flic-return-from (object already-forced uninitialized)
324 
+  (values
325 
+    (do-box-analysis
326 
+      (flic-return-from-exp object) already-forced uninitialized '#t)
327 
+    '#f))
328 
+
329 
+
330 
+;;; For if, the test propagates to both branches and the result.
331 
+;;; Look for an important optimization:
332 
+;;; in (if (and e1 e2 ...) e-then e-else),
333 
+;;; e-then can inherit already-forced information from all of the ei
334 
+;;; rather than only from e1.
335 
+;;; *** Could be smarter about the complexity, I suppose....
336 
+;;; *** Also could intersect already-forced results from both
337 
+;;; *** branches.
338 
+
339 
+(define-box-analysis flic-if (object already-forced uninitialized)
340 
+  (if (is-type? 'flic-and (flic-if-test-exp object))
341 
+      (box-analysis-if-and-aux object already-forced uninitialized)
342 
+      (box-analysis-if-other-aux object already-forced uninitialized)))
343 
+
344 
+(define (box-analysis-if-other-aux object already-forced uninitialized)
345 
+  (setf already-forced
346 
+	(do-box-analysis
347 
+	  (flic-if-test-exp object) already-forced uninitialized '#t))
348 
+  (do-box-analysis (flic-if-then-exp object) already-forced uninitialized '#t)
349 
+  (do-box-analysis (flic-if-else-exp object) already-forced uninitialized '#t)
350 
+  (values already-forced '#f))
351 
+
352 
+(define (box-analysis-if-and-aux object already-forced uninitialized)
353 
+  (let* ((test-exp  (flic-if-test-exp object))
354 
+	 (subexps   (flic-and-exps test-exp))
355 
+	 (then-exp  (flic-if-then-exp object))
356 
+	 (else-exp  (flic-if-else-exp object)))
357 
+    (setf (flic-exp-unboxed? test-exp) '#t)
358 
+    (multiple-value-bind (result1 resultn)
359 
+	(box-analysis-sequence subexps already-forced uninitialized)
360 
+      (do-box-analysis then-exp resultn uninitialized '#t)
361 
+      (do-box-analysis else-exp result1 uninitialized '#t)
362 
+      (values result1 '#f))))
363 
+
364 
+
365 
+(define-box-analysis flic-sel (object already-forced uninitialized)
366 
+  (multiple-value-bind (result complexity)
367 
+      (do-box-analysis
368 
+        (flic-sel-exp object) already-forced uninitialized '#t)
369 
+    (values result (add-complexity sel-complexity complexity))))
370 
+
371 
+(define-box-analysis flic-is-constructor (object already-forced uninitialized)
372 
+  (multiple-value-bind (result complexity)
373 
+      (do-box-analysis
374 
+        (flic-is-constructor-exp object) already-forced uninitialized '#t)
375 
+    (values result (add-complexity is-constructor-complexity complexity))))
376 
+
377 
+(define-box-analysis flic-con-number (object already-forced uninitialized)
378 
+  (multiple-value-bind (result complexity)
379 
+      (do-box-analysis
380 
+        (flic-con-number-exp object) already-forced uninitialized '#t)
381 
+    (values result (add-complexity con-number-complexity complexity))))
382 
+
383 
+(define-box-analysis flic-void (object already-forced uninitialized)
384 
+  (declare (ignore object uninitialized))
385 
+  (values already-forced 0))
386 
+
387 
+
388 
+
389 
+
390 
+;;;======================================================================
391 
+;;; Already-forced bookkeeping
392 
+;;;======================================================================
393 
+
394 
+
395 
+;;; For now, we only keep track of variables that have been forced,
396 
+;;; and not data structure accesses.
397 
+
398 
+(define (already-forced? object already-forced)
399 
+  (and (is-type? 'flic-ref object)
400 
+       (memq (flic-ref-var object) already-forced)))
401 
+
402 
+(define (note-already-forced object already-forced)
403 
+  (if (is-type? 'flic-ref object)
404 
+      (cons (flic-ref-var object) already-forced)
405 
+      already-forced))
406 
+
407 
+(define (union-already-forced new tail result)
408 
+  (cond ((eq? new tail)
409 
+	 result)
410 
+	((memq (car new) result)
411 
+	 (union-already-forced (cdr new) tail result))
412 
+	(else
413 
+	 (union-already-forced (cdr new) tail (cons (car new) result)))
414 
+	))
415 
+
416 
+
417 
+
backend/codegen.scm
History View file @ 4e98702
0 418 
new file mode 100644
... ... 
@@ -0,0 +1,600 @@
1 
+;;; codegen.scm -- compile flic code to Lisp
2 
+;;;
3 
+;;; Author :  Sandra Loosemore
4 
+;;; Date   :  29 Apr 1992
5 
+;;;
6 
+;;; to do:  check completeness of special cases for constructors
7 
+;;;         constants still need work
8 
+;;;         optimized entry points
9 
+;;;
10 
+;;; The code generated here uses the following helper functions:
11 
+;;; (make-curried-fn opt-fn strictness)
12 
+;;;   make a curried function that calls opt-fn after collecting the
13 
+;;;   arguments and processing them according to strictness.  Both
14 
+;;;   the arguments are evaluated.
15 
+;;; (make-tuple-constructor arity)
16 
+;;;   return a function that makes an untagged data structure with "arity"
17 
+;;;   slots.  "arity" is a constant.
18 
+;;; (make-tuple . args)
19 
+;;;   uncurried version of the above
20 
+;;; (make-tagged-data-constructor n arity)
21 
+;;;   return a function that makes a data structure with tag "n" and
22 
+;;;   "arity" slots.
23 
+;;; (make-tagged-data n . args)
24 
+;;;   uncurried version of the above
25 
+;;; (tuple-select arity i object)
26 
+;;;   extract component "i" from untagged "object"
27 
+;;; (tagged-data-select arity i object)
28 
+;;;   extract component "i" from tagged "object"
29 
+;;; (constructor-number object)
30 
+;;;   return the tag from "object"
31 
+;;; (delay form)
32 
+;;;   returns a delay object with unevaluated "form".
33 
+;;; (box form)
34 
+;;;   returns a delay object with evaluated "form".
35 
+;;; (force delay)
36 
+;;;   return the value of the delay object.
37 
+;;; (make-haskell-string string)
38 
+;;;   Converts a Lisp string lazily to a haskell string (using a magic
39 
+;;;   delay function).  Returns an unboxed result.
40 
+
41 
+
42 
+
43 
+;;;======================================================================
44 
+;;; Code walker
45 
+;;;======================================================================
46 
+
47 
+
48 
+;;; Here is the main entry point.
49 
+
50 
+(define (codegen-top big-let)
51 
+  (do ((bindings (flic-let-bindings big-let) (cdr bindings))
52 
+       (result   '())
53 
+       (decls    '()))
54 
+      ((null? bindings) `(begin ,@(nreverse decls) ,@(nreverse result)))
55 
+    (let ((var  (car bindings)))
56 
+      (push `(predefine ,(fullname var)) decls)
57 
+      (push (codegen-definition var (var-value var)) result))))
58 
+
59 
+
60 
+;;; See box.scm for more information about this...
61 
+
62 
+(define (do-codegen object)
63 
+  (let ((x               (codegen object))
64 
+	(unboxed?        (flic-exp-unboxed? object))
65 
+	(strict-result?  (flic-exp-strict-result? object))
66 
+	(cheap?          (flic-exp-cheap? object)))
67 
+    (if unboxed?
68 
+	(if strict-result?
69 
+	    x
70 
+	    (if cheap?
71 
+		`(unbox ,x)
72 
+		`(force ,x)))
73 
+	(if strict-result?
74 
+	    (if cheap?
75 
+		`(box ,x)
76 
+		`(delay ,x))
77 
+	    (if cheap?
78 
+		x
79 
+		`(delay (force ,x)))))))
80 
+
81 
+
82 
+(define (do-codegen-list list)
83 
+  (map (function do-codegen) list))
84 
+
85 
+
86 
+(define-flic-walker codegen (object))
87 
+
88 
+
89 
+;;; For top-level definitions bound to lambda expressions, make both
90 
+;;; a standard entry point (with possibly unboxed arguments) and
91 
+;;; a standard entry point.
92 
+
93 
+(define (codegen-definition var exp)
94 
+  (let ((fullname  (fullname var)))
95 
+    (when (or (memq 'codegen (dynamic *printers*))
96 
+	      (memq 'codegen-flic (dynamic *printers*)))
97 
+;       (format '#t "~%Codegen of ~A [~A]  " (def-name var) (struct-hash var))
98 
+       (format '#t "~%Codegen of ~A  " (def-name var))
99 
+       (when (not (var-strict? var))
100 
+	   (format '#t "Nonstrict  "))
101 
+       (when (not (eq? (var-strictness var) '()))
102 
+	   (format '#t "Strictness: ")
103 
+	   (dolist (s (var-strictness var))
104 
+	       (format '#t (if s "S " "N "))))
105 
+       (when (var-simple? var)
106 
+	   (format '#t " Inline "))
107 
+       (format '#t "~%")
108 
+       (when (memq 'codegen-flic (dynamic *printers*))
109 
+          (pprint* exp)))
110 
+    (let ((lisp-code
111 
+	   (if (not (flic-lambda? exp))
112 
+	       `(define ,fullname ,(do-codegen exp))
113 
+	       (let* ((optname  (optname var))
114 
+		      (lambda   (codegen-lambda-aux exp))
115 
+		      (def      `(define (,optname ,@(cadr lambda))
116 
+				                   ,@(cddr lambda))))
117 
+		 (if (var-selector-fn? var)
118 
+   	             ;; Standard entry point for selectors is never used.
119 
+		     def
120 
+		     `(begin
121 
+			,def
122 
+			(define ,fullname
123 
+			  ,(maybe-make-box-value
124 
+			    (codegen-curried-fn
125 
+			     `(function ,optname) (var-strictness var))
126 
+			    (var-strict? var)))))))))
127 
+      (when (or (memq 'codegen (dynamic *printers*))
128 
+		(memq 'codegen-flic (dynamic *printers*)))
129 
+	    (pprint* lisp-code))
130 
+      lisp-code)))
131 
+
132 
+(define (codegen-lambda-list vars)
133 
+  (map (function fullname) vars))
134 
+
135 
+(define (codegen-curried-fn opt-fn strictness)
136 
+  (if (null? (cdr strictness))
137 
+      ;; one-argument special cases
138 
+      (if (car strictness)
139 
+	  `(make-curried-fn-1-strict ,opt-fn)
140 
+	  `(make-curried-fn-1-nonstrict ,opt-fn))
141 
+      ;; general case
142 
+      `(make-curried-fn ,opt-fn ',strictness)))
143 
+
144 
+
145 
+;;; Curry lambdas.  Functions always return an unboxed value.
146 
+
147 
+(define-codegen flic-lambda (object)
148 
+  (codegen-curried-fn
149 
+    (codegen-lambda-aux object)
150 
+    (map (lambda (x) (var-strict? x)) (flic-lambda-vars object))))
151 
+
152 
+(define (codegen-lambda-aux object)
153 
+  (let* ((vars    (flic-lambda-vars object))
154 
+	 (ignore  '())
155 
+	 (args    (codegen-lambda-list vars)))
156 
+    (dolist (v vars)
157 
+      (if (eqv? (var-referenced v) 0)
158 
+	  (push (fullname v) ignore)))
159 
+    `(lambda ,args
160 
+       ,@(if (not (null? ignore))
161 
+	     `((declare (ignore ,@ignore)))
162 
+	     '())
163 
+       ,(do-codegen (flic-lambda-body object)))))
164 
+
165 
+
166 
+;;; This is only for non-top-level lets.
167 
+;;; The boxing of the value of each of the bindings is controlled by its
168 
+;;; strict? property.
169 
+
170 
+(define-codegen flic-let (object)
171 
+  (let ((bindings   (flic-let-bindings object))
172 
+	(body       (flic-let-body object))
173 
+	(recursive? (flic-let-recursive? object)))
174 
+    (if recursive?
175 
+	(codegen-letrec bindings body)
176 
+	(codegen-let*   bindings body))))
177 
+
178 
+
179 
+;;; For efficiency reasons, we want to make all the function bindings
180 
+;;; in the function namespace (some implementations do not do tail-recursion
181 
+;;; or other optimizations correctly otherwise).  This means we have
182 
+;;; to sort out the variable bindings from the function bindings here.
183 
+
184 
+(define (codegen-letrec bindings body)
185 
+  (let ((let-bindings     '())
186 
+	(labels-bindings  '()))
187 
+    (dolist (var bindings)
188 
+      (let ((value    (var-value var))
189 
+	    (fullname (fullname var))
190 
+	    (strict?  (var-strict? var)))
191 
+	(if (flic-lambda? value)
192 
+	    ;; Some functions may need only the optimized or standard
193 
+	    ;; entry points, but not both.
194 
+	    (let ((optname     (optname var))
195 
+		  (lambda      (codegen-lambda-aux value))
196 
+		  (optimized?  (var-optimized-refs? var))
197 
+		  (standard?   (var-standard-refs? var)))
198 
+	      (when standard?
199 
+		(push (list fullname
200 
+			    (maybe-make-box-value
201 
+			      (codegen-curried-fn
202 
+			        (if optimized? `(function ,optname) lambda)
203 
+				(var-strictness var))
204 
+			      strict?))
205 
+		      let-bindings))
206 
+	      (when optimized?
207 
+		(push (cons optname (cdr lambda)) labels-bindings)))
208 
+	    (push (list fullname (do-codegen value)) let-bindings))))
209 
+    (setf let-bindings (nreverse let-bindings))
210 
+    (setf labels-bindings (nreverse labels-bindings))
211 
+    (cond ((null? let-bindings)
212 
+	   `(labels ,labels-bindings ,(do-codegen body)))
213 
+	  ((null? labels-bindings)
214 
+	   `(letrec ,let-bindings ,(do-codegen body)))
215 
+	  (t
216 
+	   `(let ,(map (lambda (b) `(,(car b) '#f)) let-bindings)
217 
+	      (labels ,labels-bindings
218 
+		      ,@(map (lambda (b) `(setf ,@b)) let-bindings)
219 
+		      ,(do-codegen body))))
220 
+	  )))
221 
+
222 
+(define (codegen-let* bindings body)
223 
+  (if (null? bindings)
224 
+      (do-codegen body)
225 
+      (let* ((var       (car bindings))
226 
+	     (value     (var-value var))
227 
+	     (fullname  (fullname var))
228 
+	     (strict?   (var-strict? var))
229 
+	     (body      (codegen-let* (cdr bindings) body)))
230 
+	(if (flic-lambda? value)
231 
+	    ;; Some functions may need only the optimized or standard
232 
+	    ;; entry points, but not both.
233 
+	    (let ((optname     (optname var))
234 
+		  (lambda      (codegen-lambda-aux value))
235 
+		  (optimized?  (var-optimized-refs? var))
236 
+		  (standard?   (var-standard-refs? var)))
237 
+	      (when standard?
238 
+		(setf body
239 
+		      (add-let-binding
240 
+		        (list fullname
241 
+			      (maybe-make-box-value
242 
+			        (codegen-curried-fn
243 
+				  (if optimized? `(function ,optname) lambda)
244 
+				  (var-strictness var))
245 
+				strict?))
246 
+			body)))
247 
+	      (when optimized?
248 
+		(setf body `(flet ((,optname ,@(cdr lambda))) ,body)))
249 
+	      body)
250 
+	    (add-let-binding (list fullname (do-codegen value)) body)))))
251 
+
252 
+(define (add-let-binding binding body)
253 
+  (if (and (pair? body) (eq? (car body) 'let*))
254 
+      `(let* (,binding ,@(cadr body)) ,@(cddr body))
255 
+      `(let* (,binding) ,body)))
256 
+
257 
+
258 
+(define-codegen flic-app (object)
259 
+  (let ((fn         (flic-app-fn object))
260 
+	(args       (flic-app-args object))
261 
+	(saturated? (flic-app-saturated? object)))
262 
+    (cond ((and saturated? (flic-pack? fn))
263 
+	   ;; Saturated call to constructor
264 
+	   (codegen-constructor-app-aux
265 
+	     (flic-pack-con fn)
266 
+	     (do-codegen-list args)))
267 
+	  ((and saturated? (flic-ref? fn))
268 
+	   ;; Saturated call to named function
269 
+	   (let* ((var     (flic-ref-var fn))
270 
+		  (optname (optname var))
271 
+		  (argcode (do-codegen-list args)))
272 
+	     `(,optname ,@argcode)))
273 
+	  (else
274 
+	   ;; Have to make a curried call to standard entry point.
275 
+	   (let ((fncode   (do-codegen fn))
276 
+		 (argcode  (do-codegen-list args)))
277 
+	     (if (and (pair? fncode)
278 
+		      (eq? (car fncode) 'force))
279 
+		 `(funcall-force ,(cadr fncode) ,@argcode)
280 
+		 `(funcall ,fncode ,@argcode))))
281 
+	  )))
282 
+
283 
+(define (codegen-constructor-app-aux con argcode)
284 
+  (let ((alg  (con-alg con)))
285 
+    (cond ((eq? con (core-symbol ":"))
286 
+	   `(cons ,@argcode))
287 
+	  ((algdata-implemented-by-lisp? alg)
288 
+	   (apply-maybe-lambda (cadr (con-lisp-fns con)) argcode))
289 
+	  ((algdata-tuple? alg)
290 
+	   `(make-tuple ,@argcode))
291 
+	  (else
292 
+	   `(make-tagged-data ,(con-tag con) ,@argcode)))))
293 
+
294 
+
295 
+(define-codegen flic-ref (object)
296 
+  (fullname (flic-ref-var object)))
297 
+
298 
+
299 
+(define-codegen flic-const (object)
300 
+  (let ((value   (flic-const-value object)))
301 
+    (cond ((string? value)
302 
+	   `(make-haskell-string ,value))
303 
+	  ((char? value)
304 
+	   ;; *** I think the parser ought to convert characters to their
305 
+	   ;; *** ASCII codes instead of doing it here.  There are problems
306 
+	   ;; *** with valid Haskell characters that can't be represented
307 
+	   ;; *** portably as Lisp characters.
308 
+	   (char->integer value))
309 
+	  ((number? value)
310 
+	   value)
311 
+	  (else
312 
+	   ;; It must be a ratio.  This is a bit of a hack - this depends on
313 
+	   ;; the fact that 2 tuples are represented in the same manner as
314 
+	   ;; rationals.  Hacked for strict rationals - jcp
315 
+	   `(make-tuple ,(car value) ,(cadr value)))
316 
+	  )))
317 
+
318 
+
319 
+;;; Returns a function or constant, so doesn't need to delay result.
320 
+;;; See flic-app for handling of saturated constructor calls.
321 
+
322 
+(define-codegen flic-pack (object)
323 
+  (let* ((con        (flic-pack-con object))
324 
+	 (arity      (con-arity con))
325 
+	 (alg        (con-alg con))
326 
+	 (tuple?     (algdata-tuple? alg))
327 
+	 (strictness (con-slot-strict? con))
328 
+	 (index      (con-tag con)))
329 
+    (cond ((eq? con (core-symbol "Nil"))
330 
+	   ''())
331 
+	  ((eq? con (core-symbol "True"))
332 
+	   ''#t)
333 
+	  ((eq? con (core-symbol "False"))
334 
+	   ''#f)
335 
+	  ((eq? con (core-symbol ":"))
336 
+	   '(function make-cons-constructor))
337 
+	  ((algdata-implemented-by-lisp? alg)
338 
+	   (let ((fn (cadr (con-lisp-fns con))))
339 
+	     (if (eqv? (con-arity con) 0)
340 
+		 fn
341 
+		 (codegen-curried-fn
342 
+		  (if (and (pair? fn) (eq? (car fn) 'lambda))
343 
+		      fn
344 
+		      `(function ,fn))
345 
+		  strictness))))
346 
+	  ((algdata-enum? alg)
347 
+	   ;; All constructors have 0 arity; represent them just
348 
+	   ;; by numbers.
349 
+	   index)
350 
+	  (tuple?
351 
+	   ;; Only a single constructor for this type.
352 
+	   (codegen-curried-fn
353 
+	     `(make-tuple-constructor ,arity)
354 
+	     strictness))
355 
+	  ((eqv? arity 0)
356 
+	   ;; No arguments to this constructor.
357 
+	   `(make-tagged-data ,index))
358 
+	  (else
359 
+	   ;; General case.
360 
+	   (codegen-curried-fn
361 
+	    `(make-tagged-data-constructor ,index ,arity)
362 
+	    strictness))
363 
+	  )))
364 
+
365 
+
366 
+
367 
+;;; These expressions translate directly into their Lisp equivalents.
368 
+
369 
+(define-codegen flic-case-block (object)
370 
+  `(block ,(flic-case-block-block-name object)
371 
+     ,@(do-codegen-list (flic-case-block-exps object))))
372 
+
373 
+(define-codegen flic-return-from (object)
374 
+  `(return-from ,(flic-return-from-block-name object)
375 
+		,(do-codegen (flic-return-from-exp object))))
376 
+
377 
+(define-codegen flic-and (object)
378 
+  `(and ,@(do-codegen-list (flic-and-exps object))))
379 
+
380 
+(define-codegen flic-if (object)
381 
+  `(if ,(do-codegen (flic-if-test-exp object))
382 
+       ,(do-codegen (flic-if-then-exp object))
383 
+       ,(do-codegen (flic-if-else-exp object))))
384 
+
385 
+(define-codegen flic-sel (object)
386 
+  (codegen-flic-sel-aux
387 
+    (flic-sel-con object)
388 
+    (flic-sel-i object)
389 
+    (do-codegen (flic-sel-exp object))))
390 
+
391 
+(define (codegen-flic-sel-aux con index exp)
392 
+  (let* ((alg      (con-alg con))
393 
+	 (tuple?   (algdata-tuple? alg))
394 
+	 (arity    (con-arity con)))
395 
+    (cond ((eq? con (core-symbol ":"))
396 
+	   (if (eqv? index 0)
397 
+	       `(car ,exp)
398 
+	       `(cdr ,exp)))
399 
+	  ((algdata-implemented-by-lisp? alg)
400 
+	   (apply-maybe-lambda (list-ref (cddr (con-lisp-fns con)) index)
401 
+			       (list exp)))
402 
+	  (tuple?
403 
+	   `(tuple-select ,arity ,index ,exp))
404 
+	  (else
405 
+	   `(tagged-data-select ,arity ,index ,exp))
406 
+	  )))
407 
+
408 
+(define-codegen flic-is-constructor (object)
409 
+  (codegen-flic-is-constructor-aux
410 
+    (flic-is-constructor-con object)
411 
+    (do-codegen (flic-is-constructor-exp object))))
412 
+
413 
+(define (codegen-flic-is-constructor-aux con exp)
414 
+  (let ((type (con-alg con)))
415 
+    (cond ((eq? type (core-symbol "Bool"))
416 
+	   (if (eq? con (core-symbol "True"))
417 
+	       exp
418 
+	       `(not ,exp)))
419 
+	  ((eq? type (core-symbol "List"))
420 
+	   (if (eq? con (core-symbol ":"))
421 
+	       `(pair? ,exp)
422 
+	       `(null? ,exp)))
423 
+	  ((algdata-implemented-by-lisp? type)
424 
+	   (let ((fn (car (con-lisp-fns con))))
425 
+	     (apply-maybe-lambda fn (list exp))))
426 
+	  ((algdata-tuple? type)
427 
+	   ;; This should never happen.
428 
+	   ''#t)
429 
+	  ((algdata-enum? type)
430 
+	   `(eqv? (the fixnum ,exp) (the fixnum ,(con-tag con))))
431 
+	  (else
432 
+	   `(eqv? (the fixnum (constructor-number ,exp))
433 
+		  (the fixnum ,(con-tag con))))
434 
+	  )))
435 
+
436 
+
437 
+(define-codegen flic-con-number (object)
438 
+  (let ((type   (flic-con-number-type object))
439 
+	(exp    (do-codegen (flic-con-number-exp object))))
440 
+    `(the fixnum
441 
+	  ,(cond ((eq? type (core-symbol "Bool"))
442 
+		  `(if ,exp 1 0))
443 
+		 ((eq? type (core-symbol "List"))
444 
+		  `(if (pair? ,exp) 0 1))
445 
+		 ((algdata-tuple? type)
446 
+		  ;; This should never happen.
447 
+		  0)
448 
+		 ((algdata-implemented-by-lisp? type)
449 
+		  (let ((var (gensym)))
450 
+		    `(let ((,var ,exp))
451 
+		       (cond ,@(map (lambda (con)
452 
+				      `(,(apply-maybe-lambda
453 
+					  (car (con-lisp-fns con))
454 
+					  (list var))
455 
+					',(con-tag con)))
456 
+				    (algdata-constrs type))
457 
+			     (else (error "No constructor satisfies ~A.~%"
458 
+					  ',(def-name type)))))))
459 
+		 ((algdata-enum? type)
460 
+		  exp)
461 
+		 (else
462 
+		  `(constructor-number ,exp))
463 
+		 ))
464 
+    ))
465 
+
466 
+
467 
+
468 
+;;;======================================================================
469 
+;;; Utility functions
470 
+;;;======================================================================
471 
+
472 
+;;; Here are some helper functions for handing boxing and unboxing
473 
+;;; of values.
474 
+;;; maybe-make-box-delay is used to box forms that are "expensive" to
475 
+;;; compute; maybe-make-box-value is used to box forms like constants
476 
+;;; or functions that are "cheap" to compute eagerly.
477 
+;;; Maybe-unbox is used to unbox a form that returns a boxed result.
478 
+
479 
+(define (maybe-make-box-delay form unboxed?)
480 
+  (if unboxed?
481 
+      form
482 
+      `(delay ,form)))
483 
+
484 
+(define (maybe-make-box-value form unboxed?)
485 
+  (if unboxed?
486 
+      form
487 
+      `(box ,form)))
488 
+
489 
+(define (maybe-unbox form unboxed?)
490 
+  (if unboxed?
491 
+      `(force ,form)
492 
+      form))
493 
+
494 
+
495 
+;;; These two var slots are filled in lazily by the code generator,
496 
+;;; since most vars generated don't need them.  You should always
497 
+;;; use these functions instead of accessing the structure slot
498 
+;;; directly.
499 
+
500 
+(define (fullname var)
501 
+  (or (var-fullname var)
502 
+      (setf (var-fullname var)
503 
+	    (if (var-toplevel? var)
504 
+		;; For toplevel names, use module name glued onto base names.
505 
+		;; These are always interned symbols.
506 
+		(if (def-core? var)
507 
+		    (symbol-append '|*Core:| (def-name var))
508 
+		    (symbol-append (def-module var) '\: (def-name var)))
509 
+		;; Otherwise, make sure we have a gensym.
510 
+		;; The uniquification of interned symbols is required
511 
+		;; because there may be multiple nested bindings of the
512 
+		;; same name, and we want to be able to distinguish between
513 
+		;; the different bindings.
514 
+		(let ((name  (def-name var)))
515 
+		  (if (gensym? name)
516 
+		      name
517 
+		      (gensym (symbol->string name))))))
518 
+      ))
519 
+
520 
+(define (optname var)
521 
+  (or (var-optimized-entry var)
522 
+      (let ((name  (string-append (symbol->string (fullname var)) "/OPT")))
523 
+	(setf (var-optimized-entry var)
524 
+	      (if (var-toplevel? var)
525 
+		  (string->symbol name)
526 
+		  (gensym name))))))
527 
+
528 
+
529 
+
530 
+;;;======================================================================
531 
+;;; Exported functions
532 
+;;;======================================================================
533 
+
534 
+;;; This handles types exported to lisp from Haskell
535 
+;;; *** Is this really supposed to create variable bindings as
536 
+;;; *** opposed to function bindings???
537 
+;;; *** I assume all of these functions want strict arguments and return
538 
+;;; *** strict results, even if the data structures contain boxed values.
539 
+
540 
+(define (codegen-exported-types mods)
541 
+  (let ((defs '()))
542 
+    (dolist (m mods)
543 
+      (dolist (a (module-alg-defs m))
544 
+        (when (algdata-export-to-lisp? a)
545 
+	  (dolist (c (algdata-constrs a))
546 
+	    (setf defs (nconc (codegen-constr c) defs))))))
547 
+    `(begin ,@defs)))
548 
+
549 
+(define (codegen-constr c)
550 
+  (let ((lisp-fns (con-lisp-fns c)))
551 
+    (if c
552 
+        (let ((res
553 
+	       `(,(codegen-lisp-predicate (car lisp-fns) c)
554 
+		 ,(codegen-lisp-constructor (cadr lisp-fns) c)
555 
+		 ,@(codegen-lisp-accessors
556 
+		    (cddr lisp-fns) (con-slot-strict? c) c 0))))
557 
+	  (when (memq 'codegen (dynamic *printers*))
558 
+	    (dolist (d res)
559 
+	      (pprint* d)))
560 
+	  res)
561 
+	'())))
562 
+
563 
+(define (codegen-lisp-predicate name c)
564 
+  `(define (,name x)
565 
+     ,(codegen-flic-is-constructor-aux c 'x)))
566 
+
567 
+(define (codegen-lisp-constructor name c)
568 
+  (let ((strictness (con-slot-strict? c))
569 
+	(args       '())
570 
+	(exps       '()))
571 
+    (dolist (s strictness)
572 
+      (let ((arg  (gensym)))
573 
+	(push arg args)
574 
+	(push (if s arg `(box ,arg)) exps)))
575 
+    `(define (,name ,@(nreverse args))
576 
+	 ,(codegen-constructor-app-aux c (nreverse exps)))))
577 
+
578 
+(define (codegen-lisp-accessors names strictness c i)
579 
+  (declare (type fixnum i))
580 
+  (if (null? names)
581 
+      '()
582 
+      (let ((body  (codegen-flic-sel-aux c i 'x)))
583 
+	(when (not (car strictness))
584 
+	  (setf body `(force ,body)))
585 
+	(cons `(define (,(car names) x) ,body)
586 
+	      (codegen-lisp-accessors (cdr names) (cdr strictness) c (+ i 1))))
587 
+    ))
588 
+
589 
+
590 
+
591 
+;;; This is a special hack needed due to brain-dead common lisp problems.
592 
+;;; This allows the user to place lambda defined functions in ImportLispType
593 
+;;; *** I'm not convinced this is necessary;  ((lambda ...) args)
594 
+;;; *** is perfectly valid Common Lisp syntax!
595 
+
596 
+(define (apply-maybe-lambda fn args)
597 
+  (if (and (pair? fn)
598 
+	   (eq? (car fn) 'lambda))
599 
+      `(funcall ,fn ,@args)
600 
+      `(,fn ,@args)))
backend/interface-codegen.scm
History View file @ 4e98702
0 601 
new file mode 100644
... ... 
@@ -0,0 +1,200 @@
1 
+
2 
+;;; This generates code for vars defined in an interface.  This looks at
3 
+;;; annotations and fills in the slots of the var definition.
4 
+
5 
+(define (haskell-codegen/interface mods)
6 
+  (codegen/interface (car mods)))
7 
+
8 
+(define (codegen/interface mod)
9 
+ (let ((code '()))
10 
+  (dolist (d (module-decls mod))
11 
+    (when (not (signdecl? d))
12 
+      (error 'bad-decl))
13 
+    (dolist (var (signdecl-vars d))
14 
+     (let ((v (var-ref-var var)))
15 
+      (setf (var-type v) (var-signature v))
16 
+      (setf (var-toplevel? v) '#t)
17 
+      (let ((a (lookup-annotation v '|Complexity|)))
18 
+	(when (not (eq? a '#f))
19 
+	  (setf (var-complexity v)
20 
+		(car (annotation-value-args a)))))
21 
+      (let ((a (lookup-annotation v '|LispName|)))
22 
+	(when (not (eq? a '#f))
23 
+	   (let ((lisp-entry (generate-lisp-entry v a)))
24 
+	     (push lisp-entry code)
25 
+	     (when (memq 'codegen (dynamic *printers*))
26 
+  	        (pprint* lisp-entry))))))))
27 
+  `(begin ,@code)))
28 
+
29 
+(define (generate-lisp-entry v a)
30 
+  (let ((lisp-name (read-lisp-object (car (annotation-value-args a))))
31 
+	(type (maybe-expand-io-type (gtype-type (var-type v)))))
32 
+    (setf (var-optimized-entry v) lisp-name)
33 
+    (if (arrow-type? type)
34 
+	(codegen-lisp-fn v (gather-arg-types type))
35 
+	(codegen-lisp-const v type))))
36 
+
37 
+(define (codegen-lisp-fn var arg-types)
38 
+  (let* ((aux-definition '())
39 
+	 (wrapper? (foreign-fn-needs-wrapper? var arg-types))
40 
+	 (strictness-annotation (lookup-annotation var '|Strictness|))
41 
+	 (strictness (determine-strictness strictness-annotation arg-types))
42 
+	 (temps (gen-temp-names strictness)))
43 
+    (setf (var-strict? var) '#t)
44 
+    (setf (var-arity var) (length strictness))
45 
+    (setf (var-strictness var) strictness)
46 
+    (when wrapper?
47 
+	  (mlet (((code name)
48 
+		  (make-wrapper-fn var (var-optimized-entry var) arg-types)))
49 
+	      (setf (var-optimized-entry var) name)
50 
+	      (setf aux-definition (list code))))
51 
+    `(begin ,@aux-definition
52 
+	    (define ,(fullname var)
53 
+		    ,(maybe-make-box-value
54 
+		       (codegen-curried-fn
55 
+			(if wrapper?
56 
+			    `(function ,(var-optimized-entry var))
57 
+			    `(lambda ,temps
58 
+			          (,(var-optimized-entry var) ,@temps)))
59 
+			 (var-strictness var))
60 
+		       '#t)))))
61 
+
62 
+(define (determine-strictness a args)
63 
+  (if (eq? a '#f)
64 
+      (map (lambda (x) (declare (ignore x)) '#t) (cdr args))
65 
+      (parse-strictness (car (annotation-value-args a)))))
66 
+
67 
+(define (codegen-lisp-const var type)
68 
+  (let ((conversion-fn (output-conversion-fn type)))
69 
+    (setf (var-strict? var) '#f)
70 
+    (setf (var-arity var) 0)
71 
+    (setf (var-strictness var) '())
72 
+    `(define ,(fullname var)
73 
+             (delay
74 
+	       ,(if (eq? conversion-fn '#f)
75 
+		    (var-optimized-entry var)
76 
+		    `(,@conversion-fn ,(var-optimized-entry var)))))))
77 
+
78 
+(define (maybe-expand-io-type ty)
79 
+  (cond ((and (ntycon? ty)
80 
+	      (eq? (ntycon-tycon ty) (core-symbol "IO")))
81 
+	 (**ntycon (core-symbol "Arrow")
82 
+		   (list (**ntycon (core-symbol "SystemState") '())
83 
+			 (**ntycon (core-symbol "IOResult")
84 
+				   (ntycon-args ty)))))
85 
+	((arrow-type? ty)
86 
+	 (**ntycon (core-symbol "Arrow")
87 
+		   (list (car (ntycon-args ty))
88 
+			 (maybe-expand-io-type (cadr (ntycon-args ty))))))
89 
+	(else ty)))
90 
+
91 
+(define (gather-arg-types type)
92 
+  (if (arrow-type? type)
93 
+      (let ((a (ntycon-args type)))
94 
+	(cons (car a) (gather-arg-types (cadr a))))
95 
+      (list type)))
96 
+
97 
+(define (input-conversion-fn ty)
98 
+  (if (ntycon? ty)
99 
+      (let ((tycon (ntycon-tycon ty)))
100 
+	(cond ((eq? tycon (core-symbol "String"))
101 
+	       (lambda (x) `(haskell-string->string ,x)))
102 
+	      ((eq? tycon (core-symbol "List"))  ; needs to convert elements
103 
+	       (let ((var (gensym "X"))
104 
+		     (inner-fn (input-conversion-fn (car (ntycon-args ty)))))
105 
+		 (lambda (x) `(haskell-list->list
106 
+			       (lambda (,var)
107 
+				 ,(if (eq? inner-fn '#f)
108 
+				      var
109 
+				      (funcall inner-fn var)))
110 
+			       ,x))))
111 
+	      ((eq? tycon (core-symbol "Char"))
112 
+	       (lambda (x) `(integer->char ,x)))
113 
+	      (else '#f)))
114 
+      '#f))
115 
+
116 
+(define (output-conversion-fn ty)
117 
+  (if (ntycon? ty)
118 
+      (let ((tycon (ntycon-tycon ty)))
119 
+	(cond ((eq? tycon (core-symbol "String"))
120 
+	       (lambda (x) `(make-haskell-string ,x)))
121 
+	      ((eq? tycon (core-symbol "List"))
122 
+	       (let ((var (gensym "X"))
123 
+		     (inner-fn (output-conversion-fn (car (ntycon-args ty)))))
124 
+		 (lambda (x) `(list->haskell-list
125 
+			       (lambda (,var)
126 
+				 ,(if (eq? inner-fn '#f)
127 
+				      var
128 
+				      (funcall inner-fn var)))
129 
+			       ,x))))
130 
+	      ((eq? tycon (core-symbol "UnitType"))
131 
+	       (lambda (x) `(insert-unit-value ,x)))
132 
+	      ((eq? tycon (core-symbol "IOResult"))
133 
+	       (lambda (x)
134 
+		 (let ((c1 (output-conversion-fn (car (ntycon-args ty)))))
135 
+		   `(box ,(apply-conversion c1 x)))))
136 
+	      (else '#f)))
137 
+      '#f))
138 
+
139 
+(define (apply-conversion fn x)
140 
+  (if (eq? fn '#f)
141 
+      x
142 
+      (funcall fn x)))
143 
+
144 
+(define (foreign-fn-needs-wrapper? var args)
145 
+ (if (lookup-annotation var '|NoConversion|)
146 
+     '#f
147 
+     (ffnw-1 args)))
148 
+
149 
+(define (ffnw-1 args)
150 
+  (if (null? (cdr args))
151 
+      (not (eq? (output-conversion-fn (car args)) '#f))
152 
+      (or (not (eq? (input-conversion-fn (car args)) '#f))
153 
+	  (systemstate? (car args))
154 
+	  (ffnw-1 (cdr args)))))
155 
+
156 
+(define (make-wrapper-fn var fn args)
157 
+  (mlet ((new-fn (symbol-append (fullname var) '|/wrapper|))
158 
+	 (avars (gen-temp-names (cdr args)))
159 
+	 (ignore-state? (systemstate? (cadr (reverse args))))
160 
+	 ((arg-conversions res-conversion)
161 
+	  (collect-conversion-fns avars args)))
162 
+     (values
163 
+      `(define (,new-fn ,@avars)
164 
+	 ,@(if ignore-state? `((declare (ignore ,(car (last avars)))))
165 
+	                     '())
166 
+	 ,@arg-conversions
167 
+	 ,(apply-conversion res-conversion
168 
+			    `(,fn ,@(if ignore-state?
169 
+					(butlast avars)
170 
+					avars))))
171 
+      new-fn)))
172 
+
173 
+(define (collect-conversion-fns avars args)
174 
+  (if (null? avars)
175 
+      (values '() (output-conversion-fn (car args)))
176 
+      (mlet ((fn (input-conversion-fn (car args)))
177 
+	     ((c1 r) (collect-conversion-fns (cdr avars) (cdr args))))
178 
+	 (values (if (eq? fn '#f)
179 
+		     c1
180 
+		     `((setf ,(car avars) ,(funcall fn (car avars))) ,@c1))
181 
+		 r))))
182 
+
183 
+(define (arrow-type? x)
184 
+  (and (ntycon? x)
185 
+       (eq? (ntycon-tycon x) (core-symbol "Arrow"))))
186 
+
187 
+(define (systemstate? x)
188 
+  (and (ntycon? x)
189 
+       (eq? (ntycon-tycon x) (core-symbol "SystemState"))))
190 
+
191 
+(define (gen-temp-names l)
192 
+  (gen-temp-names-1 l '(A B C D E F G H I J K L M N O P)))
193 
+
194 
+(define (gen-temp-names-1 l1 l2)
195 
+  (if (null? l1)
196 
+      '()
197 
+      (if (null? l2)
198 
+	  (gen-temp-names-1 l1 (list (gensym "T")))
199 
+	  (cons (car l2) (gen-temp-names-1 (cdr l1) (cdr l2))))))
200 
+
backend/optimize.scm
History View file @ 4e98702
0 201 
new file mode 100644
... ... 
@@ -0,0 +1,1986 @@
1 
+;;; optimize.scm -- flic optimizer
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  7 May 1992
5 
+;;;
6 
+;;;
7 
+;;; The optimizer does these kinds of program transformations:
8 
+;;;
9 
+;;; * remove unreferenced variable bindings.
10 
+;;;
11 
+;;; * constant folding and various other kinds of compile-time
12 
+;;;   evaluation.
13 
+;;;
14 
+;;; * beta reduction (replace references to variables bound to simple
15 
+;;;   expressions with the expression)
16 
+;;;
17 
+
18 
+
19 
+;;; Since some of the optimizations can make additional transformations
20 
+;;; possible, we want to make multiple iteration passes.  But since each
21 
+;;; pass is likely to have diminishing benefits, we don't want to keep
22 
+;;; iterating indefinitely.  So establish a fairly arbitrary cutoff point.
23 
+;;; The value is based on empirical results from compiling the prelude.
24 
+
25 
+(define *max-optimize-iterations* 5)
26 
+(define *optimize-foldr-iteration* 0)  ; when to inline foldr
27 
+(define *optimize-build-iteration* 0)  ; when to inline build
28 
+(define *current-optimize-iteration* 0)
29 
+
30 
+
31 
+;;; Flags for enabling various optimizations
32 
+
33 
+(define *all-optimizers* '(foldr inline constant lisp))
34 
+(define *optimizers* *all-optimizers*)
35 
+
36 
+
37 
+;;; Used to note whether we are doing the various optimizations
38 
+
39 
+(define-local-syntax (do-optimization? o)
40 
+  `(memq ,o (dynamic *optimizers*)))
41 
+
42 
+(define *do-foldr-optimizations* (do-optimization? 'foldr))
43 
+(define *do-inline-optimizations* (do-optimization? 'inline))
44 
+(define *do-constant-optimizations* (do-optimization? 'constant))
45 
+
46 
+
47 
+;;; If the foldr optimization is enabled, bind the corresponding
48 
+;;; variables to these values instead of the defaults.
49 
+
50 
+(define *foldr-max-optimize-iterations* 15)
51 
+(define *foldr-optimize-foldr-iteration* 8)
52 
+(define *foldr-optimize-build-iteration* 5)
53 
+
54 
+
55 
+;;; Some random other variables
56 
+
57 
+(define *structured-constants* '())
58 
+(define *structured-constants-table* '#f)
59 
+(define *lambda-depth* 0)
60 
+(define *local-bindings* '())
61 
+
62 
+
63 
+;;; This is for doing some crude profiling.
64 
+;;; Comment out the body of the macro to disable profiling.
65 
+
66 
+;;; Here are current counts from compiling the prelude:
67 
+;;; (LET-REMOVE-UNUSED-BINDING . 5835)
68 
+;;; (REF-INLINE-SINGLE-REF . 2890)
69 
+;;; (REF-INLINE . 2692)
70 
+;;; (LET-EMPTY-BINDINGS . 2192)
71 
+;;; (APP-LAMBDA-TO-LET . 1537)
72 
+;;; (APP-MAKE-SATURATED . 416)
73 
+;;; (LET-HOIST-RETURN-FROM . 310)
74 
+;;; (CASE-BLOCK-IDENTITY . 273)
75 
+;;; (CASE-BLOCK-DEAD-CODE . 234)
76 
+;;; (CASE-BLOCK-TO-IF . 212)
77 
+;;; (SEL-FOLD-VAR . 211)
78 
+;;; (APP-HOIST-LET . 190)
79 
+;;; (LET-HOIST-LAMBDA . 181)
80 
+;;; (FOLDR-INLINE . 176)
81 
+;;; (AND-UNARY . 172)
82 
+;;; (LAMBDA-COMPRESS . 168)
83 
+;;; (APP-FOLD-SELECTOR . 141)
84 
+;;; (BUILD-INLINE-LAMBDA . 134)
85 
+;;; (LET-COMPRESS . 134)
86 
+;;; (IF-FOLD . 128)
87 
+;;; (INTEGER-TO-INT-CONSTANT-FOLD . 124)
88 
+;;; (AND-COMPRESS . 94)
89 
+;;; (APP-COMPRESS . 93)
90 
+;;; (FOLDR-CONS-IDENTITY . 69)
91 
+;;; (IF-COMPRESS-TEST . 65)
92 
+;;; (IF-HOIST-LAMBDA . 61)
93 
+;;; (APP-HOIST-STRUCTURED-CONSTANT . 60)
94 
+;;; (FOLDR-PRIM-APPEND-INLINE . 55)
95 
+;;; (FOLDR-BUILD-IDENTITY . 40)
96 
+;;; (CASE-BLOCK-DISCARD-REDUNDANT-TEST . 37)
97 
+;;; (FOLDR-NIL-IDENTITY . 36)
98 
+;;; (LET-HOIST-INVARIANT-ARGS . 30)
99 
+;;; (FOLDR-HOIST-LET . 28)
100 
+;;; (CON-NUMBER-FOLD-TUPLE . 21)
101 
+;;; (FOLDR-CONS-NIL-IDENTITY . 15)
102 
+;;; (AND-CONTAINS-TRUE . 14)
103 
+;;; (IF-IDENTITY-INVERSE . 8)
104 
+;;; (IF-HOIST-RETURN-FROM . 7)
105 
+;;; (CASE-BLOCK-HOIST-LET . 7)
106 
+;;; (INTEGER-TO-INT-IDENTITY . 7)
107 
+;;; (APP-PACK-IDENTITY . 2)
108 
+;;; (CON-NUMBER-FOLD . 2)
109 
+;;; (IF-IDENTITY . 2)
110 
+;;; (INT-TO-INTEGER-CONSTANT-FOLD . 2)
111 
+;;; (LET-HOIST-STRUCTURED-CONSTANT . 1)
112 
+
113 
+
114 
+(define-local-syntax (record-hack type . args)
115 
+  (declare (ignore args))
116 
+  `',type
117 
+;  `(record-hack-aux ,type ,@args)
118 
+  )
119 
+
120 
+(define *hacks-done* '())
121 
+
122 
+(define (record-hack-aux type . args)
123 
+  ;; *** debug
124 
+  ;; (format '#t "~s ~s~%" type args)
125 
+  (declare (ignore args))
126 
+  (let ((stuff  (assq type (car (dynamic *hacks-done*)))))
127 
+    (if stuff
128 
+	(incf (cdr stuff))
129 
+	(push (cons type 1) (car (dynamic *hacks-done*))))))
130 
+
131 
+(define (total-hacks)
132 
+  (let ((totals  '()))
133 
+    (dolist (alist *hacks-done*)
134 
+      (dolist (entry alist)
135 
+	(let ((stuff  (assq (car entry) totals)))
136 
+	  (if stuff
137 
+	      (setf (cdr stuff) (+ (cdr stuff) (cdr entry)))
138 
+	      (push (cons (car entry) (cdr entry)) totals)))))
139 
+    totals))
140 
+
141 
+
142 
+;;; This is the main entry point.
143 
+
144 
+(define (optimize-top object)
145 
+  (dynamic-let ((*structured-constants*       '())
146 
+		(*structured-constants-table* (make-table))
147 
+		(*lambda-depth*               0)
148 
+		(*local-bindings*             '())
149 
+		(*do-inline-optimizations*
150 
+		  (do-optimization? 'inline))
151 
+		(*do-constant-optimizations*
152 
+		  (do-optimization? 'constant))
153 
+		(*max-optimize-iterations*
154 
+		  (if (do-optimization? 'foldr)
155 
+		      (dynamic *foldr-max-optimize-iterations*)
156 
+		      (dynamic *max-optimize-iterations*)))
157 
+		(*optimize-foldr-iteration*
158 
+		  (if (do-optimization? 'foldr)
159 
+		      (dynamic *foldr-optimize-foldr-iteration*)
160 
+		      (dynamic *optimize-foldr-iteration*)))
161 
+		(*optimize-build-iteration*
162 
+		  (if (do-optimization? 'foldr)
163 
+		      (dynamic *foldr-optimize-build-iteration*)
164 
+		      (dynamic *optimize-build-iteration*))))
165 
+    (setf *hacks-done* '())
166 
+    (dotimes (i (dynamic *max-optimize-iterations*))
167 
+      (dynamic-let ((*current-optimize-iteration*  i))
168 
+;; debug	    (*duplicate-object-table*      (make-table)))
169 
+	(when (memq 'optimize-extra (dynamic *printers*))
170 
+	  (format '#t "~%Optimize pass ~s:" i)
171 
+	  (pprint object))
172 
+        (push '() *hacks-done*)
173 
+	(setf object (optimize-flic-let-aux object '#t))))
174 
+    (setf (flic-let-bindings object)
175 
+	  (nconc (nreverse (dynamic *structured-constants*))
176 
+		 (flic-let-bindings object))))
177 
+  (install-uninterned-globals (flic-let-bindings object))
178 
+  (postoptimize object)
179 
+  object)
180 
+
181 
+
182 
+(define-flic-walker optimize (object))
183 
+
184 
+;;; debugging stuff
185 
+;;;
186 
+;;; (define *duplicate-object-table* (make-table))
187 
+;;;
188 
+;;; (define (new-optimize object)
189 
+;;;   (if (table-entry (dynamic *duplicate-object-table*) object)
190 
+;;;       (error "Duplicate object ~s detected." object)
191 
+;;;       (begin
192 
+;;; 	(setf (table-entry (dynamic *duplicate-object-table*) object) '#t)
193 
+;;; 	(old-optimize object))))
194 
+;;;
195 
+;;; (lisp:setf (lisp:symbol-function 'old-optimize)
196 
+;;; 	   (lisp:symbol-function 'optimize))
197 
+;;; (lisp:setf (lisp:symbol-function 'optimize)
198 
+;;;  	   (lisp:symbol-function 'new-optimize))
199 
+
200 
+(define (optimize-list objects)
201 
+  (optimize-list-aux objects)
202 
+  objects)
203 
+
204 
+(define (optimize-list-aux objects)
205 
+  (if (null? objects)
206 
+      '()
207 
+      (begin
208 
+        (setf (car objects) (optimize (car objects)))
209 
+	(optimize-list-aux (cdr objects)))))
210 
+
211 
+
212 
+;;; Compress nested lambdas.  This hack is desirable because saturating
213 
+;;; applications within the lambda body effectively adds additional
214 
+;;; parameters to the function.
215 
+
216 
+;;; *** Maybe this should look for hoistable constant lambdas too.
217 
+
218 
+(define-optimize flic-lambda (object)
219 
+  (let ((vars  (flic-lambda-vars object)))
220 
+    (dynamic-let ((*lambda-depth*   (1+ (dynamic *lambda-depth*)))
221 
+		  (*local-bindings* (cons vars (dynamic *local-bindings*))))
222 
+      (dolist (var vars)
223 
+	(setf (var-referenced var) 0))
224 
+      (let ((new-body  (optimize (flic-lambda-body object))))
225 
+	(setf (flic-lambda-body object) new-body)
226 
+	(cond ((is-type? 'flic-lambda new-body)
227 
+	       (record-hack 'lambda-compress)
228 
+	       (setf (flic-lambda-vars object)
229 
+		     (nconc (flic-lambda-vars object)
230 
+			    (flic-lambda-vars new-body)))
231 
+	       (setf (flic-lambda-body object) (flic-lambda-body new-body)))
232 
+	      (else
233 
+	       '#f))
234 
+	object))))
235 
+
236 
+
237 
+;;; For let, first mark all variables as unused and check for "simple"
238 
+;;; binding values that permit beta reduction.  Then walk the subexpressions.
239 
+;;; Finally discard any bindings that are still marked as unused.
240 
+;;; *** This fails to detect unused recursive variables.
241 
+
242 
+(define-optimize flic-let (object)
243 
+  (optimize-flic-let-aux object '#f))
244 
+
245 
+(define (optimize-flic-let-aux object toplevel?)
246 
+  (let ((bindings      (flic-let-bindings object))
247 
+	(recursive?    (flic-let-recursive? object)))
248 
+    ;; *** This handling of *local-bindings* isn't quite right since
249 
+    ;; *** it doesn't account for the sequential nature of bindings
250 
+    ;; *** in a non-recursive let, but it's close enough.  We won't
251 
+    ;; *** get any semantic errors, but it might miss a few optimizations.
252 
+    (dynamic-let ((*local-bindings*
253 
+		    (if (and recursive? (not toplevel?))
254 
+			(cons bindings (dynamic *local-bindings*))
255 
+			(dynamic *local-bindings*))))
256 
+      (optimize-flic-let-bindings bindings recursive? toplevel?)
257 
+      (dynamic-let ((*local-bindings*
258 
+		      (if (and (not recursive?) (not toplevel?))
259 
+			  (cons bindings (dynamic *local-bindings*))
260 
+			  (dynamic *local-bindings*))))
261 
+	(setf (flic-let-body object) (optimize (flic-let-body object))))
262 
+      ;; Check for unused bindings and other rewrites.
263 
+      ;; Only do this for non-toplevel lets.
264 
+      (if toplevel?
265 
+	  object
266 
+	  (optimize-flic-let-rewrite object bindings recursive?)))))
267 
+
268 
+(define (optimize-flic-let-bindings bindings recursive? toplevel?)
269 
+  ;; Initialize
270 
+  (dolist (var bindings)
271 
+    (setf (var-referenced var) 0)
272 
+    (setf (var-fn-referenced var) 0)
273 
+    (when (is-type? 'flic-lambda (var-value var))
274 
+      (dolist (v (flic-lambda-vars (var-value var)))
275 
+	(setf (var-arg-invariant? v) '#t)
276 
+	(setf (var-arg-invariant-value v) '#f))))
277 
+  ;; Traverse value subforms
278 
+  (do ((bindings bindings (cdr bindings)))
279 
+      ((null? bindings) '#f)
280 
+      (let* ((var  (car bindings))
281 
+	     (val  (var-value var)))
282 
+	(if (and (is-type? 'flic-app val)
283 
+		 (dynamic *do-constant-optimizations*)
284 
+		 (let ((fn   (flic-app-fn val))
285 
+		       (args (flic-app-args val)))
286 
+		   (if recursive?
287 
+		       (structured-constant-app-recursive?
288 
+			 fn args bindings (list var))
289 
+		       (structured-constant-app? fn args))))
290 
+	    ;; Variable is bound to a structured constant.  If this
291 
+	    ;; isn't already a top-level binding, replace the value
292 
+	    ;; of the constant with a reference to a top-level variable
293 
+	    ;; that is in turn bound to the constant expression.
294 
+	    ;; binding to top-level if this is a new constant.
295 
+	    ;; *** Maybe we should also look for variables bound
296 
+	    ;; *** to lambdas, that can also be hoisted to top level.
297 
+	    (when (not toplevel?)
298 
+	      (multiple-value-bind (con args cvar)
299 
+		  (enter-structured-constant-aux val '#t)
300 
+		(record-hack 'let-hoist-structured-constant)
301 
+		(if cvar
302 
+		    (setf (var-value var) (make-flic-ref cvar))
303 
+		    (add-new-structured-constant var con args))))
304 
+	    (begin
305 
+	      ;; If this is a function that's a candidate for foldr/build
306 
+	      ;; optimization, stash the value away prior to
307 
+	      ;; inlining the calls.
308 
+	      ;; *** We might try to automagically detect functions
309 
+	      ;; *** that are candidates for these optimizations here,
310 
+	      ;; *** but have to watch out for infinite loops!
311 
+	      (when (and (var-force-inline? var)
312 
+			 (eqv? (the fixnum
313 
+				    (dynamic *current-optimize-iteration*))
314 
+			       (the fixnum
315 
+				    (dynamic *optimize-build-iteration*)))
316 
+			 (is-type? 'flic-lambda val)
317 
+			 (or (is-foldr-or-build-app? (flic-lambda-body val))))
318 
+		(setf (var-inline-value var) (copy-flic-top val)))
319 
+	      ;; Then walk value normally.
320 
+	      (let ((new-val  (optimize val)))
321 
+		(setf (var-value var) new-val)
322 
+		(setf (var-simple? var)
323 
+		      (or (var-force-inline? var)
324 
+			  (and (not (var-selector-fn? var))
325 
+			       (can-inline?
326 
+				 new-val
327 
+				 (if recursive? bindings '())
328 
+				 toplevel?))))))
329 
+	  ))))
330 
+
331 
+
332 
+(define (is-foldr-or-build-app? exp)
333 
+  (typecase exp
334 
+    (flic-app
335 
+     (let ((fn  (flic-app-fn exp)))
336 
+       (and (is-type? 'flic-ref fn)
337 
+	    (or (eq? (flic-ref-var fn) (core-symbol "foldr"))
338 
+		(eq? (flic-ref-var fn) (core-symbol "build"))))))
339 
+    (flic-let
340 
+     (is-foldr-or-build-app? (flic-let-body exp)))
341 
+    (flic-ref
342 
+     (let ((val  (var-value (flic-ref-var exp))))
343 
+       (and val (is-foldr-or-build-app? val))))
344 
+    (else
345 
+     '#f)))
346 
+
347 
+
348 
+(define (optimize-flic-let-rewrite object bindings recursive?)
349 
+  ;; Delete unused variables from the list.
350 
+  (setf bindings
351 
+	(list-delete-if
352 
+	  (lambda (var)
353 
+	    (cond ((var-toplevel? var)
354 
+		   ;; This was a structured constant hoisted to top-level.
355 
+		   '#t)
356 
+	          ((eqv? (the fixnum (var-referenced var)) (the fixnum 0))
357 
+		   (record-hack 'let-remove-unused-binding var)
358 
+		   '#t)
359 
+		  ((eqv? (the fixnum (var-referenced var)) (the fixnum 1))
360 
+		   (setf (var-single-ref var) (dynamic *lambda-depth*))
361 
+		   '#f)
362 
+		  (else
363 
+		   (setf (var-single-ref var) '#f)
364 
+		   '#f)))
365 
+	  bindings))
366 
+  ;; Add extra bindings for reducing functions with invariant
367 
+  ;; arguments.  Hopefully some of the extra bindings will go
368 
+  ;; away in future passes!
369 
+  (setf (flic-let-bindings object)
370 
+	(setf bindings (add-stuff-for-invariants bindings)))
371 
+  ;; Look for other special cases.
372 
+  (cond ((null? bindings)
373 
+	 ;; Simplifying the expression by getting rid of the LET may
374 
+	 ;; make it possible to do additional optimizations on the
375 
+	 ;; next pass.
376 
+	 (record-hack 'let-empty-bindings)
377 
+	 (flic-let-body object))
378 
+	((is-type? 'flic-return-from (flic-let-body object))
379 
+	 ;; Hoist return-from outside of LET.  This may permit
380 
+	 ;; further optimizations by an enclosing case-block.
381 
+	 (record-hack 'let-hoist-return-from)
382 
+	 (let* ((body       (flic-let-body object))
383 
+		(inner-body (flic-return-from-exp body)))
384 
+	   (setf (flic-return-from-exp body) object)
385 
+	   (setf (flic-let-body object) inner-body)
386 
+	   body))
387 
+	((and (not recursive?)
388 
+	      (is-type? 'flic-let (flic-let-body object))
389 
+	      (not (flic-let-recursive? (flic-let-body object))))
390 
+	 ;; This is purely to produce more compact code.
391 
+	 (record-hack 'let-compress)
392 
+	 (let ((body  (flic-let-body object)))
393 
+	   (setf (flic-let-bindings object)
394 
+		 (nconc bindings (flic-let-bindings body)))
395 
+	   (setf (flic-let-body object) (flic-let-body body))
396 
+	   object))
397 
+	((is-type? 'flic-lambda (flic-let-body object))
398 
+	 ;; Hoist lambda outside of LET.  This may permit
399 
+	 ;; merging of nested lambdas on a future pass.
400 
+	 (record-hack 'let-hoist-lambda)
401 
+	 (let* ((body       (flic-let-body object))
402 
+		(inner-body (flic-lambda-body body)))
403 
+	   (setf (flic-lambda-body body) object)
404 
+	   (setf (flic-let-body object) inner-body)
405 
+	   body))
406 
+	(else
407 
+	 object))
408 
+  )
409 
+
410 
+;;; Look for constant-folding and structured constants here.
411 
+
412 
+(define-optimize flic-app (object)
413 
+  (optimize-flic-app-aux object))
414 
+
415 
+(define (optimize-flic-app-aux object)
416 
+  (let ((new-fn   (optimize (flic-app-fn object)))
417 
+	(new-args (optimize-list (flic-app-args object))))
418 
+    (typecase new-fn
419 
+      (flic-ref
420 
+       ;; The function is a variable.
421 
+       (let* ((var    (flic-ref-var new-fn))
422 
+	      (val    (var-value var))
423 
+	      (n      (length new-args))
424 
+	      (arity  (guess-function-arity var)))
425 
+	 (cond ((and arity (< (the fixnum n) (the fixnum arity)))
426 
+		;; This is a first-class call that is not fully saturated.
427 
+		;; Make it saturated by wrapping a lambda around it.
428 
+		(setf new-fn
429 
+		      (do-app-make-saturated object new-fn new-args arity n))
430 
+		(setf new-args '()))
431 
+	       ((var-selector-fn? var)
432 
+		;; This is a saturated call to a selector.  We might
433 
+		;; be able to inline the call.
434 
+		(multiple-value-bind (fn args)
435 
+		    (try-to-fold-selector var new-fn new-args)
436 
+		  (setf new-fn fn)
437 
+		  (setf new-args args)))
438 
+	       ((and (not (var-toplevel? var))
439 
+		     (is-type? 'flic-lambda val))
440 
+		;; This is a saturated call to a local function.
441 
+		;; Increment its reference count and note if any of
442 
+		;; the arguments are invariant.
443 
+		(incf (var-fn-referenced var))
444 
+		(note-invariant-args new-args (flic-lambda-vars val)))
445 
+	       (else
446 
+		(let ((magic  (magic-optimize-function var)))
447 
+		  (when magic
448 
+		    (multiple-value-bind (fn args)
449 
+			(funcall magic new-fn new-args)
450 
+		      (setf new-fn fn)
451 
+		      (setf new-args args)))))
452 
+	       )))
453 
+      (flic-lambda
454 
+       ;; Turn application of lambda into a let.
455 
+       (multiple-value-bind (fn args)
456 
+	   (do-lambda-to-let-aux new-fn new-args)
457 
+	 (setf new-fn fn)
458 
+	 (setf new-args args)))
459 
+      (flic-pack
460 
+       (let ((con  (flic-pack-con new-fn))
461 
+	     (temp '#f))
462 
+	 (when (eqv? (length new-args) (con-arity con))
463 
+	   (cond ((and (dynamic *do-constant-optimizations*)
464 
+		       (every-1 (function structured-constant?) new-args))
465 
+		  ;; This is a structured constant that
466 
+		  ;; can be replaced with a top-level binding.
467 
+		  (setf (flic-app-fn object) new-fn)
468 
+		  (setf (flic-app-args object) new-args)
469 
+		  (record-hack 'app-hoist-structured-constant object)
470 
+		  (setf new-fn (enter-structured-constant object '#t))
471 
+		  (setf new-args '()))
472 
+		 ((and (setf temp (is-selector? con 0 (car new-args)))
473 
+		       (is-selector-list? con 1 temp (cdr new-args)))
474 
+		  ;; This is an expression like (cons (car x) (cdr x)).
475 
+		  ;; Replace it with just plain x to avoid reconsing.
476 
+		  (record-hack 'app-pack-identity new-fn)
477 
+		  (setf new-fn (copy-flic-top temp))
478 
+		  (setf new-args '()))
479 
+		 ))))
480 
+      (flic-let
481 
+       ;; Hoist let to surround entire application.
482 
+       ;; Simplifying the function being applied may permit further
483 
+       ;; optimizations on next pass.
484 
+       ;; (We might try to hoist lets in the argument expressions, too,
485 
+       ;; but I don't think that would lead to any real simplification
486 
+       ;; of the code.)
487 
+       (record-hack 'app-hoist-let)
488 
+       (setf (flic-app-fn object) (flic-let-body new-fn))
489 
+       (setf (flic-app-args object) new-args)
490 
+       (setf new-args '())
491 
+       (setf (flic-let-body new-fn) object)
492 
+       )
493 
+      (flic-app
494 
+       ;; Try to compress nested applications.
495 
+       ;; This may make the call saturated and permit further optimizations
496 
+       ;; on the next pass.
497 
+       (record-hack 'app-compress)
498 
+       (setf new-args (nconc (flic-app-args new-fn) new-args))
499 
+       (setf new-fn (flic-app-fn new-fn)))
500 
+      )
501 
+    (if (null? new-args)
502 
+	new-fn
503 
+	(begin
504 
+	  (setf (flic-app-fn object) new-fn)
505 
+	  (setf (flic-app-args object) new-args)
506 
+	  object))
507 
+    ))
508 
+
509 
+(define (guess-function-arity var)
510 
+  (or (let ((value  (var-value var)))
511 
+	(and value
512 
+	     (is-type? 'flic-lambda value)
513 
+	     (length (flic-lambda-vars value))))
514 
+      (var-arity var)))
515 
+
516 
+(define (do-app-make-saturated app fn args arity nargs)
517 
+  (declare (type fixnum arity nargs))
518 
+  (record-hack 'app-make-saturated fn args)
519 
+  (let ((newvars  '())
520 
+	(newargs  '()))
521 
+    (dotimes (i (- arity nargs))
522 
+      (declare (type fixnum i))
523 
+      (let ((v  (init-flic-var (create-temp-var 'arg) '#f '#f)))
524 
+	(push v newvars)
525 
+	(push (make-flic-ref v) newargs)))
526 
+    (setf (flic-app-fn app) fn)
527 
+    (setf (flic-app-args app) (nconc args newargs))
528 
+    (make-flic-lambda newvars app)))
529 
+
530 
+
531 
+
532 
+;;; If the function is a selector applied to a literal dictionary,
533 
+;;; inline it.
534 
+
535 
+(define (try-to-fold-selector var new-fn new-args)
536 
+  (let ((exp  (car new-args)))
537 
+    (if (or (and (is-type? 'flic-ref exp)
538 
+		 ;; *** should check that var is top-level?
539 
+		 (is-bound-to-constructor-app? (flic-ref-var exp)))
540 
+	    (and (is-type? 'flic-app exp)
541 
+		 (is-constructor-app-prim? exp)))
542 
+	(begin
543 
+	  (record-hack 'app-fold-selector)
544 
+	  (setf new-fn (copy-flic-top (var-value var)))
545 
+	  (do-lambda-to-let-aux new-fn new-args))
546 
+	(values new-fn new-args))))
547 
+
548 
+
549 
+;;; Various primitive functions have special optimizer functions
550 
+;;; associated with them, that do constant folding and certain
551 
+;;; other identities.  The optimizer function is called with the
552 
+;;; function expression and list of argument expressions (at least
553 
+;;; as many arguments as the arity of the function) and should return
554 
+;;; the two values.
555 
+
556 
+;;; *** This should really use some kind of hash table, but we'd
557 
+;;; *** have to initialize the table dynamically because core-symbols
558 
+;;; *** aren't defined when this file is loaded.
559 
+
560 
+(define (magic-optimize-function var)
561 
+  (cond ((eq? var (core-symbol "foldr"))
562 
+	 (function optimize-foldr-aux))
563 
+	((eq? var (core-symbol "build"))
564 
+	 (function optimize-build))
565 
+	((eq? var (core-symbol "primIntegerToInt"))
566 
+	 (function optimize-integer-to-int))
567 
+	((eq? var (core-symbol "primIntToInteger"))
568 
+	 (function optimize-int-to-integer))
569 
+	((eq? var (core-symbol "primRationalToFloat"))
570 
+	 (function optimize-rational-to-float))
571 
+	((eq? var (core-symbol "primRationalToDouble"))
572 
+	 (function optimize-rational-to-double))
573 
+	((or (eq? var (core-symbol "primNegInt"))
574 
+	     (eq? var (core-symbol "primNegInteger"))
575 
+	     (eq? var (core-symbol "primNegFloat"))
576 
+	     (eq? var (core-symbol "primNegDouble")))
577 
+	 (function optimize-neg))
578 
+	(else
579 
+	 '#f)))
580 
+
581 
+
582 
+;;; Foldr identities for deforestation
583 
+
584 
+(define (optimize-foldr fn args)
585 
+  (multiple-value-bind (fn args)
586 
+      (optimize-foldr-aux fn args)
587 
+    (maybe-make-app fn args)))
588 
+
589 
+(define (optimize-foldr-aux fn args)
590 
+  (let ((k     (car args))
591 
+	(z     (cadr args))
592 
+	(l     (caddr args))
593 
+	(tail  (cdddr args)))
594 
+    (cond ((and (is-type? 'flic-pack k)
595 
+		(eq? (flic-pack-con k) (core-symbol ":"))
596 
+		(is-type? 'flic-pack z)
597 
+		(eq? (flic-pack-con z) (core-symbol "Nil")))
598 
+	   ;; foldr (:) [] l ==> l
599 
+	   ;; (We arrange for build to be inlined before foldr
600 
+	   ;; so that this pattern can be detected.)
601 
+	   (record-hack 'foldr-cons-nil-identity)
602 
+	   (values l tail))
603 
+	  ((and (is-type? 'flic-app l)
604 
+		(is-type? 'flic-ref (flic-app-fn l))
605 
+		(eq? (flic-ref-var (flic-app-fn l))
606 
+		     (core-symbol "build"))
607 
+		(null? (cdr (flic-app-args l))))
608 
+	   ;; foldr k z (build g) ==> g k z
609 
+	   (record-hack 'foldr-build-identity)
610 
+	   (values
611 
+	     (car (flic-app-args l))
612 
+	     (cons k (cons z tail))))
613 
+	  ((and (is-type? 'flic-pack l)
614 
+		(eq? (flic-pack-con l) (core-symbol "Nil")))
615 
+	   ;; foldr k z [] ==> z
616 
+	   (record-hack 'foldr-nil-identity)
617 
+	   (values z tail))
618 
+	  ((short-string-constant? l)
619 
+	   ;; If the list argument is a string constant, expand it inline.
620 
+	   ;; Only do this if the string is fairly short, though.
621 
+	   (optimize-foldr-aux
622 
+	     fn
623 
+	     (cons k (cons z (cons (expand-string-constant l) tail)))))
624 
+	  ((and (is-type? 'flic-app l)
625 
+		(is-type? 'flic-pack (flic-app-fn l))
626 
+		(eq? (flic-pack-con (flic-app-fn l)) (core-symbol ":"))
627 
+		(eqv? (length (flic-app-args l)) 2))
628 
+	   ;; foldr k z x:xs ==> let c = k in c x (foldr c z xs)
629 
+	   (record-hack 'foldr-cons-identity)
630 
+	   (let ((x     (car (flic-app-args l)))
631 
+		 (xs    (cadr (flic-app-args l))))
632 
+	     (values
633 
+	       (if (can-inline? k '() '#f)
634 
+		   (do-foldr-cons-identity k z x xs)
635 
+		   (let ((cvar  (init-flic-var (create-temp-var 'c) k '#f)))
636 
+		     (make-flic-let
637 
+		       (list cvar)
638 
+		       (do-foldr-cons-identity (make-flic-ref cvar) z x xs)
639 
+		       '#f)))
640 
+	       tail)))
641 
+	  ((is-type? 'flic-let l)
642 
+	   ;; foldr k z (let bindings in body) ==>
643 
+	   ;;   let bindings in foldr k z body
644 
+	   (record-hack 'foldr-hoist-let)
645 
+	   (setf (flic-let-body l)
646 
+		 (optimize-foldr fn (list k z (flic-let-body l))))
647 
+	   (values l tail))
648 
+	  ((not (eqv? (the fixnum (dynamic *current-optimize-iteration*))
649 
+		      (the fixnum (dynamic *optimize-foldr-iteration*))))
650 
+	   ;; Hope for more optimizations later.
651 
+	   (values fn args))
652 
+	  ((and (is-type? 'flic-pack k)
653 
+		(eq? (flic-pack-con k) (core-symbol ":")))
654 
+	   ;; Inline to special case, highly optimized append primitive.
655 
+	   ;; Could also look for (++ (++ l1 l2) l3) => (++ l1 (++ l2 l3))
656 
+	   ;; here, but I don't think that happens very often.
657 
+           (record-hack 'foldr-prim-append-inline)
658 
+	   (values
659 
+	     (make-flic-ref (core-symbol "primAppend"))
660 
+	     (cons l (cons z tail))))
661 
+	  (else
662 
+	   ;; Default inline.
663 
+	   (record-hack 'foldr-inline k z)
664 
+	   (let ((new-fn
665 
+		   (copy-flic-top (var-value (core-symbol "inlineFoldr")))))
666 
+	     (if (is-type? 'flic-lambda new-fn)
667 
+		 (do-lambda-to-let-aux new-fn args)
668 
+		 (values new-fn args))))
669 
+	  )))
670 
+
671 
+
672 
+;;; Mess with compile-time expansion of short string constants.
673 
+
674 
+(define-integrable max-short-string-length 3)
675 
+
676 
+(define (short-string-constant? l)
677 
+  (and (is-type? 'flic-const l)
678 
+       (let ((string  (flic-const-value l)))
679 
+	 (and (string? string)
680 
+	      (<= (the fixnum (string-length string))
681 
+		  (the fixnum max-short-string-length))))))
682 
+
683 
+(define (expand-string-constant l)
684 
+  (let* ((string  (flic-const-value l))
685 
+	 (length  (string-length string)))
686 
+    (expand-string-constant-aux string 0 length)))
687 
+
688 
+(define (expand-string-constant-aux string i length)
689 
+  (declare (type fixnum i length))
690 
+  (if (eqv? i length)
691 
+      (make-flic-pack (core-symbol "Nil"))
692 
+      (make-flic-app
693 
+        (make-flic-pack (core-symbol ":"))
694 
+	(list (make-flic-const (string-ref string i))
695 
+	      (expand-string-constant-aux string (+ 1 i) length))
696 
+	'#f)))
697 
+
698 
+
699 
+;;; Helper function for the case of expanding foldr applied to cons call.
700 
+
701 
+(define (do-foldr-cons-identity c z x xs)
702 
+  (make-flic-app
703 
+    c
704 
+    (list x
705 
+	  (optimize-foldr
706 
+	    (make-flic-ref (core-symbol "foldr"))
707 
+	    (list (copy-flic-top c) z xs)))
708 
+    '#f))
709 
+
710 
+
711 
+
712 
+;;; Short-circuit build inlining for the usual case where the
713 
+;;; argument is a lambda.  (It would take several optimizer passes
714 
+;;; for this simplification to fall out, otherwise.)
715 
+
716 
+(define (optimize-build fn args)
717 
+  (let ((arg  (car args)))
718 
+    (cond ((not (eqv? (dynamic *current-optimize-iteration*)
719 
+		      (dynamic *optimize-build-iteration*)))
720 
+	   (values fn args))
721 
+	  ((is-type? 'flic-lambda arg)
722 
+	   (record-hack 'build-inline-lambda)
723 
+	   (do-lambda-to-let-aux
724 
+	     arg
725 
+	     (cons (make-flic-pack (core-symbol ":"))
726 
+		   (cons (make-flic-pack (core-symbol "Nil"))
727 
+			 (cdr args)))))
728 
+	  (else
729 
+	   (record-hack 'build-inline-other)
730 
+	   (let ((new-fn
731 
+		   (copy-flic-top (var-value (core-symbol "inlineBuild")))))
732 
+	     (if (is-type? 'flic-lambda new-fn)
733 
+		 (do-lambda-to-let-aux new-fn args)
734 
+		 (values new-fn args))))
735 
+	  )))
736 
+
737 
+
738 
+;;; Various simplifications on numeric functions.
739 
+;;; *** Obviously, could get much fancier about this.
740 
+
741 
+(define (optimize-integer-to-int fn args)
742 
+  (let ((arg  (car args)))
743 
+    (cond ((is-type? 'flic-const arg)
744 
+	   (record-hack 'integer-to-int-constant-fold)
745 
+	   (if (is-type? 'integer (flic-const-value arg))
746 
+	       (let ((value  (flic-const-value arg)))
747 
+		 (when (not (is-type? 'fixnum value))
748 
+		   ;; Overflow is a user error, not an implementation error.
749 
+		   (phase-error 'int-overflow
750 
+				"Int overflow in primIntegerToInt: ~s"
751 
+				value))
752 
+		 (values arg (cdr args)))
753 
+	       (error "Bad argument ~s to primIntegerToInt." arg)))
754 
+	  ((and (is-type? 'flic-app arg)
755 
+		(is-type? 'flic-ref (flic-app-fn arg))
756 
+		(eq? (flic-ref-var (flic-app-fn arg))
757 
+		     (core-symbol "primIntToInteger"))
758 
+		(null? (cdr (flic-app-args arg))))
759 
+	   (record-hack 'integer-to-int-identity)
760 
+	   (values (car (flic-app-args arg)) (cdr args)))
761 
+	  (else
762 
+	   (values fn args)))))
763 
+
764 
+(define (optimize-int-to-integer fn args)
765 
+  (let ((arg  (car args)))
766 
+    (cond ((is-type? 'flic-const arg)
767 
+	   (record-hack 'int-to-integer-constant-fold)
768 
+	   (if (is-type? 'integer (flic-const-value arg))
769 
+	       (values arg (cdr args))
770 
+	       (error "Bad argument ~s to primIntToInteger." arg)))
771 
+	  ((and (is-type? 'flic-app arg)
772 
+		(is-type? 'flic-ref (flic-app-fn arg))
773 
+		(eq? (flic-ref-var (flic-app-fn arg))
774 
+		     (core-symbol "primIntegerToInt"))
775 
+		(null? (cdr (flic-app-args arg))))
776 
+	   (record-hack 'int-to-integer-identity)
777 
+	   (values (car (flic-app-args arg)) (cdr args)))
778 
+	  (else
779 
+	   (values fn args)))))
780 
+
781 
+(predefine (prim.rational-to-float-aux n d))   ; in prims.scm
782 
+(predefine (prim.rational-to-double-aux n d))  ; in prims.scm
783 
+
784 
+(define (optimize-rational-to-float fn args)
785 
+  (let ((arg  (car args)))
786 
+    (cond ((is-type? 'flic-const arg)
787 
+	   (record-hack 'rational-to-float-constant-fold)
788 
+	   (if (is-type? 'list (flic-const-value arg))
789 
+	       (let ((value  (flic-const-value arg)))
790 
+		 (setf (flic-const-value arg)
791 
+		       (prim.rational-to-float-aux (car value) (cadr value)))
792 
+		 (values arg (cdr args)))
793 
+	       (error "Bad argument ~s to primRationalToFloat." arg)))
794 
+	  (else
795 
+	   (values fn args)))))
796 
+
797 
+(define (optimize-rational-to-double fn args)
798 
+  (let ((arg  (car args)))
799 
+    (cond ((is-type? 'flic-const arg)
800 
+	   (record-hack 'rational-to-double-constant-fold)
801 
+	   (if (is-type? 'list (flic-const-value arg))
802 
+	       (let ((value  (flic-const-value arg)))
803 
+		 (setf (flic-const-value arg)
804 
+		       (prim.rational-to-double-aux (car value) (cadr value)))
805 
+		 (values arg (cdr args)))
806 
+	       (error "Bad argument ~s to primRationalToDouble." arg)))
807 
+	  (else
808 
+	   (values fn args)))))
809 
+
810 
+(define (optimize-neg fn args)
811 
+  (let ((arg  (car args)))
812 
+    (cond ((is-type? 'flic-const arg)
813 
+	   (record-hack 'neg-constant-fold)
814 
+	   (if (is-type? 'number (flic-const-value arg))
815 
+	       (begin
816 
+		 (setf (flic-const-value arg) (- (flic-const-value arg)))
817 
+		 (values arg (cdr args)))
818 
+	       (error "Bad argument ~s to ~s." arg fn)))
819 
+	  (else
820 
+	   (values fn args)))))
821 
+
822 
+
823 
+
824 
+;;; Convert lambda applications to lets.
825 
+;;; If application is not saturated, break it up into two nested
826 
+;;; lambdas before doing the transformation.
827 
+;;; It's better to do this optimization immediately than hoping
828 
+;;; the call will become fully saturated on the next pass.
829 
+;;; Maybe we could also look for a flic-let with a flic-lambda as
830 
+;;; the body to catch the cases where additional arguments can
831 
+;;; be found on a later pass.
832 
+
833 
+(define (do-lambda-to-let new-fn new-args)
834 
+  (multiple-value-bind (fn args)
835 
+      (do-lambda-to-let-aux new-fn new-args)
836 
+    (maybe-make-app fn args)))
837 
+
838 
+(define (maybe-make-app fn args)
839 
+  (if (null? args)
840 
+      fn
841 
+      (make-flic-app fn args '#f)))
842 
+
843 
+(define (do-lambda-to-let-aux new-fn new-args)
844 
+  (let ((vars     (flic-lambda-vars new-fn))
845 
+	(body     (flic-lambda-body new-fn))
846 
+	(matched  '()))
847 
+    (record-hack 'app-lambda-to-let)
848 
+    (do ()
849 
+	((or (null? new-args) (null? vars)))
850 
+	(let ((var  (pop vars))
851 
+	      (arg  (pop new-args)))
852 
+	  (setf (var-value var) arg)
853 
+	  (setf (var-simple? var) (can-inline? arg '() '#t))
854 
+	  (if (eqv? (var-referenced var) 1)
855 
+	      (setf (var-single-ref var) (dynamic *lambda-depth*)))
856 
+	  (push var matched)))
857 
+    (setf matched (nreverse matched))
858 
+    (if (not (null? vars))
859 
+	(setf body (make-flic-lambda vars body)))
860 
+    (setf new-fn (make-flic-let matched body '#f))
861 
+    (values new-fn new-args)))
862 
+
863 
+
864 
+;;; For references, check to see if we can beta-reduce.
865 
+;;; Don't increment reference count for inlineable vars, but do
866 
+;;; traverse the new value expression.
867 
+
868 
+(define-optimize flic-ref (object)
869 
+  (optimize-flic-ref-aux object))
870 
+
871 
+(define (optimize-flic-ref-aux object)
872 
+  (let ((var     (flic-ref-var object)))
873 
+    (cond ((var-single-ref var)
874 
+	   ;; (or (eqv? (var-single-ref var) (dynamic *lambda-depth*)))
875 
+	   ;; *** The lambda-depth test is too conservative to handle
876 
+	   ;; *** inlining of stuff necessary for foldr/build optimizations.
877 
+	   ;; Can substitute value no matter how hairy it is.
878 
+	   ;; Note that this is potentially risky; if the single
879 
+	   ;; reference detected on the previous pass appeared as
880 
+	   ;; the value of a variable binding that is being inlined
881 
+	   ;; on the current pass, it might turn into multiple
882 
+	   ;; references again!
883 
+	   ;; We copy the value anyway to avoid problems with shared
884 
+	   ;; structure in the multiple reference case.
885 
+	   (record-hack 'ref-inline-single-ref var)
886 
+	   (optimize (copy-flic-top (var-value var))))
887 
+	  ((and (var-inline-value var) (dynamic *do-inline-optimizations*))
888 
+	   ;; Use the previously saved value in preference to the current
889 
+	   ;; value of the variable.
890 
+	   (record-hack 'ref-inline-foldr-hack)
891 
+	   (optimize (copy-flic-top (var-inline-value var))))
892 
+	  ((and (var-simple? var)
893 
+		(or (dynamic *do-inline-optimizations*)
894 
+		    (not (var-toplevel? var))))
895 
+	   ;; Can substitute, but must copy.
896 
+	   (record-hack 'ref-inline var)
897 
+	   (optimize (copy-flic-top (var-value var))))
898 
+	  ((eq? var (core-symbol "foldr"))
899 
+	   ;; Magic stuff for deforestation
900 
+	   (if (> (the fixnum (dynamic *current-optimize-iteration*))
901 
+		  (the fixnum (dynamic *optimize-foldr-iteration*)))
902 
+	       (begin
903 
+		 (record-hack 'ref-inline-foldr)
904 
+		 (optimize (make-flic-ref (core-symbol "inlineFoldr"))))
905 
+	       object))
906 
+	  ((eq? var (core-symbol "build"))
907 
+	   ;; Magic stuff for deforestation
908 
+	   (if (> (the fixnum (dynamic *current-optimize-iteration*))
909 
+		  (the fixnum (dynamic *optimize-build-iteration*)))
910 
+	       (begin
911 
+		 (record-hack 'ref-inline-build)
912 
+		 (optimize (make-flic-ref (core-symbol "inlineBuild"))))
913 
+	       object))
914 
+	  ((var-toplevel? var)
915 
+	   object)
916 
+	  (else
917 
+	   (incf (var-referenced var))
918 
+	   object))))
919 
+
920 
+
921 
+;;; Don't do anything exciting with constants.
922 
+
923 
+(define-optimize flic-const (object)
924 
+  object)
925 
+
926 
+(define-optimize flic-pack (object)
927 
+  object)
928 
+
929 
+
930 
+
931 
+;;; Various simplifications on and
932 
+
933 
+(define-optimize flic-and (object)
934 
+  (maybe-simplify-and
935 
+    object
936 
+    (optimize-and-exps (flic-and-exps object) '())))
937 
+
938 
+(define (maybe-simplify-and object exps)
939 
+  (cond ((null? exps)
940 
+	 (record-hack 'and-empty)
941 
+	 (make-flic-pack (core-symbol "True")))
942 
+	((null? (cdr exps))
943 
+	 (record-hack 'and-unary)
944 
+	 (car exps))
945 
+	(else
946 
+	 (setf (flic-and-exps object) exps)
947 
+	 object)))
948 
+
949 
+(define (optimize-and-exps exps result)
950 
+  (if (null? exps)
951 
+      (nreverse result)
952 
+      (let ((exp  (optimize (car exps))))
953 
+	(typecase exp
954 
+	  (flic-pack
955 
+	    (cond ((eq? (flic-pack-con exp) (core-symbol "True"))
956 
+		   ;; True appears in subexpressions.
957 
+		   ;; Discard this test only.
958 
+		   (record-hack 'and-contains-true)
959 
+		   (optimize-and-exps (cdr exps) result))
960 
+		  ((eq? (flic-pack-con exp) (core-symbol "False"))
961 
+		   ;; False appears in subexpressions.
962 
+		   ;; Discard remaining tests as dead code.
963 
+		   ;; Can't replace the whole and expression with false because
964 
+		   ;; of possible strictness side-effects.
965 
+		   (record-hack 'and-contains-false)
966 
+		   (nreverse (cons exp result)))
967 
+		  (else
968 
+		   ;; Should never happen.
969 
+		   (error "Non-boolean con ~s in and expression!" exp))))
970 
+	  (flic-and
971 
+	   ;; Flatten nested ands.
972 
+	   (record-hack 'and-compress)
973 
+	   (optimize-and-exps
974 
+	    (cdr exps)
975 
+	    (nconc (nreverse (flic-and-exps exp)) result)))
976 
+	  (else
977 
+	   ;; No optimization possible.
978 
+	   (optimize-and-exps (cdr exps) (cons exp result)))
979 
+	  ))))
980 
+
981 
+
982 
+;;; Case-block optimizations.  These optimizations are possible because
983 
+;;; of the restricted way this construct is used;  return-froms are
984 
+;;; never nested, etc.
985 
+
986 
+(define-optimize flic-case-block (object)
987 
+  (let* ((sym  (flic-case-block-block-name object))
988 
+	 (exps (optimize-case-block-exps
989 
+		 sym (flic-case-block-exps object) '())))
990 
+    (optimize-flic-case-block-aux object sym exps)))
991 
+
992 
+(define (optimize-flic-case-block-aux object sym exps)
993 
+  (cond ((null? exps)
994 
+	 ;; This should never happen.  It means all of the tests were
995 
+	 ;; optimized away, including the failure case!
996 
+	 (error "No exps left in case block ~s!" object))
997 
+	((and (is-type? 'flic-and (car exps))
998 
+	      (is-return-from-block?
999 
+	        sym
1000 
+	        (car (last (flic-and-exps (car exps))))))
1001 
+	 ;; The first clause is a simple and.  Hoist it out of the
1002 
+	 ;; case-block and rewrite as if/then/else.
1003 
+	 (record-hack 'case-block-to-if)
1004 
+	 (let ((then-exp  (car (last (flic-and-exps (car exps))))))
1005 
+	   (setf (flic-case-block-exps object) (cdr exps))
1006 
+	   (make-flic-if
1007 
+	     (maybe-simplify-and
1008 
+	       (car exps)
1009 
+	       (butlast (flic-and-exps (car exps))))
1010 
+	     (flic-return-from-exp then-exp)
1011 
+	     (optimize-flic-case-block-aux object sym (cdr exps)))))
1012 
+	((is-return-from-block? sym (car exps))
1013 
+	 ;; Do an identity reduction.
1014 
+	 (record-hack 'case-block-identity)
1015 
+	 (flic-return-from-exp (car exps)))
1016 
+	((is-type? 'flic-let (car exps))
1017 
+	 ;; The first clause is a let.  Since this clause is going
1018 
+	 ;; to be executed anyway, hoisting the bindings to surround
1019 
+	 ;; the entire case-block should not change their strictness
1020 
+	 ;; properties, and it may permit some further optimizations.
1021 
+	 (record-hack 'case-block-hoist-let)
1022 
+	 (let* ((exp  (car exps))
1023 
+		(body (flic-let-body exp)))
1024 
+	   (setf (flic-let-body exp)
1025 
+		 (optimize-flic-case-block-aux
1026 
+		   object sym (cons body (cdr exps))))
1027 
+	   exp))
1028 
+	(else
1029 
+	 (setf (flic-case-block-exps object) exps)
1030 
+	 object)
1031 
+	))
1032 
+
1033 
+
1034 
+(define (optimize-case-block-exps sym exps result)
1035 
+  (if (null? exps)
1036 
+      (nreverse result)
1037 
+      (let ((exp  (optimize (car exps))))
1038 
+	(cond ((is-return-from-block? sym exp)
1039 
+	       ;; Any remaining clauses are dead code and should be removed.
1040 
+	       (if (not (null? (cdr exps)))
1041 
+		   (record-hack 'case-block-dead-code))
1042 
+	       (nreverse (cons exp result)))
1043 
+	      ((is-type? 'flic-and exp)
1044 
+	       ;; See if we can remove redundant tests.
1045 
+	       (push (maybe-simplify-and
1046 
+		       exp
1047 
+		       (look-for-redundant-tests (flic-and-exps exp) result))
1048 
+		     result)
1049 
+	       (optimize-case-block-exps sym (cdr exps) result))
1050 
+	      (else
1051 
+	       ;; No optimization possible.
1052 
+	       (optimize-case-block-exps sym (cdr exps) (cons exp result)))
1053 
+	      ))))
1054 
+
1055 
+
1056 
+;;; Look for case-block tests that are known to be either true or false
1057 
+;;; because of tests made in previous clauses.
1058 
+;;; For now, we only look at is-constructor tests.  Such a test is known
1059 
+;;; to be true if previous clauses have eliminated all other possible
1060 
+;;; constructors.  And such a test is known to be false if a previous
1061 
+;;; clause has already matched this constructor.
1062 
+
1063 
+(define (look-for-redundant-tests exps previous-clauses)
1064 
+  (if (null? exps)
1065 
+      '()
1066 
+      (let ((exp  (car exps)))
1067 
+	(cond ((and (is-type? 'flic-is-constructor exp)
1068 
+		    (constructor-test-redundant? exp previous-clauses))
1069 
+	       ;; Known to be true.
1070 
+	       (record-hack 'case-block-discard-redundant-test)
1071 
+	       (cons (make-flic-pack (core-symbol "True"))
1072 
+		     (look-for-redundant-tests (cdr exps) previous-clauses)))
1073 
+
1074 
+              ((and (is-type? 'flic-is-constructor exp)
1075 
+		    (constructor-test-duplicated? exp previous-clauses))
1076 
+	       ;; Known to be false.
1077 
+	       (record-hack 'case-block-discard-duplicate-test)
1078 
+	       (list (make-flic-pack (core-symbol "False"))))
1079 
+	      (else
1080 
+	       ;; No optimization.
1081 
+	       (cons exp
1082 
+		     (look-for-redundant-tests (cdr exps) previous-clauses)))
1083 
+	      ))))
1084 
+
1085 
+
1086 
+;;; In looking for redundant/duplicated tests, only worry about
1087 
+;;; is-constructor tests that have an argument that is a variable.
1088 
+;;; It's too hairy to consider any other cases.
1089 
+
1090 
+(define (constructor-test-duplicated? exp previous-clauses)
1091 
+  (let ((con  (flic-is-constructor-con exp))
1092 
+	(arg  (flic-is-constructor-exp exp)))
1093 
+    (and (is-type? 'flic-ref arg)
1094 
+	 (constructor-test-present? con arg previous-clauses))))
1095 
+
1096 
+(define (constructor-test-redundant? exp previous-clauses)
1097 
+  (let ((con     (flic-is-constructor-con exp))
1098 
+        (arg     (flic-is-constructor-exp exp)))
1099 
+    (and (is-type? 'flic-ref arg)
1100 
+	 (every-1 (lambda (c)
1101 
+		    (or (eq? c con)
1102 
+			(constructor-test-present? c arg previous-clauses)))
1103 
+		  (algdata-constrs (con-alg con))))))
1104 
+
1105 
+(define (constructor-test-present? con arg previous-clauses)
1106 
+  (cond ((null? previous-clauses)
1107 
+	 '#f)
1108 
+	((constructor-test-present-1? con arg (car previous-clauses))
1109 
+	 '#t)
1110 
+	(else
1111 
+	 (constructor-test-present? con arg (cdr previous-clauses)))))
1112 
+
1113 
+
1114 
+;;; The tricky thing here is that, even if the constructor test is
1115 
+;;; present in the clause, we have to make sure that the entire clause won't
1116 
+;;; fail due to the presence of some other test which fails.  So look
1117 
+;;; for a very specific pattern here, namely
1118 
+;;;  (and (is-constructor con arg) (return-from ....))
1119 
+
1120 
+(define (constructor-test-present-1? con arg clause)
1121 
+  (and (is-type? 'flic-and clause)
1122 
+       (let ((exps  (flic-and-exps clause)))
1123 
+	 (and (is-type? 'flic-is-constructor (car exps))
1124 
+	      (is-type? 'flic-return-from (cadr exps))
1125 
+	      (null? (cddr exps))
1126 
+	      (let* ((inner-exp  (car exps))
1127 
+		     (inner-con  (flic-is-constructor-con inner-exp))
1128 
+		     (inner-arg  (flic-is-constructor-exp inner-exp)))
1129 
+		(and (eq? inner-con con)
1130 
+		     (flic-exp-eq? arg inner-arg)))))))
1131 
+
1132 
+
1133 
+
1134 
+;;; No fancy optimizations for return-from by itself.
1135 
+
1136 
+(define-optimize flic-return-from (object)
1137 
+  (setf (flic-return-from-exp object)
1138 
+	(optimize (flic-return-from-exp object)))
1139 
+  object)
1140 
+
1141 
+
1142 
+
1143 
+;;; Obvious simplification on if
1144 
+
1145 
+(define-optimize flic-if (object)
1146 
+  (let ((test-exp  (optimize (flic-if-test-exp object)))
1147 
+	(then-exp  (optimize (flic-if-then-exp object)))
1148 
+	(else-exp  (optimize (flic-if-else-exp object))))
1149 
+    (cond ((and (is-type? 'flic-pack test-exp)
1150 
+		(eq? (flic-pack-con test-exp) (core-symbol "True")))
1151 
+	   ;; Fold constant test
1152 
+	   (record-hack 'if-fold)
1153 
+	   then-exp)
1154 
+	  ((and (is-type? 'flic-pack test-exp)
1155 
+		(eq? (flic-pack-con test-exp) (core-symbol "False")))
1156 
+	   ;; Fold constant test
1157 
+	   (record-hack 'if-fold)
1158 
+	   else-exp)
1159 
+	  ((and (is-type? 'flic-is-constructor test-exp)
1160 
+		(eq? (flic-is-constructor-con test-exp) (core-symbol "True")))
1161 
+	   ;; Remove redundant is-constructor test.
1162 
+	   ;; Doing this as a general is-constructor identity
1163 
+	   ;; backfires because it prevents some of the important case-block
1164 
+	   ;; optimizations from being recognized, but it works fine here.
1165 
+	   (record-hack 'if-compress-test)
1166 
+	   (setf (flic-if-test-exp object) (flic-is-constructor-exp test-exp))
1167 
+	   (setf (flic-if-then-exp object) then-exp)
1168 
+	   (setf (flic-if-else-exp object) else-exp)
1169 
+	   object)
1170 
+	  ((and (is-type? 'flic-is-constructor test-exp)
1171 
+		(eq? (flic-is-constructor-con test-exp) (core-symbol "False")))
1172 
+	   ;; Remove redundant is-constructor test, flip branches.
1173 
+	   (record-hack 'if-compress-test)
1174 
+	   (setf (flic-if-test-exp object) (flic-is-constructor-exp test-exp))
1175 
+	   (setf (flic-if-then-exp object) else-exp)
1176 
+	   (setf (flic-if-else-exp object) then-exp)
1177 
+	   object)
1178 
+	  ((and (is-type? 'flic-return-from then-exp)
1179 
+		(is-type? 'flic-return-from else-exp)
1180 
+		(eq? (flic-return-from-block-name then-exp)
1181 
+		     (flic-return-from-block-name else-exp)))
1182 
+	   ;; Hoist return-from outside of IF.
1183 
+	   ;; This may permit further case-block optimizations.
1184 
+	   (record-hack 'if-hoist-return-from)
1185 
+	   (let ((return-exp  then-exp))
1186 
+	     (setf (flic-if-test-exp object) test-exp)
1187 
+	     (setf (flic-if-then-exp object) (flic-return-from-exp then-exp))
1188 
+	     (setf (flic-if-else-exp object) (flic-return-from-exp else-exp))
1189 
+	     (setf (flic-return-from-exp return-exp) object)
1190 
+	     return-exp))
1191 
+	  ((and (is-type? 'flic-pack then-exp)
1192 
+		(is-type? 'flic-pack else-exp)
1193 
+		(eq? (flic-pack-con then-exp) (core-symbol "True"))
1194 
+		(eq? (flic-pack-con else-exp) (core-symbol "False")))
1195 
+	   ;; This if does nothing useful at all!
1196 
+	   (record-hack 'if-identity)
1197 
+	   test-exp)
1198 
+	  ((and (is-type? 'flic-pack then-exp)
1199 
+		(is-type? 'flic-pack else-exp)
1200 
+		(eq? (flic-pack-con then-exp) (core-symbol "False"))
1201 
+		(eq? (flic-pack-con else-exp) (core-symbol "True")))
1202 
+	   ;; Inverse of previous case
1203 
+	   (record-hack 'if-identity-inverse)
1204 
+	   (make-flic-is-constructor (core-symbol "False") test-exp))
1205 
+	  ((or (is-type? 'flic-lambda then-exp)
1206 
+	       (is-type? 'flic-lambda else-exp))
1207 
+	   ;; Hoist lambdas to surround entire if.  This allows us to
1208 
+	   ;; do a better job of saturating them.
1209 
+	   (record-hack 'if-hoist-lambda)
1210 
+	   (multiple-value-bind (vars then-exp else-exp)
1211 
+	       (do-if-hoist-lambda then-exp else-exp)
1212 
+	     (setf (flic-if-test-exp object) test-exp)
1213 
+	     (setf (flic-if-then-exp object) then-exp)
1214 
+	     (setf (flic-if-else-exp object) else-exp)
1215 
+	     (make-flic-lambda vars object)))
1216 
+	  (else
1217 
+	   ;; No optimization possible
1218 
+	   (setf (flic-if-test-exp object) test-exp)
1219 
+	   (setf (flic-if-then-exp object) then-exp)
1220 
+	   (setf (flic-if-else-exp object) else-exp)
1221 
+	   object)
1222 
+	  )))
1223 
+
1224 
+
1225 
+
1226 
+;;; Try to pull as many variables as possible out to surround the entire
1227 
+;;; let.
1228 
+
1229 
+(define (do-if-hoist-lambda then-exp else-exp)
1230 
+  (let ((vars       '())
1231 
+	(then-args  '())
1232 
+	(else-args  '()))
1233 
+    (do ((then-vars  (if (is-type? 'flic-lambda then-exp)
1234 
+			 (flic-lambda-vars then-exp)
1235 
+			 '())
1236 
+		     (cdr then-vars))
1237 
+	 (else-vars  (if (is-type? 'flic-lambda else-exp)
1238 
+			 (flic-lambda-vars else-exp)
1239 
+			 '())
1240 
+		     (cdr else-vars)))
1241 
+	((and (null? then-vars) (null? else-vars)) '#f)
1242 
+	(let ((var  (init-flic-var (create-temp-var 'arg) '#f '#f)))
1243 
+	  (push var vars)
1244 
+	  (push (make-flic-ref var) then-args)
1245 
+	  (push (make-flic-ref var) else-args)))
1246 
+    (values
1247 
+      vars
1248 
+      (if (is-type? 'flic-lambda then-exp)
1249 
+	  (do-lambda-to-let then-exp then-args)
1250 
+	  (make-flic-app then-exp then-args '#f))
1251 
+      (if (is-type? 'flic-lambda else-exp)
1252 
+	  (do-lambda-to-let else-exp else-args)
1253 
+	  (make-flic-app else-exp else-args '#f)))))
1254 
+
1255 
+
1256 
+
1257 
+;;; Look for (sel (pack x)) => x
1258 
+
1259 
+(define-optimize flic-sel (object)
1260 
+  (optimize-flic-sel-aux object))
1261 
+
1262 
+(define (optimize-flic-sel-aux object)
1263 
+  (let ((new-exp  (optimize (flic-sel-exp object))))
1264 
+    (setf (flic-sel-exp object) new-exp)
1265 
+    (typecase new-exp
1266 
+      (flic-ref
1267 
+       ;; Check to see whether this is bound to a pack application
1268 
+       (let ((val  (is-bound-to-constructor-app? (flic-ref-var new-exp))))
1269 
+	 (if val
1270 
+	     ;; Yup, it is.  Now extract the appropriate component,
1271 
+	     ;; provided it is inlineable.
1272 
+	     (let* ((i      (flic-sel-i object))
1273 
+		    (args   (flic-app-args val))
1274 
+		    (newval (list-ref args i)))
1275 
+	       (if (can-inline? newval '() '#t)
1276 
+		   (begin
1277 
+		     (record-hack 'sel-fold-var)
1278 
+		     (optimize (copy-flic-top newval)))
1279 
+		   object))
1280 
+	     ;; The variable was bound to something else.
1281 
+	     object)))
1282 
+      (flic-app
1283 
+       ;; The obvious optimization.
1284 
+       (if (is-constructor-app-prim? new-exp)
1285 
+	   (begin
1286 
+	     (record-hack 'sel-fold-app)
1287 
+	     (list-ref (flic-app-args new-exp) (flic-sel-i object)))
1288 
+	   object))
1289 
+      (else
1290 
+       object))))
1291 
+
1292 
+
1293 
+
1294 
+
1295 
+;;; Do similar stuff for is-constructor.
1296 
+
1297 
+(define-optimize flic-is-constructor (object)
1298 
+  (let ((con      (flic-is-constructor-con object))
1299 
+	(exp      (optimize (flic-is-constructor-exp object)))
1300 
+	(exp-con  '#f))
1301 
+    (cond ((algdata-tuple? (con-alg con))
1302 
+	   ;; Tuples have only one constructor, so this is always true
1303 
+	   (record-hack 'is-constructor-fold-tuple)
1304 
+	   (make-flic-pack (core-symbol "True")))
1305 
+	  ((setf exp-con (is-constructor-app? exp))
1306 
+	   ;; The expression is a constructor application.
1307 
+	   (record-hack 'is-constructor-fold)
1308 
+	   (make-flic-pack
1309 
+	     (if (eq? exp-con con)
1310 
+		 (core-symbol "True")
1311 
+		 (core-symbol "False"))))
1312 
+	  (else
1313 
+	   ;; No optimization possible
1314 
+	   (setf (flic-is-constructor-exp object) exp)
1315 
+	   object)
1316 
+	  )))
1317 
+
1318 
+
1319 
+(define-optimize flic-con-number (object)
1320 
+  (let ((exp  (flic-con-number-exp object))
1321 
+	(type (flic-con-number-type object)))
1322 
+    ;; ***Maybe ast-to-flic should look for this one.
1323 
+    (if (algdata-tuple? type)
1324 
+	(begin
1325 
+	  (record-hack 'con-number-fold-tuple)
1326 
+	  (make-flic-const 0))
1327 
+	(let* ((new-exp  (optimize exp))
1328 
+	       (con      (is-constructor-app? new-exp)))
1329 
+	  (if con
1330 
+	      (begin
1331 
+	        (record-hack 'con-number-fold)
1332 
+		(make-flic-const (con-tag con)))
1333 
+	      (begin
1334 
+	        (setf (flic-con-number-exp object) new-exp)
1335 
+		object)))
1336 
+      )))
1337 
+
1338 
+(define-optimize flic-void (object)
1339 
+  object)
1340 
+
1341 
+
1342 
+;;;===================================================================
1343 
+;;; General helper functions
1344 
+;;;===================================================================
1345 
+
1346 
+
1347 
+;;; Lucid's built-in every function seems to do a lot of unnecessary
1348 
+;;; consing.  This one is much faster.
1349 
+
1350 
+(define (every-1 fn list)
1351 
+  (cond ((null? list)
1352 
+	 '#t)
1353 
+	((funcall fn (car list))
1354 
+	 (every-1 fn (cdr list)))
1355 
+	(else
1356 
+	 '#f)))
1357 
+
1358 
+
1359 
+
1360 
+;;; Equality predicate on flic expressions
1361 
+
1362 
+(define (flic-exp-eq? a1 a2)
1363 
+  (typecase a1
1364 
+    (flic-const
1365 
+     (and (is-type? 'flic-const a2)
1366 
+	  (equal? (flic-const-value a1) (flic-const-value a2))))
1367 
+    (flic-ref
1368 
+     (and (is-type? 'flic-ref a2)
1369 
+	  (eq? (flic-ref-var a1) (flic-ref-var a2))))
1370 
+    (flic-pack
1371 
+     (and (is-type? 'flic-pack a2)
1372 
+	  (eq? (flic-pack-con a1) (flic-pack-con a2))))
1373 
+    (flic-sel
1374 
+     (and (is-type? 'flic-sel a2)
1375 
+	  (eq? (flic-sel-con a1) (flic-sel-con a2))
1376 
+	  (eqv? (flic-sel-i a1) (flic-sel-i a2))
1377 
+	  (flic-exp-eq? (flic-sel-exp a1) (flic-sel-exp a2))))
1378 
+    (else
1379 
+     '#f)))
1380 
+
1381 
+
1382 
+
1383 
+;;; Predicates for testing whether an expression matches a pattern.
1384 
+
1385 
+(define (is-constructor-app? exp)
1386 
+  (typecase exp
1387 
+    (flic-app
1388 
+     ;; See if we have a saturated call to a constructor.
1389 
+     (is-constructor-app-prim? exp))
1390 
+    (flic-ref
1391 
+     ;; See if we can determine anything about the value the variable
1392 
+     ;; is bound to.
1393 
+     (let ((value  (var-value (flic-ref-var exp))))
1394 
+       (if value
1395 
+	   (is-constructor-app? value)
1396 
+	   '#f)))
1397 
+    (flic-let
1398 
+     ;; See if we can determine anything about the body of the let.
1399 
+     (is-constructor-app? (flic-let-body exp)))
1400 
+    (flic-pack
1401 
+     ;; See if this is a nullary constructor.
1402 
+     (let ((con  (flic-pack-con exp)))
1403 
+       (if (eqv? (con-arity con) 0)
1404 
+	   con
1405 
+	   '#f)))
1406 
+    (else
1407 
+     '#f)))
1408 
+
1409 
+(define (is-return-from-block? sym exp)
1410 
+  (and (is-type? 'flic-return-from exp)
1411 
+       (eq? (flic-return-from-block-name exp) sym)))
1412 
+
1413 
+(define (is-constructor-app-prim? exp)
1414 
+  (let ((fn    (flic-app-fn exp))
1415 
+	(args  (flic-app-args exp)))
1416 
+    (if (and (is-type? 'flic-pack fn)
1417 
+	     (eqv? (length args) (con-arity (flic-pack-con fn))))
1418 
+	(flic-pack-con fn)
1419 
+	'#f)))
1420 
+
1421 
+(define (is-bound-to-constructor-app? var)
1422 
+  (let ((val  (var-value var)))
1423 
+    (if (and val
1424 
+	     (is-type? 'flic-app val)
1425 
+	     (is-constructor-app-prim? val))
1426 
+	val
1427 
+	'#f)))
1428 
+
1429 
+(define (is-selector? con i exp)
1430 
+  (or (and (is-type? 'flic-ref exp)
1431 
+	   (is-selector? con i (var-value (flic-ref-var exp))))
1432 
+      (and (is-type? 'flic-sel exp)
1433 
+	   (eq? (flic-sel-con exp) con)
1434 
+	   (eqv? (the fixnum i) (the fixnum (flic-sel-i exp)))
1435 
+	   (flic-sel-exp exp))
1436 
+      ))
1437 
+
1438 
+(define (is-selector-list? con i subexp exps)
1439 
+  (declare (type fixnum i))
1440 
+  (if (null? exps)
1441 
+      subexp
1442 
+      (let ((temp  (is-selector? con i (car exps))))
1443 
+	(and (flic-exp-eq? subexp temp)
1444 
+	     (is-selector-list? con (+ 1 i) subexp (cdr exps))))))
1445 
+
1446 
+
1447 
+
1448 
+;;;===================================================================
1449 
+;;; Inlining criteria
1450 
+;;;===================================================================
1451 
+
1452 
+;;; Expressions that can be inlined unconditionally are constants, variable
1453 
+;;; references, and some functions.
1454 
+;;; I've made some attempt here to arrange the cases in the order they
1455 
+;;; are likely to occur.
1456 
+
1457 
+(define (can-inline? exp recursive-vars toplevel?)
1458 
+  (typecase exp
1459 
+    (flic-sel
1460 
+     ;; Listed first because it happens more frequently than
1461 
+     ;; anything else.
1462 
+     ;; *** Inlining these is an experiment.
1463 
+     ;; *** This transformation interacts with the strictness
1464 
+     ;; *** analyzer; if the variable referenced is not strict, then
1465 
+     ;; *** it is probably not a good thing to do since it adds extra
1466 
+     ;; *** forces.
1467 
+     ;; (let ((subexp  (flic-sel-exp exp)))
1468 
+     ;;   (and (is-type? 'flic-ref subexp)
1469 
+     ;;        (not (memq (flic-ref-var subexp) recursive-vars))))
1470 
+     '#f)
1471 
+    (flic-lambda
1472 
+     ;; Do not try to inline lambdas if the fancy inline optimization
1473 
+     ;; is disabled.
1474 
+     ;; Watch for problems with infinite loops with recursive variables.
1475 
+     (if (dynamic *do-inline-optimizations*)
1476 
+	 (simple-function-body? (flic-lambda-body exp)
1477 
+				(flic-lambda-vars exp)
1478 
+				recursive-vars
1479 
+				toplevel?)
1480 
+	 '#f))
1481 
+    (flic-ref
1482 
+     ;; We get into infinite loops trying to inline recursive variables.
1483 
+     (not (memq (flic-ref-var exp) recursive-vars)))
1484 
+    ((or flic-pack flic-const)
1485 
+     '#t)
1486 
+    (else
1487 
+     '#f)))
1488 
+
1489 
+
1490 
+;;; Determining whether to inline a function is difficult.  This is
1491 
+;;; very conservative to avoid code bloat.  What we need to do is
1492 
+;;; compare the cost (in program size mainly) of the inline call with
1493 
+;;; an out of line call.  For an out of line call, we pay for one function
1494 
+;;; call and a setup for each arg.  When inlining, we pay for function
1495 
+;;; calls in the body and for args referenced more than once.  In terms of
1496 
+;;; execution time, we win big when a functional parameter is called
1497 
+;;; since this `firstifies' the program.
1498 
+
1499 
+;;; Here's the criteria:
1500 
+;;;  An inline function gets to reference no more that 2 non-parameter
1501 
+;;;  values (including constants and repeated parameter references).
1502 
+;;; For non-toplevel functions, be slightly more generous since the
1503 
+;;; fixed overhead of binding the local function would go away.
1504 
+
1505 
+(define (simple-function-body? exp lambda-vars recursive-vars toplevel?)
1506 
+  (let ((c  (if toplevel? 2 4)))
1507 
+    (>= (the fixnum (simple-function-body-1 exp lambda-vars recursive-vars c))
1508 
+	0)))
1509 
+
1510 
+
1511 
+;;; I've made some attempt here to order the cases by how frequently
1512 
+;;; they appear.
1513 
+
1514 
+(define (simple-function-body-1 exp lambda-vars recursive-vars c)
1515 
+  (declare (type fixnum c))
1516 
+  (if (< c 0)
1517 
+      (values c '())
1518 
+      (typecase exp
1519 
+	(flic-ref
1520 
+	 (let ((var (flic-ref-var exp)))
1521 
+	   (cond ((memq var lambda-vars)
1522 
+		  (values c (list-remove-1 var lambda-vars)))
1523 
+		 ((memq var recursive-vars)
1524 
+		  (values -1 '()))
1525 
+		 (else
1526 
+		  (values (the fixnum (1- c)) lambda-vars)))))
1527 
+	(flic-app
1528 
+	 (simple-function-body-1/l
1529 
+	   (cons (flic-app-fn exp) (flic-app-args exp))
1530 
+	   lambda-vars recursive-vars c))
1531 
+	(flic-sel
1532 
+	 (simple-function-body-1
1533 
+	  (flic-sel-exp exp)
1534 
+	  lambda-vars recursive-vars (the fixnum (1- c))))
1535 
+	(flic-is-constructor
1536 
+	 (simple-function-body-1
1537 
+	  (flic-is-constructor-exp exp)
1538 
+	  lambda-vars recursive-vars (the fixnum (1- c))))
1539 
+	((or flic-const flic-pack)
1540 
+	 (values (the fixnum (1- c)) lambda-vars))
1541 
+	(else
1542 
+         ;; case & let & lambda not allowed.
1543 
+	 (values -1 '())))))
1544 
+
1545 
+(define (list-remove-1 item list)
1546 
+  (cond ((null? list)
1547 
+	 '())
1548 
+	((eq? item (car list))
1549 
+	 (cdr list))
1550 
+	(else
1551 
+	 (cons (car list) (list-remove-1 item (cdr list))))
1552 
+	))
1553 
+
1554 
+(define (simple-function-body-1/l exps lambda-vars recursive-vars c)
1555 
+  (declare (type fixnum c))
1556 
+  (if (or (null? exps) (< c 0))
1557 
+      (values c lambda-vars)
1558 
+      (multiple-value-bind (c-1 lambda-vars-1)
1559 
+	  (simple-function-body-1 (car exps) lambda-vars recursive-vars c)
1560 
+	(simple-function-body-1/l
1561 
+	  (cdr exps) lambda-vars-1 recursive-vars c-1))))
1562 
+
1563 
+
1564 
+
1565 
+;;;===================================================================
1566 
+;;; Constant structured data detection
1567 
+;;;===================================================================
1568 
+
1569 
+
1570 
+;;; Look to determine whether an object is a structured constant,
1571 
+;;; recursively examining its components if it's an app.  This is
1572 
+;;; necessary in order to detect constants with arbitrary circular
1573 
+;;; reference to the vars in recursive-vars.
1574 
+
1575 
+(define (structured-constant-recursive? object recursive-vars stack)
1576 
+  (typecase object
1577 
+    (flic-const
1578 
+     '#t)
1579 
+    (flic-ref
1580 
+     (let ((var  (flic-ref-var object)))
1581 
+       (or (memq var stack)
1582 
+	   (var-toplevel? var)
1583 
+	   (and (memq var recursive-vars)
1584 
+		(structured-constant-recursive?
1585 
+		 (var-value var) recursive-vars (cons var stack))))))
1586 
+    (flic-pack
1587 
+     '#t)
1588 
+    (flic-app
1589 
+     (structured-constant-app-recursive?
1590 
+       (flic-app-fn object)
1591 
+       (flic-app-args object)
1592 
+       recursive-vars
1593 
+       stack))
1594 
+    (flic-lambda
1595 
+     (lambda-hoistable? object))
1596 
+    (else
1597 
+     '#f)))
1598 
+
1599 
+(define (structured-constant-app-recursive? fn args recursive-vars stack)
1600 
+  (and (is-type? 'flic-pack fn)
1601 
+       (eqv? (length args) (con-arity (flic-pack-con fn)))
1602 
+       (every-1 (lambda (a)
1603 
+		  (structured-constant-recursive? a recursive-vars stack))
1604 
+		args)))
1605 
+
1606 
+
1607 
+;;; Here's a non-recursive (and more efficient) version of the above.
1608 
+;;; Instead of looking at the whole structure, it only looks one level
1609 
+;;; deep.  This can't detect circular constants, but is useful in
1610 
+;;; contexts where circularities cannot appear.
1611 
+
1612 
+(define (structured-constant? object)
1613 
+  (typecase object
1614 
+    (flic-ref
1615 
+     (var-toplevel? (flic-ref-var object)))
1616 
+    (flic-const
1617 
+     '#t)
1618 
+    (flic-pack
1619 
+     '#t)
1620 
+    (flic-lambda
1621 
+     (lambda-hoistable? object))
1622 
+    (else
1623 
+     '#f)))
1624 
+
1625 
+(define (structured-constant-app? fn args)
1626 
+  (and (is-type? 'flic-pack fn)
1627 
+       (eqv? (length args) (con-arity (flic-pack-con fn)))
1628 
+       (every-1 (function structured-constant?) args)))
1629 
+
1630 
+
1631 
+;;; Determine whether a lambda can be hoisted to top-level.
1632 
+;;; The main purpose of this code is to mark structured constants
1633 
+;;; containing simple lambdas to permit later folding of sel expressions
1634 
+;;; on those constants.  Since the latter expression is permissible
1635 
+;;; only on inlinable functions, stop if we hit an expression that
1636 
+;;; would make the function not inlinable.
1637 
+
1638 
+(define (lambda-hoistable? object)
1639 
+  (and (can-inline? object '() '#t)
1640 
+       (lambda-hoistable-aux
1641 
+	 (flic-lambda-body object)
1642 
+	 (flic-lambda-vars object))))
1643 
+
1644 
+(define (lambda-hoistable-aux object local-vars)
1645 
+  (typecase object
1646 
+    (flic-ref
1647 
+     (or (var-toplevel? (flic-ref-var object))
1648 
+	 (memq (flic-ref-var object) local-vars)))
1649 
+    ((or flic-const flic-pack)
1650 
+     '#t)
1651 
+    (flic-sel
1652 
+     (lambda-hoistable-aux (flic-sel-exp object) local-vars))
1653 
+    (flic-is-constructor
1654 
+     (lambda-hoistable-aux (flic-is-constructor-exp object) local-vars))
1655 
+    (flic-app
1656 
+     (and (lambda-hoistable-aux (flic-app-fn object) local-vars)
1657 
+	  (every-1 (lambda (x) (lambda-hoistable-aux x local-vars))
1658 
+		   (flic-app-args object))))
1659 
+    (else
1660 
+     '#f)))
1661 
+
1662 
+
1663 
+;;; Having determined that something is a structured constant,
1664 
+;;; enter it (and possibly its subcomponents) in the hash table
1665 
+;;; and return a var-ref.
1666 
+
1667 
+(define (enter-structured-constant value recursive?)
1668 
+  (multiple-value-bind (con args var)
1669 
+      (enter-structured-constant-aux value recursive?)
1670 
+    (when (not var)
1671 
+      (setf var (create-temp-var 'constant))
1672 
+      (add-new-structured-constant var con args))
1673 
+    (make-flic-ref var)))
1674 
+
1675 
+(define (enter-structured-constant-aux value recursive?)
1676 
+  (let* ((fn   (flic-app-fn value))
1677 
+	 (con  (flic-pack-con fn))
1678 
+	 (args (if recursive?
1679 
+		   (map (function enter-structured-constant-arg)
1680 
+			(flic-app-args value))
1681 
+		   (flic-app-args value))))
1682 
+    (values con args (lookup-structured-constant con args))))
1683 
+
1684 
+(define (enter-structured-constant-arg a)
1685 
+  (if (is-type? 'flic-app a)
1686 
+      (enter-structured-constant a '#t)
1687 
+      a))
1688 
+
1689 
+(define (lookup-structured-constant con args)
1690 
+  (lookup-structured-constant-aux
1691 
+    (table-entry *structured-constants-table* con) args))
1692 
+
1693 
+(define (lookup-structured-constant-aux alist args)
1694 
+  (cond ((null? alist)
1695 
+	 '#f)
1696 
+	((every (function flic-exp-eq?) (car (car alist)) args)
1697 
+	 (cdr (car alist)))
1698 
+	(else
1699 
+	 (lookup-structured-constant-aux (cdr alist) args))))
1700 
+
1701 
+(define (add-new-structured-constant var con args)
1702 
+  (push (cons args var) (table-entry *structured-constants-table* con))
1703 
+  (setf (var-toplevel? var) '#t)
1704 
+  (setf (var-value var) (make-flic-app (make-flic-pack con) args '#t))
1705 
+  (push var *structured-constants*)
1706 
+  var)
1707 
+
1708 
+
1709 
+
1710 
+;;;===================================================================
1711 
+;;; Invariant argument stuff
1712 
+;;;===================================================================
1713 
+
1714 
+
1715 
+;;; When processing a saturated call to a locally defined function,
1716 
+;;; note whether any of the arguments are always passed the same value.
1717 
+
1718 
+(define (note-invariant-args args vars)
1719 
+  (when (and (not (null? args)) (not (null? vars)))
1720 
+    (let* ((arg  (car args))
1721 
+	   (var  (car vars))
1722 
+	   (val  (var-arg-invariant-value var)))
1723 
+      (cond ((not (var-arg-invariant? var))
1724 
+	     ;; This argument already marked as having more than one
1725 
+	     ;; value.
1726 
+	     )
1727 
+	    ((and (is-type? 'flic-ref arg)
1728 
+		  (eq? (flic-ref-var arg) var))
1729 
+	     ;; This is a recursive call with the same argument.
1730 
+	     ;; Don't update the arg-invariant-value slot.
1731 
+	     )
1732 
+	    ((or (not val)
1733 
+		 (flic-exp-eq? arg val))
1734 
+	     ;; Either this is the first call, or a second call with
1735 
+	     ;; the same argument.
1736 
+	     (setf (var-arg-invariant-value var) arg))
1737 
+	    (else
1738 
+	     ;; Different values for this argument are passed in
1739 
+	     ;; different places, so we can't mess with it.
1740 
+	     (setf (var-arg-invariant? var) '#f)))
1741 
+      (note-invariant-args (cdr args) (cdr vars)))))
1742 
+
1743 
+
1744 
+;;; After processing a let form, check to see if any of the bindings
1745 
+;;; are for local functions with invariant arguments.
1746 
+;;; Suppose we have something like
1747 
+;;;   let foo = \ x y z -> <fn-body>
1748 
+;;;     in <let-body>
1749 
+;;; and y is known to be invariant; then we rewrite this as
1750 
+;;;   let foo1 = \ x z -> let y = <invariant-value> in <fn-body>
1751 
+;;;       foo = \ x1 y1 z1 -> foo1 x1 z1
1752 
+;;;     in <let-body>
1753 
+;;; The original foo binding is inlined on subsequent passes and
1754 
+;;; should go away.  Likewise, the binding of y should be inlined also.
1755 
+;;; *** This is kind of bogus because of the way it depends on the
1756 
+;;; *** magic force-inline bit.  It would be better to do a code walk
1757 
+;;; *** now on the entire let expression to rewrite all the calls to foo.
1758 
+
1759 
+(define (add-stuff-for-invariants bindings)
1760 
+  (if (null? bindings)
1761 
+      '()
1762 
+      (let* ((var  (car bindings))
1763 
+	     (val  (var-value var)))
1764 
+	(setf (cdr bindings)
1765 
+	      (add-stuff-for-invariants (cdr bindings)))
1766 
+	(if (and (is-type? 'flic-lambda val)
1767 
+		 ;; Don't mess with single-reference variable bindings,
1768 
+		 ;; or things we are going to inline anyway.
1769 
+		 (not (var-single-ref var))
1770 
+		 (not (var-simple? var))
1771 
+		 ;; All references must be in saturated calls to do this.
1772 
+		 (eqv? (var-referenced var) (var-fn-referenced var))
1773 
+		 ;; There is at least one argument marked invariant.
1774 
+		 (some (function var-arg-invariant?) (flic-lambda-vars val))
1775 
+		 ;; Every argument marked invariant must also be hoistable.
1776 
+		 (every-1 (function arg-hoistable?) (flic-lambda-vars val)))
1777 
+	    (hoist-invariant-args
1778 
+	      var
1779 
+	      val
1780 
+	      bindings)
1781 
+	    bindings))))
1782 
+
1783 
+(define (arg-hoistable? var)
1784 
+  (if (var-arg-invariant? var)
1785 
+      (or (not (var-arg-invariant-value var))
1786 
+	  (flic-invariant? (var-arg-invariant-value var)
1787 
+			   (dynamic *local-bindings*)))
1788 
+      '#t))
1789 
+
1790 
+(define (hoist-invariant-args var val bindings)
1791 
+  (let ((foo1-var       (copy-temp-var (def-name var)))
1792 
+	(foo1-def-vars  '())
1793 
+	(foo1-app-args  '())
1794 
+	(foo1-let-vars  '())
1795 
+	(foo-def-vars   '()))
1796 
+    (push foo1-var bindings)
1797 
+    (dolist (v (flic-lambda-vars val))
1798 
+      (let ((new-v  (copy-temp-var (def-name v))))
1799 
+	(push (init-flic-var new-v '#f '#f) foo-def-vars)
1800 
+	(if (var-arg-invariant? v)
1801 
+	    (when (var-arg-invariant-value v)
1802 
+	      (push (init-flic-var
1803 
+		      v (copy-flic-top (var-arg-invariant-value v)) '#f)
1804 
+		    foo1-let-vars))
1805 
+	    (begin
1806 
+	      (push v foo1-def-vars)
1807 
+	      (push (make-flic-ref new-v) foo1-app-args))
1808 
+	  )))
1809 
+    (setf foo1-def-vars (nreverse foo1-def-vars))
1810 
+    (setf foo1-app-args (nreverse foo1-app-args))
1811 
+    (setf foo1-let-vars (nreverse foo1-let-vars))
1812 
+    (setf foo-def-vars (nreverse foo-def-vars))
1813 
+    (record-hack 'let-hoist-invariant-args var foo1-let-vars)
1814 
+    ;; Fix up the value of foo1
1815 
+    (init-flic-var
1816 
+      foo1-var
1817 
+      (let ((body  (make-flic-let foo1-let-vars (flic-lambda-body val) '#f)))
1818 
+	(if (null? foo1-def-vars)
1819 
+	    ;; *All* of the arguments were invariant.
1820 
+	    body
1821 
+	    ;; Otherwise, make a new lambda
1822 
+	    (make-flic-lambda foo1-def-vars body)))
1823 
+      '#f)
1824 
+    ;; Fix up the value of foo and arrange for it to be inlined.
1825 
+    (setf (flic-lambda-vars val) foo-def-vars)
1826 
+    (setf (flic-lambda-body val)
1827 
+	  (if (null? foo1-app-args)
1828 
+	      (make-flic-ref foo1-var)
1829 
+	      (make-flic-app (make-flic-ref foo1-var) foo1-app-args '#t)))
1830 
+    (setf (var-simple? var) '#t)
1831 
+    (setf (var-force-inline? var) '#t)
1832 
+    ;; Return modified list of bindings
1833 
+    bindings))
1834 
+
1835 
+
1836 
+
1837 
+;;;===================================================================
1838 
+;;; Install globals
1839 
+;;;===================================================================
1840 
+
1841 
+
1842 
+;;; The optimizer, CFN, etc. can introduce new top-level variables that
1843 
+;;; are not installed in the symbol table.  This causes problems if
1844 
+;;; those variables are referenced in the .hci file (as in the inline
1845 
+;;; expansion of some other variables).  So we need to fix up the
1846 
+;;; symbol table before continuing.
1847 
+
1848 
+(define (install-uninterned-globals vars)
1849 
+  (dolist (v vars)
1850 
+    (let* ((module  (locate-module (def-module v)))
1851 
+	   (name    (def-name v))
1852 
+	   (table   (module-symbol-table module))
1853 
+	   (def     (table-entry table name)))
1854 
+      (cond ((not def)
1855 
+	     ;; This def was not installed.  Rename it if it's a gensym
1856 
+	     ;; and install it.
1857 
+	     (when (gensym? name)
1858 
+	       (setf name (rename-gensym-var v name table)))
1859 
+	     (setf (table-entry table name) v))
1860 
+	    ((eq? def v)
1861 
+	     ;; Already installed.
1862 
+	     '#t)
1863 
+	    (else
1864 
+	     ;; Ooops!  The symbol installed in the symbol table isn't
1865 
+             ;; this one!
1866 
+	     (error "Duplicate defs ~s and ~s in symbol table for ~s!"
1867 
+		    v def module))
1868 
+	    ))))
1869 
+
1870 
+
1871 
+(define (rename-gensym-var var name table)
1872 
+  (setf name (string->symbol (symbol->string name)))
1873 
+  (if (table-entry table name)
1874 
+      ;; This name already in use; gensym a new one!
1875 
+      (rename-gensym-var var (gensym (symbol->string name)) table)
1876 
+      ;; OK, no problem
1877 
+      (setf (def-name var) name)))
1878 
+
1879 
+
1880 
+
1881 
+;;;===================================================================
1882 
+;;; Postoptimizer
1883 
+;;;===================================================================
1884 
+
1885 
+;;; This is another quick traversal of the structure to determine
1886 
+;;; whether references to functions are fully saturated or not.
1887 
+;;; Also makes sure that reference counts on variables are correct;
1888 
+;;; this is needed so the code generator can generate ignore declarations
1889 
+;;; for unused lambda variables.
1890 
+
1891 
+(define-flic-walker postoptimize (object))
1892 
+
1893 
+(define-postoptimize flic-lambda (object)
1894 
+  (dolist (var (flic-lambda-vars object))
1895 
+    (setf (var-referenced var) 0))
1896 
+  (postoptimize (flic-lambda-body object)))
1897 
+
1898 
+(define-postoptimize flic-let (object)
1899 
+  (dolist (var (flic-let-bindings object))
1900 
+    (setf (var-referenced var) 0)
1901 
+    (let ((val  (var-value var)))
1902 
+      (setf (var-arity var)
1903 
+	    (if (is-type? 'flic-lambda val)
1904 
+		(length (flic-lambda-vars val))
1905 
+		0))))
1906 
+  (dolist (var (flic-let-bindings object))
1907 
+    (postoptimize (var-value var)))
1908 
+  (postoptimize (flic-let-body object)))
1909 
+
1910 
+(define-postoptimize flic-app (object)
1911 
+  (let ((fn    (flic-app-fn object)))
1912 
+    (typecase fn
1913 
+      (flic-ref
1914 
+       (let* ((var     (flic-ref-var fn))
1915 
+	      (arity   (var-arity var)))
1916 
+	 (if (not (var-toplevel? var)) (incf (var-referenced var)))
1917 
+	 (when (not (eqv? arity 0))
1918 
+	   (postoptimize-app-aux object var arity (flic-app-args object)))))
1919 
+      (flic-pack
1920 
+       (let* ((con    (flic-pack-con fn))
1921 
+	      (arity  (con-arity con)))
1922 
+	 (postoptimize-app-aux object '#f arity (flic-app-args object))))
1923 
+      (else
1924 
+       (postoptimize fn)))
1925 
+    (dolist (a (flic-app-args object))
1926 
+      (postoptimize a))))
1927 
+
1928 
+(define (postoptimize-app-aux object var arity args)
1929 
+  (declare (type fixnum arity))
1930 
+  (let ((nargs   (length args)))
1931 
+    (declare (type fixnum nargs))
1932 
+    (cond ((< nargs arity)
1933 
+	   ;; not enough arguments
1934 
+	   (when var (setf (var-standard-refs? var) '#t)))
1935 
+	  ((eqv? nargs arity)
1936 
+	   ;; exactly the right number of arguments
1937 
+	   (when var (setf (var-optimized-refs? var) '#t))
1938 
+	   (setf (flic-app-saturated? object) '#t))
1939 
+	  (else
1940 
+	   ;; make the fn a nested flic-app
1941 
+	   (multiple-value-bind (arghead argtail)
1942 
+	       (split-list args arity)
1943 
+	     (setf (flic-app-fn object)
1944 
+		   (make-flic-app (flic-app-fn object) arghead '#t))
1945 
+	     (setf (flic-app-args object) argtail)
1946 
+	     (when var (setf (var-optimized-refs? var) '#t))
1947 
+	     (dolist (a arghead)
1948 
+	       (postoptimize a))))
1949 
+	  )))
1950 
+
1951 
+(define-postoptimize flic-ref (object)
1952 
+  (let ((var  (flic-ref-var object)))
1953 
+    (if (not (var-toplevel? var)) (incf (var-referenced var)))
1954 
+    (setf (var-standard-refs? var) '#t)))
1955 
+
1956 
+(define-postoptimize flic-const (object)
1957 
+  object)
1958 
+
1959 
+(define-postoptimize flic-pack (object)
1960 
+  object)
1961 
+
1962 
+(define-postoptimize flic-and (object)
1963 
+  (for-each (function postoptimize) (flic-and-exps object)))
1964 
+
1965 
+(define-postoptimize flic-case-block (object)
1966 
+  (for-each (function postoptimize) (flic-case-block-exps object)))
1967 
+
1968 
+(define-postoptimize flic-if (object)
1969 
+  (postoptimize (flic-if-test-exp object))
1970 
+  (postoptimize (flic-if-then-exp object))
1971 
+  (postoptimize (flic-if-else-exp object)))
1972 
+
1973 
+(define-postoptimize flic-return-from (object)
1974 
+  (postoptimize (flic-return-from-exp object)))
1975 
+
1976 
+(define-postoptimize flic-sel (object)
1977 
+  (postoptimize (flic-sel-exp object)))
1978 
+
1979 
+(define-postoptimize flic-is-constructor (object)
1980 
+  (postoptimize (flic-is-constructor-exp object)))
1981 
+
1982 
+(define-postoptimize flic-con-number (object)
1983 
+  (postoptimize (flic-con-number-exp object)))
1984 
+
1985 
+(define-postoptimize flic-void (object)
1986 
+  object)
backend/strictness.scm
History View file @ 4e98702
0 1987 
new file mode 100644
... ... 
@@ -0,0 +1,845 @@
1 
+;;; strictness.scm -- strictness analyzer
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  28 May 1992
5 
+;;;
6 
+;;; The algorithm used here follows Consel, "Fast Strictness Analysis
7 
+;;; Via Symbolic Fixpoint Interation".
8 
+;;;
9 
+;;; The basic idea is to do a traversal of the flic structure, building
10 
+;;; a boolean term that represents the strictness of each subexpression.
11 
+;;; The boolean terms are composed of ands & ors of the argument variables
12 
+;;; to each function.  After traversing the body of the function, we can
13 
+;;; determine which argument variables are strict by examining the
14 
+;;; corresponding term, and then we can update the strictness attribute
15 
+;;; of the var that names the function.
16 
+;;;
17 
+;;; Another traversal needs to be done to attach strictness properties
18 
+;;; to locally bound variables.
19 
+
20 
+
21 
+;;; Here's the main entry point.
22 
+
23 
+(define (strictness-analysis-top big-let)
24 
+  (fun-strictness-walk big-let)
25 
+  (var-strictness-walk big-let '() '())
26 
+  ;; *** This probably belongs somewhere else?
27 
+  (do-box-analysis big-let '() '() '#t)
28 
+  big-let)
29 
+
30 
+
31 
+;;;======================================================================
32 
+;;; Function strictness analyzer code walk
33 
+;;;======================================================================
34 
+
35 
+;;; This actually involves two code walkers.  The first merely traverses
36 
+;;; structure and identifies function definitions.  The second traverses
37 
+;;; the definitions of the functions to compute their strictness.
38 
+
39 
+
40 
+;;; Fun-strictness-walk is the walker to find function definitions.
41 
+;;; This is trivial for everything other than flic-let.
42 
+
43 
+(define-flic-walker fun-strictness-walk (object))
44 
+
45 
+(define-fun-strictness-walk flic-lambda (object)
46 
+  (fun-strictness-walk (flic-lambda-body object)))
47 
+
48 
+(define-fun-strictness-walk flic-let (object)
49 
+  (if (flic-let-recursive? object)
50 
+      (fun-strictness-walk-letrec object)
51 
+      (fun-strictness-walk-let* object))
52 
+  (dolist (v (flic-let-bindings object))
53 
+    (fun-strictness-walk (var-value v)))
54 
+  (fun-strictness-walk (flic-let-body object)))
55 
+
56 
+(define-fun-strictness-walk flic-app (object)
57 
+  (fun-strictness-walk (flic-app-fn object))
58 
+  (for-each (function fun-strictness-walk) (flic-app-args object)))
59 
+
60 
+(define-fun-strictness-walk flic-ref (object)
61 
+  (declare (ignore object))
62 
+  '#f)
63 
+
64 
+(define-fun-strictness-walk flic-pack (object)
65 
+  (declare (ignore object))
66 
+  '#f)
67 
+
68 
+(define-fun-strictness-walk flic-const (object)
69 
+  (declare (ignore object))
70 
+  '#f)
71 
+
72 
+(define-fun-strictness-walk flic-case-block (object)
73 
+  (for-each (function fun-strictness-walk) (flic-case-block-exps object)))
74 
+
75 
+(define-fun-strictness-walk flic-return-from (object)
76 
+  (fun-strictness-walk (flic-return-from-exp object)))
77 
+
78 
+(define-fun-strictness-walk flic-and (object)
79 
+  (for-each (function fun-strictness-walk) (flic-and-exps object)))
80 
+
81 
+(define-fun-strictness-walk flic-if (object)
82 
+  (fun-strictness-walk (flic-if-test-exp object))
83 
+  (fun-strictness-walk (flic-if-then-exp object))
84 
+  (fun-strictness-walk (flic-if-else-exp object)))
85 
+
86 
+(define-fun-strictness-walk flic-sel (object)
87 
+  (fun-strictness-walk (flic-sel-exp object)))
88 
+
89 
+(define-fun-strictness-walk flic-is-constructor (object)
90 
+  (fun-strictness-walk (flic-is-constructor-exp object)))
91 
+
92 
+(define-fun-strictness-walk flic-con-number (object)
93 
+  (fun-strictness-walk (flic-con-number-exp object)))
94 
+
95 
+(define-fun-strictness-walk flic-void (object)
96 
+  (declare (ignore object))
97 
+  '#f)
98 
+
99 
+
100 
+
101 
+;;; Here is the magic for let bindings of function definitions.
102 
+;;; Sequential bindings are easy.  For recursive bindings, we must
103 
+;;; keep track of mutually recursive functions.
104 
+;;; If a function binding has a strictness annotation attached,
105 
+;;; do not mess with it further.
106 
+
107 
+(define (fun-strictness-walk-let* object)
108 
+  (dolist (var (flic-let-bindings object))
109 
+    (let ((val  (var-value var)))
110 
+      (when (is-type? 'flic-lambda val)
111 
+	(if (var-strictness var)
112 
+	    (mark-argument-strictness
113 
+	      (var-strictness var) (flic-lambda-vars val))
114 
+	    (compute-function-strictness var val '())))
115 
+      )))
116 
+
117 
+(define (fun-strictness-walk-letrec object)
118 
+  (let ((stack   '()))
119 
+    (dolist (var (flic-let-bindings object))
120 
+      (let ((val  (var-value var)))
121 
+	(if (and (is-type? 'flic-lambda val) (not (var-strictness var)))
122 
+	    (setf stack (add-recursive-function-1 var (init-var-env) stack)))))
123 
+    (dolist (var (flic-let-bindings object))
124 
+      (let ((val  (var-value var)))
125 
+	(when (is-type? 'flic-lambda val)
126 
+	  (if (var-strictness var)
127 
+	      (mark-argument-strictness
128 
+	        (var-strictness var) (flic-lambda-vars val))
129 
+	      (compute-function-strictness var val stack)))
130 
+	))))
131 
+
132 
+(define (compute-function-strictness var val stack)
133 
+  (let* ((vars  (flic-lambda-vars val))
134 
+	 (env   (add-var-binding-n vars (map (function list) vars)
135 
+				   (init-var-env)))
136 
+	 (term  (compute-strictness-walk (flic-lambda-body val) env stack)))
137 
+    (when (eq? term '#t)
138 
+      (signal-infinite-loop-function var)
139 
+      (setf (flic-lambda-body val)
140 
+	    (make-infinite-loop-error
141 
+	      (format '#f "Function ~s has an infinite loop." var))))
142 
+    (setf (var-strictness var) (munge-strictness-terms term vars))))
143 
+
144 
+
145 
+(define (signal-infinite-loop-function var)
146 
+  (recoverable-error 'infinite-loop-function
147 
+    "Function ~s has an infinite loop."
148 
+    var))
149 
+
150 
+(define (make-infinite-loop-error msg)
151 
+  (make-flic-app
152 
+    (make-flic-ref (core-symbol "error"))
153 
+    (list (make-flic-const msg))
154 
+    '#t))
155 
+
156 
+
157 
+;;; compute-strictness-walk is the traversal to compute strictness
158 
+;;; terms.
159 
+;;; The purpose of the env is to map locally bound variables onto
160 
+;;; strictness terms which are expressed as lists of argument variables
161 
+;;; to the function being analyzed.
162 
+;;; The purpose of the stack is to keep track of recursive function
163 
+;;; walks and recognize when we've reached a fixed point.
164 
+
165 
+(define-flic-walker compute-strictness-walk (object env stack))
166 
+
167 
+
168 
+;;; Making a function never forces anything.
169 
+
170 
+(define-compute-strictness-walk flic-lambda (object env stack)
171 
+  (declare (ignore object env stack))
172 
+  '#f)
173 
+
174 
+
175 
+;;; For let, add bindings to environment and get strictness of body.
176 
+
177 
+(define-compute-strictness-walk flic-let (object env stack)
178 
+  (let ((bindings    (flic-let-bindings object))
179 
+	(body        (flic-let-body object))
180 
+	(recursive?  (flic-let-recursive? object)))
181 
+    (if recursive?
182 
+	;; Must add stuff to env and stack before traversing anything.
183 
+	(begin
184 
+	  (dolist (var bindings)
185 
+	    (setf env (add-var-binding-1 var '#f env)))
186 
+	  (dolist (var bindings)
187 
+	    (let ((val  (var-value var)))
188 
+	      (when (is-type? 'flic-lambda val)
189 
+		(setf stack (add-recursive-function-1 var env stack)))))
190 
+	  (dolist (var bindings)
191 
+	    (let ((val  (var-value var)))
192 
+	      (set-var-env var env (compute-strictness-walk val env stack)))))
193 
+	;; Otherwise just do things sequentially.
194 
+	;; Note that even though there is no possibility of recursion
195 
+	;; here, we must add stuff to the stack anyway so that we can
196 
+	;; walk calls in the correct env.
197 
+	(dolist (var bindings)
198 
+	  (let ((val  (var-value var)))
199 
+	    (when (is-type? 'flic-lambda val)
200 
+	      (setf stack (add-recursive-function-1 var env stack)))
201 
+	    (setf env
202 
+		  (add-var-binding-1
203 
+		    var (compute-strictness-walk val env stack) env)))))
204 
+    (compute-strictness-walk body env stack)))
205 
+
206 
+
207 
+;;; Treat explicit, saturated calls to named functions specially.
208 
+
209 
+(define-compute-strictness-walk flic-app (object env stack)
210 
+  (let ((fn         (flic-app-fn object))
211 
+	(args       (flic-app-args object))
212 
+	(saturated? (flic-app-saturated? object)))
213 
+    (cond ((and (is-type? 'flic-ref fn) saturated?)
214 
+	   ;; Special handling for named functions.
215 
+	   (compute-application-strictness
216 
+	     (flic-ref-var fn)
217 
+	     args env stack))
218 
+	  ((and (is-type? 'flic-pack fn) saturated?)
219 
+	   ;; Similarly for constructor applications, but we always
220 
+	   ;; know which arguments are strict in advance.
221 
+	   (compute-application-strictness-aux
222 
+	      (con-slot-strict? (flic-pack-con fn))
223 
+	      args env stack))
224 
+	  (else
225 
+	   ;; Otherwise, we know that the function expression is going to
226 
+	   ;; be forced, but all of its arguments are lazy.  So ignore the
227 
+	   ;; arguments in computing the strictness of the whole expression.
228 
+	   (compute-strictness-walk fn env stack)))))
229 
+
230 
+
231 
+(define (compute-application-strictness var args env stack)
232 
+  (let* ((strictness          (var-strictness var))
233 
+	 (info                '#f)
234 
+	 (arg-strictness-list '#f))
235 
+    (cond ((eq? var (core-symbol "error"))
236 
+	   ;; This expression will return bottom no matter what.
237 
+	   'error)
238 
+	  (strictness
239 
+	   ;; We've already completed the walk for this function and
240 
+	   ;; determined which of its arguments are strict.
241 
+	   ;; The strictness expression for the application is the
242 
+	   ;; OR of the strictness of its non-lazy arguments.
243 
+	   (compute-application-strictness-aux strictness args env stack))
244 
+	  ((get-recursive-function-trace
245 
+	     (setf arg-strictness-list
246 
+		   (map (lambda (a) (compute-strictness-walk a env stack))
247 
+			args))
248 
+	     (setf info (get-recursive-function var stack)))
249 
+	   ;; We're already tracing this call.  Return true to
250 
+	   ;; terminate the fixpoint iteration.
251 
+	   '#t)
252 
+	  (else
253 
+	   ;; Otherwise, begin a new trace instance.
254 
+	   ;; Add stuff to the saved var-env to map references to
255 
+	   ;; the argument variables to the strictness terms for
256 
+	   ;; the actual arguments at this call site.
257 
+	   ;; References to closed-over variables within the function
258 
+	   ;; use the strictness values that were stored in the env
259 
+	   ;; at the point of function definition.
260 
+	   (let* ((env      (get-recursive-function-env info))
261 
+		  (lambda   (var-value var))
262 
+		  (body     (flic-lambda-body lambda))
263 
+		  (vars     (flic-lambda-vars lambda))
264 
+		  (result   '#f))
265 
+	     (push-recursive-function-trace arg-strictness-list info)
266 
+	     (setf result
267 
+		   (compute-strictness-walk
268 
+		     body
269 
+		     (add-var-binding-n vars arg-strictness-list env)
270 
+		     stack))
271 
+	     (pop-recursive-function-trace info)
272 
+	     result))
273 
+	  )))
274 
+
275 
+
276 
+(define (compute-application-strictness-aux strictness args env stack)
277 
+  (make-or-term
278 
+    (map (lambda (strict? arg)
279 
+	   (if strict? (compute-strictness-walk arg env stack) '#f))
280 
+	 strictness args)))
281 
+
282 
+
283 
+;;; For a reference, look up the term associated with the variable in env.
284 
+;;; If not present in the environment, ignore it; the binding was established
285 
+;;; outside the scope of the function being analyzed.
286 
+
287 
+(define-compute-strictness-walk flic-ref (object env stack)
288 
+  (declare (ignore stack))
289 
+  (get-var-env (flic-ref-var object) env))
290 
+
291 
+
292 
+;;; References to constants or constructors never fail.
293 
+
294 
+(define-compute-strictness-walk flic-const (object env stack)
295 
+  (declare (ignore object env stack))
296 
+  '#f)
297 
+
298 
+(define-compute-strictness-walk flic-pack (object env stack)
299 
+  (declare (ignore object env stack))
300 
+  '#f)
301 
+
302 
+
303 
+;;; The first clause of a case-block is the only one that is always
304 
+;;; executed, so it is the only one that affects the strictness of
305 
+;;; the overall expression.
306 
+
307 
+(define-compute-strictness-walk flic-case-block (object env stack)
308 
+  (compute-strictness-walk (car (flic-case-block-exps object)) env stack))
309 
+
310 
+
311 
+;;; Return-from fails if its subexpression fails.
312 
+
313 
+(define-compute-strictness-walk flic-return-from (object env stack)
314 
+  (compute-strictness-walk (flic-return-from-exp object) env stack))
315 
+
316 
+
317 
+;;; For and, the first subexpression is the only one that is always
318 
+;;; executed, so it is the only one that affects the strictness of
319 
+;;; the overall expression.
320 
+
321 
+(define-compute-strictness-walk flic-and (object env stack)
322 
+  (compute-strictness-walk (car (flic-and-exps object)) env stack))
323 
+
324 
+
325 
+;;; The strictness of an IF is the strictness of the test OR'ed
326 
+;;; with the AND of the strictness of its branches.
327 
+
328 
+(define-compute-strictness-walk flic-if (object env stack)
329 
+  (make-or-term-2
330 
+    (compute-strictness-walk (flic-if-test-exp object) env stack)
331 
+    (make-and-term-2
332 
+      (compute-strictness-walk (flic-if-then-exp object) env stack)
333 
+      (compute-strictness-walk (flic-if-else-exp object) env stack))))
334 
+
335 
+
336 
+;;; Selecting a component of a data structure causes it to be forced,
337 
+;;; so propagate the strictness of the subexpression upwards.
338 
+
339 
+(define-compute-strictness-walk flic-sel (object env stack)
340 
+  (compute-strictness-walk (flic-sel-exp object) env stack))
341 
+
342 
+
343 
+;;; Is-constructor and con-number force their subexpressions.
344 
+
345 
+(define-compute-strictness-walk flic-is-constructor (object env stack)
346 
+  (compute-strictness-walk (flic-is-constructor-exp object) env stack))
347 
+
348 
+(define-compute-strictness-walk flic-con-number (object env stack)
349 
+  (compute-strictness-walk (flic-con-number-exp object) env stack))
350 
+
351 
+(define-compute-strictness-walk flic-void (object env stack)
352 
+  (declare (ignore object env stack))
353 
+  '#f)
354 
+
355 
+
356 
+
357 
+;;;======================================================================
358 
+;;; Utilities for managing the env
359 
+;;;======================================================================
360 
+
361 
+;;; The env is just an a-list.
362 
+
363 
+(define (init-var-env)
364 
+  '())
365 
+
366 
+(define (add-var-binding-1 var binding env)
367 
+  (cons (cons var binding) env))
368 
+
369 
+(define (add-var-binding-n vars bindings env)
370 
+  (if (null? vars)
371 
+      env
372 
+      (add-var-binding-n (cdr vars) (cdr bindings)
373 
+			 (cons (cons (car vars) (car bindings)) env))))
374 
+
375 
+(define (get-var-env var env)
376 
+  (let ((stuff  (assq var env)))
377 
+    (if stuff
378 
+	(cdr stuff)
379 
+	'#f)))
380 
+
381 
+(define (set-var-env var env new-value)
382 
+  (let ((stuff  (assq var env)))
383 
+    (if stuff
384 
+	(setf (cdr stuff) new-value)
385 
+	(error "Can't find binding for ~s in environment." var))))
386 
+
387 
+
388 
+
389 
+;;;======================================================================
390 
+;;; Utilities for managing the stack
391 
+;;;======================================================================
392 
+
393 
+;;; For now, the stack is just an a-list too.
394 
+;;; Some sort of hashing scheme could also be used instead of a linear
395 
+;;; search, but if the iteration depth for the fixpoint analysis is
396 
+;;; small, it's probably not worth the trouble.
397 
+
398 
+(define (add-recursive-function-1 var env stack)
399 
+  (cons (list var env '()) stack))
400 
+
401 
+(define (get-recursive-function var stack)
402 
+  (or (assq var stack)
403 
+      (error "Can't find entry for ~s in stack." var)))
404 
+
405 
+(define (get-recursive-function-env entry)
406 
+  (cadr entry))
407 
+
408 
+(define (push-recursive-function-trace new-args entry)
409 
+  (push new-args (caddr entry)))
410 
+
411 
+(define (pop-recursive-function-trace entry)
412 
+  (pop (caddr entry)))
413 
+
414 
+(define (get-recursive-function-trace args entry)
415 
+  (get-recursive-function-trace-aux args (caddr entry)))
416 
+
417 
+(define (get-recursive-function-trace-aux args list)
418 
+  (cond ((null? list)
419 
+	 '#f)
420 
+	((every (function term=) args (car list))
421 
+	 '#t)
422 
+	(else
423 
+	 (get-recursive-function-trace-aux args (cdr list)))))
424 
+
425 
+
426 
+;;;======================================================================
427 
+;;; Utilities for boolean terms
428 
+;;;======================================================================
429 
+
430 
+
431 
+;;; A term is either #t, #f, the symbol 'error, or a list of variables
432 
+;;; (which are implicitly or'ed together).
433 
+;;; #t and 'error are treated identically, except that #t indicates
434 
+;;; failure because of infinite recursion and 'error indicates failure
435 
+;;; due to a call to the error function.
436 
+;;; In general, AND terms add nothing to the result, so to reduce
437 
+;;; needless computation we generally reduce (and a b) to #f.
438 
+
439 
+;;; Make an OR term.  First look for some obvious special cases as an
440 
+;;; efficiency hack, otherwise fall through to more general code.
441 
+
442 
+(define (make-or-term terms)
443 
+  (cond ((null? terms)
444 
+	 '#f)
445 
+	((null? (cdr terms))
446 
+	 (car terms))
447 
+	((eq? (car terms) '#t)
448 
+	 '#t)
449 
+	((eq? (car terms) 'error)
450 
+	 'error)
451 
+	((eq? (car terms) '#f)
452 
+	 (make-or-term (cdr terms)))
453 
+	(else
454 
+	 (make-or-term-2 (car terms) (make-or-term (cdr terms))))))
455 
+
456 
+(define (make-or-term-2 term1 term2)
457 
+  (cond ((eq? term2 '#t)
458 
+	 '#t)
459 
+	((eq? term2 'error)
460 
+	 'error)
461 
+	((eq? term2 '#f)
462 
+	 term1)
463 
+	((eq? term1 '#t)
464 
+	 '#t)
465 
+	((eq? term1 'error)
466 
+	 'error)
467 
+	((eq? term1 '#f)
468 
+	 term2)
469 
+	;; At this point we know both terms are variable lists.
470 
+	((implies? term2 term1)
471 
+	 term2)
472 
+	((implies? term1 term2)
473 
+	 term1)
474 
+	(else
475 
+	 (merge-list-terms term1 term2))))
476 
+
477 
+
478 
+;;;  Merge the two lists, throwing out duplicate variables.
479 
+
480 
+(define (merge-list-terms list1 list2)
481 
+  (cond ((null? list1)
482 
+	 list2)
483 
+	((null? list2)
484 
+	 list1)
485 
+	((eq? (car list1) (car list2))
486 
+	 (cons (car list1) (merge-list-terms (cdr list1) (cdr list2))))
487 
+	((var< (car list1) (car list2))
488 
+	 (cons (car list1) (merge-list-terms (cdr list1) list2)))
489 
+	(else
490 
+	 (cons (car list2) (merge-list-terms list1 (cdr list2))))))
491 
+
492 
+
493 
+;;; Helper function: does term1 imply term2?
494 
+;;; True if every subterm of term2 is also included in term1.
495 
+
496 
+(define (implies? term1 term2)
497 
+  (every (lambda (v2) (memq v2 term1)) term2))
498 
+
499 
+
500 
+;;; Make an AND term.  Because we don't want to build up arbitrarily
501 
+;;; complex AND expressions, basically just compute an OR list that
502 
+;;; represents the intersection of the subterms.
503 
+
504 
+(define (make-and-term terms)
505 
+  (cond ((null? terms)
506 
+	 '#f)
507 
+	((null? (cdr terms))
508 
+	 (car terms))
509 
+	((eq? (car terms) '#t)
510 
+	 (make-and-term (cdr terms)))
511 
+	((eq? (car terms) 'error)
512 
+	 (make-and-term (cdr terms)))
513 
+	((eq? (car terms) '#f)
514 
+	 '#f)
515 
+	(else
516 
+	 (make-and-term-2 (car terms) (make-and-term (cdr terms))))))
517 
+
518 
+(define (make-and-term-2 term1 term2)
519 
+  (cond ((eq? term2 '#t)
520 
+	 term1)
521 
+	((eq? term2 'error)
522 
+	 term1)
523 
+	((eq? term2 '#f)
524 
+	 '#f)
525 
+	((eq? term1 '#t)
526 
+	 term2)
527 
+	((eq? term1 'error)
528 
+	 term2)
529 
+	((eq? term1 '#f)
530 
+	 '#f)
531 
+	;; At this point we know both terms are variable lists.
532 
+	((implies? term2 term1)
533 
+	 term1)
534 
+	((implies? term1 term2)
535 
+	 term2)
536 
+	(else
537 
+	 (let ((result  '()))
538 
+	   (dolist (v term1)
539 
+	     (if (memq v term2)
540 
+		 (push v result)))
541 
+	   (if (null? result)
542 
+	       '#f
543 
+	       (nreverse result))))
544 
+	))
545 
+
546 
+
547 
+;;; Subterms of an and/or term are always sorted, so that to compare
548 
+;;; two terms we can just compare subterms componentwise.
549 
+
550 
+(define (term= term1 term2)
551 
+  (or (eq? term1 term2)
552 
+      (and (pair? term1)
553 
+	   (pair? term2)
554 
+	   (eq? (car term1) (car term2))
555 
+	   (term= (cdr term1) (cdr term2)))))
556 
+
557 
+
558 
+;;; Variables within an OR-list are sorted alphabetically by names.
559 
+
560 
+(define (var< var1 var2)
561 
+  (string<? (symbol->string (def-name var1))
562 
+	    (symbol->string (def-name var2))))
563 
+
564 
+
565 
+;;; Determine which of the vars are present in the term.
566 
+
567 
+(define (munge-strictness-terms term vars)
568 
+  (map (lambda (v)
569 
+	 (setf (var-strict? v)
570 
+	       (cond ((var-force-strict? v)
571 
+		      '#t)
572 
+		     ((eq? term '#t)
573 
+		      '#t)
574 
+		     ((eq? term 'error)
575 
+		      '#t)
576 
+		     ((eq? term '#f)
577 
+		      '#f)
578 
+		     ((memq v term)
579 
+		      '#t)
580 
+		     (else
581 
+		      '#f))))
582 
+       vars))
583 
+
584 
+(define (mark-argument-strictness strictness vars)
585 
+  (map (lambda (s v) (setf (var-strict? v) s)) strictness vars))
586 
+
587 
+
588 
+
589 
+;;;======================================================================
590 
+;;; Variable strictness propagation code walk
591 
+;;;======================================================================
592 
+
593 
+;;; Walk the code, marking any vars found in strict contexts as strict.
594 
+;;; Locally bound variables are consed onto the varlist.  This is
595 
+;;; used to determine which variables can be marked as strict when they
596 
+;;; appear in strict contexts.
597 
+;;; When walking something that does not appear in a strict context
598 
+;;; or that is not always evaluated, reinitialize varlist to the empty
599 
+;;; list.
600 
+;;; The stack is used to keep track of variables that have not been
601 
+;;; initialized yet, so that we can detect some kinds of infinite loops.
602 
+;;; When walking something that is not always evaluated, reset this to
603 
+;;; the empty list.
604 
+
605 
+(define-flic-walker var-strictness-walk (object varlist stack))
606 
+
607 
+
608 
+
609 
+;;; Since the body of the lambda might not be evaluated, reset
610 
+;;; both varlist and stack.
611 
+
612 
+(define-var-strictness-walk flic-lambda (object varlist stack)
613 
+  (declare (ignore varlist stack))
614 
+  (var-strictness-walk (flic-lambda-body object) '() '()))
615 
+
616 
+
617 
+;;; The basic idea for let is to find the variables that are strict in
618 
+;;; the body first, and propagate that information backwards to the
619 
+;;; binding initializers.
620 
+
621 
+(define-var-strictness-walk flic-let (object varlist stack)
622 
+  (let ((bindings  (flic-let-bindings object)))
623 
+    (var-strictness-walk-let-aux
624 
+      bindings
625 
+      (flic-let-body object)
626 
+      (append bindings varlist)
627 
+      (append bindings stack)
628 
+      (flic-let-recursive? object))))
629 
+
630 
+(define (var-strictness-walk-let-aux bindings body varlist stack recursive?)
631 
+  (if (null? bindings)
632 
+      (var-strictness-walk body varlist stack)
633 
+      (begin
634 
+	(var-strictness-walk-let-aux
635 
+	  (cdr bindings) body varlist (cdr stack) recursive?)
636 
+	(let* ((var  (car bindings))
637 
+	       (val  (var-value var)))
638 
+	  (cond ((var-strict? var)
639 
+		 ;; Recursive variables have to be set back to unstrict
640 
+		 ;; because the value form might contain forward references.
641 
+		 ;; The box analyzer will set them to strict again if the
642 
+		 ;; value forms are safe.
643 
+		 (when recursive? (setf (var-strict? var) '#f))
644 
+		 ;; Detect x = 1 + x circularities here
645 
+		 (var-strictness-walk val varlist stack))
646 
+		((flic-exp-strict-result? val)
647 
+		 ;; The val is going to be wrapped in a delay.
648 
+		 (var-strictness-walk val '() '()))
649 
+		(else
650 
+		 ;; Watch out for x = x and x = cdr x circularities.
651 
+		 ;; *** I am still a little confused about this.  It
652 
+		 ;; *** seems like the stack should be passed through
653 
+		 ;; *** when walking already-boxed values that appear as
654 
+                 ;; *** non-strict function arguments as well, but doing
655 
+		 ;; *** so generates some apparently bogus complaints
656 
+		 ;; *** about infinite loops.  So maybe doing it here
657 
+		 ;; *** is incorrect too, and we just haven't run across
658 
+		 ;; *** a test case that triggers it???
659 
+		 (var-strictness-walk val '() stack))
660 
+		)))))
661 
+
662 
+
663 
+(define (flic-exp-strict-result? val)
664 
+  (cond ((is-type? 'flic-ref val)
665 
+	 (var-strict? (flic-ref-var val)))
666 
+	((is-type? 'flic-sel val)
667 
+	 (list-ref (con-slot-strict? (flic-sel-con val)) (flic-sel-i val)))
668 
+	(else
669 
+	 '#t)))
670 
+
671 
+(define-var-strictness-walk flic-app (object varlist stack)
672 
+  (let ((fn           (flic-app-fn object))
673 
+	(args         (flic-app-args object))
674 
+	(saturated?   (flic-app-saturated? object)))
675 
+    (cond ((and saturated? (is-type? 'flic-ref fn))
676 
+	   ;; Strictness of function should be stored on var
677 
+	   (do-var-strictness-flic-app-aux
678 
+	     (var-strictness (flic-ref-var fn))
679 
+	     fn args varlist stack))
680 
+	  ((and saturated? (is-type? 'flic-pack fn))
681 
+	   ;; Strictness of constructor should be stored on con
682 
+	   (do-var-strictness-flic-app-aux
683 
+	     (con-slot-strict? (flic-pack-con fn))
684 
+	     fn args varlist stack))
685 
+	  (else
686 
+	   ;; All arguments are non-strict
687 
+	   (var-strictness-walk fn varlist stack)
688 
+	   (dolist (a args)
689 
+	     (var-strictness-walk a '() '()))))))
690 
+
691 
+(define (do-var-strictness-flic-app-aux strictness fn args varlist stack)
692 
+  (when (not strictness)
693 
+    (error "Can't find strictness for function ~s." fn))
694 
+  (dolist (a args)
695 
+    (if (pop strictness)
696 
+	(var-strictness-walk a varlist stack)
697 
+	(var-strictness-walk a '() '()))))
698 
+
699 
+
700 
+(define-var-strictness-walk flic-ref (object varlist stack)
701 
+  (let ((var  (flic-ref-var object)))
702 
+    (cond ((memq var stack)
703 
+	   ;; Circular variable definition detected.
704 
+	   (signal-infinite-loop-variable var)
705 
+	   (setf (var-value var)
706 
+		 (make-infinite-loop-error
707 
+		   (format '#f "Variable ~s has an infinite loop." var))))
708 
+	  ((memq var varlist)
709 
+	   (setf (var-strict? var) '#t))
710 
+	  (else
711 
+	   '#f))))
712 
+
713 
+(define (signal-infinite-loop-variable var)
714 
+  (recoverable-error 'infinite-loop-variable
715 
+    "Variable ~s has an infinite loop."
716 
+    var))
717 
+
718 
+(define-var-strictness-walk flic-const (object varlist stack)
719 
+  (declare (ignore object varlist stack))
720 
+  '#f)
721 
+
722 
+(define-var-strictness-walk flic-pack (object varlist stack)
723 
+  (declare (ignore object varlist stack))
724 
+  '#f)
725 
+
726 
+(define-var-strictness-walk flic-case-block (object varlist stack)
727 
+  (var-strictness-walk (car (flic-case-block-exps object)) varlist stack)
728 
+  (dolist (exp (cdr (flic-case-block-exps object)))
729 
+    (var-strictness-walk exp '() '())))
730 
+
731 
+(define-var-strictness-walk flic-return-from (object varlist stack)
732 
+  (var-strictness-walk (flic-return-from-exp object) varlist stack))
733 
+
734 
+(define-var-strictness-walk flic-and (object varlist stack)
735 
+  (var-strictness-walk (car (flic-and-exps object)) varlist stack)
736 
+  (dolist (exp (cdr (flic-and-exps object)))
737 
+    (var-strictness-walk exp '() '())))
738 
+
739 
+(define-var-strictness-walk flic-if (object varlist stack)
740 
+  (var-strictness-walk (flic-if-test-exp object) varlist stack)
741 
+  (var-strictness-walk (flic-if-then-exp object) '() '())
742 
+  (var-strictness-walk (flic-if-else-exp object) '() '()))
743 
+
744 
+(define-var-strictness-walk flic-sel (object varlist stack)
745 
+  (var-strictness-walk (flic-sel-exp object) varlist stack))
746 
+
747 
+(define-var-strictness-walk flic-is-constructor (object varlist stack)
748 
+  (var-strictness-walk (flic-is-constructor-exp object) varlist stack))
749 
+
750 
+(define-var-strictness-walk flic-con-number (object varlist stack)
751 
+  (var-strictness-walk (flic-con-number-exp object) varlist stack))
752 
+
753 
+(define-var-strictness-walk flic-void (object varlist stack)
754 
+  (declare (ignore object varlist stack))
755 
+  '#f)
756 
+
757 
+
758 
+
759 
+;;;======================================================================
760 
+;;; Printer support
761 
+;;;======================================================================
762 
+
763 
+(define (strictness-analysis-printer big-let)
764 
+  (print-strictness big-let 0))
765 
+
766 
+(define (print-strictness-list list depth)
767 
+  (dolist (o list)
768 
+    (print-strictness o depth)))
769 
+
770 
+(define (print-strictness-indent depth)
771 
+  (dotimes (i (* 2 depth))
772 
+    (declare (ignorable i))
773 
+    (write-char #\space)))
774 
+
775 
+(define (strictness-string bool)
776 
+  (if bool "#t" "#f"))
777 
+
778 
+(define-flic-walker print-strictness (object depth))
779 
+
780 
+(define-print-strictness flic-lambda (object depth)
781 
+  (print-strictness-indent depth)
782 
+  (format '#t "In anonymous function:~%")
783 
+  (print-strictness (flic-lambda-body object) (1+ depth)))
784 
+
785 
+(define-print-strictness flic-let (object depth)
786 
+  (dolist (var (flic-let-bindings object))
787 
+    (let ((val  (var-value var)))
788 
+      (if (is-type? 'flic-lambda val)
789 
+	  (begin
790 
+	    (print-strictness-indent depth)
791 
+	    (format '#t "Function ~s has argument strictness ~a.~%"
792 
+		    var
793 
+		    (map (function strictness-string) (var-strictness var)))
794 
+	    (print-strictness (flic-lambda-body val) (1+ depth)))
795 
+	  (begin
796 
+	    (print-strictness-indent depth)
797 
+	    (format '#t "Variable ~s has strictness ~a.~%"
798 
+		    var
799 
+		    (strictness-string (var-strict? var)))
800 
+	    (print-strictness val depth)))))
801 
+  (print-strictness (flic-let-body object) depth))
802 
+
803 
+(define-print-strictness flic-app (object depth)
804 
+  (print-strictness (flic-app-fn object) depth)
805 
+  (print-strictness-list (flic-app-args object) depth))
806 
+
807 
+(define-print-strictness flic-ref (object depth)
808 
+  (declare (ignore object depth))
809 
+  '#f)
810 
+
811 
+(define-print-strictness flic-const (object depth)
812 
+  (declare (ignore object depth))
813 
+  '#f)
814 
+
815 
+(define-print-strictness flic-pack (object depth)
816 
+  (declare (ignore object depth))
817 
+  '#f)
818 
+
819 
+(define-print-strictness flic-case-block (object depth)
820 
+  (print-strictness-list (flic-case-block-exps object) depth))
821 
+
822 
+(define-print-strictness flic-return-from (object depth)
823 
+  (print-strictness (flic-return-from-exp object) depth))
824 
+
825 
+(define-print-strictness flic-and (object depth)
826 
+  (print-strictness-list (flic-and-exps object) depth))
827 
+
828 
+(define-print-strictness flic-if (object depth)
829 
+  (print-strictness (flic-if-test-exp object) depth)
830 
+  (print-strictness (flic-if-then-exp object) depth)
831 
+  (print-strictness (flic-if-else-exp object) depth))
832 
+
833 
+(define-print-strictness flic-sel (object depth)
834 
+  (print-strictness (flic-sel-exp object) depth))
835 
+
836 
+(define-print-strictness flic-is-constructor (object depth)
837 
+  (print-strictness (flic-is-constructor-exp object) depth))
838 
+
839 
+(define-print-strictness flic-con-number (object depth)
840 
+  (print-strictness (flic-con-number-exp object) depth))
841 
+
842 
+(define-print-strictness flic-void (object depth)
843 
+  (declare (ignore object depth))
844 
+  '#f)
845 
+
bin/cmu-clx-haskell
History View file @ 4e98702
0 846 
new file mode 100755
... ... 
@@ -0,0 +1,9 @@
1 
+#!/bin/csh
2 
+#
3 
+# run cmu clx haskell
4 
+
5 
+if (`arch -k` == "sun4c") then
6 
+  $CMUCLBIN -core $HASKELL/bin/sun4c-clx-haskell.core
7 
+else
8 
+  $CMUCLBIN -core $HASKELL/bin/sun4m-clx-haskell.core
9 
+endif
bin/cmu-haskell
History View file @ 4e98702
0 10 
new file mode 100755
... ... 
@@ -0,0 +1,9 @@
1 
+#!/bin/csh
2 
+#
3 
+# run cmu haskell
4 
+
5 
+if (`arch -k` == "sun4c") then
6 
+  $CMUCLBIN -core $HASKELL/bin/sun4c-haskell.core
7 
+else
8 
+  $CMUCLBIN -core $HASKELL/bin/sun4m-haskell.core
9 
+endif
bin/magic.scm
History View file @ 4e98702
0 10 
new file mode 100644
... ... 
@@ -0,0 +1,10 @@
1 
+;;; magic.scm -- magic support file for dumping compiled code files.
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  8 Jul 1992
5 
+;;;
6 
+;;; This file is used to dump compiled code files.  The macro call below
7 
+;;; expands into the code being dumped.  See dump-interface.scm for more
8 
+;;; details.
9 
+
10 
+(magic-form-to-compile)
cfn/README
History View file @ 4e98702
0 11 
new file mode 100644
... ... 
@@ -0,0 +1,35 @@
1 
+Whats what in the cfn.
2 
+
3 
+Language generated by cfn contains these ast node types:
4 
+  lambda
5 
+  let
6 
+  if
7 
+  case   -- restriction: all patterns must be either literals or
8 
+                         a constructor with var and wildcard args
9 
+  app
10 
+  var-ref
11 
+  con-ref
12 
+  const
13 
+  con-number
14 
+  sel
15 
+  is-constructor
16 
+
17 
+Transformations to do:
18 
+  Convert lists to explicit calls to cons
19 
+  Simplify patterns
20 
+  Remove sequences
21 
+  Remove list comprehensions
22 
+  Remove sections
23 
+  Reduce patterns on lhs of decls
24 
+  Reduce patterns in function args
25 
+  Convert where decls to let statements
26 
+  Convert guarded-expressions to if - then - else form
27 
+
28 
+Done earlier:
29 
+  signdecls are removed in scoping
30 
+  exp-signs are removed in typechecker
31 
+  prec parser removes `negate' & pp-* nodes
32 
+
33 
+
34 
+
35 
+
cfn/cfn.scm
History View file @ 4e98702
0 36 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+;;; cfn.scm -- module definition for CFN phase
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  11 Mar 1992
5 
+;;;
6 
+
7 
+
8 
+(define-compilation-unit cfn
9 
+  (source-filename "$Y2/cfn/")
10 
+  (require ast haskell-utils)
11 
+  (unit main
12 
+	(source-filename "main.scm"))
13 
+  (unit misc
14 
+	(source-filename "misc.scm")
15 
+	(require main))
16 
+  (unit pattern
17 
+	(source-filename "pattern.scm")
18 
+	(require main)))
19 
+
20 
+
21 
+
cfn/main.scm
History View file @ 4e98702
0 22 
new file mode 100644
... ... 
@@ -0,0 +1,83 @@
1 
+;;; main.scm -- main entry point for CFN pass
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  27 Feb 1992
5 
+;;;
6 
+
7 
+
8 
+;;;===================================================================
9 
+;;; Basic support
10 
+;;;===================================================================
11 
+
12 
+
13 
+;;; Define the basic walker and some helper functions.
14 
+
15 
+(define-walker cfn ast-td-cfn-walker)
16 
+
17 
+(define (cfn-ast-1 x)
18 
+  (call-walker cfn x))
19 
+
20 
+(define (cfn-ast/list l)
21 
+  (map (lambda (x) (cfn-ast-1 x)) l))
22 
+
23 
+
24 
+;;; This is the main entry point.  It is called by the driver on
25 
+;;; each top-level decl in the module.
26 
+
27 
+(define (cfn-ast x)
28 
+  (let ((result  (cfn-ast-1 x)))
29 
+;    (pprint result)  ;*** debug
30 
+    result))
31 
+
32 
+
33 
+
34 
+;;;===================================================================
35 
+;;; Default traversal methods
36 
+;;;===================================================================
37 
+
38 
+
39 
+(define-local-syntax (make-cfn-code slot type)
40 
+  (let ((stype  (sd-type slot))
41 
+        (sname  (sd-name slot)))
42 
+    (cond ((and (symbol? stype)
43 
+                (or (eq? stype 'exp)
44 
+                    (subtype? stype 'exp)))
45 
+           `(setf (struct-slot ',type ',sname object)
46 
+                  (cfn-ast-1 (struct-slot ',type ',sname object))))
47 
+          ((and (pair? stype)
48 
+                (eq? (car stype) 'list)
49 
+                (symbol? (cadr stype))
50 
+                (or (eq? (cadr stype) 'exp)
51 
+                    (subtype? (cadr stype) 'exp)))
52 
+           `(setf (struct-slot ',type ',sname object)
53 
+                  (cfn-ast/list (struct-slot ',type ',sname object))))
54 
+          ((and (pair? stype)
55 
+                (eq? (car stype) 'list)
56 
+                (eq? (cadr stype) 'decl))
57 
+           `(setf (struct-slot ',type ',sname object)
58 
+                  (cfn-valdef-list (struct-slot ',type ',sname object))))
59 
+          (else
60 
+;          (format '#t "Cfn: skipping slot ~A in ~A~%"
61 
+;                  (sd-name slot)
62 
+;                  type)
63 
+           '#f))))
64 
+
65 
+(define-modify-walker-methods cfn
66 
+  (let if
67 
+   exp-sign
68 
+   app
69 
+   var-ref con-ref
70 
+   integer-const float-const char-const string-const
71 
+   con-number sel is-constructor
72 
+   void
73 
+   case-block return-from and-exp
74 
+   )
75 
+  (object)
76 
+  make-cfn-code)
77 
+
78 
+
79 
+;;; These have specialized walkers:
80 
+;;; lambda, case, valdef, list-comp  (pattern.scm)
81 
+;;; list-exp, list-comp, section-l, section-r, dict-placeholder,
82 
+;;; recursive-placeholder, save-old-exp (misc.scm)
83 
+
cfn/misc.scm
History View file @ 4e98702
0 84 
new file mode 100644
... ... 
@@ -0,0 +1,113 @@
1 
+;;; misc.scm -- random other transformations done during CFN processing
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  27 Feb 1992
5 
+;;;
6 
+;;; This file contains specialized CFN walkers that implement rewrite rules
7 
+;;; for list-exp, sequence-xxx, list-comp, section-l, and section-r.
8 
+
9 
+
10 
+;;; Turn list-exps into cons chains.
11 
+
12 
+(define-walker-method cfn list-exp (object)
13 
+  (do-cfn-list-exp (list-exp-exps object)))
14 
+
15 
+(define (do-cfn-list-exp exps)
16 
+  (if (null? exps)
17 
+      ;; Make a con-ref for []
18 
+      (**con/def (core-symbol "Nil"))
19 
+      ;; Otherwise make an app of :
20 
+      (let ((first  (cfn-ast-1 (car exps)))
21 
+	    (rest   (do-cfn-list-exp (cdr exps))))
22 
+	(**app (**con/def (core-symbol ":")) first rest))))
23 
+
24 
+
25 
+;;; Sections get turned into lambda expressions.
26 
+
27 
+(define-walker-method cfn section-l (object)
28 
+  (let ((def   (create-temp-var 'section-arg)))
29 
+    (**lambda/pat
30 
+      (list (**var-pat/def def))
31 
+      (**app (cfn-ast-1 (section-l-op object))
32 
+             (**var/def def)
33 
+	     (cfn-ast-1 (section-l-exp object))))))
34 
+
35 
+(define-walker-method cfn section-r (object)
36 
+  (let ((def   (create-temp-var 'section-arg)))
37 
+    (**lambda/pat
38 
+      (list (**var-pat/def def))
39 
+      (**app (cfn-ast-1 (section-r-op object))
40 
+	     (cfn-ast-1 (section-r-exp object))
41 
+             (**var/def def)))))
42 
+
43 
+
44 
+
45 
+;;; Do list comprehensions.
46 
+;;; rewrite in terms of build and foldr so that we can apply
47 
+;;; deforestation techniques later.
48 
+
49 
+(define-walker-method cfn list-comp (object)
50 
+  (let ((c   (create-temp-var 'c))
51 
+	(n   (create-temp-var 'n)))
52 
+    (cfn-ast-1
53 
+      (**app (**var/def (core-symbol "build"))
54 
+	     (**lambda/pat
55 
+	       (list (**var-pat/def c) (**var-pat/def n))
56 
+	       (do-cfn-list-comp
57 
+		 (list-comp-exp object) (list-comp-quals object) c n))))))
58 
+
59 
+(define (do-cfn-list-comp exp quals c n)
60 
+  (if (null? quals)
61 
+      (**app (**var/def c) exp (**var/def n))
62 
+      (let ((qual  (car quals)))
63 
+	(if (is-type? 'qual-generator qual)
64 
+	    (do-cfn-list-comp-generator exp qual (cdr quals) c n)
65 
+	    (do-cfn-list-comp-filter exp qual (cdr quals) c n)))))
66 
+
67 
+(define (do-cfn-list-comp-filter exp qual quals c n)
68 
+  (**if (qual-filter-exp qual)
69 
+	(do-cfn-list-comp exp quals c n)
70 
+	(**var/def n)))
71 
+
72 
+(define (do-cfn-list-comp-generator exp qual quals c n)
73 
+  (let ((gen-pat  (qual-generator-pat qual))
74 
+	(gen-exp  (qual-generator-exp qual))
75 
+	(l        (create-temp-var 'list))
76 
+	(b        (create-temp-var 'rest)))
77 
+    (**app (**var/def (core-symbol "foldr"))
78 
+	   (**lambda/pat
79 
+	     (list (**var-pat/def l) (**var-pat/def b))
80 
+	     (**case (**var/def l)
81 
+		     (list (**alt/simple
82 
+			    gen-pat
83 
+			    (do-cfn-list-comp exp quals c b))
84 
+			   (**alt/simple
85 
+			    (**wildcard-pat)
86 
+			    (**var/def b)))))
87 
+	   (**var/def n)
88 
+	   gen-exp)))
89 
+
90 
+;;; Placeholders just get eliminated
91 
+
92 
+(define-walker-method cfn dict-placeholder (object)
93 
+  (if (eq? (dict-placeholder-exp object) '#f)
94 
+      (error "Type checker screwed a dict placeholder object ~s." object)
95 
+      (cfn-ast-1 (dict-placeholder-exp object))))
96 
+
97 
+(define-walker-method cfn method-placeholder (object)
98 
+  (if (eq? (method-placeholder-exp object) '#f)
99 
+      (error "Type checker screwed a method placeholder object ~s." object)
100 
+      (cfn-ast-1 (method-placeholder-exp object))))
101 
+
102 
+(define-walker-method cfn recursive-placeholder (object)
103 
+  (if (eq? (recursive-placeholder-exp object) '#f)
104 
+      (error "Type checker screwed a recursive placeholder object ~s." object)
105 
+      (cfn-ast-1 (recursive-placeholder-exp object))))
106 
+
107 
+(define-walker-method cfn cast (object)
108 
+  (cfn-ast-1 (cast-exp object)))
109 
+
110 
+;;; Eliminate saved old expressions
111 
+
112 
+(define-walker-method cfn save-old-exp (object)
113 
+  (cfn-ast-1 (save-old-exp-new-exp object)))
cfn/pattern.scm
History View file @ 4e98702
0 114 
new file mode 100644
... ... 
@@ -0,0 +1,654 @@
1 
+;;; pattern.scm -- cfn processing of pattern-related AST structures
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  27 Feb 1992
5 
+;;;
6 
+;;; This file contains specialized CFN walkers for lambda, case, and valdef
7 
+;;; structures.
8 
+
9 
+
10 
+
11 
+;;;=====================================================================
12 
+;;; Top-level walkers
13 
+;;;=====================================================================
14 
+
15 
+
16 
+;;; The calls to remember-context are so an appropriate error message
17 
+;;; can be produced for pattern-matching failures.
18 
+
19 
+(define-walker-method cfn lambda (object)
20 
+  (remember-context object
21 
+    (do-cfn-lambda (lambda-pats object) (lambda-body object))))
22 
+
23 
+
24 
+(define-walker-method cfn case (object)
25 
+  (remember-context object
26 
+    (do-cfn-case
27 
+      (case-exp object)
28 
+      (case-alts object))))
29 
+
30 
+
31 
+
32 
+
33 
+;;; Valdefs are always processed as a list.
34 
+
35 
+(define (cfn-valdef-list list-of-valdefs)
36 
+  (if (null? list-of-valdefs)
37 
+      '()
38 
+      (nconc (cfn-valdef (car list-of-valdefs))
39 
+	     (cfn-valdef-list (cdr list-of-valdefs)))))
40 
+
41 
+(define (cfn-valdef object)
42 
+  (remember-context object
43 
+    (if (null? (single-fun-def-args (car (valdef-definitions object))))
44 
+	;; This is a pattern binding.
45 
+	(do-cfn-pattern-def-top object)
46 
+	;; This is a function binding.
47 
+	;; Branch on single-headed/multi-headed definition.
48 
+	(list (add-dict-params
49 
+	        object
50 
+		(if (null? (cdr (valdef-definitions object)))
51 
+		    (do-cfn-function-def-simple object)
52 
+		    (do-cfn-function-def-general object))))
53 
+      )))
54 
+
55 
+
56 
+;;; This adds the dictionary parameters needed by the type system.  A valdef
57 
+;;; structure has a dictionary-args field which contains the variables to be
58 
+;;; bound to dicationary arguments.
59 
+
60 
+(define (add-dict-params original-valdef generated-valdef)
61 
+  (let ((vars (valdef-dictionary-args original-valdef)))
62 
+    (when (not (null? vars))
63 
+      (let* ((sfd  (car (valdef-definitions generated-valdef)))
64 
+	     (rhs  (car (single-fun-def-rhs-list sfd)))
65 
+	     (exp  (guarded-rhs-rhs rhs))
66 
+	     (pats (map (function **var-pat/def) vars)))
67 
+	(if (is-type? 'lambda exp)
68 
+	    (setf (lambda-pats exp)
69 
+		  (nconc pats (lambda-pats exp)))
70 
+	    (setf (guarded-rhs-rhs rhs)
71 
+		  (**lambda/pat pats exp))))))
72 
+  generated-valdef)
73 
+
74 
+
75 
+;;;=====================================================================
76 
+;;; Lambda rewriting
77 
+;;;=====================================================================
78 
+
79 
+
80 
+;;; For lambda, make all the argument patterns into var pats.
81 
+;;; Rewrite the body as a CASE to do any more complicated pattern
82 
+;;; matching.
83 
+;;; The CFN output for lambda is a modified lambda expression with
84 
+;;; all var-pats as arguments.
85 
+
86 
+(define (do-cfn-lambda pats body)
87 
+  (let ((new-args  '())
88 
+	(new-vars  '())
89 
+	(new-pats  '()))
90 
+    (dolist (p pats)
91 
+      (typecase p
92 
+	(wildcard-pat
93 
+	  (push (**var-pat/def (create-temp-var 'arg)) new-args))
94 
+        (var-pat
95 
+	  (push p new-args))
96 
+	(as-pat
97 
+	  (let ((var  (var-ref-var (as-pat-var p))))
98 
+	    (push (**var-pat/def var) new-args)
99 
+	    (push (**var/def var) new-vars)
100 
+	    (push (as-pat-pattern p) new-pats)))
101 
+	(else
102 
+	  (let ((var  (create-temp-var 'arg)))
103 
+	    (push (**var-pat/def var) new-args)
104 
+	    (push (**var/def var) new-vars)
105 
+	    (push p new-pats)))))
106 
+    (setf new-args (nreverse new-args))
107 
+    (setf new-vars (nreverse new-vars))
108 
+    (setf new-pats (nreverse new-pats))
109 
+    (**lambda/pat
110 
+      new-args
111 
+      (cond ((null? new-vars)
112 
+	     ;; No fancy pattern matching necessary.
113 
+	     (cfn-ast-1 body))
114 
+	    ((null? (cdr new-vars))
115 
+	     ;; Exactly one argument to match on.
116 
+	     (do-cfn-case (car new-vars)
117 
+			  (list (**alt/simple (car new-pats) body))))
118 
+	    (else
119 
+	     ;; Multiple arguments to match on.
120 
+	     (do-cfn-case-tuple
121 
+	       new-vars
122 
+	       (list (**alt/simple (**tuple-pat new-pats) body))))
123 
+	    ))))
124 
+
125 
+
126 
+;;;=====================================================================
127 
+;;; Function definitions
128 
+;;;=====================================================================
129 
+
130 
+
131 
+;;; The output of the CFN for function definitions is a simple
132 
+;;; valdef which binds a variable to a lambda expression.
133 
+
134 
+
135 
+;;; The simple case:  there is only one set of arguments.
136 
+
137 
+(define (do-cfn-function-def-simple object)
138 
+  (let* ((pat    (valdef-lhs object))
139 
+	 (sfd    (car (valdef-definitions object))))
140 
+    (**valdef/pat
141 
+      pat
142 
+      (do-cfn-lambda
143 
+        (single-fun-def-args sfd)
144 
+	(rewrite-guards-and-where-decls
145 
+	  (single-fun-def-where-decls sfd)
146 
+	  (single-fun-def-rhs-list sfd)
147 
+	  '#f)))))
148 
+
149 
+
150 
+;;; The general case:  generate new variables as the formal parameters
151 
+;;; to the resulting lambda, then use case to do the pattern matching.
152 
+
153 
+(define (do-cfn-function-def-general object)
154 
+  (let ((pat   (valdef-lhs object))
155 
+	(vars  (map (lambda (p)
156 
+		      (declare (ignore p))
157 
+		      (create-temp-var 'arg))
158 
+		    (single-fun-def-args (car (valdef-definitions object)))))
159 
+	(alts  (map (lambda (sfd)
160 
+		      (**alt (**tuple-pat (single-fun-def-args sfd))
161 
+			     (single-fun-def-rhs-list sfd)
162 
+			     (single-fun-def-where-decls sfd)))
163 
+		    (valdef-definitions object))))
164 
+    (**valdef/pat
165 
+      pat
166 
+      (**lambda/pat
167 
+        (map (function **var-pat/def) vars)
168 
+	(if (null? (cdr vars))
169 
+	    ;; one-argument case
170 
+	    (do-cfn-case (**var/def (car vars)) alts)
171 
+	    ;; multi-argument case
172 
+	    (do-cfn-case-tuple (map (function **var/def) vars) alts))))
173 
+    ))
174 
+
175 
+
176 
+;;;=====================================================================
177 
+;;; Case
178 
+;;;=====================================================================
179 
+
180 
+
181 
+;;; For case, add failure alt, then call helper function to generate
182 
+;;; pattern matching tests.
183 
+;;; The CFN output for case is a case-block construct.
184 
+
185 
+(define (do-cfn-case exp alts)
186 
+  (setf alts
187 
+	(append alts
188 
+		(list (**alt/simple (**wildcard-pat) (make-failure-exp)))))
189 
+  (let ((list-of-pats  	(map (lambda (a) (list (alt-pat a))) alts)))
190 
+    (if (is-type? 'var-ref exp)
191 
+	(match-pattern-list (list exp) list-of-pats alts)
192 
+	(let ((temp  (create-temp-var 'cfn)))
193 
+	  (**let (list (**valdef/def temp (cfn-ast-1 exp)))
194 
+		 (match-pattern-list
195 
+		   (list (**var/def temp))
196 
+		   list-of-pats
197 
+		   alts)))
198 
+      )))
199 
+
200 
+
201 
+
202 
+;;; Here's a special case, for when the exp being matched is a tuple
203 
+;;; of var-refs and all the alts also have tuple pats.
204 
+
205 
+(define (do-cfn-case-tuple exps alts)
206 
+  (setf alts
207 
+	(append alts
208 
+		(list
209 
+		  (**alt/simple
210 
+		    (**tuple-pat
211 
+		      (map (lambda (e) (declare (ignore e)) (**wildcard-pat))
212 
+			   exps))
213 
+		    (make-failure-exp)))))
214 
+  (match-pattern-list
215 
+    exps
216 
+    (map (lambda (a) (pcon-pats (alt-pat a))) alts)
217 
+    alts))
218 
+
219 
+
220 
+(define (match-pattern-list exps list-of-pats alts)
221 
+  (let ((block-name  (gensym "PMATCH")))
222 
+    (**case-block
223 
+      block-name
224 
+      (map (lambda (a p) (match-pattern exps p a block-name))
225 
+	   alts
226 
+	   list-of-pats))))
227 
+
228 
+
229 
+;;; Produce an exp that matches the given alt against the exps.
230 
+;;; If the match succeeds, it will return-from the given block-name.
231 
+
232 
+(define (match-pattern exps pats alt block-name)
233 
+  (if (null pats)
234 
+      ;; No more patterns to match.
235 
+      ;; Return an exp that handles the guards and where-decls.
236 
+      (cfn-ast-1
237 
+        (rewrite-guards-and-where-decls
238 
+	  (alt-where-decls alt) (alt-rhs-list alt) block-name))
239 
+      ;; Otherwise dispatch on type of first pattern.
240 
+      (let ((pat  (pop pats))
241 
+	    (exp  (pop exps)))
242 
+	(funcall
243 
+	  (typecase pat
244 
+	    (wildcard-pat (function match-wildcard-pat))
245 
+	    (var-pat      (function match-var-pat))
246 
+	    (pcon         (function match-pcon))
247 
+	    (as-pat       (function match-as-pat))
248 
+	    (irr-pat      (function match-irr-pat))
249 
+	    (const-pat    (function match-const-pat))
250 
+	    (plus-pat     (function match-plus-pat))
251 
+	    (list-pat     (function match-list-pat))
252 
+	    (else         (error "Unrecognized pattern ~s." pat)))
253 
+	  pat
254 
+	  exp
255 
+	  pats
256 
+	  exps
257 
+	  alt
258 
+	  block-name))))
259 
+
260 
+
261 
+
262 
+
263 
+;;; Wildcard patterns add no pattern matching test.
264 
+;;; Just recurse on the next pattern to be matched.
265 
+
266 
+(define (match-wildcard-pat pat exp pats exps alt block-name)
267 
+  (declare (ignore pat exp))
268 
+  (match-pattern exps pats alt block-name))
269 
+
270 
+
271 
+;;; A variable pattern likewise does not add any test.  However,
272 
+;;; a binding of the variable to the corresponding exp must be added.
273 
+
274 
+(define (match-var-pat pat exp pats exps alt block-name)
275 
+  (push (**valdef/pat pat exp)
276 
+	(alt-where-decls alt))
277 
+  (match-pattern exps pats alt block-name))
278 
+
279 
+
280 
+;;; Pcons are the hairy case because they may have subpatterns that need
281 
+;;; to be matched.
282 
+;;; If there are subpats and the exp is not a var-ref, make a let binding.
283 
+;;; If the con is a tuple type, there is no need to generate a test
284 
+;;; since the test would always succeed anyway.
285 
+;;; Do not generate let bindings here for subexpressions; do this lazily
286 
+;;; if and when necessary.
287 
+
288 
+(define (match-pcon pat exp pats exps alt block-name)
289 
+  (let* ((var?    (is-type? 'var-ref exp))
290 
+	 (var     (if var?
291 
+		      (var-ref-var exp)
292 
+		      (create-temp-var 'conexp)))
293 
+	 (con     (pcon-con pat))
294 
+	 (arity   (con-arity con))
295 
+	 (alg     (con-alg con))
296 
+	 (tuple?  (algdata-tuple? alg))
297 
+	 (subpats (pcon-pats pat))
298 
+	 (subexps '()))
299 
+    (dotimes (i arity)
300 
+      (push (**sel con (**var/def var) i) subexps))
301 
+    (setf exps (nconc (nreverse subexps) exps))
302 
+    (setf pats (append subpats pats))
303 
+    (let ((tail  (match-pattern exps pats alt block-name)))
304 
+      (when (not tuple?)
305 
+	(setf tail
306 
+	      (**and-exp (**is-constructor (**var/def var) con) tail)))
307 
+      (when (not var?)
308 
+	(setf tail
309 
+	      (**let (list (**valdef/def var (cfn-ast-1 exp))) tail)))
310 
+      tail)))
311 
+
312 
+
313 
+;;; For as-pat, add a variable binding.
314 
+;;; If the expression being matched is not already a variable reference,
315 
+;;; take this opportunity to make the let binding.  Otherwise push the
316 
+;;; let-binding onto the where-decls.
317 
+
318 
+(define (match-as-pat pat exp pats exps alt block-name)
319 
+  (let ((var    (var-ref-var (as-pat-var pat)))
320 
+	(subpat (as-pat-pattern pat)))
321 
+    (if (is-type? 'var-ref exp)
322 
+	(begin
323 
+	  (push (**valdef/def var (**var/def (var-ref-var exp)))
324 
+		(alt-where-decls alt))
325 
+	  (match-pattern
326 
+	    (cons exp exps)
327 
+	    (cons subpat pats)
328 
+	    alt
329 
+	    block-name))
330 
+	(**let (list (**valdef/def var (cfn-ast-1 exp)))
331 
+	       (match-pattern
332 
+		 (cons (**var/def var) exps)
333 
+		 (cons subpat pats)
334 
+		 alt
335 
+		 block-name)))))
336 
+
337 
+
338 
+;;; An irrefutable pattern adds no test to the pattern matching,
339 
+;;; but adds a pattern binding to the where-decls.
340 
+
341 
+(define (match-irr-pat pat exp pats exps alt block-name)
342 
+  (let ((subpat  (irr-pat-pattern pat)))
343 
+    (push (**valdef/pat subpat exp) (alt-where-decls alt))
344 
+    (match-pattern exps pats alt block-name)))
345 
+
346 
+
347 
+;;; A const pat has a little piece of code inserted by the typechecker
348 
+;;; to do the test.
349 
+;;; For matches against string constants, generate an inline test to match
350 
+;;; on each character of the string.
351 
+
352 
+(define (match-const-pat pat exp pats exps alt block-name)
353 
+  (let ((const  (const-pat-value pat)))
354 
+    (**and-exp
355 
+      (if (is-type? 'string-const const)
356 
+	  (let ((string  (string-const-value const)))
357 
+	    (if (string=? string "")
358 
+		(**is-constructor exp (core-symbol "Nil"))
359 
+		(**app (**var/def (core-symbol "primStringEq")) const exp)))
360 
+	  (cfn-ast-1 (**app (const-pat-match-fn pat) exp)))
361 
+      (match-pattern exps pats alt block-name))
362 
+    ))
363 
+
364 
+
365 
+;;; Plus pats have both a magic test and a piece of code to
366 
+;;; make a binding in the where-decls.  Make a variable binding
367 
+;;; for the exp if it's not already a variable.
368 
+
369 
+(define (match-plus-pat pat exp pats exps alt block-name)
370 
+  (let* ((var?  (is-type? 'var-ref exp))
371 
+	 (var   (if var? (var-ref-var exp) (create-temp-var 'plusexp))))
372 
+    (push (**valdef/pat (plus-pat-pattern pat)
373 
+			(**app (plus-pat-bind-fn pat) (**var/def var)))
374 
+	  (alt-where-decls alt))
375 
+    (let ((tail  (match-pattern exps pats alt block-name)))
376 
+      (setf tail
377 
+	    (**and-exp
378 
+	      (cfn-ast-1 (**app (plus-pat-match-fn pat) (**var/def var)))
379 
+	      tail))
380 
+      (if var?
381 
+	  tail
382 
+	  (**let (list (**valdef/def var exp)) tail)))))
383 
+
384 
+
385 
+;;; Rewrite list pats as pcons, then process recursively.
386 
+
387 
+(define (match-list-pat pat exp pats exps alt block-name)
388 
+  (let ((newpat  (rewrite-list-pat (list-pat-pats pat))))
389 
+    (match-pattern
390 
+      (cons exp exps)
391 
+      (cons newpat pats)
392 
+      alt
393 
+      block-name)))
394 
+
395 
+(define (rewrite-list-pat subpats)
396 
+  (if (null? subpats)
397 
+      (**pcon/def (core-symbol "Nil") '())
398 
+      (**pcon/def (core-symbol ":")
399 
+		  (list (car subpats)
400 
+			(rewrite-list-pat (cdr subpats))))))
401 
+
402 
+
403 
+
404 
+
405 
+;;;=====================================================================
406 
+;;; Pattern definitions
407 
+;;;=====================================================================
408 
+
409 
+
410 
+(define (do-cfn-pattern-def-top object)
411 
+  (typecase (valdef-lhs object)
412 
+    (var-pat
413 
+      ;; If the pattern definition is a simple variable assignment, it
414 
+      ;; may have dictionary parameters that need to be messed with.
415 
+      ;; Complicated pattern bindings can't be overloaded in this way.
416 
+      (list (add-dict-params object (do-cfn-pattern-def-simple object))))
417 
+    (irr-pat
418 
+      ;; Irrefutable patterns are redundant here.
419 
+      (setf (valdef-lhs object) (irr-pat-pattern (valdef-lhs object)))
420 
+      (do-cfn-pattern-def-top object))
421 
+    (wildcard-pat
422 
+     ;; Wildcards are no-ops.
423 
+     '())
424 
+    (pcon
425 
+     ;; Special-case because it's frequent and general case creates
426 
+     ;; such lousy code
427 
+     (do-cfn-pattern-def-pcon object))
428 
+    (else
429 
+      (do-cfn-pattern-def-general object))))
430 
+
431 
+
432 
+;;; Do a "simple" pattern definition, e.g. one that already has a
433 
+;;; var-pat on the lhs.
434 
+
435 
+(define (do-cfn-pattern-def-simple object)
436 
+  (let* ((pat  (valdef-lhs object))
437 
+	 (sfd  (car (valdef-definitions object)))
438 
+	 (exp  (rewrite-guards-and-where-decls
439 
+		 (single-fun-def-where-decls sfd)
440 
+		 (single-fun-def-rhs-list sfd)
441 
+		 '#f)))
442 
+  (**valdef/pat pat (cfn-ast-1 exp))))
443 
+
444 
+
445 
+;;; Destructure a pcon.
446 
+;;; Note that the simplified expansion is only valid if none of
447 
+;;; the subpatterns introduce tests.  Otherwise we must defer to
448 
+;;; the general case.
449 
+
450 
+(define (do-cfn-pattern-def-pcon object)
451 
+  (let* ((pat     (valdef-lhs object))
452 
+	 (subpats (pcon-pats pat)))
453 
+    (if (every (function irrefutable-pat?) subpats)
454 
+	(let* ((con     (pcon-con pat))
455 
+	       (arity   (con-arity con))
456 
+	       (alg     (con-alg con))
457 
+	       (tuple?  (algdata-tuple? alg))
458 
+	       (temp    (create-temp-var 'pbind))
459 
+	       (result  '()))
460 
+	  (dotimes (i arity)
461 
+	    (setf result
462 
+		  (nconc result
463 
+			 (do-cfn-pattern-def-top
464 
+			   (**valdef/pat (pop subpats)
465 
+					 (**sel con (**var/def temp) i))))))
466 
+	  (if (null? result)
467 
+	      '()
468 
+	      (let* ((sfd   (car (valdef-definitions object)))
469 
+		     (exp   (cfn-ast-1
470 
+			      (rewrite-guards-and-where-decls
471 
+			        (single-fun-def-where-decls sfd)
472 
+				(single-fun-def-rhs-list sfd)
473 
+				'#f))))
474 
+		(when (not tuple?)
475 
+		  (let ((temp1  (create-temp-var 'cfn)))
476 
+		    (setf exp
477 
+			  (**let (list (**valdef/def temp1 exp))
478 
+				 (**if (**is-constructor (**var/def temp1) con)
479 
+				       (**var/def temp1)
480 
+				       (make-failure-exp))))))
481 
+		(cons (**valdef/def temp exp) result))))
482 
+	(do-cfn-pattern-def-general object))))
483 
+
484 
+
485 
+
486 
+;;; Turn a complicated pattern definition into a list of simple ones.
487 
+;;; The idea is to use case to match the pattern and build a tuple of
488 
+;;; all the values which are being destructured into the pattern
489 
+;;; variables.
490 
+
491 
+(define (do-cfn-pattern-def-general object)
492 
+  (multiple-value-bind (new-pat vars new-vars)
493 
+      (copy-pattern-variables (valdef-lhs object))
494 
+    (if (not (null? vars))
495 
+	(let* ((sfd      (car (valdef-definitions object)))
496 
+	       (exp      (rewrite-guards-and-where-decls
497 
+			   (single-fun-def-where-decls sfd)
498 
+			   (single-fun-def-rhs-list sfd)
499 
+			   '#f))
500 
+	       (arity    (length vars)))
501 
+	  (if (eqv? arity 1)
502 
+	      (list (**valdef/def
503 
+		      (var-ref-var (car vars))
504 
+		      (do-cfn-case
505 
+		        exp
506 
+			(list (**alt/simple new-pat (car new-vars))))))
507 
+	      (let ((temp     (create-temp-var 'pbind))
508 
+		    (bindings '()))
509 
+		(dotimes (i arity)
510 
+		  (push (**valdef/def (var-ref-var (pop vars))
511 
+				      (**tuple-sel arity i (**var/def temp)))
512 
+			bindings))
513 
+		(cons (**valdef/def
514 
+		        temp
515 
+			(do-cfn-case
516 
+			  exp
517 
+			  (list (**alt/simple new-pat (**tuple/l new-vars)))))
518 
+		      bindings))))
519 
+	'())))
520 
+
521 
+
522 
+
523 
+;;; Helper function for above.
524 
+;;; All the variables in the pattern must be replaced with temporary
525 
+;;; variables.
526 
+
527 
+(define (copy-pattern-variables pat)
528 
+  (typecase pat
529 
+    (wildcard-pat
530 
+      (values pat '() '()))
531 
+    (var-pat
532 
+      (let ((new  (create-temp-var (var-ref-name (var-pat-var pat)))))
533 
+	(values (**var-pat/def new)
534 
+		(list (var-pat-var pat))
535 
+		(list (**var/def new)))))
536 
+    (pcon
537 
+      (multiple-value-bind (new-pats vars new-vars)
538 
+	  (copy-pattern-variables-list (pcon-pats pat))
539 
+	(values (**pcon/def (pcon-con pat) new-pats)
540 
+		vars
541 
+		new-vars)))
542 
+    (as-pat
543 
+      (let ((new  (create-temp-var (var-ref-name (as-pat-var pat)))))
544 
+	(multiple-value-bind (new-pat vars new-vars)
545 
+	    (copy-pattern-variables (as-pat-pattern pat))
546 
+	  (values
547 
+	    (make as-pat
548 
+		  (var (**var/def new))
549 
+		  (pattern new-pat))
550 
+	    (cons (as-pat-var pat) vars)
551 
+	    (cons (**var/def new) new-vars)))))
552 
+    (irr-pat
553 
+      (multiple-value-bind (new-pat vars new-vars)
554 
+	  (copy-pattern-variables (irr-pat-pattern pat))
555 
+	(values
556 
+	  (make irr-pat (pattern new-pat))
557 
+	  vars
558 
+	  new-vars)))
559 
+    (const-pat
560 
+      (values pat '() '()))
561 
+    (plus-pat
562 
+      (multiple-value-bind (new-pat vars new-vars)
563 
+	  (copy-pattern-variables (plus-pat-pattern pat))
564 
+	(values
565 
+	  (make plus-pat
566 
+		(pattern new-pat)
567 
+		(k (plus-pat-k pat))
568 
+		(match-fn (plus-pat-match-fn pat))
569 
+		(bind-fn (plus-pat-bind-fn pat)))
570 
+	  vars
571 
+	  new-vars)))
572 
+    (list-pat
573 
+      (multiple-value-bind (new-pats vars new-vars)
574 
+	  (copy-pattern-variables-list (list-pat-pats pat))
575 
+	(values (make list-pat (pats new-pats))
576 
+		vars
577 
+		new-vars)))
578 
+    (else
579 
+      (error "Unrecognized pattern ~s." pat))))
580 
+
581 
+(define (copy-pattern-variables-list pats)
582 
+  (let ((new-pats  '())
583 
+	(vars      '())
584 
+	(new-vars  '()))
585 
+    (dolist (p pats)
586 
+      (multiple-value-bind (p v n) (copy-pattern-variables p)
587 
+	(push p new-pats)
588 
+	(setf vars (nconc vars v))
589 
+	(setf new-vars (nconc new-vars n))))
590 
+    (values (nreverse new-pats)
591 
+	    vars
592 
+	    new-vars)))
593 
+
594 
+
595 
+
596 
+;;;=====================================================================
597 
+;;; Helper functions for processing guards and where-decls
598 
+;;;=====================================================================
599 
+
600 
+;;; Process guards and where-decls into a single expression.
601 
+;;; If block-name is non-nil, wrap the exp with a return-from.
602 
+;;; If block-name is nil, add a failure exp if necessary.
603 
+;;; Note that this does NOT do the CFN traversal on the result or
604 
+;;; any part of it.
605 
+
606 
+(define (rewrite-guards-and-where-decls where-decls rhs-list block-name)
607 
+  (if (null? where-decls)
608 
+      (rewrite-guards rhs-list block-name)
609 
+      (**let where-decls
610 
+	     (rewrite-guards rhs-list block-name))))
611 
+
612 
+(define (rewrite-guards rhs-list block-name)
613 
+  (if (null? rhs-list)
614 
+      (if block-name
615 
+	  (**con/def (core-symbol "False"))
616 
+	  (make-failure-exp))
617 
+      (let* ((rhs     (car rhs-list))
618 
+	     (guard   (guarded-rhs-guard rhs))
619 
+	     (exp     (guarded-rhs-rhs rhs)))
620 
+	(when block-name
621 
+	  (setf exp (**return-from block-name exp)))
622 
+	(cond ((is-type? 'omitted-guard (guarded-rhs-guard (car rhs-list)))
623 
+	       exp)
624 
+	      ((and block-name (null? (cdr rhs-list)))
625 
+	       (**and-exp guard exp))
626 
+	      (else
627 
+	       (**if guard
628 
+		     exp
629 
+		     (rewrite-guards (cdr rhs-list) block-name)))
630 
+	      ))))
631 
+
632 
+
633 
+(define (make-failure-exp)
634 
+  (let ((c  (dynamic *context*)))
635 
+    (**abort
636 
+      (if (not c)
637 
+	  "Pattern match failed."
638 
+	  (let* ((stuff  (ast-node-line-number c))
639 
+		 (line   (source-pointer-line stuff))
640 
+		 (file   (source-pointer-file stuff)))
641 
+	    (if (and (is-type? 'valdef c)
642 
+		     (is-type? 'var-pat (valdef-lhs c)))
643 
+		(format
644 
+		  '#f
645 
+		  "Pattern match failed in function ~a at line ~s in file ~a."
646 
+		  (valdef-lhs c) line file)
647 
+		(format
648 
+		  '#f
649 
+		  "Pattern match failed at line ~s in file ~a."
650 
+		  line file)))))))
651 
+
652 
+
653 
+
654 
+
cl-support/PORTING
History View file @ 4e98702
0 655 
new file mode 100644
... ... 
@@ -0,0 +1,105 @@
1 
+Here are the steps involved in porting to a new Common Lisp implementation.
2 
+
3 
+(0) Find the executable you want to use.  If possible, use an image
4 
+    that doesn't have stuff like CLX, CLOS, a snazzy editor, and the
5 
+    like loaded, since we don't use any of that stuff.
6 
+
7 
+    Put an environment variable in the haskell-development script to point
8 
+    to the lisp you want to run.
9 
+
10 
+(1) You must add appropriate conditionalizations to cl-init.lisp and
11 
+    cl-definitions.lisp in this directory.  Look for places where there
12 
+    are #+ things for the other dialects.
13 
+
14 
+    As a matter of style, try to make an explicit case for each Lisp
15 
+    instead of using #- to test for it *not* being a particular dialect.
16 
+    This will prevent confusion on future ports.
17 
+
18 
+    You may also need/want to add conditionals to the primitive
19 
+    implementation files in the runtime directory.
20 
+
21 
+    Do not add #+/#- conditionalizations to any other random .scm
22 
+    files, since we want to keep this implementation-dependent stuff
23 
+    centralized.
24 
+
25 
+(2) Make subdirectories to hold compiled files in each of the source
26 
+    directories.  The name of the subdirectory must match the constant
27 
+    lisp-implementation-name in cl-definitions.lisp.
28 
+
29 
+(3) Try compiling the Haskell system (by loading cl-init.lisp) and
30 
+    fix any compilation warnings that happen.  (Hopefully there won't
31 
+    be any.)
32 
+
33 
+    You probably want to build a system initially with the default
34 
+    compiler settings and verbose compiler diagnostics.  This will make
35 
+    any problems that show up later easier to debug.  Also, it is
36 
+    helpful to capture all the messages in a dribble file to make it
37 
+    easier to verify that everything went OK.
38 
+
39 
+(4) Try compiling the prelude using (compile/prelude *prelude-unit*).
40 
+    You need to create a subdirectory in the progs/prelude directory
41 
+    to hold the output files, and define $PRELUDEBIN to point at
42 
+    this directory (see the haskell-setup script).
43 
+
44 
+    The important thing at this point is that the prelude makes it all
45 
+    the way through the codegen phase and produces Lisp code.  Don't worry
46 
+    too much now if the Lisp compiler has trouble digesting the output.
47 
+
48 
+    Once you get to this stage, it's time to start messing with
49 
+    compiler optimize proclamations.  We generally use (speed 3) and
50 
+    (safety 0).  Also, you should figure out how to suppress any
51 
+    compiler messages (e.g., set *compile-print* and *compile-verbose*
52 
+    to false).  We usually leave *compile-verbose* on during compilation
53 
+    of the Haskell compiler, but turn it off later so that people don't
54 
+    get messages from the Lisp compiler when running Haskell programs.
55 
+
56 
+(5) Make a subdirectory in the com directory and make the following set
57 
+    of scripts there:
58 
+
59 
+    clean -- remove all binary files.  Also change the main com/clean
60 
+      script to invoke this.
61 
+    compile -- recompile everything with the right compiler flags (see
62 
+      step 5).
63 
+    build-prelude -- run the prelude through the haskell compiler.
64 
+      This should save the old compiled prelude files as old-prelude.*
65 
+      case something goes wrong.
66 
+    savesys -- load the compiled prelude and save a core file.
67 
+      This should also be careful not to overwrite an existing file.
68 
+
69 
+    Look at the scripts that have already been written for other Lisps
70 
+    for hints.
71 
+
72 
+    At some point you also need to put a README file in this directory.
73 
+
74 
+
75 
+(6) Now it's time to get serious about getting the prelude to compile.
76 
+    Use the clean, compile, and build-prelude scripts you just wrote.
77 
+
78 
+    Some compilers have a hard time dealing with the large pieces of
79 
+    Lisp code produced for the prelude.  You will probably need to do
80 
+    something to make the heap bigger.  (And, make sure the machine
81 
+    you are using to do the build on has plenty of swap space.)  You
82 
+    may also need to tweak the chunk-size parameters to force the
83 
+    output to be split up into smaller pieces.
84 
+
85 
+    It's OK to leave the prelude interface file as a source file, or
86 
+    to compile it with low speed optimizations.  On the other hand,
87 
+    the prelude code file ought to be processed with as many speed
88 
+    optimizations as possible.
89 
+
90 
+(7) Build a new executable using the "savesys" script and take it for
91 
+    a test drive.
92 
+
93 
+(8) You must also hack the emacs interface file, emacs-tools/haskell.el,
94 
+    to recognize when it's gotten into the debugger or break loop.
95 
+    To test your new executable with the emacs stuff, you must
96 
+    define the environment variable HASKELLPROG to point at it, or
97 
+    set the emacs variable haskell-program-name.
98 
+
99 
+(9) If you want to use the Haskell->CLX interface, you'll have to
100 
+    mess with equivalents of the build-xlib and savesys-xlib scripts.
101 
+    There is some system-dependent code in xlibclx.scm to set up an
102 
+    error handler -- make sure you have conditionalized this appropriately
103 
+    for your Lisp system.
104 
+
105 
+
cl-support/README
History View file @ 4e98702
0 106 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+This directory contains Common-Lisp-syntax files to set up a more
2 
+Scheme-like environment.  Load cl-init.lisp and it will suck in all
3 
+the rest.
cl-support/cl-definitions.lisp
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,1351 @@
1 
+;;; cl-definitions.lisp -- mumble compatibility package for Common Lisp
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  11 Oct 1991
5 
+;;;
6 
+;;; You must load cl-setup and cl-support before trying to compile this
7 
+;;; file.
8 
+
9 
+(in-package "MUMBLE-IMPLEMENTATION")
10 
+
11 
+
12 
+;;;=====================================================================
13 
+;;; Syntax
14 
+;;;=====================================================================
15 
+
16 
+(define-mumble-import quote)
17 
+(define-mumble-import function)
18 
+
19 
+;;; Lambda lists have to have dot syntax converted to &rest.
20 
+
21 
+(define-mumble-macro mumble::lambda (lambda-list &rest body)
22 
+  `(function (lambda ,(mung-lambda-list lambda-list) ,@body)))
23 
+
24 
+(defun mung-lambda-list (lambda-list)
25 
+  (cond ((consp lambda-list)
26 
+	 (let ((last  (last lambda-list)))
27 
+	   (if (null (cdr last))
28 
+	       lambda-list
29 
+	       `(,@(ldiff lambda-list last) ,(car last) &rest ,(cdr last)))))
30 
+	((null lambda-list)
31 
+	 '())
32 
+	(t
33 
+	 `(&rest ,lambda-list))))
34 
+
35 
+
36 
+;;; We only funcall and apply things that are real functions.
37 
+
38 
+
39 
+;;; Gag.  Lucid needs to see the procedure declaration to avoid putting
40 
+;;; a coerce-to-procedure check in, but there's a compiler bug that causes
41 
+;;; it to barf if the function is a lambda form.
42 
+
43 
+#+lucid
44 
+(define-mumble-macro mumble::funcall (fn . args)
45 
+  (if (and (consp fn) (eq (car fn) 'mumble::lambda))
46 
+      `(funcall ,fn ,@args)
47 
+      `(funcall (the system::procedure ,fn) ,@args)))
48 
+
49 
+#+(or cmu allegro akcl lispworks mcl)
50 
+(define-mumble-macro mumble::funcall (fn . args)
51 
+  `(funcall (the function ,fn) ,@args))
52 
+
53 
+#+wcl
54 
+(define-mumble-macro mumble::funcall (fn . args)
55 
+  `(funcall (the lisp:procedure ,fn) ,@args))
56 
+
57 
+#-(or lucid cmu allegro akcl mcl lispworks wcl)
58 
+(missing-mumble-definition mumble::funcall)
59 
+
60 
+
61 
+;;; Could make this declare its fn argument too
62 
+
63 
+(define-mumble-import apply)
64 
+
65 
+(define-mumble-synonym mumble::map mapcar)
66 
+(define-mumble-synonym mumble::for-each mapc)
67 
+(define-mumble-import some)
68 
+(define-mumble-import every)
69 
+(define-mumble-import notany)
70 
+(define-mumble-import notevery)
71 
+(define-mumble-synonym mumble::procedure? functionp)
72 
+
73 
+
74 
+(define-mumble-import if)
75 
+(define-mumble-import when)
76 
+(define-mumble-import unless)
77 
+
78 
+
79 
+;;; COND and CASE differ from Common Lisp because of using "else" instead
80 
+;;; of "t" as the fall-through case.
81 
+
82 
+(define-mumble-import mumble::else)
83 
+
84 
+(define-mumble-macro mumble::cond (&rest cases)
85 
+  (let ((last    (car (last cases))))
86 
+    (if (eq (car last) 'mumble::else)
87 
+	`(cond ,@(butlast cases) (t ,@(cdr last)))
88 
+	`(cond ,@cases))))
89 
+
90 
+(define-mumble-macro mumble::case (data &rest cases)
91 
+  (let ((last  (car (last cases))))
92 
+    (if (eq (car last) 'mumble::else)
93 
+	`(case ,data ,@(butlast cases) (t ,@(cdr last)))
94 
+	`(case ,data ,@cases))))
95 
+
96 
+
97 
+(define-mumble-import and)
98 
+(define-mumble-import or)
99 
+(define-mumble-import not)
100 
+
101 
+(define-mumble-macro mumble::set! (variable value)
102 
+  `(setq ,variable ,value))
103 
+(define-mumble-import setf)
104 
+
105 
+
106 
+;;; AKCL's SETF brokenly tries to macroexpand the place
107 
+;;; form before looking for a define-setf-method.  Redefine the
108 
+;;; internal function to do the right thing.
109 
+
110 
+#+akcl
111 
+(defun system::setf-expand-1 (place newvalue env)
112 
+  (multiple-value-bind (vars vals stores store-form access-form)
113 
+      (get-setf-method place env)
114 
+    (declare (ignore access-form))
115 
+    `(let* ,(mapcar #'list
116 
+                    (append vars stores)
117 
+                    (append vals (list newvalue)))
118 
+       ,store-form)))
119 
+
120 
+
121 
+;;; Allegro has renamed this stuff as per ANSI CL.
122 
+
123 
+#+allegro
124 
+(eval-when (eval compile load)
125 
+  (setf (macro-function 'define-setf-method)
126 
+	(macro-function 'define-setf-expander))
127 
+  (setf (symbol-function 'get-setf-method)
128 
+	(symbol-function 'get-setf-expansion))
129 
+  )
130 
+
131 
+(define-mumble-import let)
132 
+(define-mumble-import let*)
133 
+
134 
+(define-mumble-macro mumble::letrec (bindings &rest body)
135 
+  `(let ,(mapcar #'car bindings)
136 
+     ,@(mapcar #'(lambda (b) (cons 'setq b)) bindings)
137 
+     (locally ,@body)))
138 
+
139 
+(define-mumble-import flet)
140 
+(define-mumble-import labels)
141 
+
142 
+(define-mumble-macro mumble::dynamic-let (bindings &rest body)
143 
+  `(let ,bindings
144 
+     (declare (special ,@(mapcar #'car bindings)))
145 
+     ,@body))
146 
+
147 
+(define-mumble-macro mumble::dynamic (name)
148 
+  `(locally (declare (special ,name)) ,name))
149 
+
150 
+(define-setf-method mumble::dynamic (name)
151 
+  (let ((store  (gensym)))
152 
+    (values nil
153 
+	    nil
154 
+	    (list store)
155 
+	    `(locally (declare (special ,name)) (setf ,name ,store))
156 
+	    `(locally (declare (special ,name)) ,name))))
157 
+
158 
+
159 
+(define-mumble-macro mumble::begin (&rest body)
160 
+  `(progn ,@body))
161 
+
162 
+(define-mumble-import block)
163 
+(define-mumble-import return-from)
164 
+
165 
+(define-mumble-import do)
166 
+(define-mumble-import dolist)
167 
+(define-mumble-import dotimes)
168 
+
169 
+(define-mumble-import values)
170 
+(define-mumble-import multiple-value-bind)
171 
+
172 
+(define-mumble-macro mumble::let/cc (variable &rest body)
173 
+  (let ((tagvar  (gensym)))
174 
+    `(let* ((,tagvar   (gensym))
175 
+	    (,variable (let/cc-aux ,tagvar)))
176 
+	(catch ,tagvar (locally ,@body)))))
177 
+
178 
+(defun let/cc-aux (tag)
179 
+  #'(lambda (&rest values)
180 
+      (throw tag (values-list values))))
181 
+
182 
+
183 
+(define-mumble-import unwind-protect)
184 
+
185 
+(define-mumble-import declare)
186 
+(define-mumble-import ignore)
187 
+
188 
+
189 
+;;; IGNORABLE is part of ANSI CL but not implemented by Lucid yet.
190 
+;;; IGNORE in Lucid seems to behave like what ANSI CL says IGNORABLE
191 
+;;; should do, but there doesn't seem to be any way to rename it.
192 
+
193 
+#+(or lucid akcl lispworks wcl)
194 
+(progn
195 
+  (proclaim '(declaration mumble::ignorable))
196 
+  (define-mumble-import mumble::ignorable))
197 
+
198 
+#+(or cmu mcl allegro)
199 
+(define-mumble-import cl:ignorable)
200 
+
201 
+#-(or lucid cmu allegro akcl mcl lispworks wcl)
202 
+(missing-mumble-definition mumble::ignorable)
203 
+
204 
+
205 
+(define-mumble-import type)
206 
+
207 
+
208 
+
209 
+;;;=====================================================================
210 
+;;; Definitions
211 
+;;;=====================================================================
212 
+
213 
+
214 
+;;; *** This shouldn't really do a DEFPARAMETER, since that proclaims
215 
+;;; *** the variable SPECIAL and makes any LETs of the variable do
216 
+;;; *** special binding rather than lexical binding.  But if you just
217 
+;;; *** SETF the variable, you'll get a compiler warning about an
218 
+;;; *** undeclared free variable on every reference!!!  Argggh.
219 
+
220 
+(define-mumble-macro mumble::define (pattern &rest value)
221 
+  (if (consp pattern)
222 
+      `(defun ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@value)
223 
+      `(defparameter ,pattern ,(car value))))
224 
+
225 
+(define-mumble-macro mumble::define-integrable (pattern &rest value)
226 
+  (if (consp pattern)
227 
+      `(progn
228 
+	 (eval-when (eval compile load)
229 
+	   (proclaim '(inline ,(car pattern))))
230 
+	 (defun ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@value))
231 
+      `(defconstant ,pattern ,(car value))))
232 
+
233 
+
234 
+(define-mumble-macro mumble::define-syntax (pattern . body)
235 
+  `(defmacro ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@body))
236 
+
237 
+(define-mumble-macro mumble::define-local-syntax (pattern . body)
238 
+  `(eval-when (eval compile)
239 
+     (defmacro ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@body)))
240 
+
241 
+
242 
+(define-mumble-macro mumble::define-setf (getter setter)
243 
+  `(define-setf-method ,getter (&rest subforms)
244 
+     (define-setf-aux ',setter ',getter subforms)))
245 
+
246 
+(defun define-setf-aux (setter getter subforms)
247 
+  (let ((temps    nil)
248 
+	(tempvals nil)
249 
+	(args     nil)
250 
+	(store  (gensym)))
251 
+    (dolist (x subforms)
252 
+      (if (constantp x)
253 
+	  (push x args)
254 
+	  (let ((temp  (gensym)))
255 
+	    (push temp temps)
256 
+	    (push x tempvals)
257 
+	    (push temp args))))
258 
+    (setq temps (nreverse temps))
259 
+    (setq tempvals (nreverse tempvals))
260 
+    (setq args (nreverse args))
261 
+    (values temps
262 
+	    tempvals
263 
+	    (list store)
264 
+	    `(,setter ,store ,@args)
265 
+	    `(,getter ,@args))))
266 
+
267 
+
268 
+;;; Declaring variables special will make the compiler not proclaim
269 
+;;; about references to them.
270 
+;;; A proclamation works to disable undefined function warnings in
271 
+;;; most Lisps.  Harlequin seems to offer no way to shut up these warnings.
272 
+;;; In allegro, we have to work around a bug in the compiler's handling
273 
+;;; of PROCLAIM.
274 
+
275 
+(define-mumble-macro mumble::predefine (pattern)
276 
+  `(eval-when (eval compile)
277 
+     #+allegro (let ((excl::*compiler-environment* nil))
278 
+		 (do-predefine ',pattern))
279 
+     #-allegro (do-predefine ',pattern)
280 
+     ))
281 
+
282 
+(eval-when (eval compile load)
283 
+  (defun do-predefine (pattern)
284 
+    (if (consp pattern)
285 
+        (proclaim `(ftype (function ,(mung-decl-lambda-list (cdr pattern)) t)
286 
+			  ,(car pattern)))
287 
+	(proclaim `(special ,pattern))))
288 
+  (defun mung-decl-lambda-list (lambda-list)
289 
+    (cond ((consp lambda-list)
290 
+	   (cons 't (mung-decl-lambda-list (cdr lambda-list))))
291 
+	  ((null lambda-list)
292 
+	   '())
293 
+	  (t
294 
+	   '(&rest t))))
295 
+  )
296 
+
297 
+
298 
+;;; CMUCL doesn't complain about function redefinitions, but Lucid does.
299 
+
300 
+#+(or cmu akcl mcl lispworks wcl)
301 
+(define-mumble-macro mumble::redefine (pattern . value)
302 
+  `(mumble::define ,pattern ,@value))
303 
+
304 
+#+lucid
305 
+(define-mumble-macro mumble::redefine (pattern . value)
306 
+  `(let ((lcl:*redefinition-action*  nil))
307 
+     (mumble::define ,pattern ,@value)))
308 
+
309 
+#+allegro
310 
+(define-mumble-macro mumble::redefine (pattern . value)
311 
+  `(let ((excl:*redefinition-warnings*  nil))
312 
+     (mumble::define ,pattern ,@value)))
313 
+
314 
+#-(or cmu lucid allegro akcl mcl lispworks wcl)
315 
+(missing-mumble-definition mumble::redefine)
316 
+
317 
+
318 
+#+(or cmu akcl mcl lispworks wcl)
319 
+(define-mumble-macro mumble::redefine-syntax (pattern . body)
320 
+  `(mumble::define-syntax ,pattern ,@body))
321 
+
322 
+#+lucid
323 
+(define-mumble-macro mumble::redefine-syntax (pattern . body)
324 
+  `(eval-when (eval compile load)
325 
+     (let ((lcl:*redefinition-action*  nil))
326 
+       (mumble::define-syntax ,pattern ,@body))))
327 
+
328 
+#+allegro
329 
+(define-mumble-macro mumble::redefine-syntax (pattern . body)
330 
+  `(eval-when (eval compile load)
331 
+     (let ((excl:*redefinition-warnings*  nil))
332 
+       (mumble::define-syntax ,pattern ,@body))))
333 
+
334 
+#-(or cmu lucid allegro akcl mcl lispworks wcl)
335 
+(missing-mumble-definition mumble::redefine-syntax)
336 
+
337 
+
338 
+
339 
+;;;=====================================================================
340 
+;;; Equivalence
341 
+;;;=====================================================================
342 
+
343 
+(define-mumble-function-inline mumble::eq? (x y)
344 
+  (eq x y))
345 
+(define-mumble-function-inline mumble::eqv? (x y)
346 
+  (eql x y))
347 
+
348 
+(define-mumble-function mumble::equal? (x1 x2)
349 
+  (cond ((eql x1 x2)
350 
+	 t)
351 
+	((consp x1)
352 
+	 (and (consp x2)
353 
+	      (mumble::equal? (car x1) (car x2))
354 
+	      (mumble::equal? (cdr x1) (cdr x2))))
355 
+	((simple-string-p x1)
356 
+	 (and (simple-string-p x2)
357 
+	      (string= x1 x2)))
358 
+	((simple-vector-p x1)
359 
+	 (and (simple-vector-p x2)
360 
+	      (eql (length (the simple-vector x1))
361 
+		   (length (the simple-vector x2)))
362 
+	      (every #'mumble::equal?
363 
+		     (the simple-vector x1)
364 
+		     (the simple-vector x2))))
365 
+	(t nil)))
366 
+
367 
+
368 
+;;;=====================================================================
369 
+;;; Lists
370 
+;;;=====================================================================
371 
+
372 
+(define-mumble-function-inline mumble::pair? (x)
373 
+  (consp x))
374 
+
375 
+(define-mumble-import cons)
376 
+
377 
+
378 
+;;; Can't import this directly because of type problems.
379 
+
380 
+(define-mumble-synonym mumble::list list)
381 
+
382 
+(define-mumble-function-inline mumble::make-list (length &optional (init nil))
383 
+  (the list
384 
+       (make-list length :initial-element init)))
385 
+
386 
+(define-mumble-import car)
387 
+(define-mumble-import cdr)
388 
+(define-mumble-import caar)
389 
+(define-mumble-import cadr)
390 
+(define-mumble-import cadr)
391 
+(define-mumble-import cddr)
392 
+(define-mumble-import caaar)
393 
+(define-mumble-import caadr)
394 
+(define-mumble-import caadr)
395 
+(define-mumble-import caddr)
396 
+(define-mumble-import cdaar)
397 
+(define-mumble-import cdadr)
398 
+(define-mumble-import cdadr)
399 
+(define-mumble-import cdddr)
400 
+(define-mumble-import caaaar)
401 
+(define-mumble-import caaadr)
402 
+(define-mumble-import caaadr)
403 
+(define-mumble-import caaddr)
404 
+(define-mumble-import cadaar)
405 
+(define-mumble-import cadadr)
406 
+(define-mumble-import cadadr)
407 
+(define-mumble-import cadddr)
408 
+(define-mumble-import cdaaar)
409 
+(define-mumble-import cdaadr)
410 
+(define-mumble-import cdaadr)
411 
+(define-mumble-import cdaddr)
412 
+(define-mumble-import cddaar)
413 
+(define-mumble-import cddadr)
414 
+(define-mumble-import cddadr)
415 
+(define-mumble-import cddddr)
416 
+
417 
+(define-mumble-function-inline mumble::null? (x)
418 
+  (null x))
419 
+
420 
+(define-mumble-function mumble::list? (x)
421 
+  (cond ((null x) t)
422 
+	((consp x) (mumble::list? (cdr x)))
423 
+	(t nil)))
424 
+
425 
+(define-mumble-function-inline mumble::length (x)
426 
+  (the fixnum (length (the list x))))
427 
+
428 
+(define-mumble-import append)
429 
+(define-mumble-import nconc)
430 
+
431 
+(define-mumble-function-inline mumble::reverse (x)
432 
+  (the list (reverse (the list x))))
433 
+(define-mumble-function-inline mumble::nreverse (x)
434 
+  (the list (nreverse (the list x))))
435 
+
436 
+(define-mumble-function-inline mumble::list-tail (list n)
437 
+  (nthcdr n list))
438 
+(define-mumble-function-inline mumble::list-ref (list n)
439 
+  (nth n list))
440 
+
441 
+(define-mumble-import last)
442 
+(define-mumble-import butlast)
443 
+
444 
+(define-setf-method mumble::list-ref (list n)
445 
+  (get-setf-method `(nth ,n ,list)))
446 
+
447 
+(define-mumble-function-inline mumble::memq (object list)
448 
+  (member object list :test #'eq))
449 
+(define-mumble-function-inline mumble::memv (object list)
450 
+  (member object list))
451 
+(define-mumble-function-inline mumble::member (object list)
452 
+  (member object list :test #'mumble::equal?))
453 
+
454 
+;;; *** The Lucid compiler is not doing anything inline for assq so
455 
+;;; *** I'm rewriting this  -- jcp
456 
+(define-mumble-function mumble::assq (object list)
457 
+  (if (null list)
458 
+      nil
459 
+      (if (eq object (caar list))
460 
+          (car list)
461 
+	  (mumble::assq object (cdr list)))))
462 
+
463 
+(define-mumble-function-inline mumble::assv (object list)
464 
+  (assoc object list))
465 
+(define-mumble-function-inline mumble::assoc (object list)
466 
+  (assoc object list :test #'mumble::equal?))
467 
+
468 
+(define-mumble-import push)
469 
+(define-mumble-import pop)
470 
+
471 
+(define-mumble-synonym mumble::list-copy copy-list)
472 
+
473 
+
474 
+;;;=====================================================================
475 
+;;; Symbols
476 
+;;;=====================================================================
477 
+
478 
+(define-mumble-function-inline mumble::symbol? (x)
479 
+  (symbolp x))
480 
+(define-mumble-synonym mumble::symbol->string symbol-name)
481 
+
482 
+(define-mumble-function-inline mumble::string->symbol (x)
483 
+  (intern x))
484 
+
485 
+
486 
+;;; We want a gensym that follows the new ANSI CL gensym-name-stickiness
487 
+;;; decision.
488 
+
489 
+#+(or lucid akcl wcl)
490 
+(define-mumble-function mumble::gensym (&optional (prefix "G"))
491 
+  (gensym prefix))
492 
+
493 
+#+(or cmu allegro mcl lispworks)
494 
+(define-mumble-import gensym)
495 
+
496 
+#-(or lucid akcl wcl cmu allegro mcl lispworks)
497 
+(missing-mumble-definition mumble::gensym)
498 
+
499 
+(define-mumble-function mumble::gensym? (x)
500 
+  (and (symbolp x)
501 
+       (not (symbol-package x))))
502 
+
503 
+(defun symbol-append (&rest symbols)
504 
+  (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
505 
+(define-mumble-import symbol-append)
506 
+
507 
+
508 
+;;;=====================================================================
509 
+;;; Characters
510 
+;;;=====================================================================
511 
+
512 
+(define-mumble-function-inline mumble::char? (x)
513 
+  (characterp x))
514 
+
515 
+(define-mumble-synonym mumble::char=? char=)
516 
+(define-mumble-synonym mumble::char<? char<)
517 
+(define-mumble-synonym mumble::char>? char>)
518 
+(define-mumble-synonym mumble::char>=? char>=)
519 
+(define-mumble-synonym mumble::char<=? char<=)
520 
+
521 
+(define-mumble-synonym mumble::char-ci=? char-equal)
522 
+(define-mumble-synonym mumble::char-ci<? char-lessp)
523 
+(define-mumble-synonym mumble::char-ci>? char-greaterp)
524 
+(define-mumble-synonym mumble::char-ci>=? char-not-lessp)
525 
+(define-mumble-synonym mumble::char-ci<=? char-not-greaterp)
526 
+
527 
+(define-mumble-synonym mumble::char-alphabetic? alpha-char-p)
528 
+(define-mumble-synonym mumble::char-numeric? digit-char-p)
529 
+
530 
+(define-mumble-function mumble::char-whitespace? (c)
531 
+  (member c '(#\space #\tab #\newline #\linefeed #\page #\return)))
532 
+
533 
+(define-mumble-synonym mumble::char-upper-case? upper-case-p)
534 
+(define-mumble-synonym mumble::char-lower-case? lower-case-p)
535 
+
536 
+(define-mumble-synonym mumble::char->integer char-code)
537 
+(define-mumble-synonym mumble::integer->char code-char)
538 
+
539 
+(define-mumble-import char-upcase)
540 
+(define-mumble-import char-downcase)
541 
+(define-mumble-import char-name)
542 
+
543 
+(define-mumble-synonym mumble::char->digit digit-char-p)
544 
+
545 
+
546 
+;;;=====================================================================
547 
+;;; Strings
548 
+;;;=====================================================================
549 
+
550 
+(define-mumble-function-inline mumble::string? (x)
551 
+  (simple-string-p x))
552 
+
553 
+(define-mumble-function-inline mumble::make-string
554 
+      (length &optional (init nil init-p))
555 
+  (the simple-string
556 
+       (if init-p
557 
+	   (make-string length :initial-element init)
558 
+	   (make-string length))))
559 
+
560 
+(define-mumble-function-inline mumble::string (char &rest more-chars)
561 
+  (the simple-string (coerce (cons char more-chars) 'string)))
562 
+
563 
+(define-mumble-function-inline mumble::string-length (string)
564 
+  (the fixnum (length (the simple-string string))))
565 
+
566 
+(define-mumble-function-inline mumble::string-ref (x n)
567 
+  (the character (schar (the simple-string x) (the fixnum n))))
568 
+
569 
+(define-setf-method mumble::string-ref (string n)
570 
+  (get-setf-method `(schar ,string ,n)))
571 
+
572 
+(define-mumble-synonym mumble::string=? string=)
573 
+(define-mumble-synonym mumble::string<? string<)
574 
+(define-mumble-synonym mumble::string>? string>)
575 
+(define-mumble-synonym mumble::string<=? string<=)
576 
+(define-mumble-synonym mumble::string>=? string>=)
577 
+
578 
+(define-mumble-synonym mumble::string-ci=? string-equal)
579 
+(define-mumble-synonym mumble::string-ci<? string-lessp)
580 
+(define-mumble-synonym mumble::string-ci>? string-greaterp)
581 
+(define-mumble-synonym mumble::string-ci<=? string-not-greaterp)
582 
+(define-mumble-synonym mumble::string-ci>=? string-not-lessp)
583 
+
584 
+(define-mumble-function-inline mumble::substring (string start end)
585 
+  (the simple-string (subseq (the simple-string string) start end)))
586 
+
587 
+(define-mumble-function-inline mumble::string-append
588 
+      (string &rest more-strings)
589 
+  (declare (type simple-string string))
590 
+  (the simple-string (apply #'concatenate 'string string more-strings)))
591 
+
592 
+(define-mumble-function-inline mumble::string->list (string)
593 
+  (the list (coerce (the simple-string string) 'list)))
594 
+
595 
+(define-mumble-function-inline mumble::list->string (list)
596 
+  (the simple-string (coerce (the list list) 'string)))
597 
+
598 
+(define-mumble-function-inline mumble::string-copy (string)
599 
+  (the simple-string (copy-seq (the simple-string string))))
600 
+
601 
+(define-mumble-import string-upcase)
602 
+(define-mumble-import string-downcase)
603 
+
604 
+
605 
+;;;=====================================================================
606 
+;;; Vectors
607 
+;;;=====================================================================
608 
+
609 
+(define-mumble-function-inline mumble::vector? (x)
610 
+  (simple-vector-p x))
611 
+
612 
+(define-mumble-function-inline mumble::make-vector
613 
+      (length &optional (init nil init-p))
614 
+  (declare (type fixnum length))
615 
+  (the simple-vector
616 
+       (if init-p
617 
+	   (make-array length :initial-element init)
618 
+	   (make-array length))))
619 
+
620 
+
621 
+;;; Can't import directly because types are incompatible.
622 
+
623 
+(define-mumble-synonym mumble::vector vector)
624 
+
625 
+(define-mumble-function-inline mumble::vector-length (vector)
626 
+  (the fixnum (length (the simple-vector vector))))
627 
+
628 
+(define-mumble-function-inline mumble::vector-ref (x n)
629 
+  (svref (the simple-vector x) (the fixnum n)))
630 
+
631 
+(define-setf-method mumble::vector-ref (vector n)
632 
+  (get-setf-method `(svref ,vector ,n)))
633 
+
634 
+(define-mumble-function-inline mumble::vector->list (vector)
635 
+  (the list (coerce (the simple-vector vector) 'list)))
636 
+
637 
+(define-mumble-function-inline mumble::list->vector (list)
638 
+  (the simple-vector (coerce (the list list) 'simple-vector)))
639 
+
640 
+(define-mumble-function-inline mumble::vector-copy (vector)
641 
+  (the simple-vector (copy-seq (the simple-vector vector))))
642 
+
643 
+
644 
+;;;=====================================================================
645 
+;;; Numbers
646 
+;;;=====================================================================
647 
+
648 
+(define-mumble-synonym mumble::number? numberp)
649 
+(define-mumble-synonym mumble::integer? integerp)
650 
+(define-mumble-synonym mumble::rational? rationalp)
651 
+(define-mumble-synonym mumble::float? floatp)
652 
+
653 
+(define-mumble-function-inline mumble::fixnum? (x)
654 
+  (typep x 'fixnum))
655 
+
656 
+(define-mumble-synonym mumble::exact->inexact float)
657 
+
658 
+(define-mumble-import =)
659 
+(define-mumble-import <)
660 
+(define-mumble-import >)
661 
+(define-mumble-import <=)
662 
+(define-mumble-import >=)
663 
+
664 
+(define-mumble-synonym mumble::zero? zerop)
665 
+(define-mumble-function-inline mumble::positive? (x)
666 
+  (> x 0))
667 
+(define-mumble-function-inline mumble::negative? (x)
668 
+  (< x 0))
669 
+
670 
+(define-mumble-import min)
671 
+(define-mumble-import max)
672 
+
673 
+(define-mumble-import +)
674 
+(define-mumble-import *)
675 
+(define-mumble-import -)
676 
+(define-mumble-import /)
677 
+
678 
+(define-mumble-synonym mumble::quotient floor)
679 
+(define-mumble-synonym mumble::remainder rem)
680 
+(define-mumble-synonym mumble::modulo mod)
681 
+
682 
+(define-mumble-function-inline mumble::floor (x)
683 
+  (if (floatp x) (ffloor x) (floor (the rational x))))
684 
+(define-mumble-function-inline mumble::ceiling (x)
685 
+  (if (floatp x) (fceiling x) (ceiling (the rational x))))
686 
+(define-mumble-function-inline mumble::truncate (x)
687 
+  (if (floatp x) (ftruncate x) (truncate (the rational x))))
688 
+(define-mumble-function-inline mumble::round (x)
689 
+  (if (floatp x) (fround x) (round (the rational x))))
690 
+
691 
+(define-mumble-synonym mumble::floor->exact floor)
692 
+(define-mumble-synonym mumble::ceiling->exact ceiling)
693 
+(define-mumble-synonym mumble::truncate->exact truncate)
694 
+(define-mumble-synonym mumble::round->exact round)
695 
+
696 
+(define-mumble-import 1+)
697 
+(define-mumble-import 1-)
698 
+(define-mumble-import incf)
699 
+(define-mumble-import decf)
700 
+
701 
+(define-mumble-function mumble::number->string (number &optional (radix 10))
702 
+  (let ((*print-base*  radix))
703 
+    (prin1-to-string number)))
704 
+
705 
+(define-mumble-function mumble::string->number (string &optional (radix 10))
706 
+  (let ((*read-base* radix))
707 
+    (read-from-string string)))
708 
+
709 
+(define-mumble-import expt)
710 
+
711 
+
712 
+
713 
+;;;=====================================================================
714 
+;;; Tables
715 
+;;;=====================================================================
716 
+
717 
+(define-mumble-synonym mumble::table? hash-table-p)
718 
+
719 
+(define-mumble-function-inline mumble::make-table ()
720 
+  (make-hash-table :test #'eq))
721 
+
722 
+(define-mumble-function-inline mumble::table-entry (table key)
723 
+  (gethash key table))
724 
+
725 
+(define-setf-method mumble::table-entry (table key)
726 
+  (get-setf-method `(gethash ,key ,table)))
727 
+
728 
+(define-mumble-synonym mumble::table-for-each maphash)
729 
+
730 
+(define-mumble-function mumble::copy-table (old-table)
731 
+  (let ((new-table  (make-hash-table :test #'eq
732 
+				     :size (1+ (hash-table-count old-table)))))
733 
+    (maphash #'(lambda (key val) (setf (gethash key new-table) val))
734 
+	     old-table)
735 
+    new-table))
736 
+
737 
+
738 
+;;;=====================================================================
739 
+;;; I/O
740 
+;;;=====================================================================
741 
+
742 
+(define-mumble-function-inline mumble::call-with-input-file (string proc)
743 
+  (with-open-file (stream (expand-filename string) :direction :input)
744 
+    (funcall (the function proc) stream)))
745 
+
746 
+(define-mumble-function-inline mumble::call-with-output-file (string proc)
747 
+  (with-open-file (stream (expand-filename string)
748 
+			  :direction :output :if-exists :new-version)
749 
+    (funcall (the function proc) stream)))
750 
+
751 
+(define-mumble-function-inline mumble::call-with-input-string (string proc)
752 
+  (with-input-from-string (stream string)
753 
+     (funcall (the function proc) stream)))
754 
+
755 
+(define-mumble-function-inline mumble::call-with-output-string (proc)
756 
+  (with-output-to-string (stream)
757 
+    (funcall (the function proc) stream)))
758 
+
759 
+(define-mumble-synonym mumble::input-port? input-stream-p)
760 
+(define-mumble-synonym mumble::output-port? output-stream-p)
761 
+
762 
+(define-mumble-function-inline mumble::current-input-port ()
763 
+  *standard-input*)
764 
+(define-mumble-function-inline mumble::current-output-port ()
765 
+  *standard-output*)
766 
+
767 
+(define-mumble-function-inline mumble::open-input-file (string)
768 
+  (open (expand-filename string) :direction :input))
769 
+
770 
+(define-mumble-function-inline mumble::open-output-file (string)
771 
+  (open (expand-filename string) :direction :output :if-exists :new-version))
772 
+
773 
+
774 
+(define-mumble-synonym mumble::close-input-port close)
775 
+(define-mumble-synonym mumble::close-output-port close)
776 
+
777 
+(defvar *eof-object* (make-symbol "EOF"))
778 
+
779 
+(define-mumble-function-inline mumble::read
780 
+      (&optional (port *standard-input*))
781 
+  (read port nil *eof-object*))
782 
+
783 
+(define-mumble-function-inline mumble::read-char
784 
+      (&optional (port *standard-input*))
785 
+  (read-char port nil *eof-object*))
786 
+
787 
+(define-mumble-function-inline mumble::peek-char
788 
+      (&optional (port *standard-input*))
789 
+  (peek-char nil port nil *eof-object*))
790 
+
791 
+(define-mumble-function-inline mumble::read-line
792 
+      (&optional (port *standard-input*))
793 
+  (read-line port nil *eof-object*))
794 
+
795 
+(define-mumble-function-inline mumble::eof-object? (x)
796 
+  (eq x *eof-object*))
797 
+
798 
+
799 
+;;;=====================================================================
800 
+;;; Printer
801 
+;;;=====================================================================
802 
+
803 
+(define-mumble-function mumble::internal-write (object port)
804 
+  (write object :stream port))
805 
+(define-mumble-function-inline mumble::internal-output-width (port)
806 
+  (declare (ignore port))
807 
+  nil)
808 
+(define-mumble-function-inline mumble::internal-output-position (port)
809 
+  (declare (ignore port))
810 
+  nil)
811 
+(define-mumble-synonym mumble::internal-write-char write-char)
812 
+(define-mumble-function-inline mumble::internal-write-string
813 
+                               (string port start end)
814 
+  (write-string string port :start start :end end))
815 
+(define-mumble-synonym mumble::internal-newline terpri)
816 
+(define-mumble-synonym mumble::internal-fresh-line fresh-line)
817 
+(define-mumble-synonym mumble::internal-finish-output finish-output)
818 
+(define-mumble-synonym mumble::internal-force-output force-output)
819 
+(define-mumble-synonym mumble::internal-clear-output clear-output)
820 
+
821 
+(define-mumble-function mumble::internal-write-to-string (object)
822 
+  (write-to-string object))
823 
+
824 
+
825 
+(define-mumble-function-inline mumble::internal-warning (string)
826 
+  (warn "~a" string))
827 
+
828 
+(define-mumble-function-inline mumble::internal-error (string)
829 
+  (error "~a" string))
830 
+
831 
+
832 
+;;; Printer stuff used directly by the pretty printer
833 
+
834 
+(define-mumble-import *print-escape*)
835 
+(define-mumble-import *print-circle*)
836 
+(define-mumble-import *print-pretty*)
837 
+(define-mumble-import *print-level*)
838 
+(define-mumble-import *print-length*)
839 
+(define-mumble-import *print-base*)
840 
+(define-mumble-import *print-radix*)
841 
+
842 
+
843 
+;;; These functions and variables are all defined with the XP stuff.  But,
844 
+;;; let's export all the symbols from the mumble package.
845 
+
846 
+(define-mumble-import mumble::write)
847 
+(define-mumble-import mumble::print)
848 
+(define-mumble-import mumble::prin1)
849 
+(define-mumble-import mumble::princ)
850 
+(define-mumble-import mumble::pprint)
851 
+(define-mumble-import mumble::prin1-to-string)
852 
+(define-mumble-import mumble::princ-to-string)
853 
+(define-mumble-import mumble::write-char)
854 
+(define-mumble-import mumble::write-string)
855 
+(define-mumble-import mumble::write-line)
856 
+(define-mumble-import mumble::terpri)
857 
+(define-mumble-import mumble::fresh-line)
858 
+(define-mumble-import mumble::finish-output)
859 
+(define-mumble-import mumble::force-output)
860 
+(define-mumble-import mumble::clear-output)
861 
+(define-mumble-import mumble::display)
862 
+(define-mumble-import mumble::newline)
863 
+(define-mumble-import mumble::*print-shared*)
864 
+(define-mumble-import mumble::*print-dispatch*)
865 
+(define-mumble-import mumble::*print-right-margin*)
866 
+(define-mumble-import mumble::*print-miser-width*)
867 
+(define-mumble-import mumble::*print-lines*)
868 
+(define-mumble-import mumble::*default-right-margin*)
869 
+(define-mumble-import mumble::*last-abbreviated-printing*)
870 
+(define-mumble-import mumble::*print-structure*)
871 
+(define-mumble-import mumble::*print-structure-slots*)
872 
+(define-mumble-import mumble::standard-print-dispatch)
873 
+(define-mumble-import mumble::pprint-newline)
874 
+(define-mumble-import mumble::pprint-logical-block)
875 
+(define-mumble-import mumble::pprint-pop)
876 
+(define-mumble-import mumble::pprint-exit-if-list-exhausted)
877 
+(define-mumble-import mumble::pprint-indent)
878 
+(define-mumble-import mumble::pprint-tab)
879 
+(define-mumble-import mumble::pprint-fill)
880 
+(define-mumble-import mumble::pprint-linear)
881 
+(define-mumble-import mumble::pprint-tabular)
882 
+(define-mumble-import mumble::format)
883 
+(define-mumble-import mumble::warning)
884 
+(define-mumble-import mumble::error)
885 
+
886 
+
887 
+;;; These are keywords for pprint-newline.
888 
+
889 
+(define-mumble-import mumble::linear)
890 
+(define-mumble-import mumble::fill)
891 
+(define-mumble-import mumble::miser)
892 
+(define-mumble-import mumble::mandatory)
893 
+
894 
+;;; These are keywords for pprint-indent
895 
+
896 
+;; (define-mumble-import mumble::block)  ; already imported as special form
897 
+(define-mumble-import mumble::current)
898 
+
899 
+;;; These are keywords for pprint-tab
900 
+
901 
+(define-mumble-import mumble::line)
902 
+(define-mumble-import mumble::section)
903 
+(define-mumble-import mumble::line-relative)
904 
+(define-mumble-import mumble::section-relative)
905 
+
906 
+
907 
+;;;=====================================================================
908 
+;;; System Interface
909 
+;;;=====================================================================
910 
+
911 
+(define-mumble-import macroexpand-1)
912 
+(define-mumble-import macroexpand)
913 
+
914 
+
915 
+;;; WITH-COMPILATION-UNIT is an ANSI CL feature that isn't yet
916 
+;;; supported by all Lisps.
917 
+
918 
+#+lucid
919 
+(define-mumble-macro mumble::with-compilation-unit (options &body body)
920 
+  (declare (ignore options))
921 
+  `(lcl:with-deferred-warnings ,@body))
922 
+
923 
+#+(or cmu mcl allegro lispworks)
924 
+(define-mumble-import with-compilation-unit)
925 
+
926 
+#+(or akcl wcl)
927 
+(define-mumble-macro mumble::with-compilation-unit (options &body body)
928 
+  (declare (ignore options))
929 
+  `(progn ,@body))
930 
+
931 
+#-(or lucid allegro cmu akcl mcl lispworks wcl)
932 
+(missing-mumble-definition mumble::with-compilation-unit)
933 
+
934 
+
935 
+(define-mumble-function mumble::eval (form &optional compile-p)
936 
+  (if compile-p
937 
+      (mumble::with-compilation-unit ()
938 
+        (eval-compiling-functions form))
939 
+      (eval form)))
940 
+
941 
+
942 
+;;; Simply doing (funcall (compile nil `(lambda () ,form))) would work
943 
+;;; except that top-level-ness actions would be lost (causing extraneous
944 
+;;; warning messages about global variables whose references are compiled
945 
+;;; before a previous predefine is executed, etc).  So make an attempt
946 
+;;; to process nested top-level forms in order.  This doesn't look for
947 
+;;; all of the common-lispy things that might show up in macro expansions,
948 
+;;; but it's close enough.
949 
+
950 
+(defun eval-compiling-functions (form)
951 
+  (if (atom form)
952 
+      (eval form)
953 
+      (let ((fn  (car form)))
954 
+	(cond ((or (eq fn 'mumble::begin)
955 
+		   (eq fn 'progn))
956 
+	       (do ((forms (cdr form) (cdr forms)))
957 
+		   ((null (cdr forms)) (eval-compiling-functions (car forms)))
958 
+		   (eval-compiling-functions (car forms))))
959 
+	      ((eq fn 'mumble::define)
960 
+	       (if (consp (cadr form))
961 
+		   (compile-define form)
962 
+		   (compile-other form)))
963 
+	      ((eq fn 'mumble::define-integrable)
964 
+	       (if (consp (cadr form))
965 
+		   (progn
966 
+		     (proclaim `(inline ,(car (cadr form))))
967 
+		     (compile-define form))
968 
+		   (compile-other form)))
969 
+	      ((eq fn 'mumble::predefine)
970 
+	       (do-predefine (cadr form)))
971 
+	      ((macro-function fn)
972 
+	       (eval-compiling-functions (macroexpand-1 form)))
973 
+	      (t
974 
+	       (compile-other form))))))
975 
+
976 
+(defun compile-define (form)
977 
+  (let ((name  (car (cadr form)))
978 
+	(args  (mung-lambda-list (cdr (cadr form))))
979 
+	(body  (cddr form)))
980 
+    (compile name `(lambda ,args ,@body))
981 
+    name))
982 
+
983 
+(defun compile-other (form)
984 
+  (funcall (compile nil `(lambda () ,form))))
985 
+
986 
+
987 
+;;; Load and compile-file aren't directly imported from the host
988 
+;;; Common Lisp because we want to do our own defaulting of file
989 
+;;; name extensions.
990 
+
991 
+(define-mumble-function mumble::load (filename)
992 
+  (setq filename (expand-filename filename))
993 
+  (if (string= (mumble::filename-type filename) "")
994 
+      (let ((source-file  (build-source-filename filename))
995 
+	    (binary-file  (build-binary-filename filename)))
996 
+	(if (and (probe-file binary-file)
997 
+		 (> (file-write-date binary-file)
998 
+		    (file-write-date source-file)))
999 
+	    (load binary-file)
1000 
+	    (load source-file)))
1001 
+      (load filename)))
1002 
+
1003 
+
1004 
+;;; This is used to control OPTIMIZE declarations in a somewhat more
1005 
+;;; portable way -- different implementations may need slightly different
1006 
+;;; combinations.
1007 
+;;; 0 = do as little as possible when compiling code
1008 
+;;; 1 = use "default" compiler settings
1009 
+;;; 2 = omit safety checks and do "easy" speed optimizations.
1010 
+;;; 3 = do as much as possible; type inference, inlining, etc.  May be slow.
1011 
+;;; #f = don't mess with optimize settings.
1012 
+
1013 
+(defvar *code-quality* nil)
1014 
+(define-mumble-import *code-quality*)
1015 
+
1016 
+(defun code-quality-hack (q)
1017 
+  (cond ((eql q 0)
1018 
+	 (proclaim '(optimize (speed 1) (safety 3) (compilation-speed 3)
1019 
+			      #+cmu (ext:debug 1)
1020 
+                              #+(or mcl allegro lispworks) (debug 1)
1021 
+			      )))
1022 
+	((eql q 1)
1023 
+	 (proclaim '(optimize (speed 1) (safety 1) (compilation-speed 3)
1024 
+			      #+cmu (ext:debug 1)
1025 
+                              #+(or mcl allegro lispworks) (debug 1)
1026 
+			      )))
1027 
+	((eql q 2)
1028 
+	 (proclaim '(optimize (speed 3) (safety 0) (compilation-speed 3)
1029 
+			      #+cmu (ext:debug 0)
1030 
+                              #+(or mcl allegro lispworks) (debug 0)
1031 
+			      )))
1032 
+	((eql q 3)
1033 
+	 (proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)
1034 
+			      #+cmu (ext:debug 0)
1035 
+                              #+(or mcl allegro lispworks) (debug 0)
1036 
+			      )))
1037 
+	(t
1038 
+	 (warn "Bogus *code-quality* setting ~s." q))))
1039 
+
1040 
+
1041 
+;;; If we don't do this, code generated with high code-quality settings
1042 
+;;; can't be interrupted with ^C.
1043 
+
1044 
+#+allegro
1045 
+(setf compiler:generate-interrupt-checks-switch
1046 
+      #'(lambda (safety space speed debug)
1047 
+	  (declare (ignore safety space speed debug))
1048 
+	  t))
1049 
+
1050 
+
1051 
+;;; Note that we expect the binary filename (if supplied) to be
1052 
+;;; relative to the current directory, not to the source filename.
1053 
+;;; Lucid and AKCL (and maybe other implementations) merge the :output-file
1054 
+;;; pathname with the source filename, but the merge by expand-filename
1055 
+;;; should prevent it from doing anything.
1056 
+
1057 
+(define-mumble-function mumble::compile-file (filename &optional binary)
1058 
+  (if *code-quality* (code-quality-hack *code-quality*))
1059 
+  (setq filename (expand-filename filename))
1060 
+  (if (string= (mumble::filename-type filename) "")
1061 
+      (setq filename (build-source-filename filename)))
1062 
+  (if binary
1063 
+      (compile-file filename :output-file (expand-filename binary))
1064 
+      (compile-file filename)))
1065 
+
1066 
+
1067 
+;;; See cl-init.lisp for initialization of *lisp-binary-file-type*.
1068 
+
1069 
+(defconstant source-file-type ".scm")
1070 
+(defconstant binary-file-type *lisp-binary-file-type*)
1071 
+(define-mumble-import source-file-type)
1072 
+(define-mumble-import binary-file-type)
1073 
+
1074 
+
1075 
+(defun build-source-filename (filename)
1076 
+  (mumble::assemble-filename filename filename source-file-type))
1077 
+
1078 
+(defun build-binary-filename (filename)
1079 
+  (mumble::assemble-filename filename filename binary-file-type))
1080 
+
1081 
+(proclaim '(ftype (function (simple-string) simple-string)
1082 
+		  mumble::filename-place
1083 
+		  mumble::filename-name
1084 
+		  mumble::filename-type
1085 
+		  expand-filename))
1086 
+
1087 
+(proclaim '(ftype (function (simple-string simple-string simple-string)
1088 
+			    simple-string)
1089 
+		  mumble::assemble-filename))
1090 
+
1091 
+(define-mumble-function mumble::assemble-filename (place name type)
1092 
+  (concatenate 'string
1093 
+	       (mumble::filename-place place)
1094 
+	       (mumble::filename-name name)
1095 
+	       (mumble::filename-type type)))
1096 
+
1097 
+(define-mumble-function mumble::filename-place (filename)
1098 
+  (declare (simple-string filename))
1099 
+  (let ((slash  (position #\/ filename :from-end t)))
1100 
+    (if slash
1101 
+	(subseq filename 0 (1+ slash))
1102 
+	"")))
1103 
+
1104 
+(define-mumble-function mumble::filename-name (filename)
1105 
+  (declare (simple-string filename))
1106 
+  (let* ((slash  (position #\/ filename :from-end t))
1107 
+	 (beg    (if slash (1+ slash) 0))
1108 
+	 (dot    (position #\. filename :start beg)))
1109 
+    (if (or slash dot)
1110 
+	(subseq filename beg (or dot (length filename)))
1111 
+	filename)))
1112 
+
1113 
+(define-mumble-function mumble::filename-type (filename)
1114 
+  (declare (simple-string filename))
1115 
+  (let* ((slash  (position #\/ filename :from-end t))
1116 
+	 (beg    (if slash (1+ slash) 0))
1117 
+	 (dot    (position #\. filename :start beg)))
1118 
+    (if dot
1119 
+	(subseq filename dot (length filename))
1120 
+	"")))
1121 
+
1122 
+
1123 
+;;; This function is called by all functions that pass filenames down
1124 
+;;; to the operating system.  It does environment variable substitution
1125 
+;;; and merging with *default-pathname-defaults* (set by the cd function).
1126 
+;;; Since this function translates mumble's notion of pathnames into
1127 
+;;; a lower-level representation, this function should never need to
1128 
+;;; be called outside of this file.
1129 
+
1130 
+(defun expand-filename (filename)
1131 
+  (declare (simple-string filename))
1132 
+  (namestring
1133 
+    (merge-pathnames
1134 
+      (fix-filename-syntax
1135 
+        (if (eql (schar filename 0) #\$)
1136 
+	    (let* ((end    (length filename))
1137 
+		   (slash  (or (position #\/ filename) end))
1138 
+		   (new    (mumble::getenv (subseq filename 1 slash))))
1139 
+	      (if new
1140 
+		  (concatenate 'string new (subseq filename slash end))
1141 
+		  filename))
1142 
+	    filename)
1143 
+        ))))
1144 
+
1145 
+
1146 
+;;; On non-unix machines, may need to change the mumble unix-like filename
1147 
+;;; syntax to whatever the normal syntax used by the implementation is.
1148 
+
1149 
+#+mcl
1150 
+(defun fix-filename-syntax (filename)
1151 
+  (substitute #\: #\/ filename))
1152 
+
1153 
+#-mcl
1154 
+(defun fix-filename-syntax (filename)
1155 
+  filename)
1156 
+
1157 
+
1158 
+;;; AKCL's compile-file merges the output pathname against the input
1159 
+;;; pathname.  If the output pathname doesn't have an explicit directory
1160 
+;;; but the input pathname does, the wrong thing will happen.  This
1161 
+;;; hack is so that expand-filename will always put a directory
1162 
+;;; specification on both pathnames.
1163 
+;;; Lucid CL does similar merging, but *default-pathname-defaults*
1164 
+;;; already defaults to the truename of the current directory.
1165 
+
1166 
+#+akcl
1167 
+(setf *default-pathname-defaults* (truename "./"))
1168 
+
1169 
+
1170 
+;;; WCL's *default-pathname-defaults* is OK except that it has a
1171 
+;;; type of .lisp, which is inappropriate.
1172 
+
1173 
+#+wcl
1174 
+(setf *default-pathname-defaults*
1175 
+      (make-pathname :directory
1176 
+		     (pathname-directory *default-pathname-defaults*)))
1177 
+
1178 
+#+(or mcl lispworks)
1179 
+(setf *default-pathname-defaults*
1180 
+      (truename *default-pathname-defaults*))
1181 
+
1182 
+
1183 
+(define-mumble-function mumble::file-exists? (filename)
1184 
+  (probe-file (expand-filename filename)))
1185 
+
1186 
+(define-mumble-function mumble::file-write-date (filename)
1187 
+  (file-write-date (expand-filename filename)))
1188 
+
1189 
+(define-mumble-synonym mumble::current-date get-universal-time)
1190 
+
1191 
+(define-mumble-function mumble::get-run-time ()
1192 
+  (/ (get-internal-run-time) (float internal-time-units-per-second)))
1193 
+
1194 
+
1195 
+;;; Get environment variables
1196 
+
1197 
+#+lucid
1198 
+(progn
1199 
+  (mumble::predefine (mumble::getenv string))
1200 
+  (define-mumble-synonym mumble::getenv lcl:environment-variable))
1201 
+
1202 
+#+cmu
1203 
+(define-mumble-function mumble::getenv (string)
1204 
+  (let ((symbol  (intern string (find-package "KEYWORD"))))
1205 
+    (cdr (assoc symbol extensions:*environment-list*))))
1206 
+
1207 
+#+(or akcl allegro lispworks)
1208 
+(define-mumble-function mumble::getenv (string)
1209 
+  (system::getenv string))
1210 
+
1211 
+#+wcl
1212 
+(define-mumble-function mumble::getenv (string)
1213 
+  (lisp:getenv string))
1214 
+
1215 
+
1216 
+;;; Hmmm.  The Mac doesn't have environment variables, so we'll have to
1217 
+;;; roll our own.
1218 
+
1219 
+#+mcl
1220 
+(progn
1221 
+  (defvar *environment-alist* '())
1222 
+  (define-mumble-function mumble::getenv (string)
1223 
+    (cdr (assoc string *environment-alist* :test #'string=)))
1224 
+  )
1225 
+
1226 
+
1227 
+#-(or lucid allegro cmu akcl mcl lispworks wcl)
1228 
+(missing-mumble-definition mumble::getenv)
1229 
+
1230 
+
1231 
+;;; Change working directory.
1232 
+;;; This stores a directory pathname in *default-pathname-defaults*.
1233 
+;;; See also expand-filename.
1234 
+
1235 
+(define-mumble-function mumble::cd (filename)
1236 
+  (if (not (eql (schar filename (1- (length filename))) #\/))
1237 
+      (setq filename (concatenate 'string filename "/")))
1238 
+  (setq *default-pathname-defaults* (pathname (expand-filename filename))))
1239 
+
1240 
+
1241 
+;;; Leave Lisp
1242 
+
1243 
+#+lucid
1244 
+(define-mumble-synonym mumble::exit lcl:quit)
1245 
+
1246 
+#+allegro
1247 
+(define-mumble-synonym mumble::exit excl:exit)
1248 
+
1249 
+#+cmu
1250 
+(define-mumble-synonym mumble::exit  extensions:quit)
1251 
+
1252 
+#+akcl
1253 
+(define-mumble-synonym mumble::exit lisp:bye)
1254 
+
1255 
+#+mcl
1256 
+(define-mumble-synonym mumble::exit ccl:quit)
1257 
+
1258 
+#+lispworks
1259 
+(define-mumble-synonym mumble::exit lw:bye)
1260 
+
1261 
+#+wcl
1262 
+(define-mumble-synonym mumble::exit lisp:quit)
1263 
+
1264 
+
1265 
+#-(or lucid allegro cmu akcl mcl lispworks wcl)
1266 
+(missing-mumble-definition mumble::exit)
1267 
+
1268 
+
1269 
+
1270 
+;;;=====================================================================
1271 
+;;; Reader support
1272 
+;;;=====================================================================
1273 
+
1274 
+
1275 
+;;; Make the default readtable recognize #f and #t.
1276 
+;;; CMUCL's loader rebinds *readtable* when loading file, so can't
1277 
+;;; setq it here; hack the default readtable instead.
1278 
+
1279 
+#+(or cmu mcl allegro lispworks)
1280 
+(defparameter *mumble-readtable* *readtable*)
1281 
+
1282 
+#+(or lucid akcl wcl)
1283 
+(progn
1284 
+  (defparameter *mumble-readtable* (copy-readtable nil))
1285 
+  (setq *readtable* *mumble-readtable*)
1286 
+  )
1287 
+
1288 
+#-(or lucid allegro cmu akcl mcl lispworks wcl)
1289 
+(missing-mumble-definition *mumble-readtable*)
1290 
+
1291 
+
1292 
+;;; Lucid's debugger uses the standard readtable rather than *readtable*
1293 
+;;; unless you do this magic trick.
1294 
+
1295 
+#+lucid
1296 
+(sys:add-debugger-binding '*readtable* *mumble-readtable*)
1297 
+
1298 
+
1299 
+
1300 
+(set-dispatch-macro-character #\# #\f
1301 
+    #'(lambda (stream subchar arg)
1302 
+	(declare (ignore stream subchar arg))
1303 
+	nil))
1304 
+
1305 
+(set-dispatch-macro-character #\# #\t
1306 
+    #'(lambda (stream subchar arg)
1307 
+	(declare (ignore stream subchar arg))
1308 
+	t))
1309 
+
1310 
+
1311 
+
1312 
+;;;=====================================================================
1313 
+;;; Random stuff
1314 
+;;;=====================================================================
1315 
+
1316 
+(defconstant mumble::lisp-implementation-name *lisp-implementation-name*)
1317 
+(define-mumble-import mumble::lisp-implementation-name)
1318 
+
1319 
+(define-mumble-function mumble::identify-system ()
1320 
+  (format nil "~a version ~a on ~a"
1321 
+	  (or (lisp-implementation-type)
1322 
+	      "Generic Common Lisp")
1323 
+	  (or (lisp-implementation-version)
1324 
+	      "Generic")
1325 
+	  (or (machine-type)
1326 
+	      "Generic Machine")))
1327 
+
1328 
+(defconstant mumble::left-to-right-evaluation t)
1329 
+(define-mumble-import mumble::left-to-right-evaluation)
1330 
+
1331 
+
1332 
+#+excl
1333 
+(define-mumble-function mumble::gc-messages (onoff)
1334 
+  (setf (sys:gsgc-switch :print) onoff))
1335 
+#+cmu
1336 
+(define-mumble-function mumble::gc-messages (onoff)
1337 
+  (setf extensions:*gc-verbose* onoff))
1338 
+#+(or lispworks akcl wcl mcl)
1339 
+(define-mumble-function mumble::gc-messages (onoff)
1340 
+  onoff)   ; can't figure out if they have a hook or not
1341 
+#+lucid
1342 
+(define-mumble-function mumble::gc-messages (onoff)
1343 
+  (setf lcl:*gc-silence* (not onoff))
1344 
+  onoff)
1345 
+
1346 
+
1347 
+#-(or lucid cmu allegro akcl mcl lispworks wcl)
1348 
+(missing-mumble-definition mumble::gc-messages)
1349 
+
1350 
+
1351 
+(define-mumble-import identity)
cl-support/cl-init.lisp
History View file @ 4e98702
0 1352 
new file mode 100644
... ... 
@@ -0,0 +1,170 @@
1 
+;;; cl-init.lisp -- initialize Common Lisp, loading cl-specific files.
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  23 Oct 1991
5 
+;;;
6 
+;;; All of the files loaded here are assumed to be regular Common Lisp
7 
+;;; files.
8 
+
9 
+(in-package "MUMBLE-IMPLEMENTATION")
10 
+
11 
+
12 
+;;; Turn off bogus warnings and messages!!!
13 
+
14 
+;;; Lucid complains if files don't start with IN-PACKAGE.
15 
+#+lucid
16 
+(setq lcl:*warn-if-no-in-package* '())
17 
+
18 
+
19 
+;;; CMU CL prints too many compiler progress messages.
20 
+#+cmu
21 
+(progn
22 
+  (setq *compile-print* '())
23 
+  (setq *load-verbose* t)
24 
+  )
25 
+
26 
+
27 
+;;; AKCL complains if any package operations appear at top-level
28 
+;;; after any other code.
29 
+;;; Also prints useless notes about when it does tail recursion elimination.
30 
+#+akcl
31 
+(progn
32 
+  (setq compiler:*suppress-compiler-notes* t)
33 
+  (setq compiler:*compile-verbose* t)
34 
+  (setq *load-verbose* t)
35 
+  (setq compiler::*compile-ordinaries* t)
36 
+  (si:putprop 'make-package nil 'compiler::package-operation)
37 
+  (si:putprop 'shadow nil 'compiler::package-operation)
38 
+  (si:putprop 'shadowing-import nil 'compiler::package-operation)
39 
+  (si:putprop 'export nil 'compiler::package-operation)
40 
+  (si:putprop 'unexport nil 'compiler::package-operation)
41 
+  (si:putprop 'use-package nil 'compiler::package-operation)
42 
+  (si:putprop 'unuse-package nil 'compiler::package-operation)
43 
+  (si:putprop 'import nil 'compiler::package-operation)
44 
+  (si:putprop 'provide nil 'compiler::package-operation)
45 
+  (si:putprop 'require nil 'compiler::package-operation)
46 
+  )
47 
+
48 
+
49 
+;;; Allegro also issues too many messages.
50 
+;;; ***We really ought to rename the defstructs that give the package
51 
+;;; locked errors....
52 
+
53 
+#+allegro
54 
+(progn
55 
+  (setf *compile-print* nil)
56 
+  (setf compiler:*cltl1-compile-file-toplevel-compatibility-p* nil)
57 
+  (setq excl:*enable-package-locked-errors* nil)
58 
+  (setf excl:*load-source-file-info* nil)
59 
+  (setf excl:*record-source-file-info* nil)
60 
+  (setf excl:*load-xref-info* nil)
61 
+  (setf excl:*record-source-file-info* nil)
62 
+  )
63 
+
64 
+
65 
+;;; Harlequin Lispworks prints too many messages too.
66 
+
67 
+#+lispworks
68 
+(progn
69 
+  (setf *compile-print* nil)
70 
+  (setf *load-print* nil)
71 
+  (lw:toggle-source-debugging nil)
72 
+  )
73 
+
74 
+
75 
+;;; Load up definitions
76 
+
77 
+(defvar *lisp-source-file-type* ".lisp")
78 
+(defvar *lisp-binary-file-type*
79 
+  #+lucid
80 
+  (namestring (make-pathname :type (car lcl:*load-binary-pathname-types*)))
81 
+  #+allegro
82 
+  (concatenate 'string "." excl:*fasl-default-type*)
83 
+  #+cmu
84 
+  (concatenate 'string "." (c:backend-fasl-file-type c:*backend*))
85 
+  #+akcl
86 
+  ".o"
87 
+  #+mcl
88 
+  ".fasl"
89 
+  #+lispworks
90 
+  ".wfasl"
91 
+  #+wcl
92 
+  ".o"
93 
+  #-(or lucid allegro cmu akcl mcl lispworks wcl)
94 
+  (error "Don't know how to initialize *LISP-BINARY-FILE-TYPE*.")
95 
+  )
96 
+
97 
+(defvar *lisp-implementation-name*
98 
+  #+lucid "lucid"
99 
+  #+(and allegro next) "allegro-next"
100 
+  #+(and allegro (not next)) "allegro"
101 
+  #+cmu "cmu"
102 
+  #+akcl "akcl"
103 
+  #+mcl "mcl"
104 
+  #+lispworks "lispworks"
105 
+  #+wcl "wcl"
106 
+  #-(or lucid allegro cmu akcl mcl lispworks wcl)
107 
+  (error "Don't know how to initialize *LISP-IMPLEMENTATION-NAME*.")
108 
+  )
109 
+
110 
+
111 
+
112 
+
113 
+;;; Note that this assumes that the current directory is $Y2.
114 
+;;; Environment variables in pathnames may not be supported by the
115 
+;;; host Lisp.
116 
+
117 
+#-mcl (progn
118 
+        (defvar *support-directory* "cl-support/")
119 
+        (defvar *support-binary-directory*
120 
+          (concatenate 'string
121 
+                       *support-directory*
122 
+                       *lisp-implementation-name*
123 
+                       "/")))
124 
+
125 
+(defun load-compiled-cl-file (filename)
126 
+  (let ((source-file (concatenate 'string
127 
+				  *support-directory*
128 
+				  filename
129 
+				  *lisp-source-file-type*))
130 
+	(binary-file (concatenate 'string
131 
+				  *support-binary-directory*
132 
+				  filename
133 
+				  *lisp-binary-file-type*)))
134 
+    (if (or (not (probe-file binary-file))
135 
+	    (< (file-write-date binary-file) (file-write-date source-file)))
136 
+	(compile-file source-file :output-file (merge-pathnames binary-file)))
137 
+    (load binary-file)))
138 
+
139 
+
140 
+;;; Do NOT change the load order of these files.
141 
+
142 
+(load-compiled-cl-file "cl-setup")
143 
+(load-compiled-cl-file "cl-support")
144 
+(load-compiled-cl-file "cl-definitions")
145 
+(load-compiled-cl-file "cl-types")
146 
+(load-compiled-cl-file "cl-structs")
147 
+
148 
+
149 
+;;; It would be nice if at this point we could switch *package*
150 
+;;; over to the right package.  But because *package* is rebound while
151 
+;;; this file is being loaded, it will get set back to whatever it was
152 
+;;; anyway.  Bummer.  Well, let's at least make the package that we want
153 
+;;; to use.
154 
+
155 
+(make-package "MUMBLE-USER" :use '("MUMBLE"))
156 
+
157 
+
158 
+;;; Compile and load the rest of the system.  (The Lucid compiler is fast
159 
+;;; enough to make it practical to compile things all the time.)
160 
+
161 
+(eval-when (eval compile load)
162 
+  (setf *package* (find-package "MUMBLE-USER")))
163 
+
164 
+(load "$Y2/support/system")
165 
+(compile-haskell)
166 
+
167 
+
168 
+;;; All done
169 
+
170 
+(write-line "Remember to do (in-package \"MUMBLE-USER\")!")
cl-support/cl-setup.lisp
History View file @ 4e98702
0 171 
new file mode 100644
... ... 
@@ -0,0 +1,30 @@
1 
+;;; cl-setup.lisp -- set up mumble environment in Common Lisp
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  10 Oct 1991
5 
+;;;
6 
+;;; This file must be loaded before either compiling or loading
7 
+;;; the cl-definitions file.
8 
+
9 
+
10 
+;;; The mumble package exports only those symbols that have definitions
11 
+;;; in mumble.  Many of these symbols shadow built-in CL definitions.
12 
+;;; Programs that use mumble should use the mumble package in place of
13 
+;;; (rather than in addition to) the CL package.
14 
+
15 
+(unless (find-package "MUMBLE")
16 
+  (make-package "MUMBLE" :use nil))
17 
+
18 
+
19 
+;;; The actual implementation of the mumble compatibility library happens
20 
+;;; in the MUMBLE-IMPLEMENTATION package.  We'll explicitly package-qualify
21 
+;;; all symbols from the MUMBLE package that it references, and rely
22 
+;;; on the definitional macros to arrange to export them from the MUMBLE
23 
+;;; package.
24 
+
25 
+(unless (find-package "MUMBLE-IMPLEMENTATION")
26 
+  (make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")))
27 
+
28 
+
29 
+
30 
+
cl-support/cl-structs.lisp
History View file @ 4e98702
0 31 
new file mode 100644
... ... 
@@ -0,0 +1,699 @@
1 
+;;; cl-structs.lisp -- extended structure definitions
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  19 Aug 1992
5 
+;;;
6 
+
7 
+
8 
+;;;====================================================================
9 
+;;; Basic structure types
10 
+;;;====================================================================
11 
+
12 
+
13 
+;;; Use this hash table for mapping names -> type descriptors
14 
+
15 
+(defvar *struct-lookup-table* (make-hash-table :test #'eq))
16 
+
17 
+(defmacro lookup-type (name)
18 
+  `(gethash ,name *struct-lookup-table*))
19 
+
20 
+
21 
+;;; Do NOT add or remove slots from these DEFSTRUCTS without also
22 
+;;; changing the bootstrap code below!!!
23 
+;;; Do NOT try to give these structs complicated defaulting behavior!!!
24 
+
25 
+;;; All of our objects are subtypes of STRUCT.
26 
+
27 
+
28 
+(mumble::predefine (mumble::write object . maybe-stream))
29 
+
30 
+(defun print-struct-object (object stream depth)
31 
+  (declare (ignore depth))
32 
+  (mumble::write object stream)
33 
+;  (format stream "#<Struct ~a>" (td-name (struct-type-descriptor object)))
34 
+  )
35 
+
36 
+
37 
+;;; Note that non-exported slots are prefixed with % to prevent
38 
+;;; accidental slot name collisions.
39 
+
40 
+(defstruct (struct
41 
+	     (:print-function print-struct-object)
42 
+	     (:predicate      struct?)
43 
+	     (:constructor    nil)   ; never instantiated directly
44 
+	     (:copier         nil))
45 
+  (type-descriptor nil :type t)
46 
+  (%bits 0 :type fixnum)
47 
+  )
48 
+
49 
+
50 
+(defstruct (type-descriptor
51 
+	     (:include struct
52 
+		       (type-descriptor (lookup-type 'type-descriptor)))
53 
+	     (:conc-name td-)
54 
+	     (:constructor create-type-descriptor ())
55 
+	     (:predicate nil)
56 
+	     (:copier nil))
57 
+  (name nil :type symbol)
58 
+  (slots nil :type list)         ; all slots, including inherited
59 
+  (parent-type nil :type t)
60 
+  (printer nil :type t)
61 
+  (%local-slots nil :type list)   ; "real" structure slots
62 
+  (%bits-used 0 :type fixnum)
63 
+  (%constructor nil :type symbol)
64 
+  )
65 
+
66 
+(defstruct (slot-descriptor
67 
+	     (:include struct
68 
+		       (type-descriptor (lookup-type 'slot-descriptor)))
69 
+	     (:conc-name sd-)
70 
+	     (:constructor create-slot-descriptor ())
71 
+	     (:predicate nil)
72 
+	     (:copier nil))
73 
+  (name nil :type symbol)
74 
+  (type nil :type t)
75 
+  (default nil :type t)
76 
+  (getter nil :type symbol)
77 
+  (%bit nil :type (mumble::maybe fixnum))
78 
+  (%read-only? nil :type mumble::bool)
79 
+  (%required? nil :type mumble::bool)
80 
+  (%uninitialized? nil :type mumble::bool))
81 
+
82 
+
83 
+;;; Helper function for bootstrapping.
84 
+
85 
+(defun create-slot-simple (prefix name type default
86 
+			    &optional read-only? required? uninitialized?)
87 
+  (let ((sd  (create-slot-descriptor)))
88 
+    (setf (sd-name sd) name)
89 
+    (setf (sd-type sd) type)
90 
+    (setf (sd-default sd) default)
91 
+    (setf (sd-getter sd) (symbol-append prefix name))
92 
+    (setf (sd-%read-only? sd) read-only?)
93 
+    (setf (sd-%required? sd) required?)
94 
+    (setf (sd-%uninitialized? sd) uninitialized?)
95 
+    sd))
96 
+
97 
+
98 
+;;; Initialize descriptors for the predefined struct types.
99 
+
100 
+(let ((struct-td  (setf (lookup-type 'struct)
101 
+			(create-type-descriptor)))
102 
+      (type-td    (setf (lookup-type 'type-descriptor)
103 
+			(create-type-descriptor)))
104 
+      (slot-td    (setf (lookup-type 'slot-descriptor)
105 
+			(create-type-descriptor))))
106 
+  ;; struct
107 
+  (setf (td-type-descriptor struct-td) type-td)
108 
+  (setf (td-name struct-td) 'struct)
109 
+  (setf (td-%bits-used struct-td) 0)
110 
+  ;; type-descriptor
111 
+  (setf (td-type-descriptor type-td) type-td)
112 
+  (setf (td-name type-td) 'type-descriptor)
113 
+  (setf (td-%local-slots type-td)
114 
+	(list (create-slot-simple 'td- 'name 'symbol nil)
115 
+	      (create-slot-simple 'td- 'slots 'list nil)
116 
+	      (create-slot-simple 'td- 'parent-type 't nil)
117 
+	      (create-slot-simple 'td- 'printer 't nil)
118 
+	      (create-slot-simple 'td- '%local-slots 'list nil)
119 
+	      (create-slot-simple 'td- '%bits-used 'fixnum 0)
120 
+	      (create-slot-simple 'td- '%constructor 'symbol nil)
121 
+	      ))
122 
+  (setf (td-slots type-td) (td-%local-slots type-td))
123 
+  (setf (td-%bits-used type-td) 0)
124 
+  (setf (td-%constructor type-td) 'create-type-descriptor)
125 
+  (setf (td-parent-type type-td) struct-td)
126 
+  ;; slot-descriptor
127 
+  (setf (td-type-descriptor slot-td) type-td)
128 
+  (setf (td-name slot-td) 'slot-descriptor)
129 
+  (setf (td-%local-slots slot-td)
130 
+	(list (create-slot-simple 'sd- 'name 'symbol nil)
131 
+	      (create-slot-simple 'sd- 'type 't nil)
132 
+	      (create-slot-simple 'sd- 'default 't nil)
133 
+	      (create-slot-simple 'sd- 'getter 'symbol nil)
134 
+	      (create-slot-simple 'sd- '%bit '(mumble::maybe fixnum) nil)
135 
+	      (create-slot-simple 'sd- '%read-only? 'mumble::bool nil)
136 
+	      (create-slot-simple 'sd- '%required? 'mumble::bool nil)
137 
+	      (create-slot-simple 'sd- '%uninitialized? 'mumble::bool nil)
138 
+	      ))
139 
+  (setf (td-slots slot-td) (td-%local-slots slot-td))
140 
+  (setf (td-%bits-used slot-td) 0)
141 
+  (setf (td-%constructor slot-td) 'create-slot-descriptor)
142 
+  (setf (td-parent-type type-td) struct-td)
143 
+  )
144 
+
145 
+
146 
+
147 
+;;;=====================================================================
148 
+;;; Support for bit slots
149 
+;;;=====================================================================
150 
+
151 
+(eval-when (eval compile load)
152 
+  (defconstant max-bits (integer-length most-positive-fixnum)))
153 
+
154 
+(defvar *bit-slot-getters* (make-array max-bits))
155 
+(defvar *bit-slot-setters* (make-array max-bits))
156 
+
157 
+(defmacro bit-slot-getter (i) `(svref *bit-slot-getters* ,i))
158 
+(defmacro bit-slot-setter (i) `(svref *bit-slot-setters* ,i))
159 
+
160 
+(defmacro define-bit-accessors ()
161 
+  (let ((results  nil))
162 
+    (dotimes (i max-bits)
163 
+      (let ((getter   (intern (format nil "GET-BIT-~a" i)))
164 
+	    (setter   (intern (format nil "SET-BIT-~a" i)))
165 
+	    (mask     (ash 1 i)))
166 
+	(push
167 
+	  `(progn
168 
+	     (mumble::define-integrable (,getter x)
169 
+               (not (eql (the fixnum
170 
+			      (logand (the fixnum (struct-%bits x))
171 
+				      (the fixnum ,mask)))
172 
+			 0)))
173 
+	     (mumble::define-integrable (,setter v x)
174 
+	       (setf (struct-%bits x)
175 
+		     (if v
176 
+			 (the fixnum
177 
+			      (logior (the fixnum (struct-%bits x))
178 
+				      (the fixnum ,mask)))
179 
+			 (the fixnum
180 
+			      (logandc2 (the fixnum (struct-%bits x))
181 
+					(the fixnum ,mask)))))
182 
+	       v)
183 
+	     (setf (bit-slot-getter ,i) ',getter)
184 
+	     (setf (bit-slot-setter ,i) ',setter))
185 
+	  results)))
186 
+    `(progn ,@results)))
187 
+
188 
+(define-bit-accessors)
189 
+
190 
+
191 
+
192 
+
193 
+;;;=====================================================================
194 
+;;; Random helper functions
195 
+;;;=====================================================================
196 
+
197 
+(defun quoted? (x)
198 
+  (and (consp x) (eq (car x) 'quote)))
199 
+
200 
+(defun quoted-value (x)
201 
+  (cadr x))
202 
+
203 
+(defun unknown-type-error (type)
204 
+  (error "Struct type ~s has not been defined." type))
205 
+
206 
+(defun unknown-slot-error (type slot)
207 
+  (error "Struct type ~s has no slot named ~s." type slot))
208 
+
209 
+(defun lookup-type-descriptor (type)
210 
+  (or (lookup-type type)
211 
+      (unknown-type-error type)))
212 
+
213 
+(defun lookup-slot-descriptor (type slot)
214 
+  (let ((td  (lookup-type-descriptor type)))
215 
+    (or (find slot (td-slots td) :key #'sd-name)
216 
+	(unknown-slot-error type slot))))
217 
+
218 
+(defun slot-getter-name (type slot)
219 
+  (sd-getter (lookup-slot-descriptor type slot)))
220 
+
221 
+(defun sd-getter-function (sd)
222 
+  (symbol-function (sd-getter sd)))
223 
+
224 
+
225 
+
226 
+;;;=====================================================================
227 
+;;; Struct-slot macro
228 
+;;;=====================================================================
229 
+
230 
+;;; Note that this can be SETF'ed only if type and slot are quoted.
231 
+
232 
+(defmacro struct-slot (type slot object)
233 
+  (if (and (quoted? type) (quoted? slot))
234 
+      (struct-slot-compiletime (quoted-value type) (quoted-value slot) object)
235 
+      (progn
236 
+	(warn "Type and/or slot argument to STRUCT-SLOT not constant.")
237 
+	`(struct-slot-runtime ,type ,slot ,object))))
238 
+
239 
+(defun struct-slot-compiletime (type slot object)
240 
+  (let ((sd  (lookup-slot-descriptor type slot)))
241 
+    `(the ,(sd-type sd) (,(sd-getter sd) (the ,type ,object)))))
242 
+
243 
+(defun struct-slot-runtime (type slot object)
244 
+  (let ((sd  (lookup-slot-descriptor type slot)))
245 
+    ;; *** Could insert explicit type checks here.
246 
+    (funcall (sd-getter-function sd) object)))
247 
+
248 
+
249 
+;;;=====================================================================
250 
+;;; Make macro and support
251 
+;;;=====================================================================
252 
+
253 
+(defmacro make (type . inits)
254 
+  (make-aux type inits))
255 
+
256 
+;;; Turn the call to MAKE into a call to the boa constructor.
257 
+;;; The arguments to the BOA constructor are those slots that have
258 
+;;; the required? flag set to true.  If initializers for other slots
259 
+;;; are provided, turn these into SETFs.  Bit attributes are always
260 
+;;; handled via SETF.
261 
+
262 
+(defun make-aux (type inits)
263 
+  (let* ((td           (lookup-type-descriptor type))
264 
+	 (boa          (td-%constructor td))
265 
+	 (slots        (td-slots td))
266 
+	 (tempvar      (gensym))
267 
+	 (setfs        '())
268 
+	 (bits-inits   '())
269 
+	 (slot-inits   '()))
270 
+    (check-slot-inits type inits)
271 
+    (dolist (s slots)
272 
+      (let* ((name           (sd-name s))
273 
+	     (supplied?      (mumble::assq name inits))
274 
+	     (required?      (sd-%required? s))
275 
+	     (uninitialized? (sd-%uninitialized? s))
276 
+	     (init           (if supplied?
277 
+				 (progn
278 
+				   ;; *** Maybe want to suppress this warning.
279 
+				   ;;(when (not required?)
280 
+				   ;;  (override-slot-init-warning type name))
281 
+				   (cadr supplied?))
282 
+				 (progn
283 
+				   ;; *** Maybe want to suppress this warning.
284 
+				   (when (and required? (not uninitialized?))
285 
+				     (missing-slot-init-warning type name))
286 
+				   (sd-default s)))))
287 
+	(cond ((sd-%bit s)
288 
+	       (cond ((or (eq init 'nil) (equal init '(quote nil)))
289 
+		      ;; do nothing, bit already defaults to 0
290 
+		      )
291 
+		     ((and uninitialized? (not supplied?) required?)
292 
+		      ;; no default or init supplied, leave uninitialized
293 
+		      )
294 
+		     ((constantp init)
295 
+		      ;; it must be a non-false constant, set bit to 1
296 
+		      (push (ash 1 (sd-%bit s)) bits-inits))
297 
+		     (t
298 
+		      ;; have to do runtime test
299 
+		      (push `(the fixnum (if ,init ,(ash 1 (sd-%bit s)) 0))
300 
+			    bits-inits))))
301 
+	      ((and required? (not uninitialized?))
302 
+	       ;; The constructor takes the value as a positional argument.
303 
+	       (push init slot-inits))
304 
+	      (supplied?
305 
+	       ;; Make a setf.
306 
+	       ;; No point in putting the same value in twice.
307 
+	       (unless (and (constantp init) (equal init (sd-default s)))
308 
+		 (push `(setf (,(sd-getter s) ,tempvar) ,init) setfs)))
309 
+	      (t nil))))
310 
+    (unless (null bits-inits)
311 
+      (push `(setf (struct-%bits ,tempvar)
312 
+		   ,(cond ((null (cdr bits-inits))
313 
+			   (car bits-inits))
314 
+			  ((every #'constantp bits-inits)
315 
+			   (apply #'logior bits-inits))
316 
+			  (t
317 
+			   `(the fixnum (logior ,@(nreverse bits-inits))))))
318 
+	    setfs))
319 
+    (if (null setfs)
320 
+	`(,boa ,@(nreverse slot-inits))
321 
+	`(let ((,tempvar  (,boa ,@(nreverse slot-inits))))
322 
+	   ,@(nreverse setfs)
323 
+	   ,tempvar))))
324 
+
325 
+(defun override-slot-init-warning (type name)
326 
+  (warn "Overriding default for slot ~s in MAKE ~s."
327 
+	name type))
328 
+
329 
+(defun missing-slot-init-warning (type name)
330 
+  (warn "No initializer or default for slot ~s in MAKE ~s."
331 
+	name type))
332 
+
333 
+(defun check-slot-inits (type inits)
334 
+  (dolist (i inits)
335 
+    (lookup-slot-descriptor type (car i))))
336 
+
337 
+
338 
+
339 
+;;;====================================================================
340 
+;;; Update-slots macro
341 
+;;;====================================================================
342 
+
343 
+;;; Note that type is a literal here.
344 
+;;; *** Could be smarter about merging setters for bit slots.
345 
+
346 
+(defmacro update-slots (type exp . inits)
347 
+  (let ((temp  (gensym)))
348 
+    `(let ((,temp  ,exp))
349 
+       ,@(mapcar #'(lambda (i)
350 
+		     `(setf (struct-slot ',type ',(car i) ,temp) ,(cadr i)))
351 
+		 inits))))
352 
+
353 
+
354 
+
355 
+;;;====================================================================
356 
+;;; With-slots macro
357 
+;;;====================================================================
358 
+
359 
+;;; Note that type is a literal here.
360 
+;;; ***Could be smarter about merging accesses for bit slots.
361 
+
362 
+(defmacro mumble::with-slots (type slots exp . body)
363 
+  (let ((temp  (gensym)))
364 
+    `(let* ((,temp  ,exp)
365 
+	    ,@(mapcar #'(lambda (s)
366 
+			  `(,s  (struct-slot ',type ',s ,temp)))
367 
+		      slots))
368 
+       ,@body)))
369 
+
370 
+
371 
+;;;====================================================================
372 
+;;; Define-struct macro
373 
+;;;====================================================================
374 
+
375 
+
376 
+;;; The rather strange division here is so that the call to MAKE
377 
+;;; works right.
378 
+;;; All INSTALL-STRUCT-TYPE does is fill in and install the type
379 
+;;; descriptor object.
380 
+
381 
+(defmacro define-struct (name . fields)
382 
+  (multiple-value-bind (include type-template slots prefix predicate)
383 
+      (parse-struct-fields name fields)
384 
+    `(progn
385 
+       (eval-when (eval compile load)
386 
+	 (install-struct-type
387 
+	   ',name
388 
+	   ',include
389 
+	   ',prefix
390 
+	   (make ,type-template)
391 
+	   ',slots))
392 
+       (define-struct-aux ,name ,include ,prefix ,predicate))))
393 
+
394 
+
395 
+;;; This is the macro that actually creates the DEFSTRUCT expansion.
396 
+
397 
+(defmacro define-struct-aux (name include prefix predicate)
398 
+  (let* ((td           (lookup-type name))
399 
+	 (slots        (td-slots td))
400 
+	 (local-slots  (td-%local-slots td))
401 
+	 (bit-slots    (remove-if-not #'sd-%bit slots)))
402 
+    `(progn
403 
+       ;; Make the struct definition.
404 
+       ;; *** could put the type descriptor for the default in a
405 
+       ;; *** global variable; it might speed up reference.
406 
+       (defstruct (,name
407 
+		    (:include ,include
408 
+			      (type-descriptor (lookup-type ',name)))
409 
+		    (:conc-name ,prefix)
410 
+		    ;; Disable the default keyword constructor.
411 
+		    ;; If you do this in AKCL, it will complain about
412 
+		    ;; the BOA constructor.  Bogus!!!
413 
+		    ;; If you do this in WCL, it will just quietly ignore
414 
+		    ;; the BOA.
415 
+		    #-(or akcl wcl) (:constructor nil)
416 
+		    (:constructor ,(td-%constructor td) ,(make-boa-args slots))
417 
+		    (:predicate ,predicate)
418 
+		    (:copier    nil))
419 
+	 ,@(mapcar
420 
+	    #'(lambda (s)
421 
+		`(,(sd-name s) ,(sd-default s)
422 
+		  ;; CMU common lisp initializes &aux boa constructor
423 
+		  ;; slots to NIL instead of leaving them uninitialized,
424 
+		  ;; and then complains if this doesn't match the declared
425 
+		  ;; slot type.  I think this is a bug, not a feature, but
426 
+		  ;; here's a workaround for it.
427 
+		  :type
428 
+		  #+cmu ,(if (sd-%uninitialized? s)
429 
+			     `(or ,(sd-type s) null)
430 
+			     (sd-type s))
431 
+		  #-cmu ,(sd-type s)
432 
+	          ;; Can make slots read-only only if a setf-er is not
433 
+		  ;; required by MAKE.
434 
+		  :read-only ,(and (sd-%read-only? s) (sd-%required? s))))
435 
+	    local-slots))
436 
+       ;; Make accessor functions for bit slots.
437 
+       ,@(mapcar
438 
+	  #'(lambda (s)
439 
+	      (let ((place  (symbol-append prefix (sd-name s)))
440 
+		    (getter (bit-slot-getter (sd-%bit s)))
441 
+		    (setter (bit-slot-setter (sd-%bit s))))
442 
+		`(progn
443 
+		   (mumble::define-integrable (,place x) (,getter x))
444 
+		   ,@(unless (sd-%read-only? s)
445 
+		       `((mumble::define-setf ,place ,setter))))
446 
+		))
447 
+	  bit-slots)
448 
+	 ',name)
449 
+      ))
450 
+
451 
+
452 
+
453 
+;;; Determine which arguments to make explicit to the boa constructor.
454 
+;;; Basically, expect an explicit initializer for any slot that does not
455 
+;;; have a default supplied.
456 
+;;; Supplying slot names as &aux parameters to a boa constructor is
457 
+;;; supposed to suppress initialization.
458 
+
459 
+(defun make-boa-args (slots)
460 
+  (let ((required-args      '())
461 
+	(uninitialized-args '()))
462 
+    (dolist (s slots)
463 
+      (when (and (sd-%required? s) (not (sd-%bit s)))
464 
+	(if (sd-%uninitialized? s)
465 
+	    (push (sd-name s) uninitialized-args)
466 
+	    (push (sd-name s) required-args))))
467 
+    ;; Gag.  AKCL does the wrong thing with &AUX arguments; defstruct sticks
468 
+    ;; another &AUX at the end of the lambda list.  Looks like it will do
469 
+    ;; the right thing if you just omit the uninitialized arguments from
470 
+    ;; the boa arglist entirely.
471 
+    #+akcl (nreverse required-args)
472 
+    #-akcl
473 
+    (if (null uninitialized-args)
474 
+	(nreverse required-args)
475 
+	`(,@(nreverse required-args) &aux ,@(nreverse uninitialized-args)))
476 
+    ))
477 
+
478 
+
479 
+;;; Install the type descriptor, filling in all the slots.
480 
+
481 
+(defun install-struct-type (name include prefix td slots)
482 
+  (let* ((parent-type  (lookup-type-descriptor include))
483 
+	 (bits-used    (td-%bits-used parent-type))
484 
+	 (local-slots  '())
485 
+	 (all-slots    '()))
486 
+    (dolist (s slots)
487 
+      (multiple-value-bind
488 
+	  (slot-name type default bit read-only? required? uninitialized?)
489 
+	  (parse-slot-fields name s)
490 
+	(let ((sd   (create-slot-simple
491 
+		      prefix slot-name type default
492 
+		      read-only? required? uninitialized?)))
493 
+	  (push sd all-slots)
494 
+	  (cond (bit
495 
+		 (if (eql bits-used max-bits)
496 
+		     (error "Too many bit slots in DEFINE-STRUCT ~s." name))
497 
+		 (setf (sd-%bit sd) bits-used)
498 
+		 (incf bits-used))
499 
+		(t
500 
+		 (push sd local-slots))))))
501 
+    (setf local-slots (nreverse local-slots))
502 
+    (setf (td-name td) name)
503 
+    (setf (td-slots td) (append (td-slots parent-type) (nreverse all-slots)))
504 
+    (setf (td-%local-slots td) local-slots)
505 
+    (setf (td-%bits-used td) bits-used)
506 
+    (setf (td-%constructor td) (symbol-append '%create- name))
507 
+    (setf (td-parent-type td) parent-type)
508 
+    (setf (lookup-type name) td)))
509 
+
510 
+
511 
+;;; Struct field parsing.
512 
+
513 
+(defun parse-struct-fields (name fields)
514 
+  (when (not (symbolp name))
515 
+    (error "Structure name ~s is not a symbol." name))
516 
+  (let ((include         nil)
517 
+	(type-template   nil)
518 
+	(slots           nil)
519 
+	(prefix          nil)
520 
+	(predicate       nil))
521 
+    (dolist (f fields)
522 
+      (cond ((not (consp f))
523 
+	     (unknown-field-error f name))
524 
+	    ((eq (car f) 'include)
525 
+	     (if include
526 
+		 (duplicate-field-error 'include name)
527 
+		 (setf include (cadr f))))
528 
+	    ((eq (car f) 'type-template)
529 
+	     (if type-template
530 
+		 (duplicate-field-error 'type-template name)
531 
+		 (setf type-template (cadr f))))
532 
+	    ((eq (car f) 'slots)
533 
+	     (if slots
534 
+		 (duplicate-field-error 'slots name)
535 
+		 (setf slots (cdr f))))
536 
+	    ((eq (car f) 'prefix)
537 
+	     (if prefix
538 
+		 (duplicate-field-error 'prefix name)
539 
+		 (setf prefix (cadr f))))
540 
+	    ((eq (car f) 'predicate)
541 
+	     (if predicate
542 
+		 (duplicate-field-error 'predicate name)
543 
+		 (setf predicate (cadr f))))
544 
+	    (t
545 
+	     (unknown-field-error f name))))
546 
+    (values
547 
+      (or include 'struct)
548 
+      (or type-template
549 
+	  (and include
550 
+	       (td-name (td-type-descriptor (lookup-type-descriptor include))))
551 
+	  'type-descriptor)
552 
+      (or slots '())
553 
+      (or prefix (symbol-append name '-))
554 
+      predicate)))
555 
+
556 
+(defun unknown-field-error (f name)
557 
+  (error "Unknown field ~s in DEFINE-STRUCT ~s." f name))
558 
+
559 
+(defun duplicate-field-error (f name)
560 
+  (error "Field ~s appears more than once in DEFINE-STRUCT ~s." f name))
561 
+
562 
+
563 
+
564 
+;;; Parsing for slot specifications.
565 
+
566 
+(defun parse-slot-fields (struct-name slot)
567 
+  (let ((name           nil)
568 
+	(type           t)
569 
+	(default        '*default-slot-default*)
570 
+	(bit            nil)
571 
+	(read-only?     nil)
572 
+	(required?      t)
573 
+	(uninitialized? nil))
574 
+    (if (or (not (consp slot))
575 
+	    (not (symbolp (setf name (car slot)))))
576 
+	(invalid-slot-error slot struct-name))
577 
+    (dolist (junk (cdr slot))
578 
+      (cond ((eq (car junk) 'type)
579 
+	     (setf type (cadr junk)))
580 
+	    ((eq (car junk) 'default)
581 
+	     (setf default (cadr junk))
582 
+	     (setf required? nil))
583 
+	    ((eq (car junk) 'bit)
584 
+	     (setf bit (cadr junk)))
585 
+	    ((eq (car junk) 'read-only?)
586 
+	     (setf read-only? (cadr junk)))
587 
+	    ((eq (car junk) 'uninitialized?)
588 
+	     (setf uninitialized? (cadr junk)))
589 
+	    (t
590 
+	     (invalid-slot-error slot struct-name))))
591 
+    (values
592 
+      name
593 
+      type
594 
+      default
595 
+      bit
596 
+      read-only?
597 
+      required?
598 
+      uninitialized?
599 
+      )))
600 
+
601 
+;;; Some implementations of DEFSTRUCT complain if the default value
602 
+;;; for a slot doesn't match the declared type of that slot, even if
603 
+;;; the default is never used.
604 
+;;; Using this variable as the default init form for such slots should
605 
+;;; suppress such warnings.
606 
+
607 
+(defvar *default-slot-default* nil)
608 
+
609 
+(defun invalid-slot-error (slot struct-name)
610 
+  (error "Invalid slot syntax ~s in DEFINE-STRUCT ~s." slot struct-name))
611 
+
612 
+
613 
+
614 
+;;;=====================================================================
615 
+;;; Printer hooks
616 
+;;;=====================================================================
617 
+
618 
+;;; Here is the macro for associating a printer with a structure type.
619 
+
620 
+(defmacro define-struct-printer (type function)
621 
+  `(define-struct-printer-aux ',type (function ,function)))
622 
+
623 
+(defun define-struct-printer-aux (type function)
624 
+  (let ((td  (lookup-type-descriptor type)))
625 
+    (setf (td-printer td) function)
626 
+    type))
627 
+
628 
+
629 
+;;;=====================================================================
630 
+;;; Imports
631 
+;;;=====================================================================
632 
+
633 
+
634 
+;;; Generic stuff
635 
+
636 
+(define-mumble-import struct)
637 
+(define-mumble-import struct?)
638 
+(define-mumble-import struct-type-descriptor)
639 
+
640 
+
641 
+;;; Predefined types, slots, and accessors
642 
+;;; Note:  not all slots are exported.
643 
+
644 
+(define-mumble-import type-descriptor)
645 
+(define-mumble-import name)
646 
+(define-mumble-import slots)
647 
+(define-mumble-import parent-type)
648 
+(define-mumble-import printer)
649 
+(define-mumble-import td-name)
650 
+(define-mumble-import td-slots)
651 
+(define-mumble-import td-parent-type)
652 
+(define-mumble-import td-printer)
653 
+
654 
+(define-mumble-import slot-descriptor)
655 
+(define-mumble-import name)
656 
+(define-mumble-import type)
657 
+(define-mumble-import default)
658 
+(define-mumble-import getter)
659 
+(define-mumble-import sd-name)
660 
+(define-mumble-import sd-type)
661 
+(define-mumble-import sd-default)
662 
+(define-mumble-import sd-getter)
663 
+
664 
+
665 
+;;; Utility functions
666 
+
667 
+(define-mumble-import lookup-type-descriptor)
668 
+(define-mumble-import lookup-slot-descriptor)
669 
+(define-mumble-import sd-getter-function)
670 
+
671 
+
672 
+;;; Macros
673 
+
674 
+(define-mumble-import make)
675 
+(define-mumble-import struct-slot)
676 
+(define-mumble-import define-struct)
677 
+(define-mumble-import mumble::with-slots)
678 
+(define-mumble-import update-slots)
679 
+(define-mumble-import define-struct-printer)
680 
+
681 
+
682 
+;;; Field names for define-struct
683 
+
684 
+(define-mumble-import include)
685 
+(define-mumble-import type-template)
686 
+(define-mumble-import slots)
687 
+(define-mumble-import prefix)
688 
+(define-mumble-import predicate)
689 
+
690 
+
691 
+;;; Field names for slot options
692 
+
693 
+(define-mumble-import type)
694 
+(define-mumble-import default)
695 
+(define-mumble-import bit)
696 
+(define-mumble-import read-only?)
697 
+(define-mumble-import uninitialized?)
698 
+
699 
+
cl-support/cl-support.lisp
History View file @ 4e98702
0 700 
new file mode 100644
... ... 
@@ -0,0 +1,86 @@
1 
+;;; cl-support.lisp -- compile-time support for building mumble
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  10 Oct 1991
5 
+;;;
6 
+;;; This file must be loaded before compiling the cl-definitions file.
7 
+;;; However, it is not needed when loading the compiled file.
8 
+
9 
+(in-package "MUMBLE-IMPLEMENTATION")
10 
+
11 
+
12 
+;;; Use this macro for defining an exported mumble function.
13 
+
14 
+(defmacro define-mumble-function (name &rest stuff)
15 
+  `(progn
16 
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
17 
+     (defun ,name ,@stuff)))
18 
+
19 
+
20 
+;;; This is similar, but also does some stuff to try to inline the
21 
+;;; function definition.
22 
+
23 
+(defmacro define-mumble-function-inline (name &rest stuff)
24 
+  `(progn
25 
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
26 
+#+lcl
27 
+     (lcl:defsubst ,name ,@stuff)
28 
+#-lcl
29 
+     (progn
30 
+       (proclaim '(inline ,name))
31 
+       (defun ,name ,@stuff))
32 
+     ',name))
33 
+
34 
+
35 
+;;; Use this macro for defining an exported mumble macro.
36 
+
37 
+(defmacro define-mumble-macro (name &rest stuff)
38 
+  `(progn
39 
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
40 
+     (defmacro ,name ,@stuff)))
41 
+
42 
+
43 
+;;; Use this macro for importing a random symbol into the MUMBLE
44 
+;;; package.  This is useful for things that can share directly with
45 
+;;; built-in Common Lisp definitions.
46 
+
47 
+(defmacro define-mumble-import (name)
48 
+  `(progn
49 
+     (eval-when (eval compile load) (import (list ',name) "MUMBLE"))
50 
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
51 
+     ',name))
52 
+
53 
+
54 
+;;; Use this macro for defining a function in the MUMBLE package that
55 
+;;; is a synonym for some Common Lisp function.  Try to do some stuff
56 
+;;; to make the function compile inline.
57 
+
58 
+(defmacro define-mumble-synonym (name cl-name)
59 
+  `(progn
60 
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
61 
+     (setf (symbol-function ',name) (symbol-function ',cl-name))
62 
+#+lcl
63 
+     (lcl:def-compiler-macro ,name (&rest args)
64 
+       (cons ',cl-name args))
65 
+     ',name))
66 
+
67 
+
68 
+
69 
+;;; Use this macro to define a type synonym.
70 
+
71 
+(defmacro define-mumble-type (name &rest stuff)
72 
+  `(progn
73 
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
74 
+     (deftype ,name ,@stuff)))
75 
+
76 
+
77 
+;;; This macro is used to signal a compile-time error in situations
78 
+;;; where an implementation-specific definition is missing.
79 
+
80 
+(defmacro missing-mumble-definition (name)
81 
+  (error "No definition has been provided for ~s." name))
82 
+
83 
+
84 
+
85 
+
86 
+
cl-support/cl-types.lisp
History View file @ 4e98702
0 87 
new file mode 100644
... ... 
@@ -0,0 +1,90 @@
1 
+;;; cl-types.lisp -- type-related stuff
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  5 Oct 1992
5 
+;;;
6 
+
7 
+
8 
+;;; Export CL symbols for type names
9 
+
10 
+(define-mumble-import t)
11 
+
12 
+#+lucid
13 
+(define-mumble-type mumble::procedure () 'system::procedure)
14 
+#+(or cmu akcl allegro mcl lispworks)
15 
+(define-mumble-type mumble::procedure () 'function)
16 
+#+wcl
17 
+(define-mumble-type mumble::procedure () 'lisp:procedure)
18 
+#-(or lucid cmu akcl allegro mcl lispworks wcl)
19 
+(missing-mumble-definition procedure)
20 
+
21 
+(define-mumble-type mumble::pair () 'cons)
22 
+
23 
+(define-mumble-import null)
24 
+
25 
+(define-mumble-type mumble::list (&optional element-type)
26 
+  ;; *** Common Lisp provides no way to make use of the element type
27 
+  ;; *** without using SATISFIES.
28 
+  (declare (ignore element-type))
29 
+  'list)
30 
+
31 
+(define-mumble-import symbol)
32 
+
33 
+(define-mumble-type mumble::char () 'character)
34 
+(define-mumble-type mumble::string () 'simple-string)
35 
+(define-mumble-type mumble::vector () 'simple-vector)
36 
+
37 
+(define-mumble-import number)
38 
+(define-mumble-import integer)
39 
+(define-mumble-import rational)
40 
+(define-mumble-import float)
41 
+(define-mumble-import fixnum)
42 
+
43 
+(define-mumble-type mumble::int () 'fixnum)
44 
+
45 
+(define-mumble-type mumble::table (&optional key-type value-type)
46 
+  ;; *** Common Lisp provides no way to make use of the element type
47 
+  ;; *** without using SATISFIES.
48 
+  (declare (ignore key-type value-type))
49 
+  'hash-table)
50 
+
51 
+
52 
+;;; Extensions
53 
+
54 
+(define-mumble-type mumble::enum (&rest values)
55 
+  `(member ,@values))
56 
+
57 
+(define-mumble-type mumble::tuple (&rest element-types)
58 
+  ;; *** Common Lisp provides no way to make use of the element type
59 
+  ;; *** without using SATISFIES.
60 
+  (let ((n  (length element-types)))
61 
+    (cond ((< n 2)
62 
+	   (error "Too few arguments to TUPLE type specifier."))
63 
+	  ((eql n 2)
64 
+	   'cons)
65 
+	  (t
66 
+	   'simple-vector))))
67 
+
68 
+(define-mumble-type mumble::bool () 't)
69 
+
70 
+(define-mumble-type mumble::alist (&optional key-type value-type)
71 
+  `(mumble::list (tuple ,key-type ,value-type)))
72 
+
73 
+(define-mumble-type mumble::maybe (type)
74 
+  `(or ,type null))
75 
+
76 
+
77 
+
78 
+;;; Functions, etc.
79 
+
80 
+(define-mumble-import the)
81 
+(define-mumble-synonym mumble::subtype? subtypep)
82 
+
83 
+(define-mumble-function-inline mumble::is-type? (type object)
84 
+  (typep object type))
85 
+
86 
+(define-mumble-macro mumble::typecase (data &rest cases)
87 
+  (let ((last  (car (last cases))))
88 
+    (if (eq (car last) 'mumble::else)
89 
+	`(typecase ,data ,@(butlast cases) (t ,@(cdr last)))
90 
+	`(typecase ,data ,@cases))))
cl-support/wcl-patches.lisp
History View file @ 4e98702
0 91 
new file mode 100644
... ... 
@@ -0,0 +1,68 @@
1 
+(in-package "LISP")
2 
+
3 
+
4 
+;;; The default version of this function has a bug with relative
5 
+;;; pathnames.
6 
+
7 
+(defun pathname->string (p)
8 
+  (let ((dirlist (pathname-directory p)))
9 
+    (format nil "~A~{~A/~}~A~A~A"
10 
+            (case (car dirlist)
11 
+              (:absolute "/")
12 
+              (:relative "./")
13 
+              (:up "../")
14 
+              (t ""))
15 
+            (cdr dirlist)
16 
+            (nil->empty-string (pathname-name p))
17 
+            (if (null (pathname-type p)) "" ".")
18 
+            (nil->empty-string (pathname-type p)))))
19 
+
20 
+
21 
+;;; The default version of this function defaults the C file to the
22 
+;;; wrong directory -- LOAD can't find it.
23 
+
24 
+(defun my-comf (file &key
25 
+                  (output-file (merge-pathnames ".o" file))
26 
+                  (c-file (merge-pathnames ".c" output-file))
27 
+                  (verbose *compile-verbose*)
28 
+                  (print *compile-print*)
29 
+                  (config *config*)
30 
+                  (pic? *pic?*)
31 
+                  only-to-c?)
32 
+  (old-comf file
33 
+	    :output-file output-file
34 
+	    :c-file c-file
35 
+	    :verbose verbose
36 
+	    :print print
37 
+	    :config config
38 
+	    :pic? pic?
39 
+	    :only-to-c? only-to-c?))
40 
+
41 
+(when (not (fboundp 'old-comf))
42 
+  (setf (symbol-function 'old-comf) #'comf)
43 
+  (setf (symbol-function 'comf) #'my-comf))
44 
+
45 
+
46 
+;;; WCL's evaluator tries to macroexpand everything before executing
47 
+;;; anything.  Unfortunately, this does the wrong thing with
48 
+;;; top-level PROGN's -- it tries to expand macros in subforms before
49 
+;;; executing earlier subforms that set up stuff required to do the
50 
+;;; the expansion properly.
51 
+
52 
+(defun eval-1 (form venv fenv tenv benv)
53 
+  (let ((new-form  (macroexpand form *eval-macro-env*)))
54 
+    (if (and (consp new-form)
55 
+	     (eq (car new-form) 'progn))
56 
+	(do ((forms (cdr new-form) (cdr forms)))
57 
+	    ((null (cdr forms)) (eval-1 (car forms) venv fenv tenv benv))
58 
+	    (eval-1 (car forms) venv fenv tenv benv))
59 
+	(let ((expansion (expand new-form)))
60 
+	  (when (and (listp expansion)
61 
+		     (eq (car expansion) 'define-function))
62 
+	    (setf (get (second (second expansion))
63 
+		       :function-definition)
64 
+		  form))
65 
+	  (eval/5 expansion venv fenv tenv benv))
66 
+      )))
67 
+
68 
+
com/README
History View file @ 4e98702
0 69 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+This directory contains various useful command scripts.  Scripts
2 
+that are specific to a particular host Lisp are found in the appropriate
3 
+subdirectories.  Scripts for building release distribution are in the
4 
+distrib subdirectory.
com/akcl/README
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,39 @@
1 
+This directory contains command scripts used for building Yale Haskell
2 
+from the source distribution under AKCL.  We have been using
3 
+AKCL version 1.615 on a Sparc, but we don't expect that there would
4 
+be difficulties in building with AKCL on other platforms.
5 
+
6 
+Developers need to source haskell-development instead of haskell-setup
7 
+in the .cshrc file.
8 
+
9 
+To rebuild the system:
10 
+
11 
+* You need to define environment variables Y2 and AKCL to point to the
12 
+  appropriate pathnames.  See the haskell-development script for details.
13 
+
14 
+* Make sure that the environment variable PRELUDEBIN (in the
15 
+  haskell-setup script) points to $PRELUDE/akcl.
16 
+
17 
+* Execute the "compile" script.  This will recompile all of the Lisp
18 
+  source files that make up the Yale Haskell system.  Compiled files are
19 
+  put in the "akcl" subdirectory of each source directory.
20 
+
21 
+* Execute the "build-prelude" script to compile the standard prelude.
22 
+  Note that this process tends to use up a huge amount of memory!
23 
+
24 
+* Execute the "savesys" script to build a new executable.
25 
+
26 
+* The new executable is initially called "bin/new-akcl-haskell".  Try
27 
+  it out.  If it works, you should rename it to "bin/akcl-haskell".
28 
+  Make sure that HASKELLPROG (in the haskell-setup script) is correct.
29 
+
30 
+A word of warning: we have noticed that AKCL is slower by a factor of
31 
+three or four than the other Common Lisps we've ported Yale Haskell
32 
+to.  We don't really support AKCL and we encourage you to buy one of
33 
+the commercial Lisp products instead.
34 
+
35 
+We do not support our Haskell-to-CLX interface under AKCL, either.
36 
+
37 
+
38 
+
39 
+
com/akcl/build-prelude
History View file @ 4e98702
0 40 
new file mode 100755
... ... 
@@ -0,0 +1,35 @@
1 
+#!/bin/csh
2 
+#
3 
+# build-prelude -- recompile the prelude, saving the old one as old-prelude.*
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/akcl
8 
+rm $PRELUDEBIN/old*
9 
+if (-e $PRELUDEBIN/Prelude.o) then
10 
+  foreach i ($PRELUDEBIN/Prelude*.{o,scm})
11 
+    mv $i $PRELUDEBIN/old-$i:t
12 
+    end
13 
+  endif
14 
+$AKCL <<EOF
15 
+;; Need a big heap to compile the prelude.
16 
+;(setf ext:*bytes-consed-between-gcs* 10000000)
17 
+;; If you want to recompile
18 
+;; everything from scratch, execute the "clean" script first, or
19 
+;; else use the "compile" script to do this.
20 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
21 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
22 
+(load "cl-support/cl-init.lisp")
23 
+;; Use the same compiler settings for processing the prelude.
24 
+(in-package :mumble-user)
25 
+(setf *printers* '(phase-time dump-stat))
26 
+(setf *optimizers* *all-optimizers*)
27 
+;; The compiler barfs while compiling the interface file for the prelude,
28 
+;; so set the flag for writing it as a source file.
29 
+;; Also have it break up the prelude code file into many small pieces
30 
+;; to avoid overwhelming the C compiler.
31 
+(setf *code-chunk-size* 100)
32 
+(setf *compile-interface* '#f)
33 
+(compile/compile *prelude-unit-filename*)
34 
+(lisp:bye)
35 
+EOF
com/akcl/clean
History View file @ 4e98702
0 36 
new file mode 100755
... ... 
@@ -0,0 +1,4 @@
1 
+#!/bin/csh
2 
+#
3 
+# delete AKCL binaries
4 
+'rm' $Y2/*/akcl/*.o
com/akcl/compile
History View file @ 4e98702
0 5 
new file mode 100755
... ... 
@@ -0,0 +1,11 @@
1 
+#!/bin/csh
2 
+#
3 
+# compile -- compile the Yale Haskell system from scratch.
4 
+#
5 
+#
6 
+cd $Y2
7 
+$AKCL <<EOF
8 
+;; Default optimize settings for AKCL are (speed 3) (safety 0)
9 
+(load "support/cl-support/cl-init.lisp")
10 
+(bye)
11 
+EOF
com/akcl/savesys
History View file @ 4e98702
0 12 
new file mode 100755
... ... 
@@ -0,0 +1,46 @@
1 
+#!/bin/csh
2 
+#
3 
+# savesys -- build a saved executable in bin/new-cmu-haskell.core
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/akcl
8 
+if !(-e $PRELUDEBIN/Prelude.o) then
9 
+  echo "Build the prelude first, stupid..."
10 
+  exit
11 
+  endif
12 
+$AKCL <<EOF
13 
+;;; Load the Haskell system.
14 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
15 
+(load "cl-support/cl-init.lisp")
16 
+;;; Set various internal switches to appropriate values for running
17 
+;;; Haskell code.
18 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
19 
+(setf *load-verbose* nil)
20 
+(setf compiler:*compile-verbose* nil)
21 
+(in-package :mumble-user)
22 
+(setf *printers* '(compiling loading))
23 
+(setf *optimizers* '())
24 
+(setf *compile-interface* '#f)
25 
+(setf *code-chunk-size* 100)
26 
+;;; Load the prelude.
27 
+(compile/load *prelude-unit-filename*)
28 
+;;; Set up the saved system.
29 
+;;; AKCL doesn't have the new CL condition system, so define the
30 
+;;; restart function using catch and throw.
31 
+(define (haskell-toplevel)
32 
+  (setf lisp:*package* (lisp:find-package :mumble-user))
33 
+  (setf lisp:*default-pathname-defaults* (lisp:truename "./"))
34 
+  (load-init-files)
35 
+  (do () ('#f)
36 
+    (lisp:catch 'restart-haskell
37 
+      (heval))))
38 
+(define (restart-haskell)
39 
+  (lisp:throw 'restart-haskell '#f))
40 
+;;; Have to do garbage collection and set-up of top-level function
41 
+;;; by hand before calling save.
42 
+;;; AKCL exits automatically after calling save.
43 
+(lisp:gbc 3)
44 
+(setf system::*top-level-hook* (function haskell-toplevel))
45 
+(lisp:save "bin/new-akcl-haskell")
46 
+EOF
com/allegro/README
History View file @ 4e98702
0 47 
new file mode 100644
... ... 
@@ -0,0 +1,40 @@
1 
+This directory contains command scripts used for building Yale Haskell
2 
+from the source distribution under Franz Allegro Common Lisp.  We've
3 
+been using version 4.1 on both NeXT and Sparc platforms -- don't
4 
+expect our code to work without modifications under earlier versions.
5 
+
6 
+Be sure you load the Allegro patches -- the scripts do this
7 
+automatically.  If you're trying to build on some other kind of
8 
+platform, you'll have to get the equivalent patches from Franz Inc.
9 
+Our code won't work without these bug fixes.
10 
+
11 
+Developers need to source haskell-development instead of haskell-setup
12 
+in the .cshrc file.
13 
+
14 
+To rebuild the system:
15 
+
16 
+* You need to define environment variables Y2 and ALLEGRO to point to the
17 
+  appropriate pathnames.  See the haskell-development script for details.
18 
+
19 
+* Make sure that the environment variable PRELUDEBIN (in the
20 
+  haskell-setup script) points to $PRELUDE/allegro (or $PRELUDE/allegro-next,
21 
+  as appropriate).
22 
+
23 
+* Execute the "compile" script.  This will recompile all of the Lisp
24 
+  source files that make up the Yale Haskell system.  Compiled files are
25 
+  put in the "allegro" or "allegro-next" subdirectory of each source directory.
26 
+
27 
+* Execute the "build-prelude" script to compile the standard prelude.
28 
+  Note that this process tends to use up a huge amount of memory!
29 
+
30 
+* Execute the "savesys" script to build a new executable.
31 
+
32 
+* The new executable is initially called "bin/new-allegro-haskell".  Try
33 
+  it out.  If it works, you should rename it to "bin/allegro-haskell".
34 
+  Make sure that HASKELLPROG (in the haskell-setup script) is correct.
35 
+
36 
+* If you want to build an executable with the X support, you'll also
37 
+  need to run the "build-xlib" and "savesys-xlib" scripts.  You may
38 
+  need to edit these scripts to change the pathname of the file
39 
+  containing the CLX library (or suppress the load entirely if you
40 
+  are using a Lisp executable with CLX pre-loaded.).
com/allegro/build-prelude
History View file @ 4e98702
0 41 
new file mode 100755
... ... 
@@ -0,0 +1,32 @@
1 
+#!/bin/csh
2 
+#
3 
+# build-prelude -- recompile the prelude, saving the old one as old-prelude.*
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/$ALLEGRODIR
8 
+if (-e $PRELUDEBIN/Prelude.fasl) then
9 
+  rm $PRELUDEBIN/old*
10 
+  foreach i ($PRELUDEBIN/Prelude*.{fasl,scm})
11 
+    mv $i $PRELUDEBIN/old-$i:t
12 
+    end
13 
+  endif
14 
+$ALLEGRO <<EOF
15 
+;; Need a big heap to compile the prelude.
16 
+;;(lcl:change-memory-management :expand 512 :growth-limit 2048)
17 
+#+next (progn (load "com/allegro/next-patches/patch0149.fasl")
18 
+              (load "com/allegro/next-patches/patch0151.fasl"))
19 
+#+sparc (load "com/allegro/sparc-patches/patch0151.fasl")
20 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
21 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
22 
+(load "cl-support/cl-init")
23 
+(in-package :mumble-user)
24 
+(setf *printers* '(phase-time dump-stat))
25 
+(setf *optimizers* *all-optimizers*)
26 
+;; Set appropriate compiler settings for processing the prelude.
27 
+;; Don't try to compile the interface.
28 
+(setf *code-chunk-size* 300)
29 
+(setf *compile-interface* '#f)
30 
+(compile/compile *prelude-unit-filename*)
31 
+(excl:exit)
32 
+EOF
com/allegro/build-xlib
History View file @ 4e98702
0 33 
new file mode 100755
... ... 
@@ -0,0 +1,14 @@
1 
+#!/bin/csh
2 
+#
3 
+# build-xlib -- recompile the xlib stuff
4 
+#
5 
+# note that allegro's loader will look in its lib directory automagically
6 
+# for the clx library
7 
+cd $Y2
8 
+setenv LIBRARYBIN $Y2/progs/lib/X11/$ALLEGRODIR
9 
+rm $LIBRARYBIN/xlib*.sbin
10 
+bin/allegro-haskell <<EOF
11 
+:(lisp:load "clx")
12 
+:(setf *code-quality* 3)
13 
+:compile \$HASKELL_LIBRARY/X11/xlib
14 
+EOF
com/allegro/clean
History View file @ 4e98702
0 15 
new file mode 100755
... ... 
@@ -0,0 +1,5 @@
1 
+#!/bin/csh
2 
+#
3 
+# delete Allegro CL binaries
4 
+'rm' $Y2/*/$ALLEGRODIR/*.fasl
5 
+
com/allegro/compile
History View file @ 4e98702
0 6 
new file mode 100755
... ... 
@@ -0,0 +1,15 @@
1 
+#!/bin/csh
2 
+#
3 
+# compile -- compile the Yale Haskell system from scratch.
4 
+#
5 
+#
6 
+cd $Y2
7 
+$ALLEGRO <<EOF
8 
+#+next (progn (load "com/allegro/next-patches/patch0149.fasl")
9 
+              (load "com/allegro/next-patches/patch0151.fasl"))
10 
+#+sparc (load "com/allegro/sparc-patches/patch0151.fasl")
11 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
12 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
13 
+(load "cl-support/cl-init")
14 
+(excl:exit)
15 
+EOF
com/allegro/next-patches/patch0149.fasl
History View file @ 4e98702
0 16 
new file mode 100644
1 17 
Binary files /dev/null and b/com/allegro/next-patches/patch0149.fasl differ
com/allegro/next-patches/patch0151.fasl
History View file @ 4e98702
2 18 
new file mode 100644
3 19 
Binary files /dev/null and b/com/allegro/next-patches/patch0151.fasl differ
com/allegro/savesys
History View file @ 4e98702
4 20 
new file mode 100755
... ... 
@@ -0,0 +1,54 @@
1 
+#!/bin/csh
2 
+#
3 
+# savesys -- build a saved executable in bin/new-allegro-haskell
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/$ALLEGRODIR
8 
+if !(-e $PRELUDEBIN/Prelude.fasl) then
9 
+  echo "Build the prelude first, stupid..."
10 
+  exit
11 
+  endif
12 
+$ALLEGRO <<EOF
13 
+;;; Load the Haskell system.
14 
+#+next (progn (load "com/allegro/next-patches/patch0149.fasl")
15 
+              (load "com/allegro/next-patches/patch0151.fasl"))
16 
+#+sparc (load "com/allegro/sparc-patches/patch0151.fasl")
17 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
18 
+(load "cl-support/cl-init")
19 
+;;; Set various internal switches to appropriate values for running
20 
+;;; Haskell code.
21 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
22 
+(setf *compile-verbose* nil)
23 
+(setf *load-verbose* nil)
24 
+(setf excl:*load-source-file-info* nil)
25 
+(setf excl:*record-source-file-info* nil)
26 
+(setf excl:*load-xref-info* nil)
27 
+(setf excl:*record-source-file-info* nil)
28 
+(in-package :mumble-user)
29 
+(setf *printers* '(compiling loading))
30 
+(setf *optimizers* '())
31 
+(setf *compile-interface* '#f)
32 
+;;; Load the prelude.
33 
+(compile/load *prelude-unit-filename*)
34 
+;;; Set up the saved system.
35 
+(define *saved-readtable* (lisp:copy-readtable lisp:*readtable*))
36 
+(define (haskell-toplevel)
37 
+  ;; Saved system always starts up in USER package.
38 
+  (setf lisp:*package* (lisp:find-package :mumble-user))
39 
+  ;; Saved system seems to forget about our readtable hacks.
40 
+  (setf lisp:*readtable* *saved-readtable*)
41 
+  ;; Set printer variables w/implementation-defined initial values
42 
+  ;; to known values
43 
+  (setf *print-pretty* '#f)
44 
+  (load-init-files)
45 
+  (do () ('#f)
46 
+    (cl:with-simple-restart (restart-haskell "Restart Haskell.")
47 
+      (heval))))
48 
+(define (restart-haskell)
49 
+  (cl:invoke-restart 'restart-haskell))
50 
+(excl:dumplisp
51 
+  :name #+next "bin/new-allegro-next-haskell" #-next "bin/new-allegro-haskell"
52 
+  :restart-function 'haskell-toplevel)
53 
+(excl:exit)
54 
+EOF
com/allegro/savesys-xlib
History View file @ 4e98702
0 55 
new file mode 100755
... ... 
@@ -0,0 +1,65 @@
1 
+#!/bin/csh
2 
+#
3 
+# savesys -- build a saved executable in bin/new-allegro-haskell
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/$ALLEGRODIR
8 
+if !(-e $PRELUDEBIN/Prelude.fasl) then
9 
+  echo "Build the prelude first, stupid..."
10 
+  exit
11 
+  endif
12 
+setenv LIBRARYBIN $Y2/progs/lib/X11/$ALLEGRODIR
13 
+if !(-e $LIBRARYBIN/xlib.fasl) then
14 
+  echo "Build the xlib stuff first, silly..."
15 
+  exit
16 
+  endif
17 
+$ALLEGRO <<EOF
18 
+;;; Load the Haskell system.
19 
+#+next (progn (load "com/allegro/next-patches/patch0149.fasl")
20 
+              (load "com/allegro/next-patches/patch0151.fasl"))
21 
+#+sparc (load "com/allegro/sparc-patches/patch0151.fasl")
22 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
23 
+(load "cl-support/cl-init")
24 
+;;; Set various internal switches to appropriate values for running
25 
+;;; Haskell code.
26 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
27 
+(setf *compile-verbose* nil)
28 
+(setf *load-verbose* nil)
29 
+(setf excl:*load-source-file-info* nil)
30 
+(setf excl:*record-source-file-info* nil)
31 
+(setf excl:*load-xref-info* nil)
32 
+(setf excl:*record-source-file-info* nil)
33 
+(in-package :mumble-user)
34 
+(setf *printers* '(compiling loading))
35 
+(setf *optimizers* '())
36 
+(setf *compile-interface* '#f)
37 
+;;; Load the prelude.
38 
+(compile/load *prelude-unit-filename*)
39 
+;;; Load the X support.
40 
+(lisp:load "clx")
41 
+(compile/load "\$HASKELL_LIBRARY/X11/xlib")
42 
+(setf *haskell-compiler-update*
43 
+	(string-append *haskell-compiler-update* "-X11"))
44 
+;;; Set up the saved system.
45 
+(define *saved-readtable* (lisp:copy-readtable lisp:*readtable*))
46 
+(define (haskell-toplevel)
47 
+  ;; Saved system always starts up in USER package.
48 
+  (setf lisp:*package* (lisp:find-package :mumble-user))
49 
+  ;; Saved system seems to forget about our readtable hacks.
50 
+  (setf lisp:*readtable* *saved-readtable*)
51 
+  ;; Set printer variables w/implementation-defined initial values
52 
+  ;; to known values
53 
+  (setf *print-pretty* '#f)
54 
+  (load-init-files)
55 
+  (do () ('#f)
56 
+    (cl:with-simple-restart (restart-haskell "Restart Haskell.")
57 
+      (heval))))
58 
+(define (restart-haskell)
59 
+  (cl:invoke-restart 'restart-haskell))
60 
+(excl:dumplisp
61 
+  :name #+next "bin/new-allegro-next-clx-haskell"
62 
+        #-next "bin/new-allegro-clx-haskell"
63 
+  :restart-function 'haskell-toplevel)
64 
+(excl:exit)
65 
+EOF
com/allegro/sparc-patches/patch0151.fasl
History View file @ 4e98702
0 66 
new file mode 100644
1 67 
Binary files /dev/null and b/com/allegro/sparc-patches/patch0151.fasl differ
com/clean
History View file @ 4e98702
2 68 
new file mode 100755
... ... 
@@ -0,0 +1,14 @@
1 
+#!/bin/csh
2 
+#
3 
+# clean -- delete binaries
4 
+#
5 
+
6 
+$Y2/com/lucid/clean
7 
+$Y2/com/cmu/clean
8 
+$Y2/com/allegro/clean
9 
+$Y2/com/lispworks/clean
10 
+$Y2/com/akcl/clean
11 
+
12 
+# T stuff
13 
+'rm' $Y2/*/t/*.{si,sd,sn,so}
14 
+'rm' $Y2/support/t-support/*.{si,sd,sn,so}
com/cmu/README
History View file @ 4e98702
0 15 
new file mode 100644
... ... 
@@ -0,0 +1,45 @@
1 
+This directory contains command scripts used for building Yale Haskell
2 
+from the source distribution under CMU Common Lisp on the sparc.
3 
+
4 
+We have been using version 16f of CMU Common Lisp to build Haskell.
5 
+You can ftp this from lisp-rt1.slisp.cs.cmu.edu (128.2.217.9).
6 
+There is a known problem with this version of CMU CL: core files built
7 
+under SunOS 4.1.2 won't work under 4.1.3, and vice versa.  There are
8 
+also apparently compatibility problems with 4.1.3 between sun4c and
9 
+sun4m architectures.  Anyway, we have built under 4.1.2 on a sun4c
10 
+and 4.1.3 on a sun4m.
11 
+
12 
+Developers need to source haskell-development instead of haskell-setup
13 
+in the .cshrc file.
14 
+
15 
+To rebuild the system:
16 
+
17 
+* You need to define environment variables Y2, CMUCL, and CMUCLLIB to
18 
+  point to the appropriate pathnames.  See the haskell-development
19 
+  script for details.
20 
+
21 
+* Make sure that the environment variable PRELUDEBIN (in the
22 
+  haskell-setup script) points to $PRELUDE/cmu.
23 
+
24 
+* Execute the "compile" script.  This will recompile all of the Lisp
25 
+  source files that make up the Yale Haskell system.  Compiled files
26 
+  are put in the "cmu" subdirectory of each source directory.
27 
+
28 
+* Execute the "build-prelude" script to compile the standard prelude.
29 
+  Note that this process tends to use up a huge amount of memory!
30 
+
31 
+* Execute the "savesys" script to save a core file.
32 
+
33 
+* The new core file is initially called "bin/new-cmu-haskell.core".
34 
+  Use the -core command line argument to cmucl to test it.  If it
35 
+  works, you should rename it to "bin/sun4c-haskell.core" (or
36 
+  "bin/sun4m-haskell.core") and use the "bin/cmu-haskell" script
37 
+  to execute it.  Make sure HASKELLPROG (in the haskell-setup script)
38 
+  is correct.  Depending on where you have cmucl this script may need
39 
+  editing.
40 
+
41 
+* If you want to build an executable with the X support, you'll also
42 
+  need to run the "build-xlib" and "savesys-xlib" scripts.  You
43 
+  need to edit these scripts to change the pathname of the file
44 
+  containing the CLX library (or suppress the load entirely if you
45 
+  are using a Lisp executable with CLX pre-loaded.).
com/cmu/build-prelude
History View file @ 4e98702
0 46 
new file mode 100755
... ... 
@@ -0,0 +1,32 @@
1 
+#!/bin/csh
2 
+#
3 
+# build-prelude -- recompile the prelude, saving the old one as old-prelude.*
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/cmu
8 
+if (-e $PRELUDEBIN/Prelude.sparcf) then
9 
+  rm $PRELUDEBIN/old*
10 
+  foreach i ($PRELUDEBIN/Prelude*.{scm,sparcf})
11 
+    mv $i $PRELUDEBIN/old-$i:t
12 
+    end
13 
+  endif
14 
+$CMUCL <<EOF
15 
+;; Need a big heap to compile the prelude.
16 
+(setf ext:*bytes-consed-between-gcs* 10000000)
17 
+;; If you want to recompile
18 
+;; everything from scratch, execute the "clean" script first, or
19 
+;; else use the "compile" script to do this.
20 
+(proclaim '(optimize (speed 3) (safety 0) (debug 0) (ext:inhibit-warnings 3)))
21 
+(load "cl-support/cl-init")
22 
+;; Use the same compiler settings for processing the prelude.
23 
+(in-package :mumble-user)
24 
+(setf *printers* '(phase-time dump-stat))
25 
+(setf *optimizers* *all-optimizers*)
26 
+;; The compiler barfs while compiling the interface file for the prelude,
27 
+;; so set the flag for writing it as a source file.
28 
+(setf *code-chunk-size* 300)
29 
+(setf *compile-interface* '#f)
30 
+(compile/compile *prelude-unit-filename*)
31 
+(ext:quit)
32 
+EOF
com/cmu/build-xlib
History View file @ 4e98702
0 33 
new file mode 100755
... ... 
@@ -0,0 +1,15 @@
1 
+#!/bin/csh
2 
+#
3 
+# build-xlib -- recompile the xlib stuff
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv CLXFILE /net/nebula/homes/systems/hcompile/cmu/lib/subsystems/clx-library.sparcf
8 
+setenv LIBRARYBIN $Y2/progs/lib/bin/cmu
9 
+rm $LIBRARYBIN/xlib*.sparcf
10 
+bin/cmu-haskell <<EOF
11 
+:(setf ext:*bytes-consed-between-gcs* 8000000)
12 
+:(load "\$CLXFILE")
13 
+:(setf *code-quality* 3)
14 
+:compile \$HASKELL_LIBRARY/X11/xlib
15 
+EOF
com/cmu/clean
History View file @ 4e98702
0 16 
new file mode 100755
... ... 
@@ -0,0 +1,4 @@
1 
+#!/bin/csh
2 
+#
3 
+# delete CMU CL binaries
4 
+'rm' $Y2/*/cmu/*.sparcf
com/cmu/compile
History View file @ 4e98702
0 5 
new file mode 100755
... ... 
@@ -0,0 +1,12 @@
1 
+#!/bin/csh
2 
+#
3 
+# compile -- compile the Yale Haskell system from scratch.
4 
+#
5 
+#
6 
+cd $Y2
7 
+$CMUCL <<EOF
8 
+(setf ext:*bytes-consed-between-gcs* 4000000)
9 
+(proclaim '(optimize (speed 3) (safety 0) (debug 0) (ext:inhibit-warnings 3)))
10 
+(load "cl-support/cl-init")
11 
+(quit)
12 
+EOF
com/cmu/savesys
History View file @ 4e98702
0 13 
new file mode 100755
... ... 
@@ -0,0 +1,46 @@
1 
+#!/bin/csh
2 
+#
3 
+# savesys -- build a saved executable in bin/new-cmu-haskell.core
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/cmu
8 
+if !(-e $PRELUDEBIN/Prelude.sparcf) then
9 
+  echo "Build the prelude first, stupid..."
10 
+  exit
11 
+  endif
12 
+$CMUCL <<EOF
13 
+;;; Load the Haskell system.
14 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
15 
+(load "cl-support/cl-init")
16 
+;;; Set various internal switches to appropriate values for running
17 
+;;; Haskell code.
18 
+(setf ext:*bytes-consed-between-gcs* 4000000)
19 
+(proclaim '(optimize (speed 3) (safety 0) (debug 0) (ext:inhibit-warnings 3)))
20 
+(setf *load-verbose* nil)
21 
+(setf *compile-verbose* nil)
22 
+(in-package :mumble-user)
23 
+(gc-messages '#f)
24 
+(setf *printers* '(compiling loading))
25 
+(setf *optimizers* '())
26 
+(setf *compile-interface* '#f)
27 
+;;; Load the prelude.
28 
+(compile/load *prelude-unit-filename*)
29 
+;;; Set up the saved system.
30 
+(define (haskell-toplevel)
31 
+  (load-init-files)
32 
+  (do () ('#f)
33 
+    (lisp:with-simple-restart (restart-haskell "Restart Haskell.")
34 
+      (heval))))
35 
+(define (restart-haskell)
36 
+  (lisp:invoke-restart 'restart-haskell))
37 
+(ext:save-lisp "bin/new-cmu-haskell.core"
38 
+  :purify '#t
39 
+  :root-structures '()
40 
+  :init-function 'haskell-toplevel
41 
+  :load-init-file '#f
42 
+  :site-init '#f
43 
+  :print-herald '#f
44 
+  )
45 
+(ext:quit)
46 
+EOF
com/cmu/savesys-xlib
History View file @ 4e98702
0 47 
new file mode 100755
... ... 
@@ -0,0 +1,57 @@
1 
+#!/bin/csh
2 
+#
3 
+# savesys-xlib -- build a saved executable in bin/new-cmu-clx-haskell.core
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/cmu
8 
+if !(-e $PRELUDEBIN/Prelude.sparcf) then
9 
+  echo "Build the prelude first, stupid..."
10 
+  exit
11 
+  endif
12 
+setenv CLXFILE /net/nebula/homes/systems/hcompile/cmu/lib/subsystems/clx-library.sparcf
13 
+setenv LIBRARYBIN $Y2/progs/lib/bin/cmu
14 
+if !(-e $LIBRARYBIN/xlib.sparcf) then
15 
+  echo "Build the xlib stuff first, silly..."
16 
+  exit
17 
+  endif
18 
+$CMUCL <<EOF
19 
+;;; Load the Haskell system.
20 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
21 
+(load "cl-support/cl-init")
22 
+;;; Set various internal switches to appropriate values for running
23 
+;;; Haskell code.
24 
+(setf ext:*bytes-consed-between-gcs* 4000000)
25 
+(proclaim '(optimize (speed 3) (safety 0) (debug 0) (ext:inhibit-warnings 3)))
26 
+(setf *load-verbose* nil)
27 
+(setf *compile-verbose* nil)
28 
+(in-package :mumble-user)
29 
+(gc-messages '#f)
30 
+(setf *printers* '(compiling loading))
31 
+(setf *optimizers* '())
32 
+(setf *compile-interface* '#f)
33 
+;;; Load the prelude.
34 
+(compile/load *prelude-unit-filename*)
35 
+;;; Load the X support.
36 
+(load "\$CLXFILE")
37 
+(compile/load "\$HASKELL_LIBRARY/X11/xlib")
38 
+(setf *haskell-compiler-update*
39 
+	(string-append *haskell-compiler-update* "-X11"))
40 
+;;; Set up the saved system.
41 
+(define (haskell-toplevel)
42 
+  (load-init-files)
43 
+  (do () ('#f)
44 
+    (lisp:with-simple-restart (restart-haskell "Restart Haskell.")
45 
+      (heval))))
46 
+(define (restart-haskell)
47 
+  (lisp:invoke-restart 'restart-haskell))
48 
+(ext:save-lisp "bin/new-cmu-clx-haskell.core"
49 
+  :purify '#t
50 
+  :root-structures '()
51 
+  :init-function 'haskell-toplevel
52 
+  :load-init-file '#f
53 
+  :site-init '#f
54 
+  :print-herald '#f
55 
+  )
56 
+(ext:quit)
57 
+EOF
com/lispworks/README
History View file @ 4e98702
0 58 
new file mode 100644
... ... 
@@ -0,0 +1,43 @@
1 
+This directory contains command scripts used for building Yale Haskell
2 
+from the source distribution under Lispworks from Harlequin.  We have
3 
+been using version 3.1.1 on a Sparc.
4 
+
5 
+Developers need to source haskell-development instead of haskell-setup
6 
+in the .cshrc file.
7 
+
8 
+Important: Make sure you load the stuff in the patches directory
9 
+before trying to build the system (the command files do this for you).
10 
+If you're building on some platform other than a sparc, you'll have to
11 
+get equivalent patches from Harlequin before proceeding.
12 
+
13 
+To rebuild the system:
14 
+
15 
+* You need to define environment variables Y2 and LISPWORKS to point to the
16 
+  appropriate pathnames.  See the haskell-development script for details.
17 
+
18 
+* Make sure that the environment variable PRELUDEBIN (in the
19 
+  haskell-setup script) points to $PRELUDE/lispworks.
20 
+
21 
+* Execute the "compile" script.  This will recompile all of the Lisp
22 
+  source files that make up the Yale Haskell system.  Compiled files are
23 
+  put in the "lispworks" subdirectory of each source directory.
24 
+
25 
+* Execute the "build-prelude" script to compile the standard prelude.
26 
+  Note that this process tends to use up a huge amount of memory!
27 
+
28 
+* Execute the "savesys" script to build a new executable.
29 
+
30 
+* The new executable is initially called "bin/new-lispworks-haskell".  Try
31 
+  it out.  If it works, you should rename it to "bin/lispworks-haskell".
32 
+  Make sure that HASKELLPROG (in the haskell-setup script) is correct.
33 
+
34 
+* If you want to build an executable with the X support, you'll also
35 
+  need to run the "build-xlib" and "savesys-xlib" scripts.  You may
36 
+  need to edit these scripts to load the CLX library explicitly if
37 
+  you are using a Lisp executable that doesn't have CLX pre-loaded.
38 
+
39 
+When you compile things with the Lispworks compiler, you'll see a
40 
+bunch of messages complaining about forward references to things that
41 
+haven't yet been defined.  We haven't been able to figure out how to
42 
+suppress these messages, so unless something else goes wrong you should
43 
+just ignore them.
com/lispworks/build-prelude
History View file @ 4e98702
0 44 
new file mode 100755
... ... 
@@ -0,0 +1,35 @@
1 
+#!/bin/csh
2 
+#
3 
+# build-prelude -- recompile the prelude, saving the old one as old-prelude.*
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/lispworks
8 
+if (-e $PRELUDEBIN/Prelude.wfasl) then
9 
+  rm $PRELUDEBIN/old*
10 
+  foreach i ($PRELUDEBIN/Prelude*.{wfasl,scm})
11 
+    mv $i $PRELUDEBIN/old-$i:t
12 
+    end
13 
+  endif
14 
+$LISPWORKS <<EOF
15 
+(load "com/lispworks/patches/safe-fo-closure.wfasl")
16 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
17 
+;; Need a bigger than normal stack for compiling the prelude.
18 
+(setf system::*stack-overflow-behaviour* :warn)
19 
+;; Need a big heap to compile the prelude.
20 
+;(lcl:change-memory-management :expand 512 :growth-limit 2048)
21 
+;; If you want to recompile
22 
+;; everything from scratch, execute the "clean" script first, or
23 
+;; else use the "compile" script to do this.
24 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
25 
+(load "cl-support/cl-init")
26 
+(in-package :mumble-user)
27 
+(setf *printers* '(phase-time dump-stat))
28 
+(setf *optimizers* *all-optimizers*)
29 
+;; Set appropriate compiler settings for processing the prelude.
30 
+;; Don't try to compile the interface files.
31 
+(setf *code-chunk-size* 300)
32 
+(setf *compile-interface* '#f)
33 
+(compile/compile *prelude-unit-filename*)
34 
+(lw:bye)
35 
+EOF
com/lispworks/build-xlib
History View file @ 4e98702
0 36 
new file mode 100755
... ... 
@@ -0,0 +1,12 @@
1 
+#!/bin/csh
2 
+#
3 
+# build-xlib -- recompile the xlib stuff
4 
+#
5 
+# note that lispworks comes with clx pre-loaded!
6 
+cd $Y2
7 
+setenv LIBRARYBIN $Y2/progs/lib/X11/lispworks
8 
+rm $LIBRARYBIN/xlib*.wfasl
9 
+bin/lispworks-haskell <<EOF
10 
+:(setf *code-quality* 3)
11 
+:compile \$HASKELL_LIBRARY/X11/xlib
12 
+EOF
com/lispworks/clean
History View file @ 4e98702
0 13 
new file mode 100755
... ... 
@@ -0,0 +1,5 @@
1 
+#!/bin/csh
2 
+#
3 
+# delete lispworks binaries
4 
+'rm' $Y2/*/lispworks/*.{wfasl}
5 
+
com/lispworks/compile
History View file @ 4e98702
0 6 
new file mode 100755
... ... 
@@ -0,0 +1,13 @@
1 
+#!/bin/csh
2 
+#
3 
+# compile -- compile the Yale Haskell system from scratch.
4 
+#
5 
+#
6 
+cd $Y2
7 
+$LISPWORKS <<EOF
8 
+(load "com/lispworks/patches/safe-fo-closure.wfasl")
9 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
10 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
11 
+(load "cl-support/cl-init")
12 
+(lw:bye)
13 
+EOF
com/lispworks/patches/safe-fo-closure.wfasl
History View file @ 4e98702
0 14 
new file mode 100644
1 15 
Binary files /dev/null and b/com/lispworks/patches/safe-fo-closure.wfasl differ
com/lispworks/savesys
History View file @ 4e98702
2 16 
new file mode 100755
... ... 
@@ -0,0 +1,43 @@
1 
+#!/bin/csh
2 
+#
3 
+# savesys -- build a saved executable in bin/new-lispworks-haskell
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/lispworks
8 
+if !(-e $PRELUDEBIN/Prelude.wfasl) then
9 
+  echo "Build the prelude first, stupid..."
10 
+  exit
11 
+  endif
12 
+$LISPWORKS <<EOF
13 
+;;; Load the Haskell system.
14 
+(load "com/lispworks/patches/safe-fo-closure.wfasl")
15 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
16 
+(load "cl-support/cl-init")
17 
+;;; Set various internal switches to appropriate values for running
18 
+;;; Haskell code.
19 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
20 
+(setf *load-verbose* nil)
21 
+(setf *compile-verbose* nil)
22 
+(in-package :mumble-user)
23 
+(setf *printers* '(compiling loading))
24 
+(setf *optimizers* '())
25 
+(setf *compile-interface* '#f)
26 
+;;; Load the prelude
27 
+(compile/load *prelude-unit-filename*)
28 
+;;; Set up the saved system.
29 
+(define (haskell-toplevel)
30 
+  ;; Need to reset pathname defaults
31 
+  (setf lisp:*default-pathname-defaults* (lisp:truename ""))
32 
+  (load-init-files)
33 
+  (do () ('#f)
34 
+    (lisp:with-simple-restart (restart-haskell "Restart Haskell.")
35 
+      (heval))))
36 
+(define (restart-haskell)
37 
+  (lisp:invoke-restart 'restart-haskell))
38 
+(lw:save-image "bin/new-lispworks-haskell"
39 
+  :gc '#t
40 
+  :normal-gc '#f  ; don't reset gc parameters
41 
+  :restart-function 'haskell-toplevel)
42 
+(lw:bye)
43 
+EOF
com/lispworks/savesys-xlib
History View file @ 4e98702
0 44 
new file mode 100755
... ... 
@@ -0,0 +1,52 @@
1 
+#!/bin/csh
2 
+#
3 
+# savesys -- build a saved executable in bin/new-lispworks-haskell
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/lispworks
8 
+if !(-e $PRELUDEBIN/Prelude.wfasl) then
9 
+  echo "Build the prelude first, stupid..."
10 
+  exit
11 
+  endif
12 
+setenv LIBRARYBIN $Y2/progs/lib/X11/lispworks
13 
+if !(-e $LIBRARYBIN/xlib.wfasl) then
14 
+  echo "Build the xlib stuff first, silly..."
15 
+  exit
16 
+  endif
17 
+$LISPWORKS <<EOF
18 
+;;; Load the Haskell system.
19 
+(load "com/lispworks/patches/safe-fo-closure.wfasl")
20 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
21 
+(load "cl-support/cl-init")
22 
+;;; Set various internal switches to appropriate values for running
23 
+;;; Haskell code.
24 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
25 
+(setf *load-verbose* nil)
26 
+(setf *compile-verbose* nil)
27 
+(in-package :mumble-user)
28 
+(setf *printers* '(compiling loading))
29 
+(setf *optimizers* '())
30 
+(setf *compile-interface* '#f)
31 
+;;; Load the prelude.
32 
+(compile/load *prelude-unit-filename*)
33 
+;;; Load the X support.
34 
+(compile/load "\$HASKELL_LIBRARY/X11/xlib")
35 
+(setf *haskell-compiler-update*
36 
+	(string-append *haskell-compiler-update* "-X11"))
37 
+;;; Set up the saved system.
38 
+(define (haskell-toplevel)
39 
+  ;; Need to reset pathname defaults
40 
+  (setf lisp:*default-pathname-defaults* (lisp:truename ""))
41 
+  (load-init-files)
42 
+  (do () ('#f)
43 
+    (lisp:with-simple-restart (restart-haskell "Restart Haskell.")
44 
+      (heval))))
45 
+(define (restart-haskell)
46 
+  (lisp:invoke-restart 'restart-haskell))
47 
+(lw:save-image "bin/new-lispworks-clx-haskell"
48 
+  :gc '#t
49 
+  :normal-gc '#f  ; don't reset gc parameters
50 
+  :restart-function 'haskell-toplevel)
51 
+(lw:bye)
52 
+EOF
com/locked
History View file @ 4e98702
0 53 
new file mode 100755
... ... 
@@ -0,0 +1,14 @@
1 
+#!/bin/csh
2 
+#
3 
+#
4 
+# identify locked source files
5 
+#
6 
+
7 
+cd $Y2
8 
+foreach i (*/*.scm */*.lisp)
9 
+  if (-e $i:h/RCS/$i:t,v) then
10 
+    foreach j (`rlog -R -L $i:h/RCS/$i:t,v`)
11 
+      ls -l $i
12 
+    end
13 
+  endif
14 
+end
com/lookfor
History View file @ 4e98702
0 15 
new file mode 100755
... ... 
@@ -0,0 +1,9 @@
1 
+#!/bin/csh
2 
+#
3 
+#
4 
+# look for the argument in source files.
5 
+# useful for finding all references of a function, etc.
6 
+#
7 
+
8 
+cd $Y2
9 
+fgrep -i $1 */*.scm
com/lucid/README
History View file @ 4e98702
0 10 
new file mode 100644
... ... 
@@ -0,0 +1,39 @@
1 
+This directory contains command scripts used for building Yale Haskell
2 
+from the source distribution under Lucid Common Lisp.  We have been using
3 
+Lucid version 4.0.0 on a Sparc, but we don't expect that there would
4 
+be difficulties in building with Lucid on other platforms.
5 
+
6 
+Developers need to source haskell-development instead of haskell-setup
7 
+in the .cshrc file.
8 
+
9 
+To rebuild the system:
10 
+
11 
+* You need to define environment variables Y2 and LUCID to point to the
12 
+  appropriate pathnames.  See the haskell-development script for details.
13 
+
14 
+* Make sure that the environment variable PRELUDEBIN (in the
15 
+  haskell-setup script) points to $PRELUDE/lucid.
16 
+
17 
+* Execute the "compile" script.  This will recompile all of the Lisp
18 
+  source files that make up the Yale Haskell system.  Compiled files are
19 
+  put in the "lucid" subdirectory of each source directory.
20 
+
21 
+* Execute the "build-prelude" script to compile the standard prelude.
22 
+  Note that this process tends to use up a huge amount of memory!
23 
+
24 
+* Execute the "savesys" script to build a new executable.
25 
+
26 
+* The new executable is initially called "bin/new-lucid-haskell".  Try
27 
+  it out.  If it works, you should rename it to "bin/lucid-haskell".
28 
+  Make sure that HASKELLPROG (in the haskell-setup script) is correct.
29 
+
30 
+* If you want to build an executable with the X support, you'll also
31 
+  need to run the "build-xlib" and "savesys-xlib" scripts.  You
32 
+  need to edit these scripts to change the pathname of the file
33 
+  containing the CLX library (or suppress the load entirely if you
34 
+  are using a Lisp executable with CLX pre-loaded.).
35 
+
36 
+Important note for Emacs users: We've been told that Lucid provides
37 
+some patches to GNU Emacs that cause the Haskell Emacs mode not to work.
38 
+(Apparently these patches redefine some of the interprocess communication
39 
+functions in an incompatible way.)  Use a standard Emacs.
com/lucid/build-prelude
History View file @ 4e98702
0 40 
new file mode 100755
... ... 
@@ -0,0 +1,36 @@
1 
+#!/bin/csh
2 
+#
3 
+# build-prelude -- recompile the prelude, saving the old one as old-prelude.*
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/lucid
8 
+if (-e $PRELUDEBIN/Prelude.sbin) then
9 
+  rm $PRELUDEBIN/old*
10 
+  foreach i ($PRELUDEBIN/Prelude*.{sbin,scm})
11 
+    mv $i $PRELUDEBIN/old-$i:t
12 
+    end
13 
+  endif
14 
+$LUCID <<EOF
15 
+;; Need a big heap to compile the prelude.
16 
+(lcl:change-memory-management :expand 512 :growth-limit 2048)
17 
+;; This will make sure any files that need to get compiled will be
18 
+;; compiled with Lucid's production compiler.  If you want to recompile
19 
+;; everything from scratch, execute the "clean" script first, or
20 
+;; else use the "compile" script to do this.
21 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
22 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
23 
+(load "cl-support/cl-init")
24 
+(in-package :mumble-user)
25 
+(setf *printers* '(phase-time dump-stat))
26 
+(setf *optimizers* *all-optimizers*)
27 
+;; Set appropriate compiler settings for processing the prelude.
28 
+;; Use production compiler on prelude code and split it up into pieces.
29 
+;; Use fast development compiler on interface.
30 
+(setf *code-chunk-size* 200)
31 
+(setf *compile-interface* '#t)
32 
+(setf *interface-code-quality* 2)
33 
+(setf *interface-chunk-size* '#f)
34 
+(compile/compile *prelude-unit-filename*)
35 
+(lcl:quit)
36 
+EOF
com/lucid/build-xlib
History View file @ 4e98702
0 37 
new file mode 100755
... ... 
@@ -0,0 +1,15 @@
1 
+#!/bin/csh
2 
+#
3 
+# build-xlib -- recompile the xlib stuff
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv CLXFILE /cs/licensed/sclisp-4.0/windows-x.sbin
8 
+setenv LIBRARYBIN $Y2/progs/lib/bin/lucid
9 
+rm $LIBRARYBIN/xlib*.sbin
10 
+bin/haskell <<EOF
11 
+:(lcl:change-memory-management :expand 512)
12 
+:(load "\$CLXFILE")
13 
+:(setf *code-quality* 3)
14 
+:compile \$HASKELL_LIBRARY/X11/xlib
15 
+EOF
com/lucid/clean
History View file @ 4e98702
0 16 
new file mode 100755
... ... 
@@ -0,0 +1,5 @@
1 
+#!/bin/csh
2 
+#
3 
+# delete lucid binaries
4 
+'rm' $Y2/*/lucid/*.{sbin,rbin}
5 
+
com/lucid/compile
History View file @ 4e98702
0 6 
new file mode 100755
... ... 
@@ -0,0 +1,13 @@
1 
+#!/bin/csh
2 
+#
3 
+# compile -- compile the Yale Haskell system from scratch.
4 
+#
5 
+#
6 
+cd $Y2
7 
+$LUCID <<EOF
8 
+;; To get Lucid's development mode compiler, remove (compilation-speed 0)
9 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
10 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
11 
+(load "cl-support/cl-init")
12 
+(quit)
13 
+EOF
com/lucid/savesys
History View file @ 4e98702
0 14 
new file mode 100755
... ... 
@@ -0,0 +1,44 @@
1 
+#!/bin/csh
2 
+#
3 
+# savesys -- build a saved executable in bin/new-lucid-haskell
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/lucid
8 
+if !(-e $PRELUDEBIN/Prelude.sbin) then
9 
+  echo "Build the prelude first, stupid..."
10 
+  exit
11 
+  endif
12 
+$LUCID <<EOF
13 
+;;; Load the Haskell system.
14 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
15 
+(setf lcl:*record-source-files* nil)
16 
+(load "cl-support/cl-init")
17 
+;;; Set various internal switches to appropriate values for running
18 
+;;; Haskell code.
19 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
20 
+(lcl:compiler-options :file-messages nil)
21 
+(setf lcl:*redefinition-action* nil)
22 
+(setf *load-verbose* nil)
23 
+(in-package :mumble-user)
24 
+(setf *printers* '(compiling loading))
25 
+(setf *optimizers* '())
26 
+(setf *compile-interface* '#t)
27 
+(setf *interface-code-quality* 1)
28 
+(setf *code-chunk-size* 200)
29 
+;;; Load the prelude.
30 
+(compile/load *prelude-unit-filename*)
31 
+;;; Set up the saved system.
32 
+(define (haskell-toplevel)
33 
+  (load-init-files)
34 
+  (do () ('#f)
35 
+    (lcl:with-simple-restart (restart-haskell "Restart Haskell.")
36 
+      (heval))))
37 
+(define (restart-haskell)
38 
+  (lcl:invoke-restart 'restart-haskell))
39 
+(lcl:gc)
40 
+(lcl:disksave "bin/new-lucid-haskell"
41 
+  :reserved-free-segments 64 :dynamic-free-segments 25
42 
+  :restart-function 'haskell-toplevel :full-gc '#t)
43 
+(lcl:quit)
44 
+EOF
com/lucid/savesys-xlib
History View file @ 4e98702
0 45 
new file mode 100755
... ... 
@@ -0,0 +1,55 @@
1 
+#!/bin/csh
2 
+#
3 
+# savesys-xlib -- build a saved executable in bin/new-lucid-clx-haskell
4 
+#
5 
+#
6 
+cd $Y2
7 
+setenv PRELUDEBIN $Y2/progs/prelude/lucid
8 
+if !(-e $PRELUDEBIN/Prelude.sbin) then
9 
+  echo "Build the prelude first, stupid..."
10 
+  exit
11 
+  endif
12 
+setenv CLXFILE /cs/licensed/sclisp-4.0/windows-x.sbin
13 
+setenv LIBRARYBIN $Y2/progs/lib/bin/lucid
14 
+if !(-e $LIBRARYBIN/xlib.sbin) then
15 
+  echo "Build the xlib stuff first, silly..."
16 
+  exit
17 
+  endif
18 
+$LUCID <<EOF
19 
+;;; Load the Haskell system.
20 
+(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))
21 
+(setf lcl:*record-source-files* nil)
22 
+(load "cl-support/cl-init")
23 
+;;; Set various internal switches to appropriate values for running
24 
+;;; Haskell code.
25 
+(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)))
26 
+(lcl:compiler-options :file-messages nil)
27 
+(setf lcl:*redefinition-action* nil)
28 
+(setf *load-verbose* nil)
29 
+(in-package :mumble-user)
30 
+(setf *printers* '(compiling loading))
31 
+(setf *optimizers* '())
32 
+(setf *compile-interface* '#t)
33 
+(setf *interface-code-quality* 1)
34 
+(setf *code-chunk-size* 200)
35 
+;;; Load the prelude.
36 
+(compile/load *prelude-unit-filename*)
37 
+;;; Load the X support.
38 
+(load "\$CLXFILE")
39 
+(compile/load "\$HASKELL_LIBRARY/X11/xlib")
40 
+(setf *haskell-compiler-update*
41 
+	(string-append *haskell-compiler-update* "-X11"))
42 
+;;; Set up the saved system.
43 
+(define (haskell-toplevel)
44 
+  (load-init-files)
45 
+  (do () ('#f)
46 
+    (lcl:with-simple-restart (restart-haskell "Restart Haskell.")
47 
+      (heval))))
48 
+(define (restart-haskell)
49 
+  (lcl:invoke-restart 'restart-haskell))
50 
+(lcl:gc)
51 
+(lcl:disksave "bin/new-lucid-clx-haskell"
52 
+  :reserved-free-segments 64 :dynamic-free-segments 25
53 
+  :restart-function 'haskell-toplevel :full-gc '#t)
54 
+(lcl:quit)
55 
+EOF
com/unchecked
History View file @ 4e98702
0 56 
new file mode 100755
... ... 
@@ -0,0 +1,10 @@
1 
+#!/bin/csh
2 
+#
3 
+#
4 
+# identify unchecked-in source files
5 
+#
6 
+
7 
+cd $Y2
8 
+foreach i (*/*.scm)
9 
+  if !(-e $i:h/RCS/$i:t,v) ls -l $i
10 
+end
command-interface-help
History View file @ 4e98702
0 11 
new file mode 100644
... ... 
@@ -0,0 +1,33 @@
1 
+Commands used by the Y2.0 command interface:
2 
+
3 
+Commands to dispose of the current extension:
4 
+:eval         Evaluate dialogues in the current extension
5 
+:save         Save the current extension
6 
+:kill         Forget about the current extension
7 
+:list         Print the current extension
8 
+
9 
+Commands to load & run files (compilation units)
10 
+:load file    Load a file into the system
11 
+:compile file Compile a file to native code and save the binary
12 
+:run file     Load a file and run `main'
13 
+
14 
+Commands to control the current module:
15 
+:clear        Remove all saved definitions in the current module
16 
+:module name  Set the current module
17 
+:Main         Switch to an empty module named Main
18 
+
19 
+Other commands:
20 
+:cd directory Set the current directory
21 
+:p?           Describe available printers
22 
+:p= p1 p2 ... Set the printers
23 
+:p+ p1 p2 ... Enable selected printers
24 
+:p- p1 p2 ... Disable selected printers
25 
+:o?           Describe available optimizers
26 
+:o= o1 o2 ... Set the optimizers
27 
+:o+ o1 o2 ... Enable selected optimizers
28 
+:o- o1 o2 ... Disable selected optimizers
29 
+:(fn ...)     Evaluate a Lisp expression
30 
+
31 
+Abbreviations within the current extension:
32 
+=exp          Creates a dialogue to print the expression under :e
33 
+@exp          Creates a definition which will run the dialogue under :e
command-interface/README
History View file @ 4e98702
0 34 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+This directory contains code to implement the command interface and
2 
+incremental compiler.  See the doc directory for details.
command-interface/command-interface.scm
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,11 @@
1 
+;;; csys.scm -- compilation unit definition for the compilation system
2 
+
3 
+(define-compilation-unit command-interface
4 
+  (source-filename "$Y2/command-interface/")
5 
+  (require global)
6 
+  (unit command
7 
+    (source-filename "command.scm"))
8 
+  (unit command-utils
9 
+    (source-filename "command-utils.scm"))
10 
+  (unit incremental-compiler
11 
+    (source-filename "incremental-compiler.scm")))
command-interface/command-utils.scm
History View file @ 4e98702
0 12 
new file mode 100644
... ... 
@@ -0,0 +1,208 @@
1 
+;;; command-interface/command-utils.scm
2 
+
3 
+;;; These are utilities used by the command interface.
4 
+
5 
+;;; These send output to the user
6 
+
7 
+;;; This is used in emacs mode
8 
+
9 
+(define (say/em . args)
10 
+  (say1 args))
11 
+
12 
+;;; This is for both ordinary text to emacs and output to the command interface
13 
+
14 
+(define (say . args)
15 
+  (say1 args))
16 
+
17 
+(define (say1 args)
18 
+  (apply (function format) (cons (current-output-port) args)))
19 
+
20 
+;;; This is for non-emacs output
21 
+
22 
+(define (say/ne . args)
23 
+  (when (not *emacs-mode*)
24 
+     (say1 args)))
25 
+
26 
+
27 
+;;; These random utilities should be elsewhere
28 
+
29 
+;;; This determines whether the current module is loaded & available.
30 
+;;; If the module is Main, an empty Main module is created.
31 
+
32 
+(define (cm-available?)
33 
+  (cond ((table-entry *modules* *current-mod*)
34 
+	 '#t)
35 
+	((eq? *current-mod* '|Main|)
36 
+	 (make-empty-main)
37 
+	 '#t)
38 
+	(else
39 
+	 '#f)))
40 
+
41 
+;;; This creates a empty module named Main to use as a scratch pad.
42 
+
43 
+(define (make-empty-main)
44 
+  (compile/load "$PRELUDE/Prelude")
45 
+  (setf *unit* '|Main|)
46 
+  (setf *current-mod* '|Main|)
47 
+  (let ((mods (parse-from-string
48 
+	       "module Main where {import Prelude}"
49 
+	       (function parse-module-list)
50 
+	       "foo")))
51 
+    ;;; This should generate no code at all so the returned code is ignored.
52 
+    (modules->lisp-code mods)
53 
+    (setf (table-entry *modules* *current-mod*) (car mods))
54 
+    (clear-extended-modules)))
55 
+
56 
+(define (eval-fragment eval?)
57 
+  (cond ((not (cm-available?))
58 
+	 (say "~&Module ~A is not loaded.~%" *current-mod*)
59 
+	 'error)
60 
+	((memq *fragment-status* '(Compiled Saved))
61 
+	 (when eval?
62 
+	     (eval-module *extension-module*))
63 
+	 'ok)
64 
+	((eq? *fragment-status* 'Error)
65 
+	 (say/ne "~&Errors exist in current fragment.~%")
66 
+	 'error)
67 
+	((string=? *current-string* "")
68 
+	 (say/ne "~&Current extension is empty.~%")
69 
+	 'error)
70 
+	(else
71 
+	 (let ((res (compile-fragment
72 
+		     *current-mod* *current-string*
73 
+		     *extension-file-name*)))
74 
+	   (cond ((eq? res 'error)
75 
+		  (setf *fragment-status* 'Error)
76 
+		  (notify-error))
77 
+		 (else
78 
+		  (setf *extension-module* res)
79 
+		  (setf *fragment-status* 'Compiled)
80 
+		  (when eval?
81 
+			(eval-module *extension-module*))))))))
82 
+
83 
+(define (set-current-file file)
84 
+  (cond ((null? file)
85 
+	 '())
86 
+	((null? (cdr file))
87 
+	 (setf *remembered-file* (car file)))
88 
+	(else
89 
+	 (say "~&Invalid file spec ~s.~%" file)
90 
+	 (funcall *abort-command*))))
91 
+
92 
+(define (select-current-mod mods)
93 
+  (when (pair? mods)
94 
+    (when (not (memq *current-mod* mods))
95 
+      (setf *current-mod* (car mods))
96 
+      (say/ne "~&Now in module ~A.~%" *current-mod*))))
97 
+
98 
+;;;  Emacs mode stuff
99 
+
100 
+;;; *** bogus alert!!!  This coercion may fail to produce a
101 
+;;; *** real character in some Lisps.
102 
+
103 
+(define *emacs-notify-char* (integer->char 1))
104 
+
105 
+(define (notify-ready)
106 
+  (when *emacs-mode*
107 
+     (say/em "~Ar" *emacs-notify-char*)
108 
+     (force-output (current-output-port))))
109 
+
110 
+(define (notify-input-request)
111 
+  (when *emacs-mode*
112 
+     (say/em "~Ai" *emacs-notify-char*)
113 
+     (force-output (current-output-port))))
114 
+
115 
+(define (notify-error)
116 
+  (when *emacs-mode*
117 
+     (say/em "~Ae" *emacs-notify-char*)
118 
+     (force-output (current-output-port))))
119 
+
120 
+(define (notify-printers printers)
121 
+  (notify-settings "p" printers))
122 
+
123 
+(define (notify-optimizers optimizers)
124 
+  (notify-settings "o" optimizers))
125 
+
126 
+(define (notify-settings flag values)
127 
+  (when *emacs-mode*
128 
+    (say/em "~A~A(" *emacs-notify-char* flag)
129 
+    (dolist (p values)
130 
+      (say/em " ~A" (string-downcase (symbol->string p))))
131 
+    (say/em ")~%")
132 
+    (force-output (current-output-port))))
133 
+
134 
+(define (notify-status-line str)
135 
+  (when *emacs-mode*
136 
+     (say/em "~As~A~%" *emacs-notify-char* str)
137 
+     (force-output (current-output-port))))
138 
+
139 
+;;; These are used to drive the real compiler.
140 
+
141 
+(define *compile/compile-cflags*
142 
+  (make cflags
143 
+	(load-code?          '#t)
144 
+	(compile-code?       '#t)
145 
+	(write-code?         '#t)
146 
+	(write-interface?    '#t)))
147 
+
148 
+
149 
+(define (compile/compile file)
150 
+  (haskell-compile file *compile/compile-cflags*))
151 
+
152 
+
153 
+(define *compile/load-cflags*
154 
+  (make cflags
155 
+	(load-code?          '#t)
156 
+	(compile-code?       '#f)
157 
+	(write-code?         '#f)
158 
+	(write-interface?    '#f)))
159 
+
160 
+(define (compile/load file)
161 
+  (haskell-compile file *compile/load-cflags*))
162 
+
163 
+
164 
+;;; Printer setting support
165 
+
166 
+(define (set-printers args mode)
167 
+  (set-switches *printers* (strings->syms args)
168 
+		mode *all-printers* "printers"))
169 
+
170 
+(define (set-optimizers args mode)
171 
+  (set-switches *optimizers* (strings->syms args)
172 
+		mode *all-optimizers* "optimizers"))
173 
+
174 
+(define (set-switches current new mode all name)
175 
+  (dolist (s new)
176 
+    (when (and (not (eq? s 'all)) (not (memq s all)))
177 
+      (signal-invalid-value s name all)))
178 
+  (let ((res (cond ((eq? mode '+)
179 
+		    (set-union current new))
180 
+		   ((eq? mode '-)
181 
+		    (set-difference current new))
182 
+		   ((eq? mode '=)
183 
+		    (if (equal? new '(all))
184 
+			all
185 
+			new)))))
186 
+    res))
187 
+
188 
+(define (signal-invalid-value s name all)
189 
+  (recoverable-error 'invalid-value
190 
+    "~A is not one of the valid ~A.  Possible values are: ~%~A"
191 
+    s name all))
192 
+
193 
+(define (print-file file)
194 
+  (call-with-input-file file (function write-all-chars)))
195 
+
196 
+(define (write-all-chars port)
197 
+  (let ((line  (read-line port)))
198 
+    (if (eof-object? line)
199 
+	'ok
200 
+	(begin
201 
+	  (write-line line)
202 
+	  (write-all-chars port)))))
203 
+
204 
+(define (strings->syms l)
205 
+  (map (lambda (x)
206 
+	 (string->symbol (string-upcase x)))
207 
+       l))
208 
+
command-interface/command.scm
History View file @ 4e98702
0 209 
new file mode 100644
... ... 
@@ -0,0 +1,308 @@
1 
+
2 
+;;; Globals used by the command interpreter
3 
+
4 
+(define *current-string* "")
5 
+(define *current-mod* '|Main|)
6 
+(define *current-command* '())
7 
+(define *remembered-file* "Foo")
8 
+(define *fragment-status* '())
9 
+(define *temp-counter* 0)
10 
+(define *last-compiled* "")
11 
+(define *abort-command* '())
12 
+(define *command-dispatch* '())
13 
+(define *extension-module* '())
14 
+(define *extension-file-name* "interactive")
15 
+
16 
+(define (prompt mod)
17 
+  (format '#f "~A> " mod))
18 
+
19 
+(define-local-syntax (define-command name&args helpstr . body)
20 
+  (let* ((str (car name&args))
21 
+	 (args (cdr name&args))
22 
+	 (fname (string->symbol (string-append "CMD-" str))))
23 
+    `(begin
24 
+       (define (,fname arguments)
25 
+	 (verify-command-args ',args arguments ',helpstr)
26 
+	 (apply (lambda ,args ,@body) arguments))
27 
+       (setf *command-dispatch*
28 
+	     (nconc *command-dispatch*
29 
+		    (list (cons ',str (function ,fname)))))
30 
+       ',fname)))
31 
+
32 
+(define (heval)
33 
+  (initialize-haskell-system)
34 
+  (setf *current-string* "")
35 
+  (setf *fragment-status* 'Building)
36 
+  (say "~&Yale Haskell ~A~A   ~A~%Type :? for help.~%"
37 
+       *haskell-compiler-version* *haskell-compiler-update* (identify-system))
38 
+  (read-commands))
39 
+
40 
+
41 
+;;; This loop reads commands until a quit
42 
+
43 
+(define (read-commands)
44 
+  (do ((cmd-status (read-command) (read-command)))
45 
+      ((eq? cmd-status 'quit-command-loop) (exit))))
46 
+
47 
+;;; This processes a single line of input.
48 
+
49 
+(define (read-command)
50 
+  (let/cc abort-command
51 
+    (setf *abort-command* (lambda () (funcall abort-command 'error)))
52 
+    (setf *abort-compilation* *abort-command*)
53 
+    (setf *phase* 'command-interface)
54 
+    (setf *in-error-handler?* '#f)
55 
+    (ready-for-input-line)
56 
+    (let ((ch (peek-char)))
57 
+      (cond ((eof-object? ch)
58 
+	     'quit-command-loop)
59 
+	    ((char=? ch '#\:)
60 
+	     (read-char)
61 
+	     (execute-command))
62 
+	    ((and (char=? ch '#\newline)
63 
+		  (not (eq? *fragment-status* 'Building)))
64 
+	     (read-char)
65 
+	     'Ignored)
66 
+	    (else
67 
+	     (when (not (eq? *fragment-status* 'Building))
68 
+	       (setf *fragment-status* 'Building)
69 
+	       (setf *current-string* ""))
70 
+	     (cond ((eqv? ch '#\=)
71 
+		    (read-char)
72 
+		    (append-to-current-string (expand-print-abbr (read-line))))
73 
+		   ((eqv? ch '#\@)
74 
+		    (read-char)
75 
+		    (append-to-current-string (expand-exec-abbr (read-line))))
76 
+		   (else
77 
+		    (append-to-current-string (read-line))))
78 
+	     'OK)
79 
+	    ))))
80 
+
81 
+(define (append-to-current-string string)
82 
+  (setf *current-string*
83 
+	(string-append *current-string*
84 
+		       string
85 
+		       (string #\newline))))
86 
+
87 
+
88 
+(define (expand-print-abbr string)
89 
+  (incf *temp-counter*)
90 
+  (format '#f "temp_~a = print temp1_~a where temp1_~a = ~a"
91 
+	  *temp-counter* *temp-counter* *temp-counter* string))
92 
+
93 
+(define (expand-exec-abbr string)
94 
+  (incf *temp-counter*)
95 
+  (format '#f "temp_~a :: Dialogue~%temp_~a = ~a"
96 
+	  *temp-counter* *temp-counter* string))
97 
+
98 
+
99 
+(define (ready-for-input-line)
100 
+  (when (not *emacs-mode*)
101 
+     (fresh-line (current-output-port))
102 
+     (write-string (prompt *current-mod*) (current-output-port))
103 
+     (force-output (current-output-port)))
104 
+  (notify-ready))
105 
+
106 
+(define (execute-command)
107 
+  (if (char=? (peek-char) '#\() ;this is the escape to the lisp evaluator
108 
+      (let ((form (read)))
109 
+	(eval form)
110 
+	'OK)
111 
+      (let* ((string    (read-line))
112 
+	     (length    (string-length string))
113 
+	     (cmd+args  (parse-command-args string 0 0 length)))
114 
+	(cond ((null? cmd+args)
115 
+	       (say "~&Eh?~%")
116 
+	       'OK)
117 
+	      (else
118 
+	       (let ((fn (assoc/test (function string-starts?)
119 
+				     (car cmd+args)
120 
+				     *command-dispatch*)))
121 
+		 (cond ((eq? fn '#f)
122 
+			(say "~&~A: unknown command.  Use :? for help.~%"
123 
+			     (car cmd+args))
124 
+			'OK)
125 
+		       (else
126 
+			(funcall (cdr fn) (cdr cmd+args))))))))))
127 
+
128 
+
129 
+;;; This parses the command into a list of substrings.
130 
+;;; Args are separated by spaces.
131 
+
132 
+(define (parse-command-args string start next end)
133 
+  (declare (type fixnum start next end)
134 
+	   (type string string))
135 
+  (cond ((eqv? next end)
136 
+	 (if (eqv? start next)
137 
+	     '()
138 
+	     (list (substring string start next))))
139 
+	((char=? (string-ref string next) '#\space)
140 
+	 (let ((next-next  (+ next 1)))
141 
+	   (if (eqv? start next)
142 
+	       (parse-command-args string next-next next-next end)
143 
+	       (cons (substring string start next)
144 
+		     (parse-command-args string next-next next-next end)))))
145 
+	(else
146 
+	 (parse-command-args string start (+ next 1) end))))
147 
+
148 
+(define (verify-command-args template args help)
149 
+  (cond ((and (null? template) (null? args))
150 
+	 '#t)
151 
+	((symbol? template)
152 
+	 '#t)
153 
+	((or (null? template) (null? args))
154 
+	 (say "~&Command error.~%~A~%" help)
155 
+	 (funcall *abort-command*))
156 
+	(else
157 
+	 (verify-command-args (car template) (car args) help)
158 
+	 (verify-command-args (cdr template) (cdr args) help))))
159 
+
160 
+(define-command ("?")
161 
+  ":?            Print the help file."
162 
+  (print-file "$HASKELL/command-interface-help"))
163 
+
164 
+(define-command ("eval")
165 
+  ":eval            Evaluate current extension."
166 
+  (eval-fragment '#t)
167 
+  'OK)
168 
+
169 
+(define-command ("save")
170 
+  ":save     Save current extension"
171 
+  (eval-fragment '#f)
172 
+  (cond ((eq? *fragment-status* 'Error)
173 
+	 (say/ne "~&Cannot save: errors encountered.~%"))
174 
+	((eq? *fragment-status* 'Compiled)
175 
+	 (extend-module *current-mod* *extension-module*)
176 
+	 (setf *fragment-status* 'Saved)))
177 
+  'OK)
178 
+
179 
+(define-command ("quit")
180 
+  ":quit        Quit the Haskell evaluator."
181 
+  'quit-command-loop)
182 
+
183 
+(define-command ("module" mod)
184 
+  ":module module-name    Select module for incremental evaluation."
185 
+  (setf *current-mod* (string->symbol mod))
186 
+  (when (not (cm-available?))
187 
+      (say/ne "~&Warning: module ~A is not currently loaded.~%" *current-mod*))
188 
+  'OK)
189 
+
190 
+(define-command ("run" . file)
191 
+  ":run <file>   Compile, load, and run a file."
192 
+  (set-current-file file)
193 
+  (clear-extended-modules)
194 
+  (let ((mods (compile/load *remembered-file*)))
195 
+    (when (pair? mods)
196 
+      (dolist (m mods)
197 
+	 (eval-module (table-entry *modules* m)))))
198 
+  'OK)
199 
+
200 
+(define-command ("compile" . file)
201 
+  ":compile <file> Compile and load a file."
202 
+  (set-current-file file)
203 
+  (clear-extended-modules)
204 
+  (select-current-mod (compile/compile *remembered-file*))
205 
+  'OK)
206 
+
207 
+(define-command ("load" . file)
208 
+  ":load <file>      Load a file."
209 
+  (set-current-file file)
210 
+  (clear-extended-modules)
211 
+  (select-current-mod (compile/load *remembered-file*))
212 
+  'OK)
213 
+
214 
+(define-command ("Main")
215 
+  ":Main           Switch to an empty Main module."
216 
+  (make-empty-main)
217 
+  'OK)
218 
+
219 
+(define-command ("clear")
220 
+  ":clear   Clear saved definitions from current module."
221 
+  (remove-extended-modules *current-mod*)
222 
+  (setf *current-string* "")
223 
+  (setf *fragment-status* 'Building))
224 
+
225 
+(define-command ("list")
226 
+  ":list          List current extension."
227 
+  (say "~&Current Haskell extension:~%~a" *current-string*)
228 
+  (cond ((eq? *fragment-status* 'Error)
229 
+	 (say "Extension contains errors.~%"))
230 
+	((eq? *fragment-status* 'Compiled)
231 
+	 (say "Extension is compiled and ready.~%")))
232 
+  'OK)
233 
+
234 
+(define-command ("kill")
235 
+  ":kill      Clear the current fragment."
236 
+  (when (eq? *fragment-status* 'Building)
237 
+    (setf *current-string* ""))
238 
+  'OK)
239 
+
240 
+(define-command ("p?")
241 
+  ":p?            Show available printers."
242 
+  (if *emacs-mode*
243 
+      (notify-printers (dynamic *printers*))
244 
+      (begin
245 
+	(print-file "$HASKELL/emacs-tools/printer-help.txt")
246 
+	(say "~&Active printers: ~A~%" (dynamic *printers*)))
247 
+    ))
248 
+
249 
+(define-command ("p=" . passes)
250 
+  ":p= pass1 pass2 ...  Set printers."
251 
+  (setf *printers* (set-printers passes '=))
252 
+  (say/ne "~&Setting printers: ~A~%" *printers*))
253 
+
254 
+(define-command ("p+" . passes)
255 
+  ":p+ pass1 pass2 ...  Add printers."
256 
+  (setf *printers* (set-printers passes '+))
257 
+  (say/ne "~&Setting printers: ~A~%" *printers*))
258 
+
259 
+(define-command ("p-" . passes)
260 
+  ":p- pass1 pass2 ...  Turn off printers."
261 
+  (setf *printers* (set-printers passes '-))
262 
+  (say/ne "~&Setting printers: ~A~%" *printers*))
263 
+
264 
+
265 
+
266 
+(define-command ("o?")
267 
+  ":o?            Show available optimizers."
268 
+  (if *emacs-mode*
269 
+      (notify-optimizers (dynamic *optimizers*))
270 
+      (begin
271 
+	(print-file "$HASKELL/emacs-tools/optimizer-help.txt")
272 
+	(say "~&Active optimizers: ~A~%" (dynamic *optimizers*)))
273 
+    ))
274 
+
275 
+(define-command ("o=" . optimizers)
276 
+  ":o= optimizer1 optimizer2 ...  Set optimizers."
277 
+  (setf *optimizers* (set-optimizers optimizers '=))
278 
+  (say/ne "~&Setting optimizers: ~A~%" *optimizers*))
279 
+
280 
+(define-command ("o+" . optimizers)
281 
+  ":o+ optimizer1 optimizer2 ...  Add optimizers."
282 
+  (setf *optimizers* (set-optimizers optimizers '+))
283 
+  (say/ne "~&Setting optimizers: ~A~%" *optimizers*))
284 
+
285 
+(define-command ("o-" . optimizers)
286 
+  ":o- optimizer1 optimizer2 ...  Turn off optimizers."
287 
+  (setf *optimizers* (set-optimizers optimizers '-))
288 
+  (say/ne "~&Setting optimizers: ~A~%" *optimizers*))
289 
+
290 
+
291 
+(define-command ("cd" d)
292 
+  ":cd directory   Change the current directory."
293 
+  (cd d)
294 
+  'OK)
295 
+
296 
+(define-command ("Emacs" mode)
297 
+  ":Emacs on/off   Turn on or off emacs mode."
298 
+  (cond ((string=? mode "on")
299 
+	 (setf *emacs-mode* '#t))
300 
+	((string=? mode "off")
301 
+	 (setf *emacs-mode* '#f))
302 
+	(else
303 
+	 (say "~&Use on or off.~%"))))
304 
+
305 
+(define-command ("file" name)
306 
+  ":file name"
307 
+  (setf *extension-file-name* name)
308 
+  'OK)
command-interface/incremental-compiler.scm
History View file @ 4e98702
0 309 
new file mode 100644
... ... 
@@ -0,0 +1,168 @@
1 
+;;; ==================================================================
2 
+
3 
+;;; This deals with incremental compilation as used by the command interface.
4 
+;;; The basic theory is to create new modules which import the entire
5 
+;;; symbol table of an existing module.
6 
+
7 
+
8 
+;;; This adds a new module to the extension environment.  This env is an alist
9 
+;;; of module names & extended modules.
10 
+
11 
+(define *extension-env* '())
12 
+
13 
+(define (extend-module mod-name new-ast)
14 
+  (push (tuple mod-name new-ast) *extension-env*))
15 
+
16 
+;;; This cleans out extensions for a module.
17 
+
18 
+(define (remove-extended-modules mod-name)
19 
+  (setf *extension-env* (rem-ext1 *extension-env* mod-name)))
20 
+
21 
+(define (rem-ext1 env name)
22 
+  (cond ((null? env)
23 
+	 '())
24 
+	((eq? (tuple-2-1 (car env)) name)
25 
+	 (rem-ext1 (cdr env) name))
26 
+	(else
27 
+	 (cons (car env) (rem-ext1 (cdr env) name)))))
28 
+
29 
+(define (clear-extended-modules)
30 
+  (setf *extension-env* '()))
31 
+
32 
+;;; This retrieves the current extension to a module (if any).
33 
+
34 
+(define (updated-module name)
35 
+  (let ((name+mod (assq name *extension-env*)))
36 
+    (if (not (eq? name+mod '#f))
37 
+	(tuple-2-2 name+mod)
38 
+	(let ((mod-in-table (table-entry *modules* name)))
39 
+	  (cond ((eq? mod-in-table '#f)
40 
+		 (signal-module-not-ready name))
41 
+		((eq? (module-type mod-in-table) 'interface)
42 
+		 (signal-cant-eval-interface name))
43 
+		(else mod-in-table))))))
44 
+
45 
+(define (signal-module-not-ready name)
46 
+  (fatal-error 'module-not-ready
47 
+	       "Module ~A is not loaded and ready."
48 
+	       name))
49 
+
50 
+(define (signal-cant-eval-interface name)
51 
+  (fatal-error 'no-evaluation-in-interface
52 
+	       "Module ~A is an interface: evaluation not allowed."
53 
+	       name))
54 
+
55 
+(define (compile-fragment module str filename)
56 
+  (let ((mod-ast (updated-module module)))
57 
+    (dynamic-let
58 
+       ((*printers* (if (memq 'extension *printers*) *printers* '()))
59 
+	(*abort-phase*   '#f))
60 
+     (mlet (((t-code new-ast) (compile-fragment1 module mod-ast str filename)))
61 
+       (cond ((eq? t-code 'error)
62 
+	      'error)
63 
+	     (else
64 
+	      (eval t-code)
65 
+	      new-ast))))))
66 
+
67 
+(define (compile-fragment1 mod-name mod-ast str filename)
68 
+  (let/cc x
69 
+    (dynamic-let ((*abort-compilation* (lambda () (funcall x 'error '()))))
70 
+     (let* ((mods (parse-from-string
71 
+		   (format '#f "module ~A where~%~A~%" mod-name str)
72 
+		   (function parse-module-list)
73 
+		   filename))
74 
+	   (new-mod (car mods)))
75 
+	(when (not (null? (cdr mods)))
76 
+	  (signal-module-decl-in-extension))
77 
+	(when (not (null? (module-imports new-mod)))
78 
+	  (signal-import-decl-in-extension))
79 
+	(fragment-initialize new-mod mod-ast)
80 
+	(values (modules->lisp-code mods) new-mod)))))
81 
+
82 
+(define (signal-module-decl-in-extension)
83 
+  (fatal-error 'module-decl-in-extension
84 
+	       "Module declarations are not allowed in extensions."))
85 
+
86 
+(define (signal-import-decl-in-extension)
87 
+  (fatal-error 'import-decl-in-extension
88 
+	       "Import declarations are not allowed in extensions."))
89 
+
90 
+
91 
+;;; Copy stuff into the fragment module structure from its parent module.
92 
+;;; The inverted symbol table is not necessary since the module contains
93 
+;;; no imports.
94 
+
95 
+(define (fragment-initialize new old)
96 
+  (setf (module-name new) (gensym))
97 
+  (setf (module-type new) 'extension)
98 
+  (setf (module-unit new) (module-unit old))
99 
+  (setf (module-uses-standard-prelude? new)
100 
+	(module-uses-standard-prelude? old))
101 
+  (setf (module-inherited-env new) old)
102 
+  (setf (module-fixity-table new)
103 
+        (copy-table (module-fixity-table old)))
104 
+  (setf (module-default new) (module-default old)))
105 
+
106 
+;;; This code deals with the actual evaluation of Haskell code.
107 
+
108 
+;;; This decides whether a variable has type `Dialogue'.
109 
+
110 
+(define (io-type? var)
111 
+  (let ((type (var-type var)))
112 
+    (when (not (gtype? type))
113 
+      (error "~s is not a Gtype." type))
114 
+    (and (null? (gtype-context type))
115 
+	 (is-dialogue? (gtype-type type)))))
116 
+
117 
+(define (is-dialogue? type)
118 
+  (let ((type (expand-ntype-synonym type)))
119 
+    (and (ntycon? type)
120 
+	 (eq? (ntycon-tycon type) (core-symbol "Arrow"))
121 
+	 (let* ((args (ntycon-args type))
122 
+		(a1 (expand-ntype-synonym (car args)))
123 
+		(a2 (expand-ntype-synonym (cadr args))))
124 
+	   (and
125 
+	    (ntycon? a1)
126 
+	    (eq? (ntycon-tycon a1) (core-symbol "SystemState"))
127 
+	    (ntycon? a2)
128 
+	    (eq? (ntycon-tycon a2) (core-symbol "IOResult")))))))
129 
+
130 
+(define (is-list-of? type con)
131 
+  (and (ntycon? type)
132 
+       (eq? (ntycon-tycon type) (core-symbol "List"))
133 
+       (let ((arg (expand-ntype-synonym (car (ntycon-args type)))))
134 
+	 (and (ntycon? arg) (eq? (ntycon-tycon arg) con)))))
135 
+
136 
+(define (apply-exec var)
137 
+   (initialize-io-system)
138 
+   (mlet (((_ sec)
139 
+	   (time-execution
140 
+	     (lambda ()
141 
+	       (let/cc x
142 
+		 (setf *runtime-abort* (lambda () (funcall x 'error)))
143 
+		 (let ((fn (eval (fullname var))))
144 
+		   (unless (var-strict? var)
145 
+		       (setf fn (force fn)))
146 
+		   (funcall fn (box 'state))))))))
147 
+      (say "~%")
148 
+      (when (memq 'time *printers*)
149 
+	 (say "Execution time: ~A seconds~%" sec)))
150 
+   'done)
151 
+
152 
+(define (eval-module mod)
153 
+  (dolist (v (module-vars mod))
154 
+     (when (io-type? v)
155 
+	(when (not (string-starts? "temp_" (symbol->string (def-name v))))
156 
+	   (say/ne "~&Evaluating ~A.~%" v))
157 
+	(apply-exec v))))
158 
+
159 
+(define (run-program name)
160 
+  (compile/load name)
161 
+  (let ((main-mod (table-entry *modules* '|Main|)))
162 
+    (if main-mod
163 
+	(let ((main-var (table-entry (module-symbol-table main-mod) '|main|)))
164 
+	  (if main-var
165 
+	      (apply-exec main-var)
166 
+	      (error "Variable main missing")))
167 
+	(error "module Main missing"))))
168 
+
csys/README
History View file @ 4e98702
0 169 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+This directory contains everything relating to the compilation system,
2 
+including stuff for parsing unit files, incremental recompilation, and
3 
+reading and writing code and interface files.
csys/cache-structs.scm
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,48 @@
1 
+;;; these structures deal with the compilation system and the unit cache.
2 
+
3 
+;;; An entry in the unit cache:
4 
+
5 
+(define-struct ucache
6 
+  (slots
7 
+    (ufile (type string))  ; the name of the file containing the unit definition
8 
+    (cifile (type string)) ; the filename of the (compiled) interface file
9 
+    (sifile (type string)) ; the filename of the (uncompiled) interface file
10 
+    (cfile (type string))  ; the filename of the (compiled) output file
11 
+    (sfile (type string))  ; the filename of the (uncompiled) output file
12 
+    (udate (type integer))   ; the write date of ufile
13 
+    (idate (type integer))   ; the time stamp of the binary interface file
14 
+    (stable? (type bool))     ; the stable flag
15 
+    (load-prelude? (type bool))  ; true if unit uses standard prelude
16 
+    ;; status is initially available (in cache).  It is set to loading when
17 
+    ;; requested and loaded once all imported units are loaded.
18 
+    (status (type (enum loaded loading available)))
19 
+    (ifile-loaded (type bool))  ; true when interface is loaded (modules)
20 
+    (code-loaded (type bool))   ; true when the associated code is in memory
21 
+    (source-files (type (list string)))  ; source files in the unit
22 
+    (imported-units (type (list string))) ; the filenames of imported unit files
23 
+    (lisp-files (type (list (tuple string string))))  ; source/binary pairs
24 
+    (modules (type (list module)))
25 
+    (printers-set? (type bool))
26 
+    (printers (type (list symbol)))
27 
+    (optimizers-set? (type bool))
28 
+    (optimizers (type (list symbol)))
29 
+    (chunk-size (type (maybe int)))
30 
+    ))
31 
+
32 
+
33 
+;;; This is used to hold various flags used by the compilation system,
34 
+;;; instead of passing them all as individual arguments.
35 
+
36 
+(define-struct cflags
37 
+  (slots
38 
+    ;; Whether to load code for unit into core
39 
+    (load-code?           (type bool) (default '#t))
40 
+    ;; Whether to create an output code file.
41 
+    (write-code?          (type bool) (default '#t))
42 
+    ;; Affects whether write-code? creates a source or compiled file,
43 
+    ;; and whether load-code? uses the interpreter or compiler.
44 
+    ;; Ignored if load-code? and write-code? are both false.
45 
+    (compile-code?        (type bool) (default '#t))
46 
+    ;; Whether to create an output interface file.
47 
+    (write-interface?     (type bool) (default '#t))
48 
+    ))
csys/compiler-driver.scm
History View file @ 4e98702
0 49 
new file mode 100644
... ... 
@@ -0,0 +1,640 @@
1 
+;;; compiler-driver.scm -- compilation unit management
2 
+;;;
3 
+;;; author :  John & Sandra
4 
+;;;
5 
+;;;
6 
+
7 
+
8 
+;;; Flags for controlling various low-level behaviors of the compiler.
9 
+;;; You might want to tweak these in the system-building scripts for
10 
+;;; different Lisps, but users don't normally need to mess with them.
11 
+
12 
+(define *compile-interface* '#f)
13 
+(define *interface-code-quality* 2)
14 
+(define *interface-chunk-size* '#f)
15 
+(define *default-code-quality* 2)
16 
+(define *optimized-code-quality* 3)
17 
+(define *code-chunk-size* 300)
18 
+
19 
+
20 
+
21 
+;;;=====================================================================
22 
+;;; Main entry point
23 
+;;;=====================================================================
24 
+
25 
+;;; This is the top level driver for the compiler.  It takes a file name
26 
+;;; and output controls.  It returns '#f if compilation fails.
27 
+
28 
+(define *codefile-cache* '())
29 
+
30 
+(define (haskell-compile filename cflags)
31 
+  (initialize-haskell-system)
32 
+  (let/cc abort-compile
33 
+    (dynamic-let ((*abort-compilation*
34 
+		   (lambda () (funcall abort-compile '#f))))
35 
+     (initialize-compilation)
36 
+     (let ((unit (find-cunit-name filename)))
37 
+       (let ((res (load-compilation-unit unit cflags)))
38 
+	 (map (lambda (x) (module-name x)) (ucache-modules res)))))))
39 
+
40 
+;;; this is the initialization code that occurs at the start of compilation.
41 
+
42 
+(define (initialize-compilation)
43 
+  (initialize-module-table)
44 
+  (for-each-unit
45 
+   (lambda (u)
46 
+     (setf (ucache-status u) 'available))))
47 
+
48 
+
49 
+
50 
+;;;=====================================================================
51 
+;;; Filename utilities
52 
+;;;=====================================================================
53 
+
54 
+;;; File extensions
55 
+
56 
+(define *source-file-extensions* '(".hs" ".lhs"))
57 
+(define *unit-file-extension* ".hu")
58 
+(define *interface-file-extension* ".hi")
59 
+(define *lisp-file-extensions* '(".lisp" ".scm"))
60 
+
61 
+(define (source-extension? x)
62 
+  (mem-string x *source-file-extensions*))
63 
+
64 
+(define (unit-extension? x)
65 
+  (string=? x *unit-file-extension*))
66 
+
67 
+(define (interface-extension? x)
68 
+  (string=? x *interface-file-extension*))
69 
+
70 
+(define (lisp-extension? x)
71 
+  (mem-string x *lisp-file-extensions*))
72 
+
73 
+
74 
+;;; Build file names.
75 
+
76 
+(define (make-cifilename filename)
77 
+  (let ((place  (filename-place filename))
78 
+	(name   (string-append (filename-name filename) "-hci")))
79 
+    (assemble-filename place name binary-file-type)))
80 
+
81 
+(define (make-sifilename filename)
82 
+  (let ((place  (filename-place filename))
83 
+	(name   (string-append (filename-name filename) "-hci")))
84 
+    (assemble-filename place name source-file-type)))
85 
+
86 
+(define (make-cfilename filename)
87 
+  (add-extension filename binary-file-type))
88 
+
89 
+(define (make-sfilename filename)
90 
+  (add-extension filename source-file-type))
91 
+
92 
+
93 
+;;; This take a file name (extension ignored) & searches for a unit file.
94 
+
95 
+(define (locate-existing-cunit name)
96 
+  (locate-extension name (list *unit-file-extension*)))
97 
+
98 
+;;; This take a file name (extension ignored) & searches for a source file.
99 
+
100 
+(define (locate-existing-source-file name)
101 
+  (locate-extension name *source-file-extensions*))
102 
+
103 
+(define (locate-extension name extensions)
104 
+  (if (null? extensions)
105 
+      '#f
106 
+      (let ((name-1 (add-extension name (car extensions))))
107 
+	(if (file-exists? name-1)
108 
+	    name-1
109 
+	    (locate-extension name (cdr extensions))))))
110 
+
111 
+
112 
+;;; This delivers the name of a compilation unit.  The extension of the name
113 
+;;; is ignored & a test for the presence of a compilation unit with
114 
+;;; the same name is done.  If none is found, signal an error.
115 
+
116 
+(define (find-cunit-name name)
117 
+  (or (locate-existing-cunit name)
118 
+      (locate-existing-source-file name)
119 
+      (signal-file-not-found name)))
120 
+
121 
+
122 
+
123 
+;;;=====================================================================
124 
+;;; Compilation unit file parsing
125 
+;;;=====================================================================
126 
+
127 
+;;; This parses a unit file.  The file simply contains a list of file names.
128 
+;;; The files are sorted into two catagories: other compilation units and
129 
+;;; source files in the current unit.  When a file has no extension, the system
130 
+;;; checks for a unit file first and then a source file.
131 
+
132 
+(define (parse-compilation-unit filename)
133 
+ (let ((unit-type (filename-type filename)))
134 
+  (if (or (source-extension? unit-type) (interface-extension? unit-type))
135 
+      (create-ucache filename filename (list filename) '() '() '#f '#t
136 
+		     '#f '() '#f '() '#f)
137 
+      (parse-compilation-unit-aux
138 
+        filename
139 
+	(call-with-input-file filename (function gather-file-names))))))
140 
+
141 
+(define (create-ucache filename output-filename
142 
+		       source-files imports lisp-files
143 
+		       stable? load-prelude?
144 
+		       printers-set? printers optimizers-set? optimizers
145 
+		       chunk-size)
146 
+  (let* ((cifilename
147 
+	  (make-cifilename output-filename))
148 
+	 (sifilename
149 
+	  (make-sifilename output-filename))
150 
+	 (all-imports
151 
+	  (if load-prelude?
152 
+	      (cons *prelude-unit-filename* imports)
153 
+	      imports))
154 
+	 (cache-entry
155 
+	  (make ucache
156 
+		(ufile filename)
157 
+		(sifile sifilename)
158 
+		(cifile cifilename)
159 
+		(sfile (make-sfilename output-filename))
160 
+		(cfile (make-cfilename output-filename))
161 
+		(udate (current-date))
162 
+		(idate (get-latest-ifiledate cifilename sifilename))
163 
+		(stable? stable?)
164 
+		(load-prelude? load-prelude?)
165 
+		(status 'loading)
166 
+		(ifile-loaded '#f)
167 
+		(code-loaded '#f)
168 
+		(source-files source-files)
169 
+		(imported-units all-imports)
170 
+		(lisp-files lisp-files)
171 
+		(modules '())
172 
+		(printers-set? printers-set?)
173 
+		(printers printers)
174 
+		(optimizers-set? optimizers-set?)
175 
+		(optimizers optimizers)
176 
+		(chunk-size chunk-size))))
177 
+    (install-compilation-unit filename cache-entry)
178 
+    cache-entry))
179 
+
180 
+(define (get-latest-ifiledate cifilename sifilename)
181 
+  (max (or (and (file-exists? cifilename)
182 
+		(file-write-date cifilename))
183 
+	   0)
184 
+       (or (and (file-exists? sifilename)
185 
+		(file-write-date sifilename))
186 
+	   0)))
187 
+
188 
+
189 
+;;; This returns a list of strings.  Blank lines and lines starting in -
190 
+;;; are ignored.
191 
+
192 
+(define (gather-file-names port)
193 
+  (let ((char (peek-char port)))
194 
+    (cond ((eof-object? char)
195 
+	   '())
196 
+	  ((or (char=? char '#\newline) (char=? char '#\-))
197 
+	   (read-line port)
198 
+	   (gather-file-names port))
199 
+	  (else
200 
+	   (let ((line (read-line port)))
201 
+	     (cons line (gather-file-names port)))))))
202 
+
203 
+
204 
+;;; Actually parse contents of the unit file.
205 
+
206 
+;;; These are in the command-interface stuff.
207 
+(predefine (set-printers args mode))
208 
+(predefine (set-optimizers args mode))
209 
+(predefine (parse-command-args string start next end))
210 
+
211 
+(define (parse-compilation-unit-aux filename strings)
212 
+  (let ((input-defaults   filename)
213 
+	(output-defaults  filename)
214 
+	(import-defaults  filename)
215 
+	(stable?          '#f)
216 
+	(load-prelude?    '#t)
217 
+	(filenames        '())
218 
+	(imports          '())
219 
+	(sources          '())
220 
+	(lisp-files       '())
221 
+	(printers         '())
222 
+	(printers-set?    '#f)
223 
+	(optimizers       '())
224 
+	(optimizers-set?  '#f)
225 
+	(chunk-size       '#f)
226 
+	(temp             '#f))
227 
+    ;;; First look for magic flags.
228 
+    (dolist (s strings)
229 
+      (cond ((setf temp (string-match-prefix ":input" s))
230 
+	     (setf input-defaults (merge-file-defaults temp filename)))
231 
+	    ((setf temp (string-match-prefix ":output" s))
232 
+	     (setf output-defaults (merge-file-defaults temp filename)))
233 
+	    ((setf temp (string-match-prefix ":import" s))
234 
+	     (setf import-defaults (merge-file-defaults temp filename)))
235 
+	    ((string=? ":stable" s)
236 
+	     (setf stable? '#t))
237 
+	    ((string=? ":prelude" s)
238 
+	     (setf load-prelude? '#f))
239 
+	    ((setf temp (string-match-prefix ":p=" s))
240 
+	     (setf printers-set? '#t)
241 
+	     (setf printers
242 
+		   (set-printers
243 
+		      (parse-command-args temp 0 0 (string-length temp))
244 
+		      '=)))
245 
+	    ((setf temp (string-match-prefix ":o=" s))
246 
+	     (setf optimizers-set? '#t)
247 
+	     (setf optimizers
248 
+		   (set-optimizers
249 
+                      (parse-command-args temp 0 0 (string-length temp))
250 
+		      '=)))
251 
+	    ((setf temp (string-match-prefix ":chunk-size" s))
252 
+	     (setf chunk-size (string->number temp)))
253 
+	    (else
254 
+	     (push s filenames))))
255 
+    ;;; Next sort filenames into imports and source files.
256 
+    (dolist (s filenames)
257 
+      (let ((type    (filename-type s))
258 
+	    (fname   '#f))
259 
+	(cond ((string=? type "")  ; punt for now on this issue
260 
+	       (signal-extension-needed s))
261 
+;	      ((cond ((setf fname
262 
+;			    (locate-existing-cunit
263 
+;			      (merge-file-defaults s import-defaults)))
264 
+;		      (push fname imports))
265 
+;		     ((setf fname
266 
+;			    (locate-existing-source-file
267 
+;			      (merge-file-defaults s input-defaults)))
268 
+;		      (push fname sources))
269 
+;		     (else
270 
+;		      (signal-unit-not-found s))))
271 
+	      ((unit-extension? type)
272 
+	       (setf fname  (merge-file-defaults s import-defaults))
273 
+	       (if (file-exists? fname)
274 
+		   (push fname imports)
275 
+		   (signal-unit-not-found fname)))
276 
+	      ((or (source-extension? type) (interface-extension? type))
277 
+	       (setf fname  (merge-file-defaults s input-defaults))
278 
+	       (if (file-exists? fname)
279 
+		   (push fname sources)
280 
+		   (signal-unit-not-found fname)))
281 
+	      ((lisp-extension? type)
282 
+	       (setf fname (merge-file-defaults s input-defaults))
283 
+	       (if (file-exists? fname)
284 
+		   (push (cons fname
285 
+			       (add-extension
286 
+			         (merge-file-defaults s output-defaults)
287 
+				 binary-file-type))
288 
+			 lisp-files)
289 
+		   (signal-unit-not-found fname)))
290 
+	      (else
291 
+	       (signal-unknown-file-type s)))))
292 
+    ;; Finally create the unit object.
293 
+    (create-ucache filename output-defaults
294 
+		   sources imports lisp-files
295 
+		   stable? load-prelude?
296 
+		   printers-set? printers optimizers-set? optimizers
297 
+		   chunk-size)))
298 
+
299 
+
300 
+;;; Helper functions for the above.
301 
+
302 
+(define (string-match-prefix prefix s)
303 
+  (let ((prefix-length  (string-length prefix))
304 
+	(s-length       (string-length s)))
305 
+    (if (>= s-length prefix-length)
306 
+	(string-match-prefix-aux prefix s prefix-length s-length 0)
307 
+	'#f)))
308 
+
309 
+(define (string-match-prefix-aux prefix s prefix-length s-length i)
310 
+  (cond ((eqv? i prefix-length)
311 
+	 (string-match-prefix-aux-aux s s-length i))
312 
+	((not (char=? (string-ref s i) (string-ref prefix i)))
313 
+	 '#f)
314 
+	(else
315 
+	 (string-match-prefix-aux prefix s prefix-length s-length (1+ i)))))
316 
+
317 
+(define (string-match-prefix-aux-aux s s-length i)
318 
+  (cond ((eqv? i s-length)
319 
+	 "")
320 
+	((let ((ch  (string-ref s i)))
321 
+	   (or (char=? ch '#\space) (char=? ch #\tab)))
322 
+	 (string-match-prefix-aux-aux s s-length (1+ i)))
323 
+	(else
324 
+	 (substring s i s-length))))
325 
+
326 
+(define (merge-file-defaults filename defaults)
327 
+  (let ((place  (filename-place filename))
328 
+	(name   (filename-name filename))
329 
+	(type   (filename-type filename)))
330 
+    (assemble-filename
331 
+      (if (string=? place "") defaults place)
332 
+      (if (string=? name "") defaults name)
333 
+      (if (string=? type "") defaults type))))
334 
+
335 
+
336 
+;;;=====================================================================
337 
+;;; Guts
338 
+;;;=====================================================================
339 
+
340 
+
341 
+;;; This is the main entry to the compilation system.  This causes a
342 
+;;; unit to be compiled and/or loaded.
343 
+
344 
+(define (load-compilation-unit filename cflags)
345 
+  (let ((cunit (lookup-compilation-unit filename)))
346 
+    (cond ((eq? cunit '#f)
347 
+	   ;; Unit not found in cache.
348 
+	   (load-compilation-unit-aux
349 
+	     (parse-compilation-unit filename) cflags))
350 
+	  ((eq? (ucache-status cunit) 'loaded)
351 
+	   ;; Already loaded earlier in this compile.
352 
+	   cunit)
353 
+	  ((eq? (ucache-status cunit) 'loading)
354 
+	   (signal-circular-unit filename))
355 
+	  (else
356 
+	   (load-compilation-unit-aux cunit cflags))
357 
+	  )))
358 
+
359 
+
360 
+(define (load-compilation-unit-aux c cflags)
361 
+  (setf (ucache-status c) 'loading)
362 
+  (load-imported-units c cflags)
363 
+  (if (unit-valid? c cflags)
364 
+      (load-compiled-unit c (cflags-load-code? cflags))
365 
+      (locally-compile c cflags))
366 
+  (setf (ucache-status c) 'loaded)
367 
+  ;; Hack, hack.  When loading the prelude, make sure magic symbol
368 
+  ;; table stuff is initialized.
369 
+  (when (string=? (ucache-ufile c) *prelude-unit-filename*)
370 
+    (init-prelude-globals))
371 
+  c)
372 
+
373 
+(define (load-compiled-unit c load-code?)
374 
+  (when (and load-code? (not (ucache-code-loaded c)))
375 
+    (when (memq 'loading *printers*)
376 
+      (format '#t "~&Loading unit ~s.~%" (ucache-ufile c))
377 
+      (force-output))
378 
+    (load-lisp-files (ucache-lisp-files c))
379 
+    (load-more-recent-file (ucache-cfile c) (ucache-sfile c))
380 
+    (setf (ucache-code-loaded c) '#t))
381 
+  (when (not (ucache-ifile-loaded c))
382 
+     (read-binary-interface c))
383 
+  (dolist (m (ucache-modules c))
384 
+      (add-module-to-symbol-table m))
385 
+  (link-instances (ucache-modules c)))
386 
+
387 
+
388 
+;;; These globals save the Prelude symbol table to avoid copying it
389 
+;;; into all modules which use the Prelude.
390 
+
391 
+;;; Danger!  This assumes that every local symbol in the Prelude is
392 
+;;; exported.
393 
+
394 
+(define *prelude-initialized* '#f)
395 
+
396 
+(define (init-prelude-globals)
397 
+  (when (not *prelude-initialized*)
398 
+    (let ((pmod (locate-module '|Prelude|)))
399 
+      (setf *prelude-symbol-table* (module-symbol-table pmod))
400 
+      (setf *prelude-fixity-table* (module-fixity-table pmod))
401 
+      (when (eq? (module-inverted-symbol-table pmod) '#f)
402 
+	(let ((table (make-table)))
403 
+	  (table-for-each (lambda (name def)
404 
+			    (setf (table-entry table def) name))
405 
+			  *prelude-symbol-table*)
406 
+	  (setf (module-inverted-symbol-table pmod) table)))
407 
+      (setf *prelude-inverted-symbol-table*
408 
+	    (module-inverted-symbol-table pmod)))
409 
+    (setf *prelude-initialized* '#t)))
410 
+
411 
+
412 
+;;; This recursively loads all units imported by a given unit.
413 
+
414 
+(define (load-imported-units c cflags)
415 
+  (dolist (filename (ucache-imported-units c))
416 
+    (load-compilation-unit filename cflags)))
417 
+
418 
+
419 
+
420 
+;;; Load or compile lisp files.
421 
+
422 
+(define (load-lisp-files lisp-files)
423 
+  (dolist (f lisp-files)
424 
+    (load-more-recent-file (cdr f) (car f))))
425 
+
426 
+(define (compile-lisp-files lisp-files)
427 
+  (dolist (f lisp-files)
428 
+    (let ((source  (car f))
429 
+	  (binary  (cdr f)))
430 
+      (when (not (lisp-binary-current source binary))
431 
+	(compile-file source binary))
432 
+      (load binary))))
433 
+
434 
+
435 
+
436 
+;;; This determines whether a unit is valid.
437 
+
438 
+(define (unit-valid? c cflags)
439 
+  (and (or (ucache-stable? c)
440 
+	   ;; If the unit is not stable, make sure its source files
441 
+	   ;; haven't changed.
442 
+	   (and (all-imports-current (ucache-imported-units c)
443 
+				     (ucache-idate c))
444 
+		(all-sources-current (ucache-source-files c)
445 
+				     (ucache-idate c))
446 
+		(all-lisp-sources-current (ucache-lisp-files c)
447 
+					  (ucache-idate c))))
448 
+       (or (ucache-ifile-loaded c)
449 
+	   ;; If the interface hasn't been loaded already, make sure
450 
+	   ;; that the interface file exists.
451 
+	   (file-exists? (ucache-cifile c))
452 
+	   (file-exists? (ucache-sifile c)))
453 
+       (or (not (cflags-load-code? cflags))
454 
+	   ;; If we're going to load code, make sure that the code file
455 
+	   ;; exists.
456 
+	   (ucache-code-loaded c)
457 
+	   (file-exists? (ucache-cfile c))
458 
+	   (file-exists? (ucache-sfile c)))
459 
+       (or (not (cflags-write-code? cflags))
460 
+	   ;; If we need to produce a code file, make sure this has
461 
+	   ;; already been done.
462 
+	   ;; Don't write files for stable units which have already
463 
+	   ;; been loaded, regardless of whether or not the file exists.
464 
+	   (and (ucache-stable? c) (ucache-code-loaded c))
465 
+	   (file-exists? (ucache-cfile c))
466 
+	   (and (not (cflags-compile-code? cflags))
467 
+		(file-exists? (ucache-sfile c))))
468 
+       (or (not (cflags-compile-code? cflags))
469 
+	   ;; If we need to compile the lisp files, make sure this has
470 
+	   ;; already been done.
471 
+	   ;; Don't do this for stable units which have already
472 
+	   ;; been loaded.
473 
+	   (and (ucache-stable? c) (ucache-code-loaded c))
474 
+	   (all-lisp-binaries-current (ucache-lisp-files c)))
475 
+       (or (not (cflags-write-interface? cflags))
476 
+	   ;; If we need to produce an interface file, make sure this has
477 
+	   ;; already been done.
478 
+	   ;; Don't write files for stable units which have already
479 
+	   ;; been loaded, regardless of whether or not the file exists.
480 
+	   (and (ucache-stable? c) (ucache-ifile-loaded c))
481 
+	   (file-exists? (ucache-cifile c))
482 
+	   (and (not *compile-interface*)
483 
+		(file-exists? (ucache-sifile c))))
484 
+       ))
485 
+
486 
+(define (all-sources-current sources unit-write-date)
487 
+  (every (lambda (s)
488 
+	   (let ((d  (file-write-date s)))
489 
+	     (and d (> unit-write-date d))))
490 
+	 sources))
491 
+
492 
+(define (all-imports-current imports unit-write-date)
493 
+  (every (lambda (s) (> unit-write-date
494 
+			(ucache-idate (lookup-compilation-unit s))))
495 
+	 imports))
496 
+
497 
+(define (all-lisp-sources-current lisp-files unit-write-date)
498 
+  (every (lambda (s)
499 
+	   (let ((d  (file-write-date (car s))))
500 
+	     (and d (> unit-write-date d))))
501 
+	 lisp-files))
502 
+
503 
+(define (all-lisp-binaries-current lisp-files)
504 
+  (every (lambda (s)
505 
+	   (lisp-binary-current (car s) (cdr s)))
506 
+	 lisp-files))
507 
+
508 
+(define (lisp-binary-current source binary)
509 
+  (and (file-exists? binary)
510 
+       (let ((sd  (file-write-date source))
511 
+	     (bd  (file-write-date binary)))
512 
+	 (and sd bd (> bd sd)))))
513 
+
514 
+
515 
+;;; This does the actual job of compilation.
516 
+
517 
+(define (locally-compile c cflags)
518 
+  (dynamic-let ((*printers*
519 
+		  (if (ucache-printers-set? c)
520 
+		      (ucache-printers c)
521 
+		      (dynamic *printers*)))
522 
+		(*optimizers*
523 
+		  (if (ucache-optimizers-set? c)
524 
+		      (ucache-optimizers c)
525 
+		      (dynamic *optimizers*))))
526 
+    (when (memq 'compiling *printers*)
527 
+       (format '#t "~&Compiling unit ~s.~%Optimizers: ~A~%"
528 
+	       (ucache-ufile c)
529 
+	       *optimizers*)
530 
+	       (force-output))
531 
+    (if (cflags-compile-code? cflags)
532 
+	(compile-lisp-files (ucache-lisp-files c))
533 
+	(load-lisp-files (ucache-lisp-files c)))
534 
+    (multiple-value-bind (mods code)
535 
+	(compile-haskell-files (ucache-source-files c))
536 
+      ;; General bookkeeping to update module interface in cache.
537 
+      (setf (ucache-modules c) mods)
538 
+      (setf (ucache-idate c) (current-date))
539 
+      (setf (ucache-ifile-loaded c) '#t)
540 
+      ;; Write interface file if necessary.
541 
+      (when (cflags-write-interface? cflags)
542 
+	(let ((phase-start-time (get-run-time))
543 
+	      (icode  (create-dump-code c mods (ucache-load-prelude? c))))
544 
+	  (if (dynamic *compile-interface*)
545 
+	      (write-compiled-code-file
546 
+	        (ucache-cifile c)
547 
+		icode
548 
+		(dynamic *interface-code-quality*)
549 
+		(dynamic *interface-chunk-size*))
550 
+	      (write-interpreted-code-file (ucache-sifile c) icode '#f))
551 
+	  (when (memq 'phase-time *printers*)
552 
+	    (let* ((current-time (get-run-time))
553 
+		   (elapsed-time (- current-time phase-start-time)))
554 
+	      (format '#t "Interface complete: ~A seconds~%" elapsed-time)
555 
+	      (force-output)))))
556 
+      ;; Write code file if necessary.
557 
+      (when (cflags-write-code? cflags)
558 
+	(if (cflags-compile-code? cflags)
559 
+	    (write-compiled-code-file
560 
+	      (ucache-cfile c)
561 
+	      code
562 
+	      (if (memq 'lisp (dynamic *optimizers*))
563 
+		  (dynamic *optimized-code-quality*)
564 
+		  (dynamic *default-code-quality*))
565 
+	      (or (ucache-chunk-size c) (dynamic *code-chunk-size*)))
566 
+	    (write-interpreted-code-file (ucache-sfile c) code '#t)))
567 
+      ;; Load or evaluate code if necessary.
568 
+      ;; If we just wrote a compiled code file, load that; otherwise
569 
+      ;; do eval or in-core compilation.
570 
+      (when (cflags-load-code? cflags)
571 
+	(if (and (cflags-write-code? cflags)
572 
+		 (cflags-compile-code? cflags))
573 
+	    (load (ucache-cfile c))
574 
+	    (eval code (cflags-compile-code? cflags)))
575 
+	(setf (ucache-code-loaded c) '#t))
576 
+      )))
577 
+
578 
+
579 
+
580 
+;;;=====================================================================
581 
+;;; Cache manager
582 
+;;;=====================================================================
583 
+
584 
+;;; This is the cache manager for compilation units.  We use an alist at
585 
+;;; the moment.
586 
+
587 
+(define *unit-cache* '())
588 
+
589 
+(define (reset-unit-cache)
590 
+  (setf *unit-cache* '()))
591 
+
592 
+
593 
+;;; This checks to make sure that the compilation unit it finds
594 
+;;; in the cache has not been made out-of-date by updates to the unit file.
595 
+
596 
+(define (lookup-compilation-unit name)
597 
+  (let ((r (ass-string name *unit-cache*)))
598 
+    (if r
599 
+	(let ((c  (cdr r)))
600 
+	 (if (or (ucache-stable? c)
601 
+		 (> (ucache-udate c)
602 
+		    (or (file-write-date (ucache-ufile c)) 0)))
603 
+	     c
604 
+	     '#f))
605 
+	'#f)))
606 
+
607 
+(define (install-compilation-unit name c)
608 
+  (let ((r (ass-string name *unit-cache*)))
609 
+    (if (eq? r '#f)
610 
+	(push (cons name c) *unit-cache*)
611 
+	(setf (cdr r) c))))
612 
+
613 
+(define (for-each-unit proc)
614 
+  (dolist (c *unit-cache*)
615 
+     (funcall proc (cdr c))))
616 
+
617 
+
618 
+;;;=====================================================================
619 
+;;; Error utilities
620 
+;;;=====================================================================
621 
+
622 
+(define (signal-circular-unit filename)
623 
+  (fatal-error 'circular-unit
624 
+    "The compilation unit ~a has a circular dependency."
625 
+    filename))
626 
+
627 
+(define (signal-unit-not-found filename)
628 
+  (fatal-error 'unit-not-found
629 
+    "The compilation unit file ~a was not found."
630 
+    filename))
631 
+
632 
+(define (signal-extension-needed filename)
633 
+  (fatal-error 'extension-needed
634 
+    "You must provide an extension on the filename ~a in the .hu file."
635 
+     filename))
636 
+
637 
+
638 
+
639 
+
640 
+
csys/csys.scm
History View file @ 4e98702
0 641 
new file mode 100644
... ... 
@@ -0,0 +1,25 @@
1 
+;;; csys.scm -- compilation unit definition for the compilation system
2 
+
3 
+(define-compilation-unit csys
4 
+  (source-filename "$Y2/csys/")
5 
+  (require global runtime flic)
6 
+  (unit cache-structs
7 
+    (source-filename "cache-structs.scm"))
8 
+  (unit compiler-driver
9 
+    (require cache-structs)
10 
+    (source-filename "compiler-driver.scm"))
11 
+  (unit dump-params
12 
+    (require cache-structs)
13 
+    (source-filename "dump-params.scm"))
14 
+  (unit dump-macros
15 
+    (require dump-params)
16 
+    (source-filename "dump-macros.scm"))
17 
+  (unit dump-interface
18 
+    (require dump-macros)
19 
+    (source-filename "dump-interface.scm"))
20 
+  (unit dump-flic
21 
+    (require dump-macros)
22 
+    (source-filename "dump-flic.scm"))
23 
+  (unit dump-cse
24 
+    (require dump-macros)
25 
+    (source-filename "dump-cse.scm")))
csys/dump-cse.scm
History View file @ 4e98702
0 26 
new file mode 100644
... ... 
@@ -0,0 +1,182 @@
1 
+;;; This file handles common subexpressions in the interface file.
2 
+;;; Common subexpressions are detected in two places: gtypes and strictness
3 
+;;; properties.
4 
+
5 
+;;; Compressing strictness signatures
6 
+
7 
+;;; A strictness is represented by a list of booleans.  We do two things to
8 
+;;; compress strictnesses: all lists less than *pre-defined-strictness-size*
9 
+;;; are pre-computed in a vector and the first *pre-defined-strictness-vars*
10 
+;;; vector elements are cached in global vars.  The strictness will dump as
11 
+;;; as either a global or as a vector reference into the vector.
12 
+
13 
+(define (initialize-strictness-table)
14 
+  (setf (dynamic *pre-defined-strictness-table*)
15 
+	(make-vector (expt 2 (1+ (dynamic *pre-defined-strictness-size*)))))
16 
+  (setf (vector-ref *pre-defined-strictness-table* 1) '())
17 
+  (do ((i 1 (1+ i))
18 
+       (j 1 (* j 2))
19 
+       (k 2 (* k 2)))
20 
+      ((> i *pre-defined-strictness-size*))
21 
+    (do ((l 0 (1+ l)))
22 
+	((>= l j))
23 
+      (setf (vector-ref *pre-defined-strictness-table* (+ k l))
24 
+	    (cons '#f (vector-ref *pre-defined-strictness-table* (+ j l))))
25 
+      (setf (vector-ref *pre-defined-strictness-table* (+ k j l))
26 
+	    (cons '#t (vector-ref *pre-defined-strictness-table* (+ j l))))))
27 
+  (set-strictness-vars))
28 
+
29 
+(define (strictness-table-ref x)
30 
+  (vector-ref (dynamic *pre-defined-strictness-table*) x))
31 
+
32 
+(define (dump-strictness s)
33 
+  (if (null? s)
34 
+      ''()
35 
+      (dump-strictness-1 s s 0 0)))
36 
+
37 
+(define (dump-strictness-1 s s1 n size)
38 
+  (if (null? s1)
39 
+      (if (> size *pre-defined-strictness-size*)
40 
+	  (dump-big-strictness (- size *pre-defined-strictness-size*) s)
41 
+	  (let ((k (+ n (expt 2 size))))
42 
+	    (if (< k *pre-defined-strictness-vars*)
43 
+		`(dynamic ,(vector-ref *pre-defined-strictness-names* k))
44 
+		`(strictness-table-ref ,k))))
45 
+      (dump-strictness-1 s (cdr s1) (+ (* 2 n) (if (car s1) 1 0)) (1+ size))))
46 
+
47 
+(define (dump-big-strictness k s)
48 
+  (if (= k 0)
49 
+      (dump-strictness s)
50 
+      `(cons ',(car s)
51 
+	     ,(dump-big-strictness (1- k) (cdr s)))))
52 
+
53 
+;;; This routine handles saving type signatures (gtypes).
54 
+;;; common subexpressions are detected in two places: the type body
55 
+;;; and the the contexts.
56 
+
57 
+(define (init-predefined-gtyvars)
58 
+  (setf *saved-gtyvars* (make-vector *num-saved-gtyvars*))
59 
+  (dotimes (i *num-saved-gtyvars*)
60 
+     (setf (vector-ref *saved-gtyvars* i) (**gtyvar i)))
61 
+  (setup-gtyvar-vars))
62 
+
63 
+(define (init-cse-structs)
64 
+  (initialize-strictness-table)
65 
+  (init-predefined-gtyvars))
66 
+
67 
+(define (save-cse-value v)
68 
+  (setf (vector-ref (dynamic *saved-cse-values*) (dynamic *cse-value-num*)) v)
69 
+  (incf (dynamic *cse-value-num*)))
70 
+
71 
+(define (cse-init-code)
72 
+  (let* ((n (length *cse-objects*))
73 
+	 (init-code '()))
74 
+    (do ((i (1- n) (1- i))
75 
+	 (init *cse-objects* (cdr init)))
76 
+	((null? init))
77 
+      (push `(save-cse-value ,(car init)) init-code))
78 
+    `((setf *saved-cse-values* (make-vector ,n))
79 
+      (setf *cse-value-num* 0)
80 
+      ,@init-code)))
81 
+
82 
+(define (remember-dumped-object init-code)
83 
+  (push init-code *cse-objects*)
84 
+  (incf *cse-object-num*)
85 
+  *cse-object-num*)
86 
+
87 
+(define (cse-value-ref x)
88 
+  (vector-ref (dynamic *saved-cse-values*) x))
89 
+
90 
+(define (cse-ref-code n)
91 
+  (cond ((eqv? n 0)
92 
+	 ''())
93 
+	((<= n *num-saved-gtyvars*)
94 
+	 `(dynamic ,(vector-ref *saved-gtyvar-varnames* (1- n))))
95 
+	(else
96 
+	 `(cse-value-ref ,(- n *num-saved-gtyvars* 1)))))
97 
+
98 
+(define (dump-gtyvar g)
99 
+  (let ((n (gtyvar-varnum g)))
100 
+    (if (< n *num-saved-gtyvars*)
101 
+	(1+ n)
102 
+	(remember-dumped-object `(**gtyvar ,n)))))
103 
+
104 
+(define (dump-context-list contexts)
105 
+  (if (null? contexts)
106 
+      0
107 
+      (let* ((rest (dump-context-list (cdr contexts)))
108 
+	     (classes (dump-class-list (car contexts)))
109 
+	     (t1 (assq/insert-l classes *gtype-class-index*))
110 
+	     (res (assq/insert rest (cdr t1))))
111 
+	  (if (eq? (cdr res) '#f)
112 
+	      (let ((z (remember-dumped-object
113 
+			`(cons ,(cse-ref-code classes) ,(cse-ref-code rest)))))
114 
+		(setf (cdr res) z)
115 
+		z)
116 
+	      (cdr res)))))
117 
+
118 
+(define (dump-class-list classes)
119 
+  (if (null? classes)
120 
+      0
121 
+      (let* ((rest (dump-class-list (cdr classes)))
122 
+	     (class (dump-class/n (car classes)))
123 
+	     (t1 (assq/insert-l class *context-class-index*))
124 
+	     (res (assq/insert rest (cdr t1))))
125 
+	  (if (eq? (cdr res) '#f)
126 
+	      (let ((z (remember-dumped-object
127 
+			`(cons ,class ,(cse-ref-code rest)))))
128 
+		(setf (cdr res) z)
129 
+		z)
130 
+	      (cdr res)))))
131 
+
132 
+(define (dump-gtype-1 g)
133 
+  (cond ((gtyvar? g)
134 
+	 (dump-gtyvar g))
135 
+	((ntyvar? g)
136 
+	 (dump-gtype-1 (prune g)))
137 
+	(else
138 
+	 (dump-gtycon g))))
139 
+
140 
+(define (dump-gtycon g)
141 
+  (let* ((ty (ntycon-tycon g))
142 
+	 (tycon (if (algdata? ty) (dump-algdata/n ty) (dump-synonym/n ty)))
143 
+	 (l (dump-gtype-list (ntycon-args g)))
144 
+	 (t1 (assq/insert-l tycon *gtype-tycon-index*))
145 
+	 (res (assq/insert l (cdr t1))))
146 
+    (if (eq? (cdr res) '#f)
147 
+	(let ((z (remember-dumped-object
148 
+		  `(**ntycon ,tycon ,(cse-ref-code l)))))
149 
+	  (setf (cdr res) z)
150 
+	  z)
151 
+	(cdr res))))
152 
+
153 
+(define (dump-gtype-list l)
154 
+  (if (null? l)
155 
+      0
156 
+      (let* ((g (dump-gtype-1 (car l)))
157 
+	     (rest (dump-gtype-list (cdr l)))
158 
+	     (t1 (assq/insert-l g *gtype-list-index*))
159 
+	     (res (assq/insert rest (cdr t1))))
160 
+	(if (eq? (cdr res) '#f)
161 
+	    (let ((z (remember-dumped-object
162 
+		      `(cons ,(cse-ref-code g)
163 
+			     ,(cse-ref-code rest)))))
164 
+	      (setf (cdr res) z)
165 
+	      z)
166 
+	    (cdr res)))))
167 
+
168 
+(define (dump-gtype/cse g)
169 
+ (cse-ref-code
170 
+  (let* ((context (dump-context-list (gtype-context g)))
171 
+	 (type (dump-gtype-1 (gtype-type g)))
172 
+	 (t1 (assq/insert-l type *gtype-index*))
173 
+	 (res (assq/insert context (cdr t1))))
174 
+    (if (eq? (cdr res) '#f)
175 
+	(let ((z (remember-dumped-object
176 
+		      `(**gtype ,(cse-ref-code context)
177 
+				,(cse-ref-code type)))))
178 
+	      (setf (cdr res) z)
179 
+	      z)
180 
+	(cdr res)))))
181 
+
182 
+
csys/dump-flic.scm
History View file @ 4e98702
0 183 
new file mode 100644
... ... 
@@ -0,0 +1,130 @@
1 
+;;; dump-flic.scm -- general dump functions for flic structures
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  24 Feb 1993
5 
+;;;
6 
+;;;
7 
+;;; This stuff is used to write inline expansions to the interface file.
8 
+;;;
9 
+
10 
+
11 
+(define-flic-walker dump-flic (object var-renamings))
12 
+
13 
+(define (dump-flic-list objects var-renamings)
14 
+  (let ((result  '()))
15 
+    (dolist (o objects)
16 
+      (push (dump-flic o var-renamings) result))
17 
+    `(list ,@(nreverse result))))
18 
+
19 
+(define (dump-flic-top object)
20 
+  (dump-flic object '()))
21 
+
22 
+
23 
+(define (make-temp-bindings-for-dump oldvars var-renamings)
24 
+  (let ((vars      '())
25 
+	(bindings  '()))
26 
+    (dolist (v oldvars)
27 
+      (let ((var  (def-name v))
28 
+	    (temp (gensym)))
29 
+	(push temp vars)
30 
+	(push `(,temp (create-temp-var ',var)) bindings)
31 
+	(push (cons v temp) var-renamings)))
32 
+    (setf bindings (nreverse bindings))
33 
+    (setf vars (nreverse vars))
34 
+    (values vars bindings var-renamings)))
35 
+
36 
+(define-dump-flic flic-lambda (object var-renamings)
37 
+  (multiple-value-bind (vars bindings var-renamings)
38 
+      (make-temp-bindings-for-dump (flic-lambda-vars object) var-renamings)
39 
+    `(let ,bindings
40 
+       (make-flic-lambda
41 
+	 (list ,@vars)
42 
+	 ,(dump-flic (flic-lambda-body object) var-renamings)))
43 
+    ))
44 
+
45 
+(define-dump-flic flic-let (object var-renamings)
46 
+  (multiple-value-bind (vars bindings var-renamings)
47 
+      (make-temp-bindings-for-dump (flic-let-bindings object) var-renamings)
48 
+    `(let ,bindings
49 
+       ,@(map (lambda (temp v)
50 
+		`(setf (var-value ,temp)
51 
+		       ,(dump-flic (var-value v) var-renamings)))
52 
+	      vars
53 
+	      (flic-let-bindings object))
54 
+       (make-flic-let
55 
+	 (list ,@vars)
56 
+	 ,(dump-flic (flic-let-body object) var-renamings)
57 
+	 ',(flic-let-recursive? object)))
58 
+    ))
59 
+
60 
+(define-dump-flic flic-app (object var-renamings)
61 
+  `(make-flic-app
62 
+     ,(dump-flic (flic-app-fn object) var-renamings)
63 
+     ,(dump-flic-list (flic-app-args object) var-renamings)
64 
+     ',(flic-app-saturated? object)))
65 
+
66 
+(define-dump-flic flic-ref (object var-renamings)
67 
+  (let* ((var    (flic-ref-var object))
68 
+	 (entry  (assq var var-renamings)))
69 
+    (if entry
70 
+	`(make-flic-ref ,(cdr entry))
71 
+	`(make-flic-ref ,(dump-object var)))))
72 
+
73 
+(define-dump-flic flic-const (object var-renamings)
74 
+  (declare (ignore var-renamings))
75 
+  `(make-flic-const ',(flic-const-value object)))
76 
+
77 
+(define-dump-flic flic-pack (object var-renamings)
78 
+  (declare (ignore var-renamings))
79 
+  `(make-flic-pack ,(dump-object (flic-pack-con object))))
80 
+
81 
+(define-dump-flic flic-case-block (object var-renamings)
82 
+  `(make-flic-case-block
83 
+     ',(flic-case-block-block-name object)
84 
+     ,(dump-flic-list (flic-case-block-exps object) var-renamings)))
85 
+
86 
+(define-dump-flic flic-return-from (object var-renamings)
87 
+  `(make-flic-return-from
88 
+     ',(flic-return-from-block-name object)
89 
+     ,(dump-flic (flic-return-from-exp object) var-renamings)))
90 
+
91 
+(define-dump-flic flic-and (object var-renamings)
92 
+  `(make-flic-and
93 
+     ,(dump-flic-list (flic-and-exps object) var-renamings)))
94 
+
95 
+(define-dump-flic flic-if (object var-renamings)
96 
+  `(make-flic-if
97 
+     ,(dump-flic (flic-if-test-exp object) var-renamings)
98 
+     ,(dump-flic (flic-if-then-exp object) var-renamings)
99 
+     ,(dump-flic (flic-if-else-exp object) var-renamings)))
100 
+
101 
+(define-dump-flic flic-sel (object var-renamings)
102 
+  `(make-flic-sel
103 
+     ,(dump-object (flic-sel-con object))
104 
+     ,(flic-sel-i object)
105 
+     ,(dump-flic (flic-sel-exp object) var-renamings)))
106 
+
107 
+(define-dump-flic flic-is-constructor (object var-renamings)
108 
+  `(make-flic-is-constructor
109 
+     ,(dump-object (flic-is-constructor-con object))
110 
+     ,(dump-flic (flic-is-constructor-exp object) var-renamings)))
111 
+
112 
+(define-dump-flic flic-con-number (object var-renamings)
113 
+  `(make-flic-con-number
114 
+     ,(dump-object (flic-con-number-type object))
115 
+     ,(dump-flic (flic-con-number-exp object) var-renamings)))
116 
+
117 
+(define-dump-flic flic-void (object var-renamings)
118 
+  (declare (ignore object var-renamings))
119 
+  `(make-flic-void))
120 
+
121 
+
122 
+
123 
+
124 
+
125 
+
126 
+
127 
+
128 
+
129 
+
130 
+
csys/dump-interface.scm
History View file @ 4e98702
0 131 
new file mode 100644
... ... 
@@ -0,0 +1,800 @@
1 
+;;; dump-interface.scm -- interface file writer/loader
2 
+;;;
3 
+;;; author :  John & Sandra
4 
+;;; date   :  8 Jul 1992
5 
+;;;
6 
+;;; This writes binary interface files.  A binary interface file is just
7 
+;;; a lisp (mumble) source file which directly builds the ast structure
8 
+;;; created by a compilation.  These files could be stored in either
9 
+;;; source or binary (compiled lisp) form.
10 
+
11 
+;;; An interface may reference entities defined in other interfaces.
12 
+;;; To ensure consistancy between when an interface is written and
13 
+;;; when it is read back in, a stamp is assigned to all interface files
14 
+;;; which serves as a unique id.  The stamps of all imported units are
15 
+;;; saved and examined at load time.
16 
+
17 
+
18 
+
19 
+;;;==================================================================
20 
+;;; Interface to compilation system
21 
+;;;==================================================================
22 
+
23 
+
24 
+;;; For compiled code, don't actually write out all the source code.
25 
+;;; Use a magic macro to memoize the form to be compiled.
26 
+
27 
+(define *form-to-compile* '#f)
28 
+(define *magic-file-to-compile* "$HASKELL/bin/magic.scm")
29 
+
30 
+
31 
+;;; The output from compiling the prelude can completely overwhelm
32 
+;;; the Lisp compiler.  If this variable is a number, it specifies
33 
+;;; a "reasonable" number of top-level forms which can be compiled
34 
+;;; and write-compiled-code-file will try to break up the input
35 
+;;; code automagically.
36 
+
37 
+(define *magic-chunk-size* '#f)
38 
+
39 
+
40 
+;;; This is called to write both the code file and the interface file.
41 
+
42 
+(define (write-compiled-code-file filename code code-quality chunk-size)
43 
+  (let ((phase-start-time (get-run-time))
44 
+        (forms            (flatten-forms code)))
45 
+    (dynamic-let ((*magic-chunk-size*
46 
+		   (or chunk-size (dynamic *magic-chunk-size*)))
47 
+		  (*code-quality*
48 
+		   (or code-quality (dynamic *code-quality*))))
49 
+      (if (or (not (dynamic *magic-chunk-size*))
50 
+	      (<= (the fixnum (length forms))
51 
+		  (the fixnum (dynamic *magic-chunk-size*))))
52 
+	  (write-compiled-code-file-aux filename `(begin ,@forms))
53 
+	  (with-compilation-unit ()
54 
+	    (write-compiled-code-file-aux
55 
+	      filename
56 
+	      `(begin
57 
+		 ,@(map (lambda (f) `(load ,f))
58 
+			(write-compiled-code-file-split filename forms)))
59 
+	      ))))
60 
+    (when (memq 'phase-time *printers*)
61 
+      (let* ((current-time (get-run-time))
62 
+	     (elapsed-time (- current-time phase-start-time)))
63 
+	(format '#t "Lisp compilation complete: ~A seconds~%" elapsed-time)))
64 
+    ))
65 
+
66 
+(define (write-compiled-code-file-split filename forms)
67 
+  (let ((place     (filename-place filename))
68 
+	(name      (filename-name filename))
69 
+	(type      (filename-type filename))
70 
+	(result    '()))
71 
+    (do ((i 0 (1+ i)))
72 
+	((null? forms))
73 
+	(multiple-value-bind (head tail)
74 
+	    (split-list forms (dynamic *magic-chunk-size*))
75 
+	  (let ((fname
76 
+		  (assemble-filename
77 
+		    place (format '#f "~a-part~a" name i) type)))
78 
+	    (push fname result)
79 
+	    (write-compiled-code-file-aux fname `(begin ,@head))
80 
+	    (setf forms tail))))
81 
+    (nreverse result)))
82 
+
83 
+(define (flatten-forms code)
84 
+  (if (and (pair? code) (eq? (car code) 'begin))
85 
+      (nreverse (flatten-forms-aux (cdr code) '()))
86 
+      (list code)))
87 
+
88 
+(define (flatten-forms-aux forms result)
89 
+  (dolist (f forms)
90 
+    (if (and (pair? f) (eq? (car f) 'begin))
91 
+	(setf result (flatten-forms-aux (cdr f) result))
92 
+	(push f result)))
93 
+  result)
94 
+
95 
+
96 
+(define (write-compiled-code-file-aux filename code)
97 
+  (dynamic-let ((*form-to-compile*  code))
98 
+    (compile-file (dynamic *magic-file-to-compile*) filename)))
99 
+
100 
+(define-syntax (magic-form-to-compile)
101 
+  (dynamic *form-to-compile*))
102 
+
103 
+
104 
+;;; Writing source code is good for debugging purposes, but slow.
105 
+;;; The *print-circle* and *print-shared* flags have to be set because
106 
+;;; the code printed out may contain gensyms, and this will ensure
107 
+;;; that the code can be read in again.
108 
+
109 
+(define (write-interpreted-code-file filename code hairy?)
110 
+  (dynamic-let ((*print-circle*   '#t)
111 
+		(*print-shared*   '#t))
112 
+    (call-with-output-file
113 
+      filename
114 
+      (lambda (port)
115 
+	(if hairy?
116 
+	    (pprint-flatten code port)
117 
+	    (print-flatten code port))))))
118 
+
119 
+
120 
+;;; This attempts to read a compiled interface for a unit.  This is
121 
+;;; done whenever the unit file is newer than the source file.  If
122 
+;;; imported units have changed, the load will fail and recompilation
123 
+;;; will be attempted.
124 
+;;; The caller is responsible for making sure that the interface file exists
125 
+;;; and for making sure that the interface file is up-to-date with
126 
+;;; respect to imported modules and that all the imported modules are
127 
+;;; known.
128 
+
129 
+;;; These variables are assigned by the code in the dump file.
130 
+
131 
+(define *modules-loaded* '())
132 
+(define *modules-imported* '())
133 
+(define *defs-referenced* '())
134 
+(define *saved-cse-values* '())
135 
+(define *writer-version* '())
136 
+
137 
+(define (read-binary-interface unit)
138 
+  (dynamic-let ((*modules-loaded*  '())
139 
+		(*modules-imported* '())
140 
+		(*defs-referenced*  '())
141 
+		(*saved-cse-values* '())
142 
+		(*writer-version* '()))
143 
+    (let ((file-date
144 
+	   (load-more-recent-file (ucache-cifile unit) (ucache-sifile unit))))
145 
+      (cond ((string=? *writer-version* *haskell-compiler-version*)
146 
+	     (setf (ucache-idate unit) file-date)
147 
+	     (setf (ucache-modules unit) (vector->list *modules-loaded*))
148 
+	     (setf (ucache-ifile-loaded unit) '#t)
149 
+	     '#t)
150 
+	    (else
151 
+	     (signal-incompatible-interface-file (ucache-cifile unit))
152 
+	     '#f)))))
153 
+
154 
+(define (signal-incompatible-interface-file filename)
155 
+  (fatal-error 'incompatible-interface-file
156 
+    "File ~A~%~
157 
+     was written by a different version of the Haskell system.~%~
158 
+     You must remove it and recompile."
159 
+    filename))
160 
+
161 
+
162 
+(define (load-more-recent-file cfile sfile)
163 
+  (cond ((file-exists? cfile)
164 
+	 (if (or (not (file-exists? sfile))
165 
+		 (> (file-write-date cfile)
166 
+		    (file-write-date sfile)))
167 
+	     (load-compiled-interface-file cfile)
168 
+	     (load-interpreted-interface-file sfile)))
169 
+	((file-exists? sfile)
170 
+	 (load-interpreted-interface-file sfile))
171 
+	(else
172 
+	 (signal-file-not-found cfile))))
173 
+
174 
+(define (load-interpreted-interface-file file)
175 
+  (load file)
176 
+  (file-write-date file))
177 
+
178 
+(define (load-compiled-interface-file file)
179 
+  (load file)
180 
+  (file-write-date file))
181 
+
182 
+
183 
+;;;==================================================================
184 
+;;; Dump code generator
185 
+;;;==================================================================
186 
+
187 
+;;; Globals
188 
+
189 
+(define *dump-defs* '())
190 
+(define *dump-slot-init-code* '())
191 
+(define *dump-def-counter* 0)
192 
+(define *dump-def-code-table* (make-table))
193 
+(define *cse-objects* '())
194 
+(define *cse-value-num* 0)
195 
+(define *cse-object-num* '())
196 
+(define *gtype-class-index* '())
197 
+(define *context-class-index* '())
198 
+(define *gtype-tycon-index* '())
199 
+(define *gtype-list-index* '())
200 
+(define *gtype-index* '())
201 
+(define *number-vars-dumped* 0)
202 
+
203 
+
204 
+(define-syntax (def-dump-code def)
205 
+  `(table-entry *dump-def-code-table* ,def))
206 
+
207 
+;;; This saves slot initialization code.
208 
+
209 
+(define (add-dump-init code)
210 
+  (push code *dump-slot-init-code*))
211 
+
212 
+
213 
+;;; Here is the top-level call.
214 
+
215 
+(define (create-dump-code unit modules load-prelude?)
216 
+  (dynamic-let ((*unit* (module-unit (car modules)))
217 
+		(*dump-defs*  '())
218 
+		(*dump-slot-init-code*  '())
219 
+		(*dump-def-counter* 0)
220 
+		(*dump-def-code-table* (make-table))
221 
+		(*cse-objects* '())
222 
+		(*cse-object-num* *num-saved-gtyvars*)
223 
+		(*gtype-class-index* '())
224 
+		(*context-class-index* '())
225 
+		(*gtype-tycon-index* '())
226 
+		(*gtype-list-index* '())
227 
+		(*gtype-index* '())
228 
+		(*number-vars-dumped* 0)
229 
+		(*number-types-dumped* 0)
230 
+		(*number-classes-dumped* 0))
231 
+    (let ((res (create-dump-code-aux unit modules load-prelude?)))
232 
+      (when (memq 'dumper (dynamic *printers*))
233 
+        (pprint* res))
234 
+      (when (memq 'dump-stat (dynamic *printers*))
235 
+	(format '#t
236 
+	  "~&Dumped ~A definitions, ~A type objects, and ~A classes.~%"
237 
+          *number-vars-dumped* *number-types-dumped*
238 
+	  *number-classes-dumped*)
239 
+	(format '#t "Used ~A definitions and ~A type cells.~%"
240 
+		*dump-def-counter* (length *cse-objects*)))
241 
+      res)))
242 
+
243 
+;;; This assumes all modules are in the same compilation unit and that
244 
+;;; *unit* is set to that unit.
245 
+;;; imod-code establishes local bindings for all the imported modules.
246 
+;;; dmod-code establishes local bindings for all the modules defined in
247 
+;;; this compilation unit.
248 
+
249 
+(define (create-dump-code-aux unit modules load-prelude?)
250 
+  (let* ((imod-counter  0)
251 
+	 (imod-alist    '())
252 
+	 (explicit-imports (collect-all-imported-modules unit))
253 
+	 (all-imports   (if load-prelude?
254 
+			    (append (collect-prelude-modules) explicit-imports)
255 
+			    explicit-imports))
256 
+	 (imod-code     (map (lambda (m)
257 
+			       (push (cons (module-name m) imod-counter)
258 
+				     imod-alist)
259 
+			       (incf imod-counter)
260 
+			       `(locate-module ',(module-name m)))
261 
+			     all-imports))
262 
+	 (dmod-counter  0)
263 
+	 (dmod-alist    '())
264 
+	 (dmod-code     (map (lambda (m)
265 
+			       (push (cons (module-name m) dmod-counter)
266 
+				     dmod-alist)
267 
+			       (incf dmod-counter)
268 
+			       `(make module
269 
+				      (unit ',(module-unit m))
270 
+				      (name ',(module-name m))
271 
+				      (type ',(module-type m))))
272 
+			     modules)))
273 
+    ;; This actually does most of the work.  It dumps the module asts by
274 
+    ;; placing inits for each slot into *dump-slot-init-code*.  A list of
275 
+    ;; definitions referenced is maintained in *dump-defs*.
276 
+    (dolist (m modules)
277 
+      (dump-module m (cdr (assq (module-name m) dmod-alist))))
278 
+    ;; This creates the final code
279 
+    `(begin
280 
+       (setf *writer-version* ',*haskell-compiler-version*)
281 
+       (setf *modules-imported* (vector ,@imod-code))
282 
+       (setf *modules-loaded* (vector ,@dmod-code))
283 
+       ;; This sets the elements individually instead of using the vector
284 
+       ;; function, because the vector may be longer than
285 
+       ;; call-arguments-limit.
286 
+       (setf *defs-referenced*
287 
+	     (make-vector ,(dynamic *dump-def-counter*)))
288 
+       ,@(map (lambda (d)
289 
+		`(setf ,(def-dump-code d)
290 
+		       ,(make-def-init-code d imod-alist dmod-alist)))
291 
+	      *dump-defs*)
292 
+       ,@(cse-init-code)
293 
+       ,@(dynamic *dump-slot-init-code*)
294 
+       )
295 
+    ))
296 
+
297 
+
298 
+;;; Runtime support
299 
+
300 
+(define-syntax (lookup-imported-mod i)
301 
+  `(vector-ref *modules-imported* ,i))
302 
+
303 
+(define-syntax (lookup-defined-mod i)
304 
+  `(vector-ref *modules-loaded* ,i))
305 
+
306 
+(define (set-export-from-def-vector table key index)
307 
+  (setf (table-entry table key)
308 
+	(list (cons key (vector-ref *defs-referenced* index)))))
309 
+
310 
+(define (set-export-from-def table key def)
311 
+  (setf (table-entry table key)
312 
+	(list (cons key def))))
313 
+
314 
+(define (set-symtab-from-def-vector table key index)
315 
+  (setf (table-entry table key)
316 
+	(vector-ref *defs-referenced* index)))
317 
+
318 
+(define (init-variable-slots var exported? toplevel? type simple? strict?)
319 
+  (setf (def-exported? var) exported?)
320 
+  (setf (var-toplevel? var) toplevel?)
321 
+  (setf (var-type var) type)
322 
+  (setf (var-simple? var) simple?)
323 
+  (setf (var-strict? var) strict?)
324 
+  var)
325 
+
326 
+(define (init-function-slots var exported? toplevel? type simple? strict?
327 
+			     arity strictness opt-entry)
328 
+  (setf (def-exported? var) exported?)
329 
+  (setf (var-toplevel? var) toplevel?)
330 
+  (setf (var-type var) type)
331 
+  (setf (var-simple? var) simple?)
332 
+  (setf (var-strict? var) strict?)
333 
+  (setf (var-arity var) arity)
334 
+  (setf (var-strictness var) strictness)
335 
+  (setf (var-optimized-entry var) opt-entry)
336 
+  var)
337 
+
338 
+(define (init-method-var-slots var class default method-signature)
339 
+  (setf (method-var-class var) class)
340 
+  (setf (method-var-default var) default)
341 
+  (setf (method-var-method-signature var) method-signature)
342 
+  var)
343 
+
344 
+(define (init-constructor-slots
345 
+  	   con arity types signature tag alg fixity infix?)
346 
+  (setf (con-arity con) arity)
347 
+  (setf (con-types con) types)
348 
+  (setf (con-signature con) signature)
349 
+  (setf (con-tag con) tag)
350 
+  (setf (con-alg con) alg)
351 
+  (setf (con-fixity con) fixity)
352 
+  (setf (con-infix? con) infix?)
353 
+  (dotimes (i arity)
354 
+    (push '#f (con-slot-strict? con)))
355 
+  con)
356 
+
357 
+(define (make-new-instance algdata tyvars class context gcontext dictionary m)
358 
+  (make instance
359 
+	(algdata algdata)
360 
+	(tyvars tyvars)
361 
+	(class class)
362 
+	(context context)
363 
+	(gcontext gcontext)
364 
+	(dictionary dictionary)
365 
+	(methods m)
366 
+	(ok? '#t)))
367 
+
368 
+
369 
+;;; This computes the transitive closure of all modules available to
370 
+;;; a unit.
371 
+
372 
+(define (collect-all-imported-modules unit)
373 
+  (collect-all-modules-1 (ucache-imported-units unit) '() '()))
374 
+
375 
+(define (collect-all-modules-1 units mods-so-far units-seen)
376 
+  (cond ((null? units)
377 
+	 mods-so-far)
378 
+	((mem-string (car units) units-seen)
379 
+	 (collect-all-modules-1 (cdr units) mods-so-far units-seen))
380 
+	(else
381 
+	 (let ((u (lookup-compilation-unit (car units))))
382 
+	   (collect-all-modules-1
383 
+	    (append (ucache-imported-units u) (cdr units))
384 
+	    (append (ucache-modules u) mods-so-far)
385 
+	    (cons (ucache-ufile u) units-seen))))
386 
+	))
387 
+
388 
+(define (collect-prelude-modules)
389 
+  (let ((prelude-unit (lookup-compilation-unit *prelude-unit-filename*)))
390 
+    (append (ucache-modules prelude-unit)
391 
+	    (collect-all-imported-modules prelude-unit))))
392 
+
393 
+(define (def->core-name-string def)
394 
+  (if (con? def)
395 
+      (remove-con-prefix (symbol->string (def-name def)))
396 
+      (symbol->string (def-name def))))
397 
+
398 
+;;; This code returns the load time definition for an object.  When the
399 
+;;; object is a core symbol or in a different unit, previously
400 
+;;; created definitions are returned.  Otherwise, a new definition is
401 
+;;; created.
402 
+
403 
+(define (make-def-init-code d imod-alist dmod-alist)
404 
+  (declare (ignore dmod-alist))
405 
+  (cond ((def-core? d)
406 
+	 `(core-symbol ,(def->core-name-string d)))
407 
+	((eq? (def-unit d) *unit*)
408 
+	 `(create-definition/inner
409 
+	    ',(def-module d)
410 
+	    ',(def-name d)
411 
+	    ',(cond ((method-var? d) 'method-var)
412 
+		    ((var? d) 'var)
413 
+		    ((con? d) 'con)
414 
+		    ((synonym? d) 'synonym)
415 
+		    ((algdata? d) 'algdata)
416 
+		    ((class? d) 'class))))
417 
+	((is-tuple-constructor? d)
418 
+	 `(tuple-constructor ,(tuple-constructor-arity d)))
419 
+	((is-tuple-tycon? d)
420 
+	 `(tuple-tycon ,(tuple-constructor-arity (car (algdata-constrs d)))))
421 
+	(else
422 
+	 (let ((m (assq (def-module d) imod-alist)))
423 
+	   ;; This is a bogus error message.  The problem is that nothing
424 
+	   ;; so far ensures units are closed under import/export: some
425 
+	   ;; modules may be referenced that are accidentally in the symbol
426 
+	   ;; table.  The unif file for the current module needs to be
427 
+	   ;; updated when this happens.
428 
+	   (when (eq? m '#f)
429 
+	     (fatal-error 'symbol-not-in-unit
430 
+ "Reference to symbol ~A in module ~A: not in compilation unit.~%"
431 
+                (def-name d) (def-module d)))
432 
+	 `(table-entry
433 
+	    (module-symbol-table
434 
+	      (lookup-imported-mod ,(tuple-2-2 m)))
435 
+	    ',(def-name d))))
436 
+	))
437 
+
438 
+
439 
+;;; Once a module has been compiled, most of its slots are useless.
440 
+;;; All we really need to save are the identifying information,
441 
+;;; symbol table, and export table.
442 
+;;; Instances also need to be dumped here instead of with class objects;
443 
+;;; this is because links can go across compilation unit boundaries.
444 
+;;; They are fixed up when pulling units out of the cache.
445 
+;;; The identifying info is stored when the module variable is bound.
446 
+
447 
+
448 
+(define (dump-module module index)
449 
+  (let ((mod-exp `(lookup-defined-mod ,index))
450 
+	(save-all-symbols (or (eq? (module-type module) 'standard)
451 
+			      (eq? (module-name module) '|Prelude|))))
452 
+    ;; Dump symbol table entries only for defs for which this is
453 
+    ;; the "home" module.  (In other words, ignore imported defs.)
454 
+    ;; The purpose of this is to allow references from other
455 
+    ;; interface files to be resolved; see make-def-init-code.
456 
+    ;; Jcp: we need to save the complete symbol table for incremental
457 
+    ;; compilation to work.
458 
+    (let ((code  '()))
459 
+      (table-for-each
460 
+        (lambda (key val)
461 
+	  (when (or save-all-symbols
462 
+		    (eq? (def-module val) (module-name module)))
463 
+	    (let ((def  (dump-object val)))
464 
+	      (push
465 
+	        (if (and (pair? def)
466 
+			 (eq? (car def) 'vector-ref)
467 
+			 (eq? (cadr def) '*defs-referenced*))
468 
+		    `(set-symtab-from-def-vector table ',key ,(caddr def))
469 
+		    `(setf (table-entry table ',key) ,def))
470 
+		code))))
471 
+	(module-symbol-table module))
472 
+      (add-dump-init `(setf (module-symbol-table ,mod-exp)
473 
+			    (let ((table  (make-table))) ,@code table))))
474 
+    ;; dump the fixity table - needed by the incremental compiler
475 
+    (when save-all-symbols
476 
+      (let ((code  '()))
477 
+	(table-for-each
478 
+	  (lambda (key val)
479 
+	    (push `(setf (table-entry table ',key)
480 
+			 (make-fixity ',(fixity-associativity val)
481 
+				      ',(fixity-precedence val)))
482 
+		  code))
483 
+	  (module-fixity-table module))
484 
+	(add-dump-init `(setf (module-fixity-table ,mod-exp)
485 
+			      (let ((table  (make-table))) ,@code table)))))
486 
+    ;; Dump all export table entries.  This is used by the import/export
487 
+    ;; phase to resolve references.
488 
+    (let ((code  '()))
489 
+      (table-for-each
490 
+        (lambda (key val)
491 
+	  ;; val is an a-list of (sym . def) pairs.
492 
+	  ;; Look for shortcut to reduce size of generated code.
493 
+	  (push
494 
+	    (if (and (null? (cdr val))
495 
+		     (eq? (car (car val)) key))
496 
+		(let ((def  (dump-object (cdr (car val)))))
497 
+		  (if (and (pair? def)
498 
+			   (eq? (car def) 'vector-ref)
499 
+			   (eq? (cadr def) '*defs-referenced*))
500 
+		      `(set-export-from-def-vector table ',key ,(caddr def))
501 
+		      `(set-export-from-def table ',key ,def)))
502 
+		`(setf (table-entry table ',key) ,(dump-object val)))
503 
+	    code))
504 
+	(module-export-table module))
505 
+      (add-dump-init `(setf (module-export-table ,mod-exp)
506 
+			    (let ((table  (make-table))) ,@code table))))
507 
+    ;; Dump the instances.
508 
+    (add-dump-init `(setf (module-instance-defs ,mod-exp)
509 
+			  ,(dump-object (module-instance-defs module))))
510 
+    (add-dump-init `(setf (module-default ,mod-exp)
511 
+			  ,(dump-object (module-default module))))
512 
+    (add-dump-init `(setf (module-uses-standard-prelude? ,mod-exp)
513 
+			  ,(dump-object
514 
+			    (module-uses-standard-prelude? module))))
515 
+    ))
516 
+
517 
+(define (make-fixity a p)
518 
+  (make fixity (associativity a) (precedence p)))
519 
+
520 
+
521 
+;;;==================================================================
522 
+;;; Dump structure traversal
523 
+;;;==================================================================
524 
+
525 
+;;; This is the general object dumper.  It recognizes the basic Lisp
526 
+;;; objects and dumps them.  Given an object, this generates lisp code
527 
+;;; to recreate the object at load time.
528 
+
529 
+(define (dump-object x)
530 
+  (cond ((struct? x)
531 
+	 (dump x))
532 
+	((or (symbol? x) (null? x))
533 
+	 ;; Symbols and lists must be quoted.
534 
+	 `',x)
535 
+	((or (number? x)
536 
+	     (eq? x '#t)
537 
+	     (eq? x '#f)
538 
+	     (string? x)   ; This makes dumped strings immutable.
539 
+	     (char? x))
540 
+	 ;; These objects are self-evaluating.
541 
+	 x)
542 
+	((list? x)
543 
+	 ;; True lists
544 
+	 `(list ,@(map (function dump-object) x)))
545 
+	((pair? x)
546 
+	 `(cons ,(dump-object (car x))
547 
+		,(dump-object (cdr x))))
548 
+	((vector? x)
549 
+	 `(vector ,@(map (function dump-object) (vector->list x))))
550 
+	((table? x)
551 
+	 `(list->table ,@(dump-object (table->list x))))
552 
+	(else
553 
+	 (error "Don't know how to dump ~A." x))))
554 
+
555 
+
556 
+;;; *** Should install the walker in the type descriptor.
557 
+
558 
+(define-walker dump)
559 
+
560 
+(define (dump x)
561 
+  (call-walker dump x))
562 
+
563 
+
564 
+
565 
+;;;==================================================================
566 
+;;; Dumpers for defs
567 
+;;;==================================================================
568 
+
569 
+
570 
+;;; All walkers for def structures should call this macro.  The body
571 
+;;; is invoked only if the def belongs to the current compilation unit
572 
+;;; and hasn't already been traversed.  Within the body, the
573 
+;;; variable "v" is bound to a form that will evaluate to the
574 
+;;; corresponding def structure at run time.  This is also
575 
+;;; the return value from the macro.
576 
+
577 
+(define-local-syntax (with-new-def (v d stat-var) . body)
578 
+  (let ((temp   (gensym))
579 
+	(expvar (gensym)))
580 
+    `(let ((,temp  ,d)
581 
+	   (,expvar '#f))
582 
+       (if (not (def-dump-code ,temp))
583 
+	   (begin
584 
+	     (cond ((not (def-core? ,temp))
585 
+		    (setf ,expvar
586 
+			  (list 'vector-ref
587 
+				'*defs-referenced*
588 
+				(dynamic *dump-def-counter*)))
589 
+		    (incf (dynamic *dump-def-counter*))
590 
+		    (push ,temp *dump-defs*))
591 
+		   (else
592 
+		    (setf ,expvar
593 
+			  (make-core-symbol-name
594 
+			    (def->core-name-string ,temp)))))
595 
+	     (setf (def-dump-code ,temp) ,expvar)
596 
+	     (when (eq? (def-unit ,temp) *unit*)
597 
+	       (incf (dynamic ,stat-var))
598 
+	       (let ((,v  ,expvar))
599 
+		 ,@body))
600 
+	     ,expvar)
601 
+	   (def-dump-code ,temp)))))
602 
+
603 
+
604 
+;;; This macro is used to save the value of a structure slot in the
605 
+;;; initforms of the dump.
606 
+
607 
+(define-local-syntax (dump-def-slots obj-var type dexp slots)
608 
+  `(add-dump-init
609 
+     (list 'update-slots ',type ,dexp
610 
+	   ,@(map (lambda (s)
611 
+		    `(list ',s
612 
+			   (dump-object (struct-slot ',type ',s ,obj-var))))
613 
+		  slots)))
614 
+  )
615 
+
616 
+
617 
+
618 
+(define-walker-method dump var (var)
619 
+  (dump-var/n var))
620 
+
621 
+(define (dump-var/n var)
622 
+  (with-new-def (dexp var *number-vars-dumped*)
623 
+    (do-dump-var dexp var '#f)))
624 
+
625 
+(define (do-dump-var dexp var method-var?)
626 
+  (let ((code            '())
627 
+	(exported?       (def-exported? var))
628 
+	(toplevel?       (var-toplevel? var))
629 
+	(type            (var-type var))
630 
+	(simple?         (var-simple? var))
631 
+	(strict?         (var-strict? var))
632 
+	(arity           (var-arity var))
633 
+	(strictness      (var-strictness var))
634 
+	(opt-entry       (var-optimized-entry var))
635 
+	(complexity      (var-complexity var))
636 
+	(fixity          (var-fixity var))
637 
+	(value           (var-value var))
638 
+	(inline-value    (var-inline-value var))
639 
+	(sel?            (var-selector-fn? var)))
640 
+    ;; Some slots are useless for vars that don't name functions.
641 
+    (if (eqv? arity 0)
642 
+	(push `(init-variable-slots var
643 
+	         ',exported?
644 
+		 ',toplevel?
645 
+		 ,(dump-object type)
646 
+		 ',simple?
647 
+		 ',strict?)
648 
+	      code)
649 
+	(push `(init-function-slots var
650 
+		 ',exported?
651 
+		 ',toplevel?
652 
+		 ,(dump-object type)
653 
+		 ',simple?
654 
+		 ',strict?
655 
+		 ',arity
656 
+		 ,(dump-strictness strictness)
657 
+		 ',opt-entry)
658 
+	      code))
659 
+    ;; These slots rarely need to be tweaked from the default.
660 
+    (when sel?
661 
+      (push `(setf (var-selector-fn? var) '#t) code))
662 
+    (when complexity
663 
+      (push `(setf (var-complexity var) ,complexity) code))
664 
+    (when fixity
665 
+      (push `(setf (var-fixity var) ,(dump-object fixity)) code))
666 
+    ;; Save values of simple variables to permit inlining.
667 
+    ;; Save values of structured constants to permit folding of flic-sel
668 
+    ;; operations -- this is necessary to optimize dictionary lookups.
669 
+    (when (or simple? sel?
670 
+	      (and value
671 
+		   (is-type? 'flic-app value)
672 
+		   (structured-constant-app?
673 
+		     (flic-app-fn value) (flic-app-args value))))
674 
+      (push `(setf (var-value var) ,(dump-flic-top value)) code))
675 
+    (when inline-value
676 
+      (push `(setf (var-inline-value var) ,(dump-flic-top inline-value)) code))
677 
+    ;; Save extra stuff for method vars
678 
+    (when method-var?
679 
+      (push `(init-method-var-slots var
680 
+	       ,(dump-object (method-var-class var))
681 
+	       ,(dump-object (method-var-default var))
682 
+	       ,(dump-object (method-var-method-signature var)))
683 
+	    code))
684 
+    ;; Push the whole mess onto the init code.
685 
+    (add-dump-init `(let ((var  ,dexp)) ,@(nreverse code)))))
686 
+
687 
+
688 
+(define-walker-method dump method-var (var)
689 
+  (dump-method-var/n var))
690 
+
691 
+(define (dump-method-var/n var)
692 
+  (with-new-def (dexp var *number-vars-dumped*)
693 
+    (do-dump-var dexp var '#t)))
694 
+
695 
+(define-walker-method dump con (con)
696 
+  (dump-con/n con))
697 
+
698 
+(define (dump-con/n con)
699 
+  (with-new-def (dexp con *number-types-dumped*)
700 
+    (add-dump-init
701 
+      `(let ((con (init-constructor-slots
702 
+		   ,dexp
703 
+		   ,(con-arity con)
704 
+		   ,(dump-object (con-types con))
705 
+		   ,(dump-object (con-signature con))
706 
+		   ,(con-tag con)
707 
+		   ,(dump-object (con-alg con))
708 
+		   ,(dump-object (con-fixity con))
709 
+		   ',(con-infix? con))))
710 
+	 ,@(if (memq '#t (con-slot-strict? con))
711 
+	       `((setf (con-slot-strict? con) ',(con-slot-strict? con)))
712 
+	       '())
713 
+	 ,@(if (eq? (con-lisp-fns con) '())
714 
+	       '()
715 
+	       `((setf (con-lisp-fns con) ',(con-lisp-fns con))))
716 
+	 con))))
717 
+
718 
+;;; *** Could define similar init functions for other defs instead
719 
+;;; *** of setting slots inline, but I'm lazy and they don't show up
720 
+;;; *** nearly as often as the others.
721 
+
722 
+(define-walker-method dump algdata (alg)
723 
+  (dump-algdata/n alg))
724 
+
725 
+(define (dump-algdata/n alg)
726 
+  (with-new-def (dexp alg *number-types-dumped*)
727 
+    (dump-def-slots alg algdata dexp
728 
+		    (arity n-constr constrs context tyvars signature
729 
+			   enum? tuple? real-tuple? implemented-by-lisp?))))
730 
+
731 
+(define-walker-method dump synonym (syn)
732 
+  (dump-synonym/n syn))
733 
+
734 
+(define (dump-synonym/n syn)
735 
+  (with-new-def (dexp syn *number-types-dumped*)
736 
+    (dump-def-slots syn synonym dexp (arity args body))))
737 
+
738 
+(define-walker-method dump class (class)
739 
+  (dump-class/n class))
740 
+
741 
+(define (dump-class/n class)
742 
+  (with-new-def (dexp class *number-classes-dumped*)
743 
+    (dump-def-slots class class dexp
744 
+		    (super super* tyvar method-vars selectors kind
745 
+		     n-methods dict-size))))
746 
+
747 
+
748 
+;;;==================================================================
749 
+;;; Dumpers for non-def AST structs
750 
+;;;==================================================================
751 
+
752 
+;;; This section contains dumpers to handle type-related structs that
753 
+;;; are referenced by the various def guys.
754 
+
755 
+
756 
+(define-walker-method dump instance (o)
757 
+  (if (not (instance-ok? o))
758 
+      (error "Attempt to dump instance that's not ok!"))
759 
+  `(make-new-instance
760 
+     ,(dump-object (instance-algdata o))
761 
+     ,(dump-object (instance-tyvars o))
762 
+     ,(dump-object (instance-class o))
763 
+     ,(dump-object (instance-context o))
764 
+     ,(dump-object (instance-gcontext o))
765 
+     ,(dump-object (instance-dictionary o))
766 
+     ,(dump-object (instance-methods o))))
767 
+
768 
+
769 
+
770 
+(define-walker-method dump gtype (o)
771 
+  (dump-gtype/cse o))
772 
+
773 
+(define-walker-method dump fixity (o)
774 
+  `(**fixity ',(fixity-associativity o) ',(fixity-precedence o)))
775 
+
776 
+(define-walker-method dump tyvar (o)
777 
+  `(**tyvar ',(tyvar-name o)))
778 
+
779 
+(define-walker-method dump class-ref (o)
780 
+  `(**class/def ,(dump-object (class-ref-class o))))
781 
+
782 
+(define-walker-method dump context (o)
783 
+  `(**context ,(dump-object (context-class o))
784 
+	      ,(dump-object (context-tyvar o))))
785 
+
786 
+(define-walker-method dump tycon (o)
787 
+  `(**tycon/def ,(dump-object (tycon-def o))
788 
+		,(dump-object (tycon-args o))))
789 
+
790 
+(define-walker-method dump default-decl (o)
791 
+  `(make default-decl (types ,(dump-object (default-decl-types o)))))
792 
+
793 
+(define-walker-method dump signature (o)
794 
+  `(make signature (context ,(dump-object (signature-context o)))
795 
+	           (type ,(dump-object (signature-type o)))))
796 
+
797 
+;;; All ntyvars should be instantiated at this point
798 
+
799 
+; (define-walker-method dump ntyvar (o)
800 
+;  (dump-object (prune o)))
csys/dump-macros.scm
History View file @ 4e98702
0 801 
new file mode 100644
... ... 
@@ -0,0 +1,37 @@
1 
+(define-syntax (set-strictness-vars)
2 
+  (let ((res '()))
3 
+    (dotimes (i *pre-defined-strictness-vars*)
4 
+       (push `(setf (dynamic ,(vector-ref *pre-defined-strictness-names* i))
5 
+		    (vector-ref *pre-defined-strictness-table* ',i))
6 
+	     res))
7 
+    `(begin ,@res)))
8 
+
9 
+(define-syntax (setup-gtyvar-vars)
10 
+ (let ((res '()))
11 
+   (dotimes (i *num-saved-gtyvars*)
12 
+     (push `(setf (dynamic ,(vector-ref *saved-gtyvar-varnames* i))
13 
+		  (vector-ref *saved-gtyvars* ',i))
14 
+	   res))
15 
+   `(begin ,@res)))
16 
+
17 
+(define-syntax (assq/insert x table)
18 
+  `(let ((res (assq ,x ,table)))
19 
+     (if (eqv? res '#f)
20 
+	 (begin
21 
+	   (let ((new-pair (cons ,x '#f)))
22 
+	     (push new-pair ,table)
23 
+	     new-pair))
24 
+	 res)))
25 
+
26 
+(define-syntax (assq/insert-l x table)
27 
+  `(let ((res (assq ,x ,table)))
28 
+     (if (eqv? res '#f)
29 
+	 (begin
30 
+	   (let ((new-pair (cons ,x '())))
31 
+	     (push new-pair ,table)
32 
+	     new-pair))
33 
+	 res)))
34 
+
35 
+
36 
+
37 
+
csys/dump-params.scm
History View file @ 4e98702
0 38 
new file mode 100644
... ... 
@@ -0,0 +1,18 @@
1 
+(define *num-saved-gtyvars* 19)
2 
+(define *pre-defined-strictness-size* 7)  ; length of max strictness list
3 
+(define *pre-defined-strictness-table* '())
4 
+(define *pre-defined-strictness-vars* 32) ; number of global vars
5 
+(define *pre-defined-strictness-names*
6 
+  (make-vector *pre-defined-strictness-vars*))
7 
+
8 
+(dotimes (i *pre-defined-strictness-vars*)
9 
+     (setf (vector-ref *pre-defined-strictness-names* i)
10 
+	   (string->symbol (format '#f "SAVED-STRICTNESS-~A" i))))
11 
+
12 
+(define *saved-gtyvars* '())
13 
+(define *saved-gtyvar-varnames* (make-vector *num-saved-gtyvars*))
14 
+(dotimes (i *num-saved-gtyvars*)
15 
+  (setf (vector-ref *saved-gtyvar-varnames* i)
16 
+	(string->symbol (format '#f "SAVED-GTYVAR-NAME~A" i))))
17 
+
18 
+
csys/magic.scm
History View file @ 4e98702
0 19 
new file mode 100644
... ... 
@@ -0,0 +1,10 @@
1 
+;;; magic.scm -- magic support file for dumping compiled code files.
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  8 Jul 1992
5 
+;;;
6 
+;;; This file is used to dump compiled code files.  The macro call below
7 
+;;; expands into the code being dumped.  See dump-interface.scm for more
8 
+;;; details.
9 
+
10 
+(magic-form-to-compile)
depend/README
History View file @ 4e98702
0 11 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+This directory contains the dependency analysis phase.  Its function
2 
+is to sort out local variable bindings into sequential and recursive
3 
+groups.
depend/depend.scm
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,13 @@
1 
+;;; depend.scm -- module definition for dependency analysis
2 
+;;;
3 
+;;; author :  John
4 
+;;; date   :  24 Mar 1992
5 
+;;;
6 
+
7 
+
8 
+(define-compilation-unit depend
9 
+  (source-filename "$Y2/depend/")
10 
+  (require ast haskell-utils)
11 
+  (unit dependency-analysis
12 
+	(source-filename "dependency-analysis.scm")))
13 
+
0 14 
\ No newline at end of file
depend/dependency-analysis.scm
History View file @ 4e98702
1 15 
new file mode 100644
... ... 
@@ -0,0 +1,151 @@
1 
+;;; depend/depend.scm     Author: John
2 
+
3 
+;;; This performs dependency analysis.  All module definitions are gathered
4 
+;;; into a single nested let/let*.
5 
+
6 
+(define-walker depend ast-td-depend-walker)
7 
+
8 
+;;; This extracts the declarations out of the top level of the modules and
9 
+;;; creates a single let defining all values from the modules.
10 
+
11 
+(define (do-dependency-analysis modules)
12 
+  (let ((all-decls '()))
13 
+    (dolist (mod modules)
14 
+      (setf all-decls (append (module-decls mod) all-decls)))
15 
+    (analyze-dependency-top
16 
+      (**let all-decls (make void)))))
17 
+
18 
+
19 
+(define *depend-fn-table* (make-table))
20 
+
21 
+(define-syntax (var-depend-fn var)
22 
+  `(table-entry *depend-fn-table* ,var))
23 
+
24 
+(define (analyze-dependency-top x)
25 
+  (dynamic-let ((*depend-fn-table*  (make-table)))
26 
+    (analyze-dependency x)))
27 
+
28 
+
29 
+;;; This is the entry point to dependency analysis for an expression or decl
30 
+
31 
+(define (analyze-dependency x)
32 
+  (call-walker depend x))
33 
+
34 
+(define (analyze-dependency/list l)
35 
+  (dolist (x l)
36 
+    (analyze-dependency x)))
37 
+
38 
+;;; This makes default walkers for dependency analysis.  Expressions are
39 
+;;; walked into; declaration lists must be sorted.
40 
+
41 
+(define-local-syntax (make-depend-code slot type)
42 
+  (let ((stype  (sd-type slot))
43 
+        (sname  (sd-name slot))
44 
+	(depend-exp-types '(exp alt qual single-fun-def guarded-rhs)))
45 
+    (cond ((and (symbol? stype)
46 
+		(memq stype depend-exp-types))
47 
+	   `(analyze-dependency (struct-slot ',type ',sname object)))
48 
+          ((and (pair? stype)
49 
+                (eq? (car stype) 'list)
50 
+                (symbol? (cadr stype))
51 
+                (memq (cadr stype) depend-exp-types)
52 
+	   `(analyze-dependency/list
53 
+		(struct-slot ',type ',sname object))))
54 
+          ((equal? stype '(list decl))
55 
+	   `(setf (struct-slot ',type ',sname object)
56 
+		  (restructure-decl-list (struct-slot ',type ',sname object))))
57 
+          (else
58 
+;           (format '#t "Depend: skipping slot ~A in ~A~%"
59 
+;                  (sd-name slot)
60 
+;                  type)
61 
+           '#f))))
62 
+
63 
+(define-modify-walker-methods depend
64 
+  (lambda let if case alt exp-sign app con-ref
65 
+   integer-const float-const char-const string-const
66 
+   list-exp sequence sequence-then sequence-to sequence-then-to
67 
+   list-comp section-l section-r qual-generator qual-filter omitted-guard
68 
+   con-number sel is-constructor cast void
69 
+   single-fun-def guarded-rhs
70 
+   case-block return-from and-exp
71 
+   )
72 
+  (object)
73 
+  make-depend-code)
74 
+
75 
+;;; This sorts a list of decls.  Recursive groups are placed in
76 
+;;; special structures: recursive-decl-group
77 
+
78 
+(define (restructure-decl-list decls)
79 
+  (let ((stack '())
80 
+	(now 0)
81 
+	(sorted-decls '())
82 
+	(edge-fn '()))
83 
+   (letrec ((visit (lambda (k)
84 
+		     (let ((minval 0)
85 
+			   (recursive? '#f)
86 
+			   (old-edge-fn edge-fn))
87 
+		       (incf now)
88 
+;		       (format '#t "Visiting ~A: id = ~A~%" (valdef-lhs k) now)
89 
+		       (setf (valdef-depend-val k) now)
90 
+		       (setf minval now)
91 
+		       (push k stack)
92 
+		       (setf edge-fn
93 
+			     (lambda (tv)
94 
+;			       (format '#t "Edge ~A -> ~A~%" (valdef-lhs k)
95 
+;				                             (valdef-lhs tv))
96 
+			       (let ((val (valdef-depend-val tv)))
97 
+                                (cond ((eq? tv k)
98 
+				       (setf recursive? '#t))
99 
+				      ((eqv? val 0)
100 
+				       (setf minval (min minval
101 
+							 (funcall visit tv))))
102 
+				      (else
103 
+				       (setf minval (min minval val))))
104 
+;				(format '#t "Min for ~A is ~A~%"
105 
+;					(valdef-lhs k) minval)
106 
+			       )))
107 
+		       (analyze-dependency/list (valdef-definitions k))
108 
+		       (setf edge-fn old-edge-fn)
109 
+		       (when (eqv? minval (valdef-depend-val k))
110 
+			 (let ((defs '()))
111 
+			   (do ((quit? '#f)) (quit?)
112 
+			     (push (car stack) defs)
113 
+			     (setf (valdef-depend-val (car stack)) 100000)
114 
+			     (setf quit? (eq? (car stack) k))
115 
+			     (setf stack (cdr stack)))
116 
+;			   (format '#t "Popping stack: ~A~%"
117 
+;				   (map (lambda (x) (valdef-lhs x)) defs))
118 
+			   (if (and (null? (cdr defs))
119 
+				    (not recursive?))
120 
+			       (push k sorted-decls)
121 
+			       (push (make recursive-decl-group (decls defs))
122 
+				     sorted-decls))))
123 
+		       minval))))
124 
+    ;; for now assume all decl lists have only valdefs
125 
+    (dolist (d decls)
126 
+      (let ((decl d))  ; to force new binding for each closure
127 
+	(setf (valdef-depend-val decl) 0)
128 
+	(dolist (var (collect-pattern-vars (valdef-lhs decl)))
129 
+	  (setf (var-depend-fn (var-ref-var var))
130 
+		(lambda () (funcall edge-fn decl))))))
131 
+    (dolist (decl decls)
132 
+      (when (eqv? (valdef-depend-val decl) 0)
133 
+	(funcall visit decl)))
134 
+    (dolist (decl decls)
135 
+      (dolist (var (collect-pattern-vars (valdef-lhs decl)))
136 
+	(setf (var-depend-fn (var-ref-var var)) '#f)))
137 
+    (nreverse sorted-decls))))
138 
+
139 
+;;; This is the only non-default walker needed.  When a reference to a
140 
+;;; variable is encountered, the sort algorithm above is notified.
141 
+
142 
+(define-walker-method depend var-ref (object)
143 
+  (let ((fn (var-depend-fn (var-ref-var object))))
144 
+    (when (not (eq? fn '#f))
145 
+       (funcall fn))))
146 
+
147 
+(define-walker-method depend overloaded-var-ref (object)
148 
+  (let ((fn (var-depend-fn (overloaded-var-ref-var object))))
149 
+    (when (not (eq? fn '#f))
150 
+       (funcall fn))))
151 
+
derived/README
History View file @ 4e98702
0 152 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+This directory contains code to generate AST structure for derived
2 
+instances.
derived/ast-builders.scm
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,273 @@
1 
+;;; These functions build non-trivial ast structure.
2 
+
3 
+;;; Prelude functions: booleans
4 
+
5 
+(define (**== e1 e2)
6 
+  (**app (**var/def (core-symbol "==")) e1 e2))
7 
+
8 
+(define (**<= e1 e2)
9 
+  (**app (**var/def (core-symbol "<=")) e1 e2))
10 
+
11 
+(define (**< e1 e2)
12 
+  (**app (**var/def (core-symbol "<")) e1 e2))
13 
+
14 
+(define (**> e1 e2)
15 
+  (**app (**var/def (core-symbol ">")) e1 e2))
16 
+
17 
+(define (**and e1 e2)
18 
+  (**app (**var/def (core-symbol "&&")) e1 e2))
19 
+
20 
+(define (**or e1 e2)
21 
+  (**app (**var/def (core-symbol "||")) e1 e2))
22 
+
23 
+(define (**true) (**con/def (core-symbol "True")))
24 
+
25 
+(define (**false) (**con/def (core-symbol "False")))
26 
+
27 
+;; Tuples
28 
+
29 
+(define (**tuple2 x y)
30 
+  (**app (**con/def (tuple-constructor 2)) x y))
31 
+
32 
+(define (**tupleN exps)
33 
+  (**app/l (**con/def (tuple-constructor (length exps))) exps))
34 
+
35 
+;; Arithmetic
36 
+
37 
+(define (**+ x y)
38 
+  (**app (**var/def (core-symbol "+")) x y))
39 
+
40 
+(define (**+/Int x y)
41 
+  (**app (**var/def (core-symbol "primPlusInt")) x y))
42 
+
43 
+(define (**- x y)
44 
+  (**app (**var/def (core-symbol "-")) x y))
45 
+
46 
+(define (**1+ x)
47 
+  (**+ x (**int 1)))
48 
+
49 
+;; Lists
50 
+
51 
+(define (**cons x y)
52 
+  (**app (**con/def (core-symbol ":")) x y))
53 
+
54 
+(define (**null)
55 
+  (**con/def (core-symbol "Nil")))
56 
+
57 
+(define (**list . args)
58 
+  (**list/l args))
59 
+
60 
+(define (**list/l args)
61 
+  (if (null? args)
62 
+      (**null)
63 
+      (**cons (car args)
64 
+	      (**list/l (cdr args)))))
65 
+
66 
+(define (**list/pattern pats)
67 
+  (if (null? pats)
68 
+      (**pcon/def (core-symbol "Nil") '())
69 
+      (**pcon/def (core-symbol ":")
70 
+		  (list (car pats) (**list/pattern (cdr pats))))))
71 
+
72 
+(define (**append . lists)
73 
+  (**append/l lists))
74 
+
75 
+(define (**append/l lists)
76 
+  (if (null? (cdr lists))
77 
+      (car lists)
78 
+      (**app (**var/def (core-symbol "++"))
79 
+	     (car lists)
80 
+	     (**append/l (cdr lists)))))
81 
+
82 
+(define (**take n l)
83 
+  (**app (**var/def (core-symbol "take")) n l))
84 
+
85 
+(define (**drop n l)
86 
+  (**app (**var/def (core-symbol "drop")) n l))
87 
+
88 
+;; Functionals
89 
+
90 
+(define (**dot fn . args)
91 
+  (**dot/l fn args))
92 
+
93 
+(define (**dot/l fn args)
94 
+ (if (null? args)
95 
+     fn
96 
+     (**app (**var/def (core-symbol ".")) fn (**dot/l (car args) (cdr args)))))
97 
+
98 
+;; Printing
99 
+
100 
+(define (**showChar x)
101 
+  (**app (**var/def (core-symbol "showChar")) x))
102 
+
103 
+(define (**space)
104 
+  (**showChar (**char #\ )))
105 
+
106 
+(define (**comma)
107 
+  (**showChar (**char #\,)))
108 
+
109 
+(define (**showsPrec x y)
110 
+  (**app (**var/def (core-symbol "showsPrec")) x y))
111 
+
112 
+(define (**shows x)
113 
+  (**app (**var/def (core-symbol "shows")) x))
114 
+
115 
+(define (**showString x)
116 
+  (**app (**var/def (core-symbol "showString")) x))
117 
+
118 
+(define (**showParen x y)
119 
+  (**app (**var/def (core-symbol "showParen")) x y))
120 
+
121 
+;; Reading
122 
+
123 
+(define (**readsPrec x y)
124 
+  (**app (**var/def (core-symbol "readsPrec")) x y))
125 
+
126 
+(define (**lex x)
127 
+  (**app (**var/def (core-symbol "lex")) x))
128 
+
129 
+(define (**readParen bool fn r)
130 
+  (**app (**var/def (core-symbol "readParen")) bool fn r))
131 
+
132 
+(define (**reads s)
133 
+  (**app (**var/def (core-symbol "reads")) s))
134 
+
135 
+;;; Binary
136 
+
137 
+(define (**showBinInt i b)
138 
+  (**app (**var/def (core-symbol "primShowBinInt")) i b))
139 
+
140 
+(define (**readBinSmallInt max b)
141 
+  (**app (**var/def (core-symbol "primReadBinSmallInt")) max b))
142 
+
143 
+(define (**showBin x b)
144 
+  (**app (**var/def (core-symbol "showBin")) x b))
145 
+
146 
+(define (**readBin b)
147 
+  (**app (**var/def (core-symbol "readBin")) b))
148 
+
149 
+;;; Some higher level code generators
150 
+
151 
+;;; foldr  (expanded inline)
152 
+
153 
+(define (**foldr build-fn terms init)
154 
+  (if (null? terms)
155 
+      init
156 
+      (funcall build-fn (car terms) (**foldr build-fn (cdr terms) init))))
157 
+
158 
+;;; Unlike foldr, this uses two sets of args to avoid tupling
159 
+
160 
+(define (**foldr2 build-fn terms1 terms2 init-fn)
161 
+  (if (null? (cdr terms1))
162 
+      (funcall init-fn (car terms1) (car terms2))
163 
+      (funcall build-fn (car terms1) (car terms2)
164 
+	      (**foldr2 build-fn (cdr terms1) (cdr terms2) init-fn))))
165 
+
166 
+;;; Enum
167 
+
168 
+(define (**enumFrom x)
169 
+  (**app (**var/def (core-symbol "enumFrom")) x))
170 
+
171 
+(define (**enumFromThen from then)
172 
+  (**app (**var/def (core-symbol "enumFromThen")) from then))
173 
+
174 
+(define (**enumFromTo from to)
175 
+  (**app (**var/def (core-symbol "enumFromTo")) from to))
176 
+
177 
+(define (**enumFromThenTo from then to)
178 
+  (**app (**var/def (core-symbol "enumFromThenTo")) from then to))
179 
+
180 
+;;; Cast overrides the type system
181 
+
182 
+(define (**cast x)
183 
+  (make cast (exp x)))
184 
+
185 
+;;; Case.  This also generates the alts.  All variants of case generate
186 
+;;; an arm for each constructor in a datatype.  This arm can be selected
187 
+;;; by pattern matching a value of the type, with all fields bound to vars,
188 
+;;; or with numbered or named selections.
189 
+
190 
+;;; The fn always generates the arms given the constructor.  In the /con case,
191 
+;;; the fn also gets the variable list of values bound in the fields.
192 
+
193 
+(define (**case/con alg exp fn)
194 
+  (**case exp
195 
+	  (map (lambda (con)
196 
+		 (let* ((arity (con-arity con))
197 
+			(vars (temp-vars "x" arity)))
198 
+		   (**alt/simple (**pat (cons con vars))
199 
+				 (funcall fn con vars))))
200 
+	       (algdata-constrs alg))))
201 
+
202 
+;;; Selectors are integers (used for Bin)
203 
+
204 
+(define (**case/int alg exp fn)
205 
+  (**case exp
206 
+    (map (lambda (con)
207 
+	   (**alt/simple
208 
+	      (**pat (con-tag con))
209 
+	      (funcall fn con)))
210 
+	 (algdata-constrs alg))))
211 
+
212 
+;;; Selectors are strings (Text)
213 
+
214 
+(define (**case/strings alg exp fn)
215 
+  (**case exp
216 
+    (map (lambda (con)
217 
+	   (**alt/simple
218 
+	    (**pat (remove-con-prefix (symbol->string (def-name con))))
219 
+	    (funcall fn con)))
220 
+	 (algdata-constrs alg))))
221 
+
222 
+;;; Definitions containing multi-body
223 
+
224 
+(define (**multi-define fname alg nullary-fn single-fn
225 
+			          combine-fn else-val)
226 
+  (**define/multiple fname
227 
+    (append
228 
+      (map (lambda (con) (**define/2 con nullary-fn single-fn combine-fn))
229 
+	     (algdata-constrs alg))
230 
+      (if (not (eq? else-val '#f))
231 
+	  `(((_ _) ,(funcall else-val)))
232 
+	  '()))))
233 
+
234 
+(define (**define/2 con nullary-fn single-fn combine-fn)
235 
+  (let* ((arity (con-arity con))
236 
+	 (vars1 (temp-vars "l" arity))
237 
+	 (vars2 (temp-vars "r" arity)))
238 
+    `(((,con ,@vars1) (,con ,@vars2))
239 
+      ,(if (eqv? arity 0)
240 
+	   (funcall nullary-fn)
241 
+	   (**foldr2 combine-fn (suspend-vars vars1) (suspend-vars vars2)
242 
+			   single-fn)))))
243 
+
244 
+(define (**define/multiple fn args)
245 
+  (make valdef
246 
+	(lhs (**pat fn))
247 
+	(definitions
248 
+          (map (lambda (arg)
249 
+		 (make single-fun-def
250 
+		       (args (map (function **pat) (car arg)))
251 
+		       (rhs-list (list (make guarded-rhs
252 
+					     (guard (**omitted-guard))
253 
+					     (rhs (cadr arg)))))
254 
+		       (where-decls '())
255 
+		       (infix? '#f)))
256 
+	       args))))
257 
+
258 
+(define (suspend-vars vars) (map (lambda (v) (lambda () (**var v))) vars))
259 
+
260 
+(define (temp-vars root arity)
261 
+  (temp-vars1 root 1 arity))
262 
+
263 
+(define (temp-vars1 root i arity)
264 
+  (if (> i arity)
265 
+      '()
266 
+      (cons (string->symbol (string-append root (number->string i)))
267 
+	    (temp-vars1 root (1+ i) arity))))
268 
+
269 
+(define (tuple-con algdata)
270 
+  (car (algdata-constrs algdata)))
271 
+
272 
+(define (con-string x)
273 
+  (remove-con-prefix (symbol->string (def-name x))))
derived/derived-instances.scm
History View file @ 4e98702
0 274 
new file mode 100644
... ... 
@@ -0,0 +1,255 @@
1 
+
2 
+;;; Basic DI structure:
3 
+;;;  a. Create the set of instances
4 
+;;;  b. Expand the context of each potential instance.
5 
+;;;  c. Once b. reaches a fixpoint, fill in the ast for the generated instances
6 
+
7 
+(define *di-context-changed* '#f)
8 
+
9 
+(define (add-derived-instances modules)
10 
+  (let ((insts '()))
11 
+    (walk-modules modules
12 
+     (lambda () (setf insts (append (find-derivable-instances) insts))))
13 
+    (compute-di-fixpoint insts)
14 
+    (dolist (inst insts)
15 
+      (when (instance-ok? inst)
16 
+        (create-instance-fns inst)
17 
+	(push inst (module-instance-defs
18 
+		    (table-entry *modules*
19 
+				 (def-module (instance-algdata inst)))))))))
20 
+
21 
+(define (compute-di-fixpoint insts)
22 
+  (setf *di-context-changed* '#f)
23 
+  (dolist (inst insts)
24 
+    (propagate-di-context inst))
25 
+  (when *di-context-changed* (compute-di-fixpoint insts)))
26 
+
27 
+;;; Create instance decls for all derived instances in a module.  Filter
28 
+;;; out underivable instances (Ix & Enum only)
29 
+
30 
+(define (find-derivable-instances)
31 
+  (let ((algs (module-alg-defs *module*))
32 
+	(insts '()))
33 
+    (dolist (alg algs)
34 
+      (dolist (class (algdata-deriving alg))
35 
+	 (cond ((memq class (list (core-symbol "Eq")
36 
+				  (core-symbol "Ord")
37 
+				  (core-symbol "Text")
38 
+				  (core-symbol "Binary")))
39 
+		(setf insts (add-derivable-instance insts alg class '#f)))
40 
+	       ((eq? class *printer-class*)
41 
+		(setf insts (add-derivable-instance
42 
+			     insts alg (core-symbol "Text") '#t)))
43 
+	       ((eq? class (core-symbol "Ix"))
44 
+		(if (or (algdata-enum? alg)
45 
+			(algdata-tuple? alg))
46 
+		    (setf insts (add-derivable-instance insts alg class '#f))
47 
+		    (signal-cant-derive-ix alg)))
48 
+	       ((eq? class (core-symbol "Enum"))
49 
+		(if (algdata-enum? alg)
50 
+		    (setf insts (add-derivable-instance insts alg class '#f))
51 
+		    (signal-cant-derive-enum alg)))
52 
+	       (else
53 
+		(signal-not-derivable class)))))
54 
+    insts))
55 
+
56 
+
57 
+(define (signal-cant-derive-ix alg)
58 
+  (phase-error 'cant-derive-IX
59 
+    "An Ix instance for ~A cannot be derived.  It is not an enumeration~%~
60 
+     or single-constructor datatype."
61 
+    alg))
62 
+
63 
+(define (signal-cant-derive-enum alg)
64 
+  (phase-error 'cant-derive-Enum
65 
+    "An Enum instance for ~A cannot be derived.  It is not an enumeration."
66 
+    alg))
67 
+
68 
+(define (signal-not-derivable class)
69 
+  (recoverable-error 'not-derivable
70 
+    "Class ~A is not one of the classes that permits derived instances."
71 
+    class))
72 
+
73 
+
74 
+;; This adds a provisional instance template.  Of course, there may already
75 
+;;; be an instance (error!)
76 
+
77 
+(define (add-derivable-instance insts alg cls sp)
78 
+  (let ((existing-inst (lookup-instance alg cls)))
79 
+    (cond ((eq? existing-inst '#f)
80 
+	   (let ((inst (new-instance cls alg (algdata-tyvars alg))))
81 
+	     (setf (instance-context inst) (algdata-context alg))
82 
+	     (setf (instance-decls inst) '())
83 
+	     (setf (instance-ok? inst) '#t)
84 
+	     (setf (instance-suppress-readers? inst) sp)
85 
+	     (cons inst insts)))
86 
+	  (else
87 
+	   (signal-instance-exists alg cls)
88 
+	   insts))))
89 
+
90 
+(define (signal-instance-exists alg cls)
91 
+  (recoverable-error 'instance-exists
92 
+    "An instance for type ~A in class ~A already exists;~%~
93 
+     the deriving clause is being ignored."
94 
+    alg cls))
95 
+
96 
+;;; This updates all instance contexts for an algdata.  Each derivable
97 
+;;; instance generates a recursive context for every field.  If a
98 
+;;; component cannot satisfy the desired context, the ok? field is set to
99 
+;;; #f to mark the instance as bogus.
100 
+
101 
+(define (propagate-di-context inst)
102 
+  (when (instance-ok? inst)
103 
+    (propagate-constructor-contexts inst
104 
+			   (algdata-constrs (instance-algdata inst)))))
105 
+
106 
+;;; These two functions propagate the context to ever field of every
107 
+;;; constructor
108 
+
109 
+(define (propagate-constructor-contexts inst constrs)
110 
+  (or (null? constrs)
111 
+      (and (propagate-contexts inst (instance-class inst)
112 
+			       (con-types (car constrs)))
113 
+	   (propagate-constructor-contexts inst (cdr constrs)))))
114 
+
115 
+(define (propagate-contexts inst class types)
116 
+  (or (null? types)
117 
+      (and (propagate-type-context inst class (car types))
118 
+	   (propagate-contexts inst class (cdr types)))))
119 
+
120 
+;;; This propagates a context out to a given type.  The type can only contain
121 
+;;; the tyvars which are args to the algdata.
122 
+
123 
+(define (propagate-type-context inst class type)
124 
+  (cond ((tyvar? type)
125 
+	 (cond ((single-ast-context-implies?
126 
+		   (instance-context inst) class (tyvar-name type))
127 
+		'#t)
128 
+	       (else
129 
+		(setf *di-context-changed* '#t)
130 
+		(setf (instance-context inst)
131 
+		      (augment-context (instance-context inst) class
132 
+				       (tyvar-name type)))
133 
+		'#t)))
134 
+	((synonym? (tycon-def type))
135 
+	 (propagate-type-context inst class (expand-synonym type)))
136 
+	(else
137 
+	 (let* ((algdata (tycon-def type))  ; must be a algdata
138 
+	        (args (tycon-args type))
139 
+		(new-inst (lookup-instance algdata class)))
140 
+	   (cond ((or (eq? new-inst '#f)
141 
+		      (not (instance-ok? new-inst)))
142 
+		  (signal-cannot-derive-instance
143 
+		    (instance-class inst) (instance-algdata inst))
144 
+		  (setf (instance-ok? inst) '#f)
145 
+		  (setf *di-context-changed* '#t)
146 
+		  '#f)
147 
+		 (else
148 
+		  (propagate-instance-contexts inst
149 
+				      (instance-context new-inst)
150 
+				      (instance-tyvars new-inst)
151 
+				      args)))))))
152 
+
153 
+
154 
+(define (single-ast-context-implies? ast-context class tyvar)
155 
+  (cond ((null? ast-context)
156 
+	 '#f)
157 
+	((eq? tyvar (context-tyvar (car ast-context)))
158 
+	 (let ((class1 (class-ref-class (context-class (car ast-context)))))
159 
+	   (or (eq? class1 class)
160 
+	       (memq class (class-super* class1))
161 
+	       (single-ast-context-implies? (cdr ast-context) class tyvar))))
162 
+	(else
163 
+	 (single-ast-context-implies? (cdr ast-context) class tyvar))))
164 
+
165 
+;;; *** This message makes no sense to me.  What is the problem that
166 
+;;; *** makes it impossible to derive the instance?
167 
+
168 
+(define (signal-cannot-derive-instance class alg)
169 
+  (phase-error 'cannot-derive-instance
170 
+    "Instance ~A(~A) cannot be derived."
171 
+    class alg))
172 
+
173 
+
174 
+;;; This propagates contexts into structure components.  The context
175 
+;;; changes due to the context associated with the various instance
176 
+;;; decls encountered.
177 
+
178 
+;;; Here's the plan for expanding Cls(Alg t1 t2 .. tn) using
179 
+;;; instance (Cls1(vx),Cls2(vy),...) => Cls(Alg(v1 v2 .. vn))
180 
+;;;   for each Clsx in the instance context, propagate Clsx to the
181 
+;;;   ti corresponding to vx, where vx must be in the set vi.
182 
+
183 
+(define (propagate-instance-contexts inst contexts tyvars args)
184 
+  (or (null? contexts)
185 
+      (and (propagate-type-context inst
186 
+	      (class-ref-class (context-class (car contexts)))
187 
+	      (find-corresponding-tyvar
188 
+	       (context-tyvar (car contexts)) tyvars args))
189 
+	   (propagate-instance-contexts inst (cdr contexts) tyvars args))))
190 
+
191 
+;;; Given the t(i) and the v(i), return the t corresponding to a v.
192 
+
193 
+(define (find-corresponding-tyvar tyvar tyvars args)
194 
+  (if (eq? tyvar (car tyvars))
195 
+      (car args)
196 
+      (find-corresponding-tyvar tyvar (cdr tyvars) (cdr args))))
197 
+
198 
+;;; 1 level type synonym expansion
199 
+
200 
+(define (expand-synonym type)
201 
+  (let* ((synonym (tycon-def type))
202 
+	 (args (synonym-args synonym))
203 
+	 (body (synonym-body synonym)))
204 
+  (let ((alist (map (lambda (tyvar arg) (tuple tyvar arg))
205 
+		    args (tycon-args type))))
206 
+    (copy-synonym-body body alist))))
207 
+
208 
+(define (copy-synonym-body type alist)
209 
+  (if (tyvar? type)
210 
+      (tuple-2-2 (assq (tyvar-name type) alist))
211 
+      (make tycon (def (tycon-def type))
212 
+	          (name (tycon-name type))
213 
+		  (args (map (lambda (ty)
214 
+			       (copy-synonym-body ty alist))
215 
+			     (tycon-args type))))))
216 
+
217 
+;;; This fills in the body decls for an instance function.
218 
+
219 
+(define (create-instance-fns inst)
220 
+  (let ((class (instance-class inst))
221 
+	(alg (instance-algdata inst)))
222 
+    (cond ((eq? class (core-symbol "Eq"))
223 
+	   (add-instance inst (eq-fns alg)))
224 
+	  ((eq? class (core-symbol "Ord"))
225 
+	   (add-instance inst (ord-fns alg)))
226 
+	  ((eq? class (core-symbol "Ix"))
227 
+	   (add-instance inst (ix-fns alg)))
228 
+	  ((eq? class (core-symbol "Enum"))
229 
+	   (add-instance inst (enum-fns alg)))
230 
+	  ((eq? class (core-symbol "Text"))
231 
+	   (add-instance inst (text-fns alg (instance-suppress-readers? inst))))
232 
+	  ((eq? class (core-symbol "Binary"))
233 
+	   (add-instance inst (binary-fns alg))))))
234 
+
235 
+(define (add-instance inst decls)
236 
+  (setf (instance-decls inst) decls))
237 
+
238 
+;;; Add class(var) to a context, removing any contexts made redundant by
239 
+;;; the new addition.  Example: adding Ord a to (Eq a, Eq b) would yield
240 
+;;; (Ord a,Eq b).
241 
+
242 
+(define (augment-context contexts cl var)
243 
+  (cons (**context (**class/def cl) var)
244 
+	(remove-implied-contexts cl var contexts)))
245 
+
246 
+(define (remove-implied-contexts class1 tyvar1 contexts)
247 
+  (if (null? contexts)
248 
+      '#f
249 
+      (with-slots context (class tyvar) (car contexts)
250 
+	(let ((rest (remove-implied-contexts class1 tyvar1 (cdr contexts)))
251 
+	      (class2 (class-ref-class class)))
252 
+	  (if (and (eq? tyvar1 tyvar)
253 
+		   (memq class2 (class-super* class1)))
254 
+	      rest
255 
+	      (cons (car contexts) rest))))))
derived/derived.scm
History View file @ 4e98702
0 256 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+;;; -- compilation unit definition for derived instances
2 
+;;;
3 
+;;; author :  John
4 
+;;;
5 
+
6 
+(define-compilation-unit derived
7 
+  (source-filename "$Y2/derived/")
8 
+  (require global)
9 
+  (unit derived-instances
10 
+    (source-filename "derived-instances.scm"))
11 
+  (unit ast-builders
12 
+    (source-filename "ast-builders"))
13 
+  (unit eq-ord
14 
+    (source-filename "eq-ord"))
15 
+  (unit ix-enum
16 
+    (source-filename "ix-enum"))
17 
+  (unit text-binary
18 
+    (source-filename "text-binary"))
19 
+  )
20 
+
21 
+
derived/eq-ord.scm
History View file @ 4e98702
0 22 
new file mode 100644
... ... 
@@ -0,0 +1,69 @@
1 
+;;; ----------------------------------------------------------------
2 
+;;;  Eq
3 
+;;; ----------------------------------------------------------------
4 
+
5 
+(define (Eq-fns algdata)
6 
+  (list
7 
+   (cond ((algdata-enum? algdata)
8 
+	  (**define '== '(|x| |y|)
9 
+		    (**== (**con-number (**var '|x|) algdata)
10 
+			  (**con-number (**var '|y|) algdata))))
11 
+	 (else
12 
+	  (**multi-define '== algdata
13 
+			  ;; For nullary constructors
14 
+			  (function **true)
15 
+			  ;; For unary constructors
16 
+			  (lambda (v1 v2)
17 
+			    (**== (funcall v1) (funcall v2)))
18 
+			  ;; For n-ary constructors
19 
+			  (lambda (v1 v2 bool)
20 
+			    (**and (**== (funcall v1) (funcall v2)) bool))
21 
+			  ;; The else clause in case the constructors do
22 
+			  ;; not match.
23 
+			  (if (algdata-tuple? algdata)
24 
+			      '#f
25 
+			      (function **false)))))))
26 
+
27 
+;;; ----------------------------------------------------------------
28 
+;;;  Ord
29 
+;;; ----------------------------------------------------------------
30 
+
31 
+(define (Ord-fns algdata)
32 
+  (list (ord-fn1 algdata '< (function **<))
33 
+	(ord-fn1 algdata '<= (function **<=))))
34 
+
35 
+(define (Ord-fn1 algdata fn prim)
36 
+  (cond ((algdata-enum? algdata)
37 
+	 (**define fn '(|x| |y|)
38 
+		       (funcall prim (**con-number (**var '|x|) algdata)
39 
+				     (**con-number (**var '|y|) algdata))))
40 
+	((algdata-tuple? algdata)
41 
+	 (**multi-define fn algdata
42 
+		         (function **false)
43 
+			 (lambda (x y) (funcall prim (funcall x) (funcall y)))
44 
+			 (function combine-eq-<)
45 
+			 '#f))
46 
+	(else
47 
+	 (**define fn '(|x| |y|)
48 
+	   (**let
49 
+	    (list
50 
+	     (**multi-define '|inner| algdata
51 
+			       (if (eq? fn '<) (function **false)
52 
+				               (function **true))
53 
+			       (lambda (x y)
54 
+				 (funcall prim (funcall x) (funcall y)))
55 
+			       (function combine-eq-<)
56 
+			       '#f)
57 
+	     (**define '|cx| '() (**con-number (**var '|x|) algdata))
58 
+	     (**define '|cy| '() (**con-number (**var '|y|) algdata)))
59 
+	    (**or (**< (**var '|cx|) (**var '|cy|))
60 
+		  (**and (**== (**var `|cx|) (**var '|cy|))
61 
+			 (**app (**var '|inner|)
62 
+				(**var '|x|)
63 
+				(**var '|y|)))))))))
64 
+
65 
+(define (combine-eq-< v1 v2 rest)
66 
+  (**or (**< (funcall v1) (funcall v2))
67 
+	(**and (**== (funcall v1) (funcall v2))
68 
+	       rest)))
69 
+
derived/ix-enum.scm
History View file @ 4e98702
0 70 
new file mode 100644
... ... 
@@ -0,0 +1,116 @@
1 
+;;; ----------------------------------------------------------------
2 
+;;;  Ix
3 
+;;; ----------------------------------------------------------------
4 
+
5 
+(define (ix-fns algdata)
6 
+  (if (algdata-enum? algdata)
7 
+      (ix-fns/enum algdata)
8 
+      (ix-fns/tuple algdata)))
9 
+
10 
+(define (ix-fns/enum algdata)
11 
+ (list
12 
+   (**define '|range| '((tuple |l| |u|))
13 
+     (**let
14 
+      (list
15 
+       (**define '|cl| '() (**con-number (**var '|l|) algdata))
16 
+       (**define '|cu| '() (**con-number (**var '|u|) algdata)))
17 
+      (**if (**< (**var '|cu|) (**var '|cl|))
18 
+	    (**null)
19 
+	    (**take (**+ (**- (**var '|cu|) (**var '|cl|)) (**int 1))
20 
+		    (**drop (**var '|cl|)
21 
+		      (**list/l
22 
+		       (map (function **con/def)
23 
+			    (algdata-constrs algdata))))))))
24 
+   (**define '|index| '((tuple |l| |u|) |x|)
25 
+      (**- (**con-number (**var '|x|) algdata)
26 
+	   (**con-number (**var '|l|) algdata)))
27 
+   (**define '|inRange| '((tuple |l| |u|) |x|)
28 
+      (**and (**<= (**con-number (**var '|l|) algdata)
29 
+		   (**con-number (**var '|x|) algdata))
30 
+	     (**<= (**con-number (**var '|x|) algdata)
31 
+		   (**con-number (**var '|u|) algdata))))))
32 
+
33 
+(define (ix-fns/tuple algdata)
34 
+  (let* ((con (tuple-con algdata))
35 
+	 (arity (con-arity con))
36 
+	 (llist (temp-vars "l" arity))
37 
+	 (ulist (temp-vars "u" arity))
38 
+	 (ilist (temp-vars "i" arity)))
39 
+   (list
40 
+    (**define '|range| `((tuple (,con ,@llist) (,con ,@ulist)))
41 
+      (**listcomp (**app/l (**con/def con) (map (function **var) ilist))
42 
+		  (map (lambda (iv lv uv)
43 
+			  (**gen iv
44 
+			       (**app (**var '|range|)
45 
+				      (**tuple2 (**var lv)
46 
+						(**var uv)))))
47 
+			ilist llist ulist)))
48 
+    (**define '|index| `((tuple (,con ,@llist) (,con ,@ulist))
49 
+			 (,con ,@ilist))
50 
+	  (index-body (reverse ilist) (reverse llist) (reverse ulist)))
51 
+    (**define '|inRange| `((tuple (,con ,@llist) (,con ,@ulist))
52 
+			   (,con ,@ilist))
53 
+		(inrange-body ilist llist ulist)))))
54 
+
55 
+(define (index-body is ls us)
56 
+  (let ((i1 (**app (**var '|index|)
57 
+		   (**tuple2 (**var (car ls)) (**var (car us)))
58 
+		   (**var (car is)))))
59 
+    (if (null? (cdr is))
60 
+	i1
61 
+	(**app (**var '|+|)
62 
+	       i1 (**app (**var '|*|)
63 
+			 (**1+ (**app (**var '|index|)
64 
+				      (**tuple2 (**var (car ls))
65 
+						(**var (car us)))
66 
+				      (**var (car us))))
67 
+			 (index-body (cdr is) (cdr ls) (cdr us)))))))
68 
+
69 
+(define (inrange-body is ls us)
70 
+  (let ((i1 (**app (**var '|inRange|)
71 
+		   (**tuple2 (**var (car ls)) (**var (car us)))
72 
+		   (**var (car is)))))
73 
+    (if (null? (cdr is))
74 
+	i1
75 
+	(**app (**var/def (core-symbol "&&"))
76 
+	       i1
77 
+	       (inrange-body (cdr is) (cdr ls) (cdr us))))))
78 
+
79 
+;;; ----------------------------------------------------------------
80 
+;;;  Enum
81 
+;;; ----------------------------------------------------------------
82 
+
83 
+; Enum uses the Int methods since Enums are represented as Ints.
84 
+
85 
+(define (enum-fns algdata)
86 
+  (list
87 
+   (**define '|enumFrom| '(|x|)
88 
+       (**let
89 
+	 (list
90 
+	  (**define '|from'| '(|x'|)
91 
+	      (**if (**> (**var '|x'|)
92 
+			 (**con-number (**con/def (last-con algdata)) algdata))
93 
+		    (**null)
94 
+		    (**cons (**var '|x'|)
95 
+			    (**app (**var '|from'|) (**1+ (**var '|x'|)))))))
96 
+	 (**cast (**app (**var '|from'|)
97 
+			(**con-number (**var '|x|) algdata)))))
98 
+   (**define '|enumFromThen| '(|x| |y|)
99 
+     (**let
100 
+      (list
101 
+       (**define '|step| '()
102 
+	 (**- (**con-number (**var '|y|) algdata)
103 
+	      (**con-number (**var '|x|) algdata)))
104 
+       (**define '|from'| '(|x'|)
105 
+	(**if (**or (**> (**var '|x'|)
106 
+			 (**con-number (**con/def (last-con algdata)) algdata))
107 
+		    (**< (**var '|x'|) (**int 0)))
108 
+	      (**null)
109 
+	      (**cons (**var '|x'|)
110 
+		      (**app (**var '|from'|)
111 
+			     (**+ (**var '|x'|) (**var '|step|)))))))
112 
+      (**cast (**app (**var '|from'|) (**con-number (**var '|x|) algdata)))))))
113 
+
114 
+(define (last-con algdata)
115 
+  (car (reverse (algdata-constrs algdata))))
116 
+
derived/text-binary.scm
History View file @ 4e98702
0 117 
new file mode 100644
... ... 
@@ -0,0 +1,228 @@
1 
+;;; ----------------------------------------------------------------
2 
+;;;  Text
3 
+;;; ----------------------------------------------------------------
4 
+
5 
+(define (text-fns algdata suppress-reader?)
6 
+  (let ((print+read
7 
+	 (cond ((algdata-enum? algdata)
8 
+		(text-enum-fns algdata))
9 
+	       (else
10 
+		(text-general-fns algdata)))))
11 
+    (when suppress-reader?
12 
+      (setf print+read (list (car print+read))))
13 
+    print+read))
14 
+
15 
+(define (text-enum-fns algdata)
16 
+  (list
17 
+   (**define '|showsPrec| '(|d| |x|)
18 
+      (**case/con algdata (**var '|x|)
19 
+		  (lambda (con vars)
20 
+		     (declare (ignore vars))
21 
+		     (**showString (**string (con-string con))))))
22 
+   (**define '|readsPrec| '(|d| |str|)
23 
+     (**listcomp
24 
+      (**var '|s|)
25 
+      (list
26 
+       (**gen '(tuple |tok| |rest|) (**lex (**var '|str|)))
27 
+       (**gen '|s|
28 
+	      (**case (**var '|tok|)
29 
+		      `(,@(map (lambda (con)
30 
+				 (**alt/simple
31 
+				  (**pat (con-string con))
32 
+				  (**list (**tuple2 (**con/def con)
33 
+						    (**var '|rest|)))))
34 
+			       (algdata-constrs algdata))
35 
+			,(**alt/simple (**pat '_) (**null))))))))))
36 
+
37 
+;;; This has been hacked to split up the read function for large
38 
+;;; data types to avoid choking the lisp compiler.
39 
+
40 
+(define (text-general-fns algdata)
41 
+ (let ((split-fn-def? (> (algdata-n-constr algdata) 6)))  ;; pretty arbitrary!
42 
+  (list
43 
+   (**define '|showsPrec| '(|d| |x|)
44 
+       (**case/con algdata (**var '|x|)
45 
+	  (lambda (con vars)
46 
+	    (if (con-infix? con)
47 
+		(show-infix con vars)
48 
+		(show-prefix con vars)))))
49 
+   (**define '|readsPrec| '(|d| |str|)
50 
+     (**append/l
51 
+      (map (lambda (con)
52 
+	     (cond ((con-infix? con)
53 
+		    (read-infix con))
54 
+		   (else
55 
+		    (read-prefix con split-fn-def?))))
56 
+		 (algdata-constrs algdata)))))))
57 
+
58 
+(define (show-infix con vars)
59 
+  (multiple-value-bind (p lp rp) (get-con-fixity con)
60 
+    (**showParen
61 
+     (**< (**Int p) (**var '|d|))
62 
+     (**dot (**showsPrec (**int lp) (**var (car vars)))
63 
+	    (**showString
64 
+	      (**string (string-append " " (con-string con) " ")))
65 
+	    (**showsPrec (**int rp) (**var (cadr vars)))))))
66 
+
67 
+(define (show-prefix con vars)
68 
+  (**showParen
69 
+   (**<= (**int 10) (**var '|d|))
70 
+   (**dot/l (**showString (**string (con-string con)))
71 
+	    (show-fields vars))))
72 
+
73 
+(define (show-fields vars)
74 
+  (if (null? vars)
75 
+      '()
76 
+      `(,(**space) ,(**showsPrec (**int 10) (**var (car vars)))
77 
+	,@(show-fields (cdr vars)))))
78 
+
79 
+(define (read-infix con)
80 
+  (multiple-value-bind (p lp rp) (get-con-fixity con)
81 
+    (**let
82 
+     (list
83 
+      (**define '|readVal| '(|r|)
84 
+	 (**listcomp
85 
+	  (**tuple2 (**app (**con/def con) (**var '|u|) (**var '|v|))
86 
+		    (**var '|s2|))
87 
+	  (list
88 
+	   (**gen '(tuple |u| |s0|)
89 
+		  (**readsPrec (**int lp) (**var '|r|)))
90 
+	   (**gen `(tuple ,(con-string con) |s1|)
91 
+		  (**lex (**var '|s0|)))
92 
+	   (**gen '(tuple |v| |s2|)
93 
+		  (**readsprec (**int rp) (**var '|s1|)))))))
94 
+     (**readParen (**< (**int p) (**var '|d|))
95 
+		  (**var '|readVal|) (**var '|str|)))))
96 
+
97 
+(define (read-prefix con split?)
98 
+  (let ((res (read-prefix-1 con)))
99 
+    (if (not split?)
100 
+	res
101 
+	(dynamic-let ((*module-name* (def-module con)))
102 
+	 (dynamic-let ((*module* (table-entry *modules* *module-name*)))
103 
+  	  (let* ((alg (con-alg con))
104 
+		 (fn (make-new-var
105 
+		      (string-append (symbol->string (def-name alg))
106 
+				     "/read-"
107 
+				     (remove-con-prefix
108 
+				      (symbol->string (def-name con))))))
109 
+		 (new-code (**app (**var/def fn) (**var '|str|) (**var '|d|)))
110 
+		 (def (**define fn '(|str| |d|) res)))
111 
+	  (setf (module-decls *module*) (cons def (module-decls *module*)))
112 
+	  new-code))))))
113 
+
114 
+(define (read-prefix-1 con)
115 
+  (let* ((arity (con-arity con))
116 
+	 (vars (temp-vars "x" arity))
117 
+	 (svars (cons '|rest| (temp-vars "s" arity))))
118 
+    (**let
119 
+     (list
120 
+      (**define '|readVal| '(|r|)
121 
+        (**listcomp
122 
+	 (**tuple2 (**app/l (**con/def con) (map (function **var) vars))
123 
+		   (**var (car (reverse svars))))
124 
+	 (cons
125 
+	  (**gen `(tuple ,(con-string con) |rest|)
126 
+		 (**lex (**var '|r|)))
127 
+	  (read-fields vars svars (cdr svars))))))
128 
+     (**readParen (**< (**int 9) (**var '|d|))
129 
+		  (**var '|readVal|) (**var '|str|)))))
130 
+
131 
+(define (read-fields vars s0 s1)
132 
+  (if (null? vars)
133 
+      '()
134 
+      (cons
135 
+       (**gen `(tuple ,(car vars) ,(car s1))
136 
+	      (**readsprec (**int 10) (**var (car s0))))
137 
+       (read-fields (cdr vars) (cdr s0) (cdr s1)))))
138 
+
139 
+
140 
+;;; ----------------------------------------------------------------
141 
+;;;  Binary
142 
+;;; ----------------------------------------------------------------
143 
+
144 
+(define (binary-fns algdata)
145 
+ (let ((res
146 
+  (cond ((algdata-enum? algdata)
147 
+	 (binary-enum-fns algdata))
148 
+	((algdata-tuple? algdata)
149 
+	 (binary-tuple-fns algdata))
150 
+	(else
151 
+	 (binary-general-fns algdata)))))
152 
+;   (dolist (x res)
153 
+;       (fresh-line)
154 
+;       (pprint x))
155 
+   res))
156 
+
157 
+
158 
+(define (binary-enum-fns algdata)
159 
+  (list
160 
+    (**define '|showBin| '(|x| |b|)
161 
+	(**showBinInt (**con-number (**var '|x|) algdata) (**var '|b|)))
162 
+    (**define '|readBin| '(|b|)
163 
+      (**let
164 
+       (list
165 
+	(**define '(tuple |n| |b1|) '()
166 
+	   (**readBinSmallInt
167 
+	    (**var '|b|)
168 
+	    (**int (1- (algdata-n-constr algdata))))))
169 
+        (**tuple2
170 
+	 (**case/int algdata (**var '|n|)
171 
+	       (lambda (con)
172 
+		 (**con/def con)))
173 
+	 (**var '|b1|))))))
174 
+
175 
+(define (binary-tuple-fns algdata)
176 
+  (let* ((con (tuple-con algdata))
177 
+	 (arity (con-arity con))
178 
+	 (vars (temp-vars "v" arity)))
179 
+    (list
180 
+      (**define '|showBin| `((,con ,@vars) |b|)
181 
+	  (show-binary-body vars '|b|))
182 
+      (**define '|readBin| '(|b|)
183 
+	  (read-binary-body con)))))
184 
+
185 
+(define (show-binary-body vars b)
186 
+  (**foldr (lambda (new-term prev-terms)
187 
+	       (**showBin new-term prev-terms))
188 
+	   (map (function **var) vars)
189 
+	   (**var b)))
190 
+
191 
+(define (read-binary-body con)
192 
+  (let* ((arity (con-arity con))
193 
+	 (vars (temp-vars "v" arity))
194 
+	 (bvars (cons '|b| (temp-vars "b" arity))))
195 
+    (**let
196 
+     (map (lambda (v b nb)
197 
+	    (**define `(tuple ,v ,nb) '()
198 
+		      (**readBin (**var b))))
199 
+	  vars bvars (cdr bvars))
200 
+     (**tuple2
201 
+      (**app/l (**con/def con)
202 
+	       (map (function **var) vars))
203 
+      (**var (car (reverse bvars)))))))
204 
+
205 
+(define (binary-general-fns algdata)
206 
+  (list
207 
+    (**define '|showBin| '(|x| |b|)
208 
+      (**showBinInt
209 
+       (**con-number (**var '|x|) algdata)
210 
+       (**case/con algdata (**var '|x|)
211 
+	  (lambda (con vars)
212 
+	    (declare (ignore con))
213 
+	    (show-binary-body vars '|b|)))))
214 
+    (**define '|readBin| '(|bin|)
215 
+      (**let
216 
+       (list
217 
+	(**define '(tuple |i| |b|) '()
218 
+	 (**readBinSmallInt (**var '|bin|)
219 
+			    (**int (1- (algdata-n-constr algdata))))))
220 
+       (**case/int algdata (**var '|i|) (function read-binary-body))))))
221 
+
222 
+(define (get-con-fixity con)
223 
+  (let ((fixity (con-fixity con)))
224 
+    (if (not (eq? fixity '#f))
225 
+	(let ((p (fixity-precedence fixity))
226 
+	      (a (fixity-associativity fixity)))
227 
+	  (values p (if (eq? a 'L) p (1+ p)) (if (eq? a 'R) p (1+ p))))
228 
+	(values 9 10 9))))
doc/announcement
History View file @ 4e98702
0 229 
new file mode 100644
... ... 
@@ -0,0 +1,64 @@
1 
+
2 
+      Announcing the release of Yale Haskell 2.0.5
3 
+
4 
+We are releasing the latest version of the Yale Haskell system,
5 
+Y2.0.5, in source form.  This fixes a number of minor problems in the
6 
+2.0.5a release (for Sparc only) and should be relatively bug free.
7 
+
8 
+Yale Haskell can be built from sources using CMU Common Lisp, Lucid
9 
+Common Lisp, Allegro Common Lisp, or Harlequin LispWorks.  The system
10 
+may also build on akcl but the performance is very poor.
11 
+
12 
+Compiled versions of the system are available for Sparc systems running
13 
+SunOS 4.1.2 and Sparc 10's (sun4m) running 4.1.3.  Anyone building a system
14 
+using CMU lisp on a different platform should let us know and we will
15 
+add more executables to the ftp area.  Look at the README for further
16 
+information.
17 
+
18 
+This release features an X window interface.  Using CLX, the full
19 
+functionality of X windows has been made available at the Haskell
20 
+level.  There is also a Haskell <-> Lisp interface similar to the C
21 
+interface in the Glasgow system.
22 
+
23 
+
24 
+Our system is available for anonymous ftp from the Yale Haskell ftp site:
25 
+
26 
+        Site     Host name              Raw IP address
27 
+        Yale     nebula.cs.yale.edu     128.36.13.1
28 
+
29 
+All files are in the directory pub/haskell/yale.
30 
+
31 
+haskell-source-205.tar.gz   -- The full sources
32 
+haskell-205-<machine+OS>.tar.gz
33 
+Compiling from scratch will take an hour or two, depending on system
34 
+resources.  The file $HASKELL/com/<your-lisp>/README will contain
35 
+complete building instructions.
36 
+
37 
+To obtain Yale Haskell via ftp:
38 
+
39 
+  - Move to the directory where you intend to place Yale Haskell
40 
+  - Ftp to nebula and login anonymously
41 
+  - cd to pub/haskell/yale
42 
+  - Get the tar file: get haskell-source-205.tar.gz (a .Z file is available
43 
+    for those without gzip).
44 
+  - Unzip the file: (your zip utility may have a different name)
45 
+           gzip -d *.gz
46 
+  - Untar the file: tar xf *.tar
47 
+  - Consult the documentation for further instructions.  Either print
48 
+    out the reference manual in doc/manual/haskell.dvi or look at
49 
+    install.verb in the same directory.
50 
+
51 
+Send any comments or questions to haskell-request@cs.yale.edu
52 
+
53 
+
54 
+New features in this release include:
55 
+
56 
+  * Much better optimization
57 
+  * Monadic I/O
58 
+  * A general Haskell to Lisp interface
59 
+  * An X window interface
60 
+  * Strictness annotations and strict data constructors
61 
+  * Lots of bugs fixed
62 
+  * Improvements to the tutorial and Emacs interface
63 
+  * Ported to all major Lisp systems
64 
+
doc/comparison
History View file @ 4e98702
0 65 
new file mode 100644
... ... 
@@ -0,0 +1,291 @@
1 
+
2 
+         Different Versions of Yale Haskell Compared
3 
+         -------------------------------------------
4 
+
5 
+
6 
+There are currently three different platforms running Yale Haskell.
7 
+Yale Haskell runs on Lucid Common Lisp, CMU Common Lisp, and AKCL.  This
8 
+document describes the differences between these systems.
9 
+
10 
+Differences in performance between the different versions of Yale
11 
+Haskell reflect the underlying Lisp systems.  The better the Lisp
12 
+system, the better the Haskell system built on it.  However, getting
13 
+optimal performance from our Haskell system on top of a Common Lisp
14 
+system requires careful attention to the underlying compiler.  Small
15 
+changes in the optimization settings or the addition of crucial
16 
+declarations can make significant differences in performance.  We have
17 
+been doing most of our work using the Lucid system and have tuned it
18 
+more than the others.  These comparisons are greatly influenced by the
19 
+amount of time we have spent tuning the system: the CMU version has
20 
+been tuned only a little and the AKCL version hardly at all.
21 
+
22 
+
23 
+  Methodology
24 
+
25 
+The following timings are only approximate.  They were obtained using
26 
+the timing functions provided by the Common Lisp system.  All timings
27 
+were done on an unloaded Sparc 1.  No attempt was made to account for
28 
+garbage collection, differences in heap size, or similar factors.  We
29 
+don't intend these benchmark results to be taken as an exhaustive
30 
+comparison of the different Lisp implementations involved.
31 
+
32 
+
33 
+  Portability
34 
+
35 
+We have had no trouble moving our system to different hardware
36 
+platforms under the same Lisp system.  Since the release is in source
37 
+form, we expect that users will be able to build on any hardware
38 
+platform supported by one the Lisps we have ported to.  Probably the
39 
+only real constraint on portability is the requirement for a large
40 
+virtual memory space.
41 
+
42 
+From the comp.lang.lisp FAQ:
43 
+
44 
+  Lucid Common Lisp runs on a variety of platforms, including PCs (AIX),
45 
+  Apollo, HP, Sun-3, Sparc, IBM RT, IBM RS/6000, Decstation 3100,
46 
+  Silicon Graphics, and Vax.
47 
+
48 
+  CMU Common Lisp is free, and runs on Sparcs (Mach and SunOs),
49 
+  DecStation 3100 (Mach), IBM RT (Mach) and requires 16mb RAM, 25mb disk.
50 
+
51 
+  Kyoto Common Lisp (KCL) is free, but requires a license. Conforms to CLtL1.
52 
+  It is available by anonymous ftp from rascal.ics.utexas.edu [128.83.138.20],
53 
+  cli.com [192.31.85.1], or [133.11.11.11] (a machine in Japan)
54 
+  in the directory /pub.  AKCL is in the file akcl-xxx.tar.Z (take the
55 
+  highest value of xxx).  To obtain KCL, one  must first sign and mail a
56 
+  copy of the license agreement to: Special Interest Group in LISP,
57 
+  c/o Taiichi Yuasa, Department of Computer Science,  Toyohashi
58 
+  University of Technology, Toyohashi 441, JAPAN. Runs on Sparc,
59 
+  IBM RT, RS/6000, DecStation 3100, hp300, hp800, Macintosh II (under AUX),
60 
+  mp386, IBM PS2, Silicon Graphics 4d, Sun3, Sun4, Sequent Symmetry,
61 
+  IBM 370, NeXT and Vax. A port to DOS is in beta test as
62 
+  math.utexas.edu:pub/beta2.zip.
63 
+
64 
+We have not yet completed ports of Yale Haskell to any other Lisp
65 
+implementations, although we are likely to do so in the future.
66 
+
67 
+
68 
+ System Size
69 
+
70 
+The overall size of the Haskell system depends on the size of the
71 
+underlying Lisp system and how much unnecessary Lisp overhead has been
72 
+removed for the system.  We have removed large Lisp packages (like
73 
+CLOS or CLX), but have not attempted to do any tree shaking.  The size
74 
+of the saved images (including the Lisp system, the Haskell compiler,
75 
+and the compiled prelude) is
76 
+
77 
+Image Size:
78 
+
79 
+Lucid   10 meg
80 
+CMU     18 meg
81 
+AKCL    11 meg
82 
+
83 
+The larger size of the CMU system is probably an artifact of their way
84 
+of saving the system.
85 
+
86 
+
87 
+  Compilation Time
88 
+
89 
+There are three possible ways to compile a Haskell program.  All
90 
+Haskell programs must be translated into Lisp.  The generated Lisp can
91 
+then be interpreted, using no additional compilation time; compiled
92 
+with a `fast' but nonoptimizing Lisp compiler; or compiled with the
93 
+`slow' compiler that aggressively attempts to perform as many
94 
+optimizations as possible.
95 
+
96 
+To time the `fast', nonoptimizing compiler, we have been using
97 
+
98 
+(PROCLAIM '(OPTIMIZE (SPEED 3) (SAFETY 0) (COMPILATION-SPEED 3)))
99 
+
100 
+and for the `slow', fully optimizing compiler, we have been using
101 
+
102 
+(PROCLAIM '(OPTIMIZE (SPEED 3) (SAFETY 0) (COMPILATION-SPEED 0)))
103 
+
104 
+so that the only difference is in the COMPILATION-SPEED quality.
105 
+Lucid does, in fact, provide two completely different compilers that
106 
+correspond to these optimize settings.  For all three implementations,
107 
+it appears that that the effect of a higher compilation speed setting
108 
+is primarily in being less aggressive about inlining and making use of
109 
+type declarations.
110 
+
111 
+The Haskell system itself (including the Prelude) is normally built
112 
+with the fully optimizing compiler.
113 
+
114 
+To show just the Haskell to Lisp compilation time, here are the times
115 
+needed to compile the Prelude (about 2500 lines of Haskell code).
116 
+This does not include the time in the Lisp compiler or starting up the
117 
+system.
118 
+
119 
+Time to compile the Prelude into Lisp: (CPU times)
120 
+
121 
+Lucid     111 sec
122 
+CMU       87  sec
123 
+AKCL      576 sec
124 
+
125 
+Running the Lisp compiler on the generated code takes far longer than
126 
+running the Haskell compiler to produce the Lisp code.  For example,
127 
+the optimizing Lucid compiler takes 47 minutes to compile the Prelude
128 
+(about x20 slower than Haskell -> Lisp).  The nonoptimizing compiler
129 
+is significantly faster but generates poorer code.
130 
+
131 
+The following times are the Lisp compilation time for the Prolog
132 
+interpreter (found in the demo directory of our release):
133 
+
134 
+Lucid - interpreted     8.8 sec  Haskell -> Lisp
135 
+Lucid - nonopt         20.0 sec  Lisp -> Machine code
136 
+Lucid - optimizing    320.0 sec  Lisp -> Machine code
137 
+CMU - interpreted      12.4 sec  Haskell -> Lisp
138 
+CMU - nonopt          121.0 sec  Lisp -> Machine code
139 
+CMU - optimizing      152.8 sec  Lisp -> Machine code
140 
+AKCL - interpreted     47.8 sec  Haskell -> Lisp
141 
+AKCL - nonopt          ~180 sec  Lisp -> Machine code
142 
+AKCL - optimizing      ~360 sec  Lisp -> Machine code
143 
+
144 
+The AKCL timings are only approximate, because the Lisp timing
145 
+functions do not capture the time spent in the C compiler.
146 
+
147 
+
148 
+Code Speed
149 
+
150 
+The speed of the Haskell program depends on whether the Lisp code
151 
+has been compiled with the optimizing or nonoptimizing compiler, or
152 
+is running interpretively.
153 
+
154 
+The first benchmark is nfib, which indicates the basic speed of
155 
+function calling and Int arithmetic.
156 
+
157 
+module Main where
158 
+
159 
+nfib :: Int -> Int
160 
+nfib 0 = 1
161 
+nfib 1 = 1
162 
+nfib n = nfib (n-1) + nfib (n-2)
163 
+
164 
+
165 
+                             nfib 20            nfib 30
166 
+Lucid (Interpreted)          116 sec            *
167 
+Lucid (nonopt)               0.14 sec           9.4 sec
168 
+Lucid (optimizing)           0.08 sec           4.8 sec
169 
+CMU (Interpreted)            23.8 sec           *
170 
+CMU (nonopt)                 0.24 sec           6.9 sec
171 
+CMU (optimizing)             0.11 sec           7.0 sec
172 
+AKCL (Interpreted)           141 sec            *
173 
+AKCL (nonopt)                0.20 sec           21.3 sec
174 
+AKCL (optimizing)            0.15 sec           18.2 sec
175 
+
176 
+* Too slow to benchmark
177 
+
178 
+For other data types, there was no significant difference betwen
179 
+optimizing and nonoptimizing compilation in any of the systems.
180 
+Changing the signature of nfib to Integer -> Integer:
181 
+
182 
+                             nfib 20            nfib 30
183 
+Lucid (interpreted)          140 sec            *
184 
+Lucid (compiled)             0.18 sec           10.2 sec
185 
+CMU (interpreted)            24.2 sec           *
186 
+CMU (compiled)               0.16 sec           10.5 sec
187 
+AKCL (interpreted)           145 sec            *
188 
+AKCL (compiled)              1.07 sec           127 sec
189 
+
190 
+Nfib with signature Float -> Float:
191 
+
192 
+                             nfib 20            nfib 30
193 
+Lucid (interpreted)          222  sec            *
194 
+Lucid (compiled)             16.4 sec           2416 sec
195 
+CMU (interpreted)            44.2 sec           *
196 
+CMU (compiled)               1.61 sec           352 sec
197 
+AKCL (interpreted)           161 sec            *
198 
+AKCL (compiled)              103 sec            *
199 
+
200 
+Overloaded functions run considerably slower than nonoverloaded
201 
+functions.  By allowing nfib to remain overloaded, Num a => a -> a,
202 
+and using the Int overloading the same benchmarks run much slower.
203 
+Again, there is no real difference between the different compiler
204 
+optimization settings.
205 
+
206 
+                             nfib 15            nfib 20
207 
+Lucid (interpreted)          14.2 sec           156 sec
208 
+Lucid (compiled)             0.97 sec           9.3 sec
209 
+CMU (interpreted)            23.8 sec           155 sec
210 
+CMU (compiled)               0.89 sec           15.6 sec
211 
+AKCL (interpreted)           30.8 sec           387 sec
212 
+AKCL (compiled)              10.3 sec           119 sec
213 
+
214 
+Basic Haskell data structuring operations (pattern matching and
215 
+construction) can be tested using another version of nfib which uses
216 
+natural numbers:
217 
+
218 
+  data Nat = Z | S Nat
219 
+
220 
+The difference betwen CMU and Lucid here is consistent with other
221 
+benchmarks that manipulate structures.
222 
+
223 
+                             nfib 10            nfib 15
224 
+Lucid (Interpreted)          1.39 sec           26.7 sec
225 
+Lucid (compiled)             0.26 sec           2.28 sec
226 
+CMU (interpreted)            3.1 sec            <stack overflow>
227 
+CMU (compiled)               0.16 sec           0.54 sec
228 
+AKCL (Interpreted)           4.25 sec           <stack overflow>
229 
+AKCL (compiled)              0.21 sec           13.9 sec
230 
+
231 
+
232 
+ A Large Program
233 
+
234 
+For a final benchmark, we use the Prolog interpreter as a way of
235 
+getting a feel for general performance of larger programs.  This
236 
+program is typical of symbolic (as opposed to numeric) computation.
237 
+
238 
+Time to solve append(X,Y,cons(a,cons(b,cons(c,nil)))):
239 
+
240 
+Lucid    12.2 sec
241 
+CMU      12.0 sec
242 
+AKCL     69.1 sec
243 
+
244 
+My interpretation of this result is that although Lucid is a bit
245 
+slower on the previous small benchmarks, it makes up for this is
246 
+larger programs where advantages like better instruction scheduling,
247 
+register allocation, or memory usage may make a difference.  In
248 
+general, Lucid and CMU are very similar in performance for larger
249 
+programs.
250 
+
251 
+
252 
+ Conclusions
253 
+
254 
+Briefly stated, the pluses and minuses of each system are as follows:
255 
+
256 
+Lucid (4.0.0):
257 
+ + Development (nonoptimizing) compiler is very fast
258 
+ + Fast Haskell -> Lisp compilation
259 
+ + Generates good code
260 
+ + Very robust
261 
+ - Costs money
262 
+ - Slow floating point code
263 
+ - Fairly slow interpreter
264 
+ - The production (optimizing) compiler is extremely slow.
265 
+
266 
+CMU (16e):
267 
+ + Free
268 
+ + As fast as Lucid for Haskell -> Lisp
269 
+ + Good floating point performance
270 
+ + Generated code is very fast
271 
+ + Fast interpreter
272 
+ - Slow Lisp -> machine code compilation
273 
+ - Doesn't run on many systems
274 
+
275 
+AKCL (1.615):
276 
+ + Free
277 
+ + Widely portable
278 
+ - Slow (generally 3 - 5 times slower, sometimes much worse)
279 
+ - Flakey (tends to core dump on errors, choke on large programs, etc.)
280 
+
281 
+Generally, using the fully optimizing compiler seems to be useful only
282 
+in code involving Int arithmetic.
283 
+
284 
+The fast compiler for Lucid is a big advantage, delivering by far the
285 
+fastest compilation to machine code with relatively little loss in
286 
+speed compared to the optimizing compiler.
287 
+
288 
+
289 
+            Yale Haskell Group
290 
+            September 25, 1992
291 
+
doc/lisp-interface/lisp-interface.dvi
History View file @ 4e98702
0 292 
new file mode 100644
1 293 
Binary files /dev/null and b/doc/lisp-interface/lisp-interface.dvi differ
doc/manual/haskell.dvi
History View file @ 4e98702
2 294 
new file mode 100644
3 295 
Binary files /dev/null and b/doc/manual/haskell.dvi differ
doc/optimizer/optimizer.dvi
History View file @ 4e98702
4 296 
new file mode 100644
5 297 
Binary files /dev/null and b/doc/optimizer/optimizer.dvi differ
doc/tutorial/tutorial.ps
History View file @ 4e98702
6 298 
new file mode 100644
... ... 
@@ -0,0 +1,6257 @@
1 
+%!PS-Adobe-2.0
2 
+%%Creator: dvips, version 5.4 (C) 1986-90 Radical Eye Software
3 
+%%Title: tutorial.dvi
4 
+%%Pages: 53 1
5 
+%%BoundingBox: 0 0 612 792
6 
+%%EndComments
7 
+%%BeginProcSet: tex.pro
8 
+/TeXDict 200 dict def TeXDict begin /N /def load def /B{bind def}N /S /exch
9 
+load def /X{S N}B /TR /translate load N /isls false N /vsize 10 N /@rigin{
10 
+isls{[0 1 -1 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
11 
+Resolution VResolution vsize neg mul TR}B /@letter{/vsize 10 N}B /@landscape{
12 
+/isls true N /vsize -1 N}B /@a4{/vsize 10.6929133858 N}B /@a3{/vsize 15.5531 N
13 
+}B /@ledger{/vsize 16 N}B /@legal{/vsize 13 N}B /@manualfeed{statusdict
14 
+/manualfeed true put}B /@copies{/#copies X}B /FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0
15 
+]N /df{/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0
16 
+]N df-tail}B /df-tail{/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N
17 
+/FontBBox FBB N string /base X array /BitMaps X /BuildChar{CharBuilder}N
18 
+/Encoding IE N end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[
19 
+}B /E{pop nn dup definefont setfont}B /ch-image{ch-data dup type /stringtype
20 
+ne{ctr get /ctr ctr 1 add N}if}B /ch-width{ch-data dup length 5 sub get}B
21 
+/ch-height{ch-data dup length 4 sub get}B /ch-xoff{128 ch-data dup length 3
22 
+sub get sub}B /ch-yoff{ch-data dup length 2 sub get 127 sub}B /ch-dx{ch-data
23 
+dup length 1 sub get}B /ctr 0 N /CharBuilder{save 3 1 roll S dup /base get 2
24 
+index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx 0 ch-xoff ch-yoff
25 
+ch-height sub ch-xoff ch-width add ch-yoff setcachedevice ch-width ch-height
26 
+true[1 0 0 -1 -.1 ch-xoff sub ch-yoff .1 add]{ch-image}imagemask restore}B /D{
27 
+/cc X dup type /stringtype ne{]}if nn /base get cc ctr put nn /BitMaps get S
28 
+ctr S sf 1 ne{dup dup length 1 sub dup 2 index S get sf div put}if put /ctr
29 
+ctr 1 add N}B /I{cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI
30 
+save N @rigin 0 0 moveto}B /eop{clear SI restore showpage userdict /eop-hook
31 
+known{eop-hook}if}B /@start{userdict /start-hook known{start-hook}if
32 
+/VResolution X /Resolution X 1000 div /DVImag X /IE 256 array N 0 1 255{IE S 1
33 
+string dup 0 3 index put cvn put}for}B /p /show load N /RMat[1 0 0 -1 0 0]N
34 
+/BDot 8 string N /v{/ruley X /rulex X V}B /V{gsave TR -.1 -.1 TR rulex ruley
35 
+scale 1 1 false RMat{BDot}imagemask grestore}B /a{moveto}B /delta 0 N /tail{
36 
+dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}B /d{
37 
+-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{4 M}B /l{p
38 
+-4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{p 1 w}B /r{p 2 w}B /s{p 3 w}B /t
39 
+{p 4 w}B /w{0 rmoveto}B /x{0 S rmoveto}B /y{3 2 roll p a}B /bos{/SS save N}B
40 
+/eos{clear SS restore}B end
41 
+%%EndProcSet
42 
+%%BeginProcSet: special.pro
43 
+TeXDict begin /SDict 200 dict N SDict begin /@SpecialDefaults{/hs 612 N /vs
44 
+792 N /ho 0 N /vo 0 N /hsc 1 N /vsc 1 N /ang 0 N /CLIP false N /BBcalc false N
45 
+/p 3 def}B /@scaleunit 100 N /@hscale{@scaleunit div /hsc X}B /@vscale{
46 
+@scaleunit div /vsc X}B /@hsize{/hs X /CLIP true N}B /@vsize{/vs X /CLIP true
47 
+N}B /@hoffset{/ho X}B /@voffset{/vo X}B /@angle{/ang X}B /@rwi{10 div /rwi X}
48 
+B /@llx{/llx X}B /@lly{/lly X}B /@urx{/urx X}B /@ury{/ury X /BBcalc true N}B
49 
+/magscale true def end /@MacSetUp{userdict /md known{userdict /md get type
50 
+/dicttype eq{md begin /letter{}N /note{}N /legal{}N /od{txpose 1 0 mtx
51 
+defaultmatrix dtransform S atan/pa X newpath clippath mark{transform{
52 
+itransform moveto}}{transform{itransform lineto}}{6 -2 roll transform 6 -2
53 
+roll transform 6 -2 roll transform{itransform 6 2 roll itransform 6 2 roll
54 
+itransform 6 2 roll curveto}}{{closepath}}pathforall newpath counttomark array
55 
+astore /gc xdf pop ct 39 0 put 10 fz 0 fs 2 F/|______Courier fnt invertflag{
56 
+PaintBlack}if}N /txpose{pxs pys scale ppr aload pop por{noflips{pop S neg S TR
57 
+pop 1 -1 scale}if xflip yflip and{pop S neg S TR 180 rotate 1 -1 scale ppr 3
58 
+get ppr 1 get neg sub neg ppr 2 get ppr 0 get neg sub neg TR}if xflip yflip
59 
+not and{pop S neg S TR pop 180 rotate ppr 3 get ppr 1 get neg sub neg 0 TR}if
60 
+yflip xflip not and{ppr 1 get neg ppr 0 get neg TR}if}{noflips{TR pop pop 270
61 
+rotate 1 -1 scale}if xflip yflip and{TR pop pop 90 rotate 1 -1 scale ppr 3 get
62 
+ppr 1 get neg sub neg ppr 2 get ppr 0 get neg sub neg TR}if xflip yflip not
63 
+and{TR pop pop 90 rotate ppr 3 get ppr 1 get neg sub neg 0 TR}if yflip xflip
64 
+not and{TR pop pop 270 rotate ppr 2 get ppr 0 get neg sub neg 0 S TR}if}
65 
+ifelse scaleby96{ppr aload pop 4 -1 roll add 2 div 3 1 roll add 2 div 2 copy
66 
+TR .96 dup scale neg S neg S TR}if}N /cp{pop pop showpage pm restore}N end}if}
67 
+if}N /normalscale{Resolution 72 div VResolution 72 div neg scale magscale{
68 
+DVImag dup scale}if}N /psfts{S 65536 div N}N /startTexFig{/psf$SavedState save
69 
+N userdict maxlength dict begin /magscale false def normalscale currentpoint
70 
+TR /psf$ury psfts /psf$urx psfts /psf$lly psfts /psf$llx psfts /psf$y psfts
71 
+/psf$x psfts currentpoint /psf$cy X /psf$cx X /psf$sx psf$x psf$urx psf$llx
72 
+sub div N /psf$sy psf$y psf$ury psf$lly sub div N psf$sx psf$sy scale psf$cx
73 
+psf$sx div psf$llx sub psf$cy psf$sy div psf$ury sub TR /showpage{}N
74 
+/erasepage{}N /copypage{}N @MacSetUp}N /doclip{psf$llx psf$lly psf$urx psf$ury
75 
+currentpoint 6 2 roll newpath 4 copy 4 2 roll moveto 6 -1 roll S lineto S
76 
+lineto S lineto closepath clip newpath moveto}N /endTexFig{end psf$SavedState
77 
+restore}N /@beginspecial{SDict begin /SpecialSave save N gsave normalscale
78 
+currentpoint TR @SpecialDefaults}B /@setspecial{CLIP{newpath 0 0 moveto hs 0
79 
+rlineto 0 vs rlineto hs neg 0 rlineto closepath clip}{initclip}ifelse ho vo TR
80 
+hsc vsc scale ang rotate BBcalc{rwi urx llx sub div dup scale llx neg lly neg
81 
+TR}if /showpage{}N /erasepage{}N /copypage{}N newpath}B /@endspecial{grestore
82 
+clear SpecialSave restore end}B /@defspecial{SDict begin}B /@fedspecial{end}B
83 
+/li{lineto}B /rl{rlineto}B /rc{rcurveto}B /np{/SaveX currentpoint /SaveY X N 1
84 
+setlinecap newpath}B /st{stroke SaveX SaveY moveto}B /fil{fill SaveX SaveY
85 
+moveto}B /ellipse{/endangle X /startangle X /yrad X /xrad X /savematrix matrix
86 
+currentmatrix N TR xrad yrad scale 0 0 1 startangle endangle arc savematrix
87 
+setmatrix}B end
88 
+%%EndProcSet
89 
+TeXDict begin 1000 300 300 @start /Fa 3 84 df<00000000C000000001E000000003E000
90 
+000003C000000007C00000000F800000001F000000001E000000003E000000007C00000000F800
91 
+000000F000000001F000000003E000000007C000000007800000000F800000001F000000003E00
92 
+0000003C000000007C00000000F800000001F000000001E000000003E000000007C00000000780
93 
+0000000F800000001F000000003E000000003C000000007C00000000F800000001F000000001E0
94 
+00000003E000000007C00000000F800000000F000000001F000000003E000000007C0000000078
95 
+00000000F800000000F0000000006000000000232E82AB1F>19 D<00000000001800000000003C
96 
+0000000000FC0000000001F80000000003F00000000007E0000000001F80000000003F00000000
97 
+007E0000000001FC0000000003F00000000007E0000000000FC0000000003F00000000007E0000
98 
+000000FC0000000001F80000000007E0000000000FC0000000001F80000000007F0000000000FC
99 
+0000000001F80000000003F0000000000FC0000000001F80000000003F00000000007E00000000
100 
+01F80000000003F00000000007E0000000001FC0000000003F00000000007E0000000000FC0000
101 
+000000F000000000006000000000002E2582A22A>35 D<6000000000F000000000F80000000078
102 
+000000007C000000003E000000001F000000000F000000000F8000000007C000000003E0000000
103 
+01E000000001F000000000F8000000007C000000003C000000003E000000001F000000000F8000
104 
+0000078000000007C000000003E000000001E000000001F000000000F8000000007C000000003C
105 
+000000003E000000001F000000000F80000000078000000007C000000003E000000001F0000000
106 
+00F000000000F8000000007C000000003E000000001E000000001F000000000F8000000007C000
107 
+000003C000000003E000000001E000000000C0232E82AB1F>83 D E /Fb
108 
+5 111 df<004000C000C003800D8001800180030003000300030006000600060006000C000C00
109 
+0C000C001800FF800A157C9412>49 D<030706000000000000384C4C4C8C181818303262622438
110 
+08177D960B>105 D<003000700020000000000000000000000000038004400460046008C000C0
111 
+00C000C0018001800180018003000300030003006600E600CC0070000C1D81960B>I<1F000600
112 
+0600060006000C000C000C000C001870189819381A30340038003E0033006300631063106310C3
113 
+20C1C00D177D9610>I<387044984708460C8C180C180C180C1818301831186118623026303810
114 
+0E7D8D14>110 D E /Fc 46 122 df<000FF07F00007FF9FF8000F83FC7C001E07F8FC003E07F
115 
+0FC007C07F0FC007C03F078007C01F000007C01F000007C01F000007C01F000007C01F0000FFFF
116 
+FFF800FFFFFFF80007C01F000007C01F000007C01F000007C01F000007C01F000007C01F000007
117 
+C01F000007C01F000007C01F000007C01F000007C01F000007C01F000007C01F000007C01F0000
118 
+07C01F000007C01F00003FF8FFF0003FF8FFF0002220809F1F>11 D<FFF0FFF0FFF0FFF00C047F
119 
+8B11>45 D<387CFEFEFE7C3807077C860F>I<00E00001E0000FE000FFE000F3E00003E00003E0
120 
+0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
121 
+0003E00003E00003E00003E00003E00003E00003E000FFFF80FFFF80111D7C9C1A>49
122 
+D<07F0001FFE00383F007C1F80FE0FC0FE0FC0FE0FE0FE07E07C07E03807E0000FE0000FC0000F
123 
+C0001F80001F00003E0000780000F00000E00001C0000380600700600E00601C00E01FFFC03FFF
124 
+C07FFFC0FFFFC0FFFFC0131D7D9C1A>I<01FC0007FF000E0F801E0FC03F07E03F07E03F07E03F
125 
+07E01E0FC0000FC0000F80001F0001FC0001FC00000F800007C00003E00003F00003F83803F87C
126 
+03F8FE03F8FE03F8FE03F0FC03F07807E03C0FC01FFF8003FC00151D7E9C1A>I<0001C00003C0
127 
+0007C00007C0000FC0001FC0003BC00073C00063C000C3C00183C00383C00703C00E03C00C03C0
128 
+1803C03803C07003C0E003C0FFFFFEFFFFFE0007C00007C00007C00007C00007C00007C000FFFE
129 
+00FFFE171D7F9C1A>I<3803803FFF803FFF003FFE003FFC003FF0003F80003000003000003000
130 
+0030000033F80037FE003C1F00380F801007C00007C00007E00007E07807E0FC07E0FC07E0FC07
131 
+E0FC07C0780FC0600F80381F001FFC0007F000131D7D9C1A>I<387CFEFEFE7C38000000000000
132 
+387CFEFEFE7C3807147C930F>58 D<0000E000000000E000000001F000000001F000000001F000
133 
+000003F800000003F800000006FC00000006FC0000000EFE0000000C7E0000000C7E000000183F
134 
+000000183F000000303F800000301F800000701FC00000600FC00000600FC00000C007E00000FF
135 
+FFE00001FFFFF000018003F000018003F000030001F800030001F800060001FC00060000FC000E
136 
+0000FE00FFE00FFFE0FFE00FFFE0231F7E9E28>65 D<FFFFFE00FFFFFFC007C007E007C003F007
137 
+C001F807C001FC07C001FC07C001FC07C001FC07C001FC07C001F807C003F807C007F007C00FE0
138 
+07FFFF8007FFFFC007C003F007C001F807C001FC07C000FC07C000FE07C000FE07C000FE07C000
139 
+FE07C000FE07C000FC07C001FC07C003F807C007F0FFFFFFE0FFFFFF001F1F7E9E25>I<0007FC
140 
+02003FFF0E00FE03DE03F000FE07E0003E0FC0001E1F80001E3F00000E3F00000E7F0000067E00
141 
+00067E000006FE000000FE000000FE000000FE000000FE000000FE000000FE0000007E0000007E
142 
+0000067F0000063F0000063F00000C1F80000C0FC0001807E0003803F0007000FE01C0003FFF80
143 
+0007FC001F1F7D9E26>I<FFFFFE0000FFFFFFC00007E007F00007E001F80007E000FC0007E000
144 
+7E0007E0003F0007E0003F0007E0001F8007E0001F8007E0001F8007E0001FC007E0001FC007E0
145 
+001FC007E0001FC007E0001FC007E0001FC007E0001FC007E0001FC007E0001FC007E0001F8007
146 
+E0001F8007E0001F8007E0003F0007E0003F0007E0007E0007E000FC0007E001F80007E007F000
147 
+FFFFFFC000FFFFFE0000221F7E9E28>I<FFFFFFE0FFFFFFE007E007E007E001E007E000E007E0
148 
+006007E0007007E0003007E0003007E0603007E0603007E0600007E0E00007E1E00007FFE00007
149 
+FFE00007E1E00007E0E00007E0600007E0600C07E0600C07E0000C07E0001807E0001807E00018
150 
+07E0003807E0007807E000F807E003F0FFFFFFF0FFFFFFF01E1F7E9E22>I<FFFFFFE0FFFFFFE0
151 
+07E007E007E001E007E000E007E0006007E0007007E0003007E0003007E0603007E0603007E060
152 
+0007E0E00007E1E00007FFE00007FFE00007E1E00007E0E00007E0600007E0600007E0600007E0
153 
+000007E0000007E0000007E0000007E0000007E0000007E0000007E00000FFFF8000FFFF80001C
154 
+1F7E9E21>I<FFFF0FFFF0FFFF0FFFF007E0007E0007E0007E0007E0007E0007E0007E0007E000
155 
+7E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007FF
156 
+FFFE0007FFFFFE0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007
157 
+E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E00FFFF0FFFF0
158 
+FFFF0FFFF0241F7E9E29>72 D<FFFF8000FFFF800007E0000007E0000007E0000007E0000007E0
159 
+000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007
160 
+E0000007E0000007E0000007E000C007E000C007E000C007E001C007E001C007E001C007E00380
161 
+07E0038007E00F8007E01F80FFFFFF80FFFFFF801A1F7E9E1F>76 D<FFE000FFF0FFF000FFF007
162 
+F000060007F800060006FC000600067E000600063F000600063F800600061F800600060FC00600
163 
+0607E006000603F006000601F806000601FC06000600FC060006007E060006003F060006001F86
164 
+0006001FC60006000FE600060007E600060003F600060001FE00060000FE00060000FE00060000
165 
+7E000600003E000600001E000600000E00FFF0000600FFF0000600241F7E9E29>78
166 
+D<001FF80000FFFF0001F81F8007E007E00FC003F01F8001F81F0000F83F0000FC7F0000FE7E00
167 
+007E7E00007EFE00007FFE00007FFE00007FFE00007FFE00007FFE00007FFE00007FFE00007FFE
168 
+00007F7E00007E7F0000FE7F0000FE3F0000FC3F8001FC1F8001F80FC003F007E007E001F81F80
169 
+00FFFF00001FF800201F7D9E27>I<FFFFFE00FFFFFF8007E00FE007E003F007E001F807E001F8
170 
+07E001FC07E001FC07E001FC07E001FC07E001FC07E001F807E001F807E003F007E00FE007FFFF
171 
+8007FFFE0007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0
172 
+000007E0000007E0000007E00000FFFF0000FFFF00001E1F7E9E24>I<03FC080FFF381E03F838
173 
+00F8700078700038F00038F00018F00018F80000FC00007FC0007FFE003FFF801FFFE00FFFF007
174 
+FFF000FFF80007F80000FC00007C00003CC0003CC0003CC0003CE00038E00078F80070FE01E0E7
175 
+FFC081FF00161F7D9E1D>83 D<7FFFFFFC7FFFFFFC7C07E07C7007E01C6007E00C6007E00CE007
176 
+E00EC007E006C007E006C007E006C007E0060007E0000007E0000007E0000007E0000007E00000
177 
+07E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E000
178 
+0007E0000007E00003FFFFC003FFFFC01F1E7E9D24>I<FFFE0FFFC0FFE0FFFE0FFFC0FFE00FC0
179 
+00FC000E000FE000FC000E0007E000FE000C0007E000FE000C0003F000FE00180003F001FF0018
180 
+0003F001BF00180001F801BF00300001F8031F80300001FC031F80700000FC031F80600000FC06
181 
+0FC06000007E060FC0C000007E0E0FE0C000007E0C07E0C000003F0C07E18000003F1803F18000
182 
+003F9803F38000001F9803F30000001FB001FB0000000FF001FE0000000FF001FE0000000FE000
183 
+FE00000007E000FC00000007C0007C00000007C0007C00000003C0007800000003800038000000
184 
+018000300000331F7F9E36>87 D<07FC001FFF003F0F803F07C03F03E03F03E00C03E00003E000
185 
+7FE007FBE01F03E03C03E07C03E0F803E0F803E0F803E0FC05E07E0DE03FF8FE0FE07E17147F93
186 
+19>97 D<FF0000FF00001F00001F00001F00001F00001F00001F00001F00001F00001F00001F00
187 
+001F1FC01F7FF01FE0F81F807C1F007E1F003E1F003E1F003F1F003F1F003F1F003F1F003F1F00
188 
+3F1F003E1F003E1F007C1F807C1EC1F81C7FE0181F8018207E9F1D>I<01FE0007FF801F0FC03E
189 
+0FC03E0FC07C0FC07C0300FC0000FC0000FC0000FC0000FC0000FC00007C00007E00003E00603F
190 
+00C01F81C007FF0001FC0013147E9317>I<0007F80007F80000F80000F80000F80000F80000F8
191 
+0000F80000F80000F80000F80000F801F8F80FFEF81F83F83E01F87E00F87C00F87C00F8FC00F8
192 
+FC00F8FC00F8FC00F8FC00F8FC00F87C00F87C00F87E00F83E01F81F07F80FFEFF03F8FF18207E
193 
+9F1D>I<01FE0007FF800F83C01E01E03E00F07C00F07C00F8FC00F8FFFFF8FFFFF8FC0000FC00
194 
+00FC00007C00007C00003E00181E00180F807007FFE000FF8015147F9318>I<001F8000FFC001
195 
+F3E003E7E003C7E007C7E007C3C007C00007C00007C00007C00007C000FFFC00FFFC0007C00007
196 
+C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007
197 
+C00007C0003FFC003FFC0013207F9F10>I<01FC3C07FFFE0F079E1E03DE3E03E03E03E03E03E0
198 
+3E03E03E03E01E03C00F07800FFF0009FC001800001800001C00001FFF800FFFF007FFF81FFFFC
199 
+3C007C70003EF0001EF0001EF0001E78003C78003C3F01F80FFFE001FF00171E7F931A>I<FF00
200 
+00FF00001F00001F00001F00001F00001F00001F00001F00001F00001F00001F00001F0FC01F3F
201 
+E01F61F01FC0F81F80F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00
202 
+F81F00F81F00F81F00F8FFE3FFFFE3FF18207D9F1D>I<1C003E007F007F007F003E001C000000
203 
+00000000000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F
204 
+001F001F001F00FFE0FFE00B217EA00E>I<FF0000FF00001F00001F00001F00001F00001F0000
205 
+1F00001F00001F00001F00001F00001F01FE1F01FE1F00F01F00C01F03801F07001F0C001F1800
206 
+1F7C001FFC001F9E001F0F001E0F801E07C01E03C01E01E01E01F01E00F8FFC3FFFFC3FF18207E
207 
+9F1C>107 D<FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
208 
+001F001F001F001F001F001F001F001F001F001F001F001F001F00FFE0FFE00B207E9F0E>I<FE
209 
+0FE03F80FE1FF07FC01E70F9C3E01E407D01F01E807E01F01F807E01F01F007C01F01F007C01F0
210 
+1F007C01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01
211 
+F01F007C01F01F007C01F0FFE3FF8FFEFFE3FF8FFE27147D932C>I<FE0FC0FE3FE01E61F01EC0
212 
+F81E80F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00
213 
+F81F00F8FFE3FFFFE3FF18147D931D>I<01FF0007FFC01F83F03E00F83E00F87C007C7C007CFC
214 
+007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00F83E00F81F83F007FFC001FF0017
215 
+147F931A>I<FF1FC0FF7FF01FE1F81F80FC1F007E1F007E1F003E1F003F1F003F1F003F1F003F
216 
+1F003F1F003F1F003E1F007E1F007C1F80FC1FC1F81F7FE01F1F801F00001F00001F00001F0000
217 
+1F00001F00001F0000FFE000FFE000181D7E931D>I<01F81807FE381F87783F01F83E01F87E00
218 
+F87C00F8FC00F8FC00F8FC00F8FC00F8FC00F8FC00F87C00F87E00F87E00F83F01F81F87F80FFE
219 
+F803F8F80000F80000F80000F80000F80000F80000F80000F80007FF0007FF181D7E931C>I<FE
220 
+3E00FE7F801ECFC01E8FC01E8FC01F8FC01F03001F00001F00001F00001F00001F00001F00001F
221 
+00001F00001F00001F00001F0000FFF000FFF00012147E9316>I<0FE63FFE701E600EE006E006
222 
+F800FFC07FF83FFC1FFE03FE001FC007C007E007F006F81EFFFCC7F010147E9315>I<01800180
223 
+018003800380038007800F803F80FFFCFFFC0F800F800F800F800F800F800F800F800F800F800F
224 
+860F860F860F860F8607CC03F801F00F1D7F9C14>I<FF07F8FF07F81F00F81F00F81F00F81F00
225 
+F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F01F81F01F80F06F807FC
226 
+FF03F8FF18147D931D>I<FFE07F80FFE07F801F001C000F8018000F80180007C0300007C03000
227 
+03E0600003E0600001F0C00001F0C00001F9C00000F9800000FF8000007F0000007F0000003E00
228 
+00003E0000001C0000001C000019147F931C>I<FFE1FF00FFE1FF000F80700007C0E00007E0C0
229 
+0003E1800001F3800000FF0000007E0000003E0000003F0000007F8000006F800000C7C0000183
230 
+E0000381F0000701F8000E00FC00FF81FF80FF81FF8019147F931C>120
231 
+D<FFE07F80FFE07F801F001C000F8018000F80180007C0300007C0300003E0600003E0600001F0
232 
+C00001F0C00001F9C00000F9800000FF8000007F0000007F0000003E0000003E0000001C000000
233 
+1C0000001800000018000078300000FC300000FC600000C0E00000E1C000007F8000001E000000
234 
+191D7F931C>I E /Fd 2 111 df<0300038003000000000000000000000000001C002400460046
235 
+008C000C0018001800180031003100320032001C0009177F960C>105 D<383C0044C600470200
236 
+4602008E06000C06000C06000C0C00180C00180C40181840181880300880300F00120E7F8D15>
237 
+110 D E /Fe 20 122 df<03CC0E2E181C381C301C701CE038E038E038E038C072C072C07260F2
238 
+61341E180F107C8F14>97 D<7E000E000E000E001C001C001C001C00380038003BC03C30783070
239 
+1870187018E038E038E038E038C070C060C0E060C063801E000D1A7C9912>I<01F006080C1818
240 
+38301070006000E000E000E000E000E008E010602030C01F000D107C8F12>I<001F8000038000
241 
+0380000380000700000700000700000700000E00000E0003CE000E2E00181C00381C00301C0070
242 
+1C00E03800E03800E03800E03800C07200C07200C0720060F2006134001E1800111A7C9914>I<
243 
+01E006181C08380870087010FFE0E000E000E000E000E0086010602030C01F000D107C8F12>I<
244 
+1F80000380000380000380000700000700000700000700000E00000E00000E7C000F86001E0700
245 
+1E07001C07001C0700380E00380E00380E00381C00701C80701C80703880703900E01900600E00
246 
+111A7E9914>104 D<030706000000000000384C4E8E9C9C1C3838707272E2E4643808197C980C>
247 
+I<1F8003800380038007000700070007000E000E000E0E0E131C271C431C801F003C003F8039C0
248 
+38E070E270E270E270E4E0646038101A7E9912>107 D<3F0707070E0E0E0E1C1C1C1C38383838
249 
+70707070E4E4E4E46830081A7D990A>I<307C1E00598663009E0783809E0703809C0703809C07
250 
+0380380E0700380E0700380E0700380E0E00701C0E40701C0E40701C1C40701C1C80E0380C8060
251 
+1807001A107C8F1F>I<307C005986009E07009E07009C07009C0700380E00380E00380E00381C
252 
+00701C80701C80703880703900E01900600E0011107C8F16>I<01F006180C0C180E300E700E60
253 
+0EE00EE00EE00CE01CE018E030606030C01F000F107C8F14>I<030F000590C009E0C009C06009
254 
+C06009C0600380E00380E00380E00380E00701C00701800703800703000E8E000E78000E00000E
255 
+00001C00001C00001C00001C0000FF00001317808F14>I<03C20E2E181C381C301C701CE038E0
256 
+38E038E038C070C070C07060F061E01EE000E000E001C001C001C001C01FF00F177C8F12>I<30
257 
+F059189E389C189C009C0038003800380038007000700070007000E00060000D107C8F10>I<03
258 
+E004300830187018601C001F801FC00FE000E00060E060E06080C041803E000C107D8F10>I<06
259 
+000E000E000E000E001C001C00FFC01C0038003800380038007000700070007000E100E100E100
260 
+E200640038000A177C960D>I<38064C074E0E8E0E9C0E9C0E1C1C381C381C381C703970397039
261 
+3079389A0F0C10107C8F15>I<38184C1C4E1C8E0C9C0C9C0C1C08380838083808701070107020
262 
+304018C00F000E107C8F12>I<38064C074E0E8E0E9C0E9C0E1C1C381C381C381C703870387038
263 
+307838F00F700070006060E0E1C0C18047003C0010177C8F13>121 D E
264 
+/Ff 27 122 df<60F0F878181818303060C080050C789614>39 D<00C001C0030006000C001C00
265 
+38003000700070006000E000E000E000E000E000E000E000600070007000300038001C000C0006
266 
+00030001C000C00A1D7A9914>I<8000C0006000300018001C000E000600070007000300038003
267 
+800380038003800380038003000700070006000E001C00180030006000C0008000091D7C9914>
268 
+I<01C00001C00001C00001C00001C00001C00001C000FFFF80FFFF80FFFF8001C00001C00001C0
269 
+0001C00001C00001C00001C00011117F9314>43 D<70F8FCFC7C0C1830E0C0060A798414>I<70
270 
+F8F8F8700505798414>46 D<0006000E000E001C001C003800380070007000E000E001C001C003
271 
+8003800380070007000E000E001C001C003800380070007000E000E000C0000F1D7E9914>I<70
272 
+F8F8F87000000000000070F8F8F8700510798F14>58 D<FFFF80FFFF807FFF8000000000000000
273 
+00007FFF80FFFF80FFFF8011097F8F14>61 D<FFE0FFE0E000E000E000E000E000E000E000E000
274 
+E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000FFE0FFE00B
275 
+1D799914>91 D<FFE0FFE000E000E000E000E000E000E000E000E000E000E000E000E000E000E0
276 
+00E000E000E000E000E000E000E000E000E000E000E0FFE0FFE00B1D7F9914>93
277 
+D<0818306060C0C0C0F0F87830050C799914>96 D<1FC0007FF000707800201800001C00001C00
278 
+07FC001FFC003C1C00701C00E01C00E01C00E01C00707C003FFF800F8F8011107E8F14>I<03F8
279 
+0FFC1C1C380870006000E000E000E000E00060007000380E1C1E0FFC03F00F107E8F14>99
280 
+D<007E00007E00000E00000E00000E00000E00000E0007CE000FFE001C3E00301E00700E00E00E
281 
+00E00E00E00E00E00E00E00E00E00E00700E00301E00383E001FEFC007CFC012177F9614>I<07
282 
+E00FF01C38301C700CE00EE00EFFFEFFFEE00060007000380E1C1E0FFC03F00F107E8F14>I<00
283 
+7C00FE01CE03840380038003807FFEFFFE03800380038003800380038003800380038003800380
284 
+03807FFC7FFC0F177F9614>I<030007800780030000000000000000007F807F80038003800380
285 
+038003800380038003800380038003800380FFFCFFFC0E187D9714>105
286 
+D<FF80FF8003800380038003800380038003800380038003800380038003800380038003800380
287 
+03800380FFFEFFFE0F177E9614>108 D<FC7800FDFE001F86001E07001C07001C07001C07001C
288 
+07001C07001C07001C07001C07001C07001C0700FF8FE0FF8FE01310808F14>110
289 
+D<07C01FF03C78701C701CE00EE00EE00EE00EE00EE00E701C783C3C781FF007C00F107E8F14>
290 
+I<03CE000FFE001C3E00301E00700E00E00E00E00E00E00E00E00E00E00E00E00E00700E00301E
291 
+001C3E000FEE0007CE00000E00000E00000E00000E00000E00000E00007FC0007FC012187F8F14
292 
+>113 D<0FD83FF86038C038C038F0007F803FF007F8001C6006E006F006F81CFFF8CFE00F107E
293 
+8F14>115 D<030007000700070007007FFCFFFC07000700070007000700070007000700070E07
294 
+0E070E070C03FC00F00F157F9414>I<FE3F80FE3F801C1C001C1C001C1C001C1C000E38000E38
295 
+000E380006300007700007700007700003E00003E00003E00011107F8F14>118
296 
+D<7E3F007E3F001E38000E780007700007E00003E00001C00003C00003E0000770000E78000E38
297 
+001C1C00FE3F80FE3F8011107F8F14>120 D<FE3F80FE3F801C1C001C1C001C1C000E1C000E38
298 
+000E380007380007300007300003700003700001E00001E00001E00001C00001C00001C0000380
299 
+007380007700007E00003C000011187F8F14>I E /Fg 56 123 df<000FF000007FFC0001F80E
300 
+0003E01F0007C03F000F803F000F803F000F801E000F800C000F8000000F8000000F8000000F80
301 
+0000FFFFFF00FFFFFF000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F
302 
+801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F00
303 
+0F801F007FF0FFE07FF0FFE01B237FA21F>12 D<3803807C07C0FE0FE0FF0FF0FF0FF07F07F03B
304 
+03B00300300300300700700600600600600C00C01C01C018018070070020020014117EA21D>34
305 
+D<387CFEFFFF7F3B03030706060C1C18702008117C8610>44 D<FFFCFFFCFFFCFFFC0E047F8C13
306 
+>I<387CFEFEFE7C3807077C8610>I<0000180000380000380000700000700000E00000E00000E0
307 
+0001C00001C0000380000380000380000700000700000700000E00000E00001C00001C00001C00
308 
+00380000380000700000700000700000E00000E00001C00001C00001C000038000038000070000
309 
+0700000700000E00000E00000E00001C00001C0000380000380000380000700000700000E00000
310 
+E00000C0000015317DA41C>I<00180000780001F800FFF800FFF80001F80001F80001F80001F8
311 
+0001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F8
312 
+0001F80001F80001F80001F80001F80001F80001F80001F8007FFFE07FFFE013207C9F1C>49
313 
+D<03FC000FFF003C1FC07007E07C07F0FE03F0FE03F8FE03F8FE01F87C01F83803F80003F80003
314 
+F00003F00007E00007C0000F80001F00003E0000380000700000E01801C0180380180700180E00
315 
+380FFFF01FFFF03FFFF07FFFF0FFFFF0FFFFF015207D9F1C>I<00FE0007FFC00F07E01E03F03F
316 
+03F03F81F83F81F83F81F81F03F81F03F00003F00003E00007C0001F8001FE0001FF000007C000
317 
+01F00001F80000FC0000FC3C00FE7E00FEFF00FEFF00FEFF00FEFF00FC7E01FC7801F81E07F00F
318 
+FFC001FE0017207E9F1C>I<0000E00001E00003E00003E00007E0000FE0001FE0001FE00037E0
319 
+0077E000E7E001C7E00187E00307E00707E00E07E00C07E01807E03807E07007E0E007E0FFFFFE
320 
+FFFFFE0007E00007E00007E00007E00007E00007E00007E000FFFE00FFFE17207E9F1C>I<1000
321 
+201E01E01FFFC01FFF801FFF001FFE001FF8001BC00018000018000018000018000019FC001FFF
322 
+001E0FC01807E01803E00003F00003F00003F80003F83803F87C03F8FE03F8FE03F8FC03F0FC03
323 
+F07007E03007C01C1F800FFF0003F80015207D9F1C>I<001F8000FFE003F07007C0F00F01F81F
324 
+01F83E01F83E01F87E00F07C00007C0000FC0800FC7FC0FCFFE0FD80F0FF00F8FE007CFE007CFC
325 
+007EFC007EFC007EFC007E7C007E7C007E7C007E3C007C3E007C1E00F80F00F00783E003FFC000
326 
+FF0017207E9F1C>I<6000007800007FFFFE7FFFFE7FFFFC7FFFF87FFFF87FFFF0E00060E000C0
327 
+C00180C00300C00300000600000C00001C0000180000380000780000780000F00000F00000F000
328 
+01F00001F00001F00003F00003F00003F00003F00003F00003F00003F00001E00017227DA11C>
329 
+I<00FE0003FFC00703E00E00F01C00F01C00783C00783E00783F00783F80783FE0F01FF9E01FFF
330 
+C00FFF8007FFC003FFE007FFF01E7FF83C1FFC7807FC7801FEF000FEF0003EF0001EF0001EF000
331 
+1CF8001C7800383C00381F01F00FFFC001FF0017207E9F1C>I<01FE0007FF800F83E01E01F03E
332 
+00F07C00F87C0078FC007CFC007CFC007CFC007EFC007EFC007EFC007E7C00FE7C00FE3E01FE1E
333 
+037E0FFE7E07FC7E00207E00007C00007C1E007C3F00F83F00F83F00F03F01E01E03C01C0F800F
334 
+FE0003F80017207E9F1C>I<387CFEFEFE7C380000000000000000387CFEFEFE7C3807167C9510>
335 
+I<000070000000007000000000F800000000F800000000F800000001FC00000001FC00000003FE
336 
+00000003FE00000003FE00000006FF000000067F0000000E7F8000000C3F8000000C3F80000018
337 
+3FC00000181FC00000381FE00000300FE00000300FE00000600FF000006007F00000E007F80000
338 
+FFFFF80000FFFFF800018001FC00018001FC00038001FE00030000FE00030000FE000600007F00
339 
+0600007F00FFE00FFFF8FFE00FFFF825227EA12A>65 D<FFFFFF8000FFFFFFE00007F001F80007
340 
+F000FC0007F0007E0007F0007E0007F0007F0007F0007F0007F0007F0007F0007F0007F0007F00
341 
+07F0007E0007F000FE0007F000FC0007F003F80007FFFFF00007FFFFF00007F001FC0007F0007E
342 
+0007F0003F0007F0003F8007F0001F8007F0001FC007F0001FC007F0001FC007F0001FC007F000
343 
+1FC007F0001FC007F0003F8007F0003F8007F0007F0007F001FE00FFFFFFF800FFFFFFC0002222
344 
+7EA128>I<0003FE0080001FFF818000FF01E38001F8003F8003E0001F8007C0000F800F800007
345 
+801F800007803F000003803F000003807F000001807E000001807E00000180FE00000000FE0000
346 
+0000FE00000000FE00000000FE00000000FE00000000FE00000000FE000000007E000000007E00
347 
+0001807F000001803F000001803F000003801F800003000F8000030007C000060003F0000C0001
348 
+F800380000FF00F000001FFFC0000003FE000021227DA128>I<FFFFFF8000FFFFFFF00007F003
349 
+FC0007F0007E0007F0003F0007F0001F8007F0000FC007F00007E007F00007E007F00007F007F0
350 
+0003F007F00003F007F00003F007F00003F807F00003F807F00003F807F00003F807F00003F807
351 
+F00003F807F00003F807F00003F807F00003F807F00003F007F00003F007F00003F007F00007E0
352 
+07F00007E007F0000FC007F0001F8007F0003F0007F0007E0007F003FC00FFFFFFF000FFFFFF80
353 
+0025227EA12B>I<FFFFFFFCFFFFFFFC07F000FC07F0003C07F0001C07F0000C07F0000E07F000
354 
+0E07F0000607F0180607F0180607F0180607F0180007F0380007F0780007FFF80007FFF80007F0
355 
+780007F0380007F0180007F0180007F0180307F0180307F0000307F0000607F0000607F0000607
356 
+F0000E07F0000E07F0001E07F0003E07F001FCFFFFFFFCFFFFFFFC20227EA125>I<FFFFFFF8FF
357 
+FFFFF807F001F807F0007807F0003807F0001807F0001C07F0001C07F0000C07F0000C07F0180C
358 
+07F0180C07F0180007F0180007F0380007F0780007FFF80007FFF80007F0780007F0380007F018
359 
+0007F0180007F0180007F0180007F0000007F0000007F0000007F0000007F0000007F0000007F0
360 
+000007F00000FFFFE000FFFFE0001E227EA123>I<FFFFE0FFFFE003F80003F80003F80003F800
361 
+03F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F800
362 
+03F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F800
363 
+FFFFE0FFFFE013227FA115>73 D<FFFFE000FFFFE00007F0000007F0000007F0000007F0000007
364 
+F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F00000
365 
+07F0000007F0000007F0000007F0000007F0000007F0001807F0001807F0001807F0001807F000
366 
+3807F0003807F0007007F0007007F000F007F001F007F007F0FFFFFFF0FFFFFFF01D227EA122>
367 
+76 D<FFF000000FFFFFF800001FFF07F800001FE006FC000037E006FC000037E006FC000037E0
368 
+067E000067E0067E000067E0063F0000C7E0063F0000C7E0061F800187E0061F800187E0060FC0
369 
+0307E0060FC00307E0060FC00307E00607E00607E00607E00607E00603F00C07E00603F00C07E0
370 
+0601F81807E00601F81807E00601F81807E00600FC3007E00600FC3007E006007E6007E006007E
371 
+6007E006003FC007E006003FC007E006001F8007E006001F8007E006001F8007E006000F0007E0
372 
+FFF00F00FFFFFFF00600FFFF30227EA135>I<FFF8001FFEFFFC001FFE07FC0000C007FE0000C0
373 
+06FF0000C0067F8000C0063FC000C0061FE000C0060FE000C0060FF000C00607F800C00603FC00
374 
+C00601FE00C00600FE00C00600FF00C006007F80C006003FC0C006001FE0C006000FF0C0060007
375 
+F0C0060007F8C0060003FCC0060001FEC0060000FFC00600007FC00600007FC00600003FC00600
376 
+001FC00600000FC006000007C006000003C006000003C0FFF00001C0FFF00000C027227EA12C>
377 
+I<0007FC0000003FFF800000FC07E00003F001F80007E000FC000FC0007E001F80003F001F8000
378 
+3F003F00001F803F00001F807F00001FC07E00000FC07E00000FC0FE00000FE0FE00000FE0FE00
379 
+000FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE07E00000FC07F
380 
+00001FC07F00001FC03F00001F803F80003F801F80003F000FC0007E0007E000FC0003F001F800
381 
+00FC07E000003FFF80000007FC000023227DA12A>I<FFFFFF00FFFFFFE007F007F007F001FC07
382 
+F000FC07F0007E07F0007E07F0007F07F0007F07F0007F07F0007F07F0007F07F0007E07F0007E
383 
+07F000FC07F001FC07F007F007FFFFE007FFFF0007F0000007F0000007F0000007F0000007F000
384 
+0007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F00000FFFF8000FFFF
385 
+800020227EA126>I<FFFFFE0000FFFFFFC00007F007F00007F001F80007F000FC0007F0007E00
386 
+07F0007F0007F0007F0007F0007F0007F0007F0007F0007F0007F0007F0007F0007E0007F000FC
387 
+0007F001F80007F007F00007FFFFC00007FFFF800007F00FE00007F007F00007F003F80007F001
388 
+FC0007F001FC0007F001FC0007F001FC0007F001FC0007F001FC0007F001FC0007F001FC0007F0
389 
+01FC0607F000FE0607F000FF0CFFFF803FF8FFFF800FF027227EA12A>82
390 
+D<01FC0407FF8C1F03FC3C007C7C003C78001C78001CF8000CF8000CFC000CFC0000FF0000FFE0
391 
+007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FF00007F00003F00003FC0001FC000
392 
+1FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF8018227DA11F>I<7FFFFFFF807FFF
393 
+FFFF807E03F80F807803F807807003F803806003F80180E003F801C0E003F801C0C003F800C0C0
394 
+03F800C0C003F800C0C003F800C00003F800000003F800000003F800000003F800000003F80000
395 
+0003F800000003F800000003F800000003F800000003F800000003F800000003F800000003F800
396 
+000003F800000003F800000003F800000003F800000003F800000003F800000003F8000003FFFF
397 
+F80003FFFFF80022227EA127>I<FFFF803FFCFFFF803FFC07F000018007F000018007F0000180
398 
+07F000018007F000018007F000018007F000018007F000018007F000018007F000018007F00001
399 
+8007F000018007F000018007F000018007F000018007F000018007F000018007F000018007F000
400 
+018007F000018007F000018007F000018007F000018007F000018003F000030003F800030001F8
401 
+00060000FC000E00007E001C00003F80F800000FFFE0000001FF000026227EA12B>I<0400400E
402 
+00E0180180380380300300600600600600E00E00C00C00C00C00DC0DC0FE0FE0FF0FF0FF0FF07F
403 
+07F03E03E01C01C014117AA21D>92 D<07FC001FFF803F07C03F03E03F01E03F01F01E01F00001
404 
+F00001F0003FF003FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF8
405 
+7F07E03F18167E951B>97 D<FF000000FF0000001F0000001F0000001F0000001F0000001F0000
406 
+001F0000001F0000001F0000001F0000001F0000001F0000001F0FE0001F3FF8001FF07C001F80
407 
+1E001F001F001F000F801F000F801F000FC01F000FC01F000FC01F000FC01F000FC01F000FC01F
408 
+000FC01F000FC01F000F801F001F801F801F001FC03E001EE07C001C3FF800180FC0001A237EA2
409 
+1F>I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000FC0000FC0000FC0000FC0000
410 
+FC0000FC00007C00007E00007E00003E00301F00600FC0E007FF8000FE0014167E9519>I<0001
411 
+FE000001FE0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000
412 
+003E0000003E0000003E0001FC3E0007FFBE000F81FE001F007E003E003E007E003E007C003E00
413 
+FC003E00FC003E00FC003E00FC003E00FC003E00FC003E00FC003E00FC003E007C003E007C003E
414 
+003E007E001E00FE000F83BE0007FF3FC001FC3FC01A237EA21F>I<00FE0007FF800F87C01E01
415 
+E03E01F07C00F07C00F8FC00F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00
416 
+003E00181F00300FC07003FFC000FF0015167E951A>I<003F8000FFC001E3E003C7E007C7E00F
417 
+87E00F83C00F80000F80000F80000F80000F80000F8000FFFC00FFFC000F80000F80000F80000F
418 
+80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F
419 
+80000F80007FF8007FF80013237FA211>I<03FC1E0FFF7F1F0F8F3E07CF3C03C07C03E07C03E0
420 
+7C03E07C03E07C03E03C03C03E07C01F0F801FFF0013FC003000003000003800003FFF801FFFF0
421 
+0FFFF81FFFFC3800FC70003EF0001EF0001EF0001EF0001E78003C7C007C3F01F80FFFE001FF00
422 
+18217E951C>I<FF000000FF0000001F0000001F0000001F0000001F0000001F0000001F000000
423 
+1F0000001F0000001F0000001F0000001F0000001F07E0001F1FF8001F307C001F403C001F803E
424 
+001F803E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F00
425 
+3E001F003E001F003E001F003E001F003E001F003E00FFE1FFC0FFE1FFC01A237EA21F>I<1C00
426 
+3E007F007F007F003E001C000000000000000000000000000000FF00FF001F001F001F001F001F
427 
+001F001F001F001F001F001F001F001F001F001F001F001F001F00FFE0FFE00B247EA310>I<FF
428 
+00FF001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00
429 
+1F001F001F001F001F001F001F001F001F001F001F001F001F00FFE0FFE00B237EA210>108
430 
+D<FF07F007F000FF1FFC1FFC001F303E303E001F403E403E001F801F801F001F801F801F001F00
431 
+1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
432 
+001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00
433 
+1F001F00FFE0FFE0FFE0FFE0FFE0FFE02B167E9530>I<FF07E000FF1FF8001F307C001F403C00
434 
+1F803E001F803E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E
435 
+001F003E001F003E001F003E001F003E001F003E001F003E00FFE1FFC0FFE1FFC01A167E951F>
436 
+I<00FE0007FFC00F83E01E00F03E00F87C007C7C007C7C007CFC007EFC007EFC007EFC007EFC00
437 
+7EFC007EFC007E7C007C7C007C3E00F81F01F00F83E007FFC000FE0017167E951C>I<FF0FE000
438 
+FF3FF8001FF07C001F803E001F001F001F001F801F001F801F000FC01F000FC01F000FC01F000F
439 
+C01F000FC01F000FC01F000FC01F000FC01F001F801F001F801F803F001FC03E001FE0FC001F3F
440 
+F8001F0FC0001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F000000FF
441 
+E00000FFE000001A207E951F>I<00FE030007FF87000FC1C7001F006F003F003F007E003F007E
442 
+001F007C001F00FC001F00FC001F00FC001F00FC001F00FC001F00FC001F00FC001F007E001F00
443 
+7E001F003E003F001F007F000FC1DF0007FF9F0001FC1F0000001F0000001F0000001F0000001F
444 
+0000001F0000001F0000001F0000001F000000FFE00000FFE01B207E951E>I<FE1F00FE3FC01E
445 
+67E01EC7E01E87E01E87E01F83C01F00001F00001F00001F00001F00001F00001F00001F00001F
446 
+00001F00001F00001F00001F0000FFF000FFF00013167E9517>I<0FF3003FFF00781F00600700
447 
+E00300E00300F00300FC00007FE0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380
448 
+E00380F00700FC0E00EFFC00C7F00011167E9516>I<0180000180000180000180000380000380
449 
+000780000780000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80
450 
+000F80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000F8
451 
+0011207F9F16>I<FF01FE00FF01FE001F003E001F003E001F003E001F003E001F003E001F003E
452 
+001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F00
453 
+7E001F00FE000F81BE0007FF3FC001FC3FC01A167E951F>I<FFE01FE0FFE01FE00F8006000F80
454 
+06000FC00E0007C00C0007E01C0003E0180003E0180001F0300001F0300000F8600000F8600000
455 
+7CC000007CC000007FC000003F8000003F8000001F0000001F0000000E0000000E00001B167F95
456 
+1E>I<FFE07FC0FFE07FC00F801C0007C0380003E0700003F0600001F8C00000F98000007F8000
457 
+003F0000001F0000001F8000003FC0000037C0000063E00000C1F00001C0F8000380FC0007007E
458 
+000E003E00FF80FFE0FF80FFE01B167F951E>120 D<FFE01FE0FFE01FE00F8006000F8006000F
459 
+C00E0007C00C0007E01C0003E0180003E0180001F0300001F0300000F8600000F86000007CC000
460 
+007CC000007FC000003F8000003F8000001F0000001F0000000E0000000E0000000C0000000C00
461 
+000018000078180000FC380000FC300000FC60000069C000007F8000001F0000001B207F951E>
462 
+I<7FFFF07FFFF07C03E07007C0600FC0E01F80C01F00C03E00C07E0000FC0000F80001F00003F0
463 
+3007E03007C0300F80701F80703F00603E00E07C03E0FFFFE0FFFFE014167E9519>I
464 
+E /Fh 11 121 df<70F8F8F87005057C840D>58 D<70F8FCFC74040404080810102040060E7C84
465 
+0D>I<00F1800389C00707800E03801C03803C0380380700780700780700780700F00E00F00E00
466 
+F00E00F00E10F01C20F01C20703C20705C40308C400F078014147E9318>97
467 
+D<007C01C207010E011C013C013802780C7BF07C00F000F000F000F00070007001700230041838
468 
+07C010147E9315>101 D<01E0000FE00001C00001C00001C00001C00003800003800003800003
469 
+80000700000700000701E00706100E08700E10F00E20F00E40601C80001D00001E00001FC00038
470 
+7000383800383800381C20703840703840703840701880E01880600F0014207E9F18>107
471 
+D<1E07802318C023A06043C0704380704380708700E00700E00700E00700E00E01C00E01C00E01
472 
+C00E03821C03841C07041C07081C03083803101801E017147E931B>110
473 
+D<03C1E004621804741C08781C08701E08701E10E01E00E01E00E01E00E01E01C03C01C03C01C0
474 
+3C01C0380380780380700380E003C1C0072380071E000700000700000E00000E00000E00000E00
475 
+001C00001C0000FFC000171D819317>112 D<00C000E001C001C001C001C003800380FFF80380
476 
+07000700070007000E000E000E000E001C001C001C001C10382038203820384018800F000D1C7F
477 
+9B10>116 D<0F00601180702180E021C0E041C0E04380E08381C00701C00701C00701C00E0380
478 
+0E03800E03800E03840E07080C07080C07080E0F1006131003E1E016147E931A>I<0F01801183
479 
+C02183E021C1E041C0E04380608380400700400700400700400E00800E00800E00800E01000E01
480 
+000C02000E04000E040006180001E00013147E9316>I<03C1C00C62201034701038F02038F020
481 
+386040700000700000700000700000E00000E00000E00000E02061C040F1C040F1C080E2C08044
482 
+6300383C0014147E931A>120 D E /Fi 86 127 df<70F8F8F8F8F8F8F8F8F8F8F8F8F8F8F8F8
483 
+70000000000070F8F8F870051C779B18>33 D<4010E038F078E038E038E038E038E038E038E038
484 
+E038E038E03860300D0E7B9C18>I<00C00001C00001C00001C00003F0000FFC003FFE007DCF00
485 
+71C700E1C380E1C780E1C780E1C780F1C00079C0003DC0001FE0000FF80003FC0001DE0001CF00
486 
+01C70061C380F1C380F1C380E1C380E1C70071C70079DE003FFE001FF80007E00001C00001C000
487 
+01C00000C00011247D9F18>36 D<3803007C07807C0780EE0F80EE0F00EE0F00EE1F00EE1E00EE
488 
+1E00EE3E007C3C007C3C00387C0000780000780000F80000F00001F00001E00001E00003E00003
489 
+C00003C00007C0000783800787C00F87C00F0EE00F0EE01F0EE01E0EE01E0EE03E0EE03C07C03C
490 
+07C018038013247E9F18>I<01C00007E0000FF0000E70001C38001C38001C38001C38001C73F0
491 
+1C73F01CE3F00FE3800FC7000F87000F07001F0E003F0E007B8E0073DC00E1DC00E0F800E0F800
492 
+E07070E0787070FC707FFFE03FCFE00F03C0141C7F9B18>I<387C7C7E3E0E0E0E1C1C38F8F0C0
493 
+070E789B18>I<007000F001E003C007800F001E001C00380038007000700070007000E000E000
494 
+E000E000E000E000E000E0007000700070007000380038001C001E000F00078003C001F000F000
495 
+700C24799F18>I<6000F00078003C001E000F000780038001C001C000E000E000E000E0007000
496 
+7000700070007000700070007000E000E000E000E001C001C0038007800F001E003C007800F000
497 
+60000C247C9F18>I<01C00001C00001C00001C000C1C180F1C780F9CF807FFF001FFC0007F000
498 
+07F0001FFC007FFF00F9CF80F1C780C1C18001C00001C00001C00001C00011147D9718>I<0060
499 
+0000F00000F00000F00000F00000F00000F00000F0007FFFC0FFFFE0FFFFE07FFFC000F00000F0
500 
+0000F00000F00000F00000F00000F00000600013147E9718>I<1C3E7E7F3F1F070E1E7CF86008
501 
+0C788518>I<7FFF00FFFF80FFFF807FFF0011047D8F18>I<3078FCFC78300606778518>I<0003
502 
+00000780000780000F80000F00001F00001E00001E00003E00003C00007C0000780000780000F8
503 
+0000F00001F00001E00003E00003C00003C00007C0000780000F80000F00000F00001F00001E00
504 
+003E00003C00003C00007C0000780000F80000F00000F0000060000011247D9F18>I<01F00007
505 
+FC000FFE001F1F001C07003803807803C07001C07001C0E000E0E000E0E000E0E000E0E000E0E0
506 
+00E0E000E0E000E0E000E0F001E07001C07001C07803C03803801C07001F1F000FFE0007FC0001
507 
+F000131C7E9B18>I<01800380038007800F803F80FF80FB804380038003800380038003800380
508 
+03800380038003800380038003800380038003807FFCFFFE7FFC0F1C7B9B18>I<03F0000FFE00
509 
+3FFF007C0F807003C0E001C0F000E0F000E06000E00000E00000E00001C00001C00003C0000780
510 
+000F00001E00003C0000780000F00001E00007C0000F80001E00E03C00E07FFFE0FFFFE07FFFE0
511 
+131C7E9B18>I<07F8001FFE003FFF007807807803C07801C03001C00001C00003C0000380000F
512 
+0003FF0003FE0003FF000007800003C00001C00000E00000E00000E0F000E0F000E0F001C0F003
513 
+C07C07803FFF001FFE0003F800131C7E9B18>I<001F00003F0000770000770000E70001E70001
514 
+C7000387000787000707000E07001E07003C0700380700780700F00700FFFFF8FFFFF8FFFFF800
515 
+0700000700000700000700000700000700007FF000FFF8007FF0151C7F9B18>I<1FFF803FFF80
516 
+3FFF803800003800003800003800003800003800003800003800003BF8003FFE003FFF003C0780
517 
+1803C00001C00000E00000E06000E0F000E0F000E0E001C07003C07C0F803FFF001FFC0003F000
518 
+131C7E9B18>I<007E0001FF0007FF800F83C01E03C01C03C0380180380000700000700000E1F8
519 
+00E7FE00FFFF00FE0780F803C0F001C0F000E0E000E0F000E07000E07000E07000E03801C03C03
520 
+C01E07800FFF0007FE0001F800131C7E9B18>I<E00000FFFFE0FFFFE0FFFFE0E003C0E0078000
521 
+0700000E00001E00001C0000380000380000700000700000E00000E00000E00001C00001C00001
522 
+C00001C00003C000038000038000038000038000038000038000038000131D7E9C18>I<03F800
523 
+0FFE001FFF003E0F803803807001C07001C07001C07001C03803803C07801FFF0007FC000FFE00
524 
+1F1F003C07807001C0F001E0E000E0E000E0E000E0E000E07001C07803C03E0F801FFF000FFE00
525 
+03F800131C7E9B18>I<03F0000FFC001FFE003C0F00780780700380E001C0E001C0E001C0E001
526 
+E0E001E07001E07803E03C0FE01FFFE00FFEE003F0E00000E00001C00001C00001C03003807807
527 
+80780F00783E003FFC001FF00007C000131C7E9B18>I<3078FCFC783000000000000000003078
528 
+FCFC78300614779318>I<183C7E7E3C180000000000000000183C7E7E3E1E0E1C3C78F060071A
529 
+789318>I<000300000780001F80003F00007E0001FC0003F00007E0001FC0003F00007E0000FC
530 
+0000FC00007E00003F00001FC00007E00003F00001FC00007E00003F00001F8000078000030011
531 
+187D9918>I<7FFFC0FFFFE0FFFFE0FFFFE0000000000000000000000000FFFFE0FFFFE0FFFFE0
532 
+7FFFC0130C7E9318>I<600000F00000FC00007E00003F00001FC00007E00003F00001FC00007E
533 
+00003F00001F80001F80003F00007E0001FC0003F00007E0001FC0003F00007E0000FC0000F000
534 
+0060000011187D9918>I<007C0001FE0007FF000F87801E03C03C1DC0387FC070FFE071E3E071
535 
+C1E0E1C1E0E380E0E380E0E380E0E380E0E380E0E380E0E1C1C071C1C071E3C070FF80387F003C
536 
+1C001E00E00F83E007FFC001FF80007E00131C7E9B18>64 D<00700000F80000F80000D80000D8
537 
+0001DC0001DC0001DC00018C00038E00038E00038E00038E000306000707000707000707000707
538 
+000FFF800FFF800FFF800E03800E03801C01C01C01C07F07F0FF8FF87F07F0151C7F9B18>I<FF
539 
+FC00FFFF00FFFF801C03C01C01C01C00E01C00E01C00E01C00E01C01E01C01C01C07C01FFF801F
540 
+FF001FFFC01C03C01C00E01C00F01C00701C00701C00701C00701C00F01C00E01C03E0FFFFC0FF
541 
+FF80FFFE00141C7F9B18>I<00F8E003FEE007FFE00F07E01E03E03C01E03800E07000E07000E0
542 
+700000E00000E00000E00000E00000E00000E00000E00000E000007000007000E07000E03800E0
543 
+3C00E01E01C00F07C007FF8003FE0000F800131C7E9B18>I<7FF800FFFE007FFF001C0F801C03
544 
+C01C03C01C01E01C00E01C00E01C00F01C00701C00701C00701C00701C00701C00701C00701C00
545 
+701C00F01C00E01C00E01C01E01C01C01C03C01C0F807FFF00FFFE007FF800141C7F9B18>I<FF
546 
+FFF0FFFFF0FFFFF01C00701C00701C00701C00701C00001C00001C0E001C0E001C0E001FFE001F
547 
+FE001FFE001C0E001C0E001C0E001C00001C00001C00381C00381C00381C00381C0038FFFFF8FF
548 
+FFF8FFFFF8151C7F9B18>I<FFFFE0FFFFE0FFFFE01C00E01C00E01C00E01C00E01C00001C0000
549 
+1C1C001C1C001C1C001FFC001FFC001FFC001C1C001C1C001C1C001C00001C00001C00001C0000
550 
+1C00001C00001C0000FFC000FFC000FFC000131C7E9B18>I<01F1C003FDC00FFFC01F0FC01C03
551 
+C03803C03801C07001C07001C0700000E00000E00000E00000E00000E00000E00FF0E01FF0E00F
552 
+F07001C07001C07003C03803C03803C01C07C01F0FC00FFFC003FDC001F1C0141C7E9B18>I<7F
553 
+07F0FF8FF87F07F01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01FFFC01F
554 
+FFC01FFFC01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C07F07F0FF
555 
+8FF87F07F0151C7F9B18>I<7FFF00FFFF807FFF0001C00001C00001C00001C00001C00001C000
556 
+01C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C000
557 
+01C00001C00001C0007FFF00FFFF807FFF00111C7D9B18>I<7FE000FFE0007FE0000E00000E00
558 
+000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
559 
+000E00000E00000E00700E00700E00700E00700E00707FFFF0FFFFF07FFFF0141C7F9B18>76
560 
+D<FC01F8FE03F8FE03F83B06E03B06E03B06E03B06E03B8EE03B8EE0398CE0398CE039DCE039DC
561 
+E039DCE038D8E038D8E038F8E03870E03870E03800E03800E03800E03800E03800E03800E0FE03
562 
+F8FE03F8FE03F8151C7F9B18>I<7E07F0FF0FF87F07F01D81C01D81C01D81C01DC1C01CC1C01C
563 
+C1C01CE1C01CE1C01CE1C01C61C01C71C01C71C01C31C01C39C01C39C01C39C01C19C01C19C01C
564 
+1DC01C0DC01C0DC01C0DC07F07C0FF87C07F03C0151C7F9B18>I<0FF8003FFE007FFF00780F00
565 
+700700F00780E00380E00380E00380E00380E00380E00380E00380E00380E00380E00380E00380
566 
+E00380E00380E00380E00380E00380F00780700700780F007FFF003FFE000FF800111C7D9B18>
567 
+I<FFFE00FFFF80FFFFC01C03C01C01E01C00E01C00701C00701C00701C00701C00701C00E01C01
568 
+E01C03C01FFFC01FFF801FFE001C00001C00001C00001C00001C00001C00001C00001C0000FF80
569 
+00FF8000FF8000141C7F9B18>I<7FF800FFFE007FFF001C0F801C03801C03C01C01C01C01C01C
570 
+01C01C03C01C03801C0F801FFF001FFE001FFE001C0F001C07001C03801C03801C03801C03801C
571 
+03801C039C1C039C1C039C7F01F8FF81F87F00F0161C7F9B18>82 D<03F3801FFF803FFF807C0F
572 
+80700780E00380E00380E00380E000007000007800003F00001FF00007FE0000FF00000F800003
573 
+C00001C00000E00000E06000E0E000E0E001E0F001C0F80780FFFF80FFFE00E7F800131C7E9B18
574 
+>I<7FFFF8FFFFF8FFFFF8E07038E07038E07038E0703800700000700000700000700000700000
575 
+700000700000700000700000700000700000700000700000700000700000700000700000700007
576 
+FF0007FF0007FF00151C7F9B18>I<FF07F8FF07F8FF07F81C01C01C01C01C01C01C01C00E0380
577 
+0E03800E03800E03800F0780070700070700070700070700038E00038E00038E00038E00018C00
578 
+01DC0001DC0001DC0000D80000F80000F800007000151C7F9B18>86 D<FE03F8FE03F8FE03F870
579 
+00707000707000703800E03800E03800E03800E03800E038F8E038F8E039DCE039DCE019DCC019
580 
+DCC019DCC0198CC01D8DC01D8DC01D8DC01D8DC00D8D800D05800F07800F07800E0380151C7F9B
581 
+18>I<7F8FE07F9FE07F8FE00E07000F0700070E00078E00039C0003DC0001F80001F80000F000
582 
+00F00000700000F00000F80001F80001DC00039E00038E00070F000707000E07800E03801E03C0
583 
+7F07F0FF8FF87F07F0151C7F9B18>I<FFF8FFF8FFF8E000E000E000E000E000E000E000E000E0
584 
+00E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
585 
+E000E000FFF8FFF8FFF80D24779F18>91 D<600000F00000F00000F800007800007C00003C0000
586 
+3C00003E00001E00001F00000F00000F00000F800007800007C00003C00003C00003E00001E000
587 
+01F00000F00000F800007800007800007C00003C00003E00001E00001E00001F00000F00000F80
588 
+00078000078000030011247D9F18>I<FFF8FFF8FFF80038003800380038003800380038003800
589 
+380038003800380038003800380038003800380038003800380038003800380038003800380038
590 
+00380038FFF8FFF8FFF80D247F9F18>I<018007C01FF07EFCF83EE00E0F067C9B18>I<7FFF00FF
591 
+FF80FFFF807FFF0011047D7F18>I<061E3E387070E0E0E0F8FC7C7C38070E789E18>I<1FE0003F
592 
+F8007FFC00781E00300E0000070000070000FF0007FF001FFF007F0700780700E00700E00700E0
593 
+0700F00F00781F003FFFF01FFBF007E1F014147D9318>I<7E0000FE00007E00000E00000E0000
594 
+0E00000E00000E00000E3E000EFF800FFFC00FC1E00F80E00F00700E00700E00380E00380E0038
595 
+0E00380E00380E00380F00700F00700F80E00FC1E00FFFC00EFF80063E00151C809B18>I<01FE
596 
+0007FF001FFF803E0780380300700000700000E00000E00000E00000E00000E00000E000007000
597 
+007001C03801C03E03C01FFF8007FF0001FC0012147D9318>I<001F80003F80001F8000038000
598 
+038000038000038000038003E3800FFB801FFF803C1F80380F80700780700380E00380E00380E0
599 
+0380E00380E00380E00380700780700780380F803C1F801FFFF00FFBF803E3F0151C7E9B18>I<
600 
+01F00007FC001FFE003E0F00380780700380700380E001C0E001C0FFFFC0FFFFC0FFFFC0E00000
601 
+7000007001C03801C03E03C01FFF8007FF0001FC0012147D9318>I<001F80007FC000FFE000E1
602 
+E001C0C001C00001C00001C0007FFFC0FFFFC0FFFFC001C00001C00001C00001C00001C00001C0
603 
+0001C00001C00001C00001C00001C00001C00001C00001C0007FFF007FFF007FFF00131C7F9B18
604 
+>I<01E1F007FFF80FFFF81E1E301C0E003807003807003807003807003807001C0E001E1E001F
605 
+FC001FF80039E0003800001C00001FFE001FFFC03FFFE07801F0700070E00038E00038E00038E0
606 
+00387800F07E03F01FFFC00FFF8001FC00151F7F9318>I<7E0000FE00007E00000E00000E0000
607 
+0E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E00E00E00E00E00E00E0
608 
+0E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FCFFE7FE7FC3FC171C809B18>I<0380
609 
+0007C00007C00007C0000380000000000000000000000000007FC000FFC0007FC00001C00001C0
610 
+0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C000FFFF
611 
+00FFFF80FFFF00111D7C9C18>I<0038007C007C007C003800000000000000000FFC1FFC0FFC00
612 
+1C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C
613 
+001C001C6038F078FFF07FE03F800E277E9C18>I<FE0000FE0000FE00000E00000E00000E0000
614 
+0E00000E00000E3FF00E7FF00E3FF00E07800E0F000E1E000E3C000E78000EF0000FF8000FFC00
615 
+0F9C000F0E000E0F000E07000E03800E03C0FFC7F8FFC7F8FFC7F8151C7F9B18>I<7FE000FFE0
616 
+007FE00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
617 
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0007FFFC0FFFFE07FFF
618 
+C0131C7E9B18>I<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C
619 
+001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C007F1F
620 
+1F00FFBFBF807F1F1F001914819318>I<7E3E00FEFF807FFFC00FC1C00F80E00F00E00E00E00E
621 
+00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FCFFE7FE7FC3FC17
622 
+14809318>I<01F0000FFE001FFF003E0F803803807001C07001C0E000E0E000E0E000E0E000E0
623 
+E000E0F001E07001C07803C03C07803E0F801FFF000FFE0001F00013147E9318>I<7E3E00FEFF
624 
+807FFFC00FC1E00F80E00F00700E00700E00380E00380E00380E00380E00380E00380F00700F00
625 
+700F80E00FC1E00FFFC00EFF800E3E000E00000E00000E00000E00000E00000E00000E00007FC0
626 
+00FFE0007FC000151E809318>I<01E38007FB801FFF803E1F80380F80700780700780E00380E0
627 
+0380E00380E00380E00380E00380700780700780380F803C1F801FFF800FFB8003E38000038000
628 
+0380000380000380000380000380000380003FF8003FF8003FF8151E7E9318>I<7F87E0FF9FF0
629 
+7FBFF803F87803F03003E00003C00003C000038000038000038000038000038000038000038000
630 
+0380000380007FFE00FFFF007FFE0015147F9318>I<07F7003FFF007FFF00780F00E00700E007
631 
+00E007007C00007FE0001FFC0003FE00001F00600780E00380E00380F00380F80F00FFFF00FFFC
632 
+00E7F00011147D9318>I<0180000380000380000380000380007FFFC0FFFFC0FFFFC003800003
633 
+80000380000380000380000380000380000380000380000380400380E00380E00380E001C1C001
634 
+FFC000FF80003E0013197F9818>I<7E07E0FE0FE07E07E00E00E00E00E00E00E00E00E00E00E0
635 
+0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E01E00F03E007FFFC03FFFE01FCFC171480
636 
+9318>I<7F8FF0FF8FF87F8FF01E03C00E03800E03800E0380070700070700070700038E00038E
637 
+00038E00038E0001DC0001DC0001DC0000F80000F80000700015147F9318>I<FF8FF8FF8FF8FF
638 
+8FF83800E03800E03800E01C01C01C01C01C71C01CF9C01CF9C01CD9C01CD9C00DDD800DDD800D
639 
+DD800D8D800F8F800F8F8007070015147F9318>I<7F8FF07F9FF07F8FF0070700078E00039E00
640 
+01DC0001F80000F80000700000F00000F80001DC00039E00038E000707000F07807F8FF0FF8FF8
641 
+7F8FF015147F9318>I<7F8FF0FF8FF87F8FF00E01C00E03800E03800703800707000707000387
642 
+00038600038E0001CE0001CE0000CC0000CC0000DC000078000078000078000070000070000070
643 
+0000F00000E00079E0007BC0007F80003F00001E0000151E7F9318>I<3FFFF07FFFF07FFFF070
644 
+01E07003C0700780000F00001E00003C0000F80001F00003C0000780000F00701E00703C007078
645 
+0070FFFFF0FFFFF0FFFFF014147F9318>I<0007E0001FE0007FE000780000E00000E00000E000
646 
+00E00000E00000E00000E00000E00000E00000E00000E00001E0007FC000FF8000FF80007FC000
647 
+01E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E000007800
648 
+007FE0001FE00007E013247E9F18>I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0
649 
+F0F0F0F0F0F0F0F0F0F0F0F0600424769F18>I<7C0000FF0000FFC00003C00000E00000E00000
650 
+E00000E00000E00000E00000E00000E00000E00000E00000E00000F000007FC0003FE0003FE000
651 
+7FC000F00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00003
652 
+C000FFC000FF00007C000013247E9F18>I<060C1F1E3FBEFBF8F1F060C00F067C9B18>I
653 
+E /Fj 59 123 df<0003E0001C1800381800703C00E03C00E03801C00001C00001C00001C00001
654 
+C0000380007FFFF00380700380700380700380700700E00700E00700E00700E00700E00700E00E
655 
+01C00E01C00E01C00E01C00E01C00E01C01C03801E03C0FF0FF816207E9F19>12
656 
+D<381C7C3E7C3E7E3F3A1D040204020402080408041008201040208040100E7A9F17>34
657 
+D<1C3E7E7E3A0202040408081020C0070E7D840D>44 D<FFC0FFC00A027D8A0F>I<3078F87870
658 
+05057C840D>I<00000400000C00000C0000180000180000300000300000600000600000C00000
659 
+C0000180000180000300000300000600000600000C00000C000018000018000030000030000060
660 
+0000600000C00000C0000180000180000300000300000600000600000600000C00000C00001800
661 
+00180000300000300000600000600000C00000C00000800000162D7EA117>I<000C001C00FC0F
662 
+380038003800380038003800700070007000700070007000E000E000E000E000E000E001C001C0
663 
+01C001C001C001C0038003C0FFFE0F1E7C9D17>49 D<003F8000C1E00100F00200780400780400
664 
+780F007C0F807C0F807C0F00780600780000F80000F00001E00001C0000380000700000E00001C
665 
+0000380000600000C0000180000300200600200800401000403FFFC07FFF80FFFF80161E7E9D17
666 
+>I<007F000183C00201E00400F00700F00F00F00F01F00F01F00001E00001E00003C000038000
667 
+0700000E0000F800000E000007000007800007C00003C00007C03007C07807C0F807C0F807C0F0
668 
+0780800F00400E00201C0018780007E000141F7D9D17>I<0000600000600000E00001C00003C0
669 
+0005C0000DC00009C00011C000238000438000C380008380010380020380040700080700180700
670 
+100700200700400700FFFFF0000E00000E00000E00000E00000E00001C00001E0001FFE0141E7E
671 
+9D17>I<01803001FFE003FFC003FF0003FC00020000020000020000040000040000040000047C
672 
+000587000603800C01800801C00001C00001E00001E00001E00001E07003C0F803C0F003C0E003
673 
+80800780400700400E00201C0018700007C000141F7D9D17>I<000F8000704000C0200180E003
674 
+01E00701E00E00C01E00001C00003C000038000078F800790E007A07007C0300F80380F80380F0
675 
+03C0F003C0F003C0F003C0F00780E00780E00780E00700E00F00600E00701C0030180018700007
676 
+C000131F7C9D17>I<2000003FFFE07FFFC07FFF80400100C00200800200800400000800001000
677 
+0020000040000040000080000180000300000300000700000600000E00000E00001E00001C0000
678 
+1C00003C00003C00003C0000780000780000780000300000131F799D17>I<003F0000C1C00100
679 
+600200600400300C00300C00300C00300C00600E00600F80C00FC18007F60003FC0001FC0001FF
680 
+00063F800C0F801007C03003C06001C06000C0C000C0C000C0C000C0C00080C001006003003004
681 
+0018180007E000141F7D9D17>I<007E0001C3000301800601C00E01C01C00C03C00E03C00E03C
682 
+01E07801E07801E07801E07801E07803E07803E03803C03807C01C0BC00C13C003E38000078000
683 
+0780000700000E00600E00F01C00F01800E0300080600041C0003F0000131F7C9D17>I<000010
684 
+0000001800000038000000380000007800000078000000FC000001BC0000013C0000033C000002
685 
+3C0000063C0000043E0000081E0000081E0000101E0000101E0000201E0000200F0000400F0000
686 
+400F0000FFFF0000800F0001000F8001000780020007800200078004000780040007800C0007C0
687 
+3E0007C0FF807FFC1E207E9F22>65 D<07FFFF00007C01C0003C01E0003C00F0007800F8007800
688 
+F8007800F8007800F8007800F8007800F000F001F000F001E000F003C000F00F8000FFFE0000F0
689 
+0F0001E007C001E003C001E003E001E001E001E001E001E001E003C001E003C003E003C003E003
690 
+C003C003C007C003C00F8007800F0007803E00FFFFF0001D1F7E9E20>I<0001F808000E061800
691 
+380138007000F801E0007803C0007007800030078000300F0000301F0000301E0000303E000020
692 
+3C0000007C0000007C0000007C0000007C000000F8000000F8000000F8000000F8000000F80000
693 
+007800004078000080780000803C0000803C0001001C0002000E00020006000C000300100001C0
694 
+E000003F00001D217B9F21>I<07FFFF00007C01E0003C00F0003C00780078003C0078003C0078
695 
+001E0078001E0078001E0078001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F01
696 
+E0001E01E0003E01E0003E01E0003E01E0003C01E0007C03C0007803C000F003C000F003C001E0
697 
+03C003C003C0078007800F0007803C00FFFFE000201F7E9E23>I<07FFFFF8007C0078003C0038
698 
+003C001800780018007800080078000800780008007800080078080800F0100000F0100000F010
699 
+0000F0300000FFF00000F0700001E0200001E0200001E0200001E0200001E0000801E0001003C0
700 
+001003C0001003C0002003C0002003C0006003C000C0078001C0078007C0FFFFFF801D1F7E9E1F
701 
+>I<07FFFFF8007C0078003C0038003C0018007800180078000800780008007800080078000800
702 
+78000800F0100000F0100000F0100000F0300000F0700000FFF00001E0600001E0200001E02000
703 
+01E0200001E0200001E0000003C0000003C0000003C0000003C0000003C0000003C00000078000
704 
+0007C00000FFFE00001D1F7E9E1E>I<0001FC04000F030C003C009C0070007C00E0003C01C000
705 
+3803800018078000180F0000181F0000181E0000183E0000103C0000007C0000007C0000007C00
706 
+00007C000000F8000000F8000000F8007FFCF80003E0780001E0780001E0780003C0780003C03C
707 
+0003C03C0003C01C0003C00E0007C007000B800380118001E06080003F80001E217B9F24>I<07
708 
+FFC7FFC0007C00F800003C007800003C007800007800F000007800F000007800F000007800F000
709 
+007800F000007800F00000F001E00000F001E00000F001E00000F001E00000FFFFE00000F001E0
710 
+0001E003C00001E003C00001E003C00001E003C00001E003C00001E003C00003C007800003C007
711 
+800003C007800003C007800003C007800003C007800007800F000007C00F8000FFF8FFF800221F
712 
+7E9E22>I<07FFE0007C00003C00003C0000780000780000780000780000780000780000F00000
713 
+F00000F00000F00000F00000F00001E00001E00001E00001E00001E00001E00003C00003C00003
714 
+C00003C00003C00003C00007800007C000FFFC00131F7F9E10>I<07FFF000007E0000003C0000
715 
+003C000000780000007800000078000000780000007800000078000000F0000000F0000000F000
716 
+0000F0000000F0000000F0000001E0000001E0000001E0000001E0000001E0008001E0010003C0
717 
+010003C0010003C0030003C0020003C0060003C0060007801E0007807C00FFFFFC00191F7E9E1C
718 
+>76 D<07FC0000FFC0007C0000F800003C00017800003C00017800004E0002F000004E0002F000
719 
+004E0004F000004E0004F000004E0008F000004E0008F00000870011E00000870011E000008700
720 
+21E00000870021E00000870041E00000838041E00001038083C00001038083C00001038103C000
721 
+01038203C0000101C203C0000101C403C0000201C40780000201C80780000201C80780000201D0
722 
+0780000200F00780000600E00780000600E00F00000F00C00F8000FFE0C1FFF8002A1F7E9E2A>
723 
+I<07FC01FFC0003E003E00003E001800003E001800004F001000004F0010000047801000004780
724 
+10000043C010000043C010000083C020000081E020000081E020000080F020000080F020000080
725 
+782000010078400001007C400001003C400001003C400001001E400001001E400002000F800002
726 
+000F800002000F800002000780000200078000060003800006000300000F00010000FFE0010000
727 
+221F7E9E22>I<0003F800001E0E000038070000E0038001C001C003C001E0078000E00F0000F0
728 
+0F0000F01E0000F01E0000F83E0000F83C0000F87C0000F87C0000F87C0000F87C0000F8F80001
729 
+F0F80001F0F80001F0F80001F0F80003E0780003E0780003C0780007C07C0007803C000F003C00
730 
+1E001E001C000E0038000700F00003C3C00000FE00001D217B9F23>I<07FFFF00007C03C0003C
731 
+01E0003C00F0007800F0007800F8007800F8007800F8007800F8007800F000F001F000F001E000
732 
+F003C000F0078000F00F0000FFF80001E0000001E0000001E0000001E0000001E0000001E00000
733 
+03C0000003C0000003C0000003C0000003C0000003C000000780000007C00000FFFC00001D1F7E
734 
+9E1F>I<07FFFC00007C0700003C03C0003C01E0007801E0007801F0007801F0007801F0007801
735 
+F0007801E000F003E000F003C000F0078000F00F0000F03C0000FFF00001E0300001E0380001E0
736 
+1C0001E01C0001E01C0001E01E0003C03E0003C03E0003C03E0003C03E0003C03E0003C03E0207
737 
+803E0407C01F04FFFC0F18000003E01F207E9E21>82 D<003F040060CC01803C03801C03001C07
738 
+00180600080E00080E00080E00080E00000F00000F80000FE00007FE0003FF8001FFC0007FE000
739 
+07E00001E00000E00000F00000F04000E04000E04000E04000E06000C0600180E00380F80300C6
740 
+0C0081F80016217D9F19>I<3FFFFFF03C0780F03007803060078030400F0010400F0010C00F00
741 
+10800F0010800F0010800F0010001E0000001E0000001E0000001E0000001E0000001E0000003C
742 
+0000003C0000003C0000003C0000003C0000003C00000078000000780000007800000078000000
743 
+7800000078000000F0000001F800007FFFE0001C1F7A9E21>I<FFFC3FF80F8007C00780030007
744 
+8003000F0002000F0002000F0002000F0002000F0002000F0002001E0004001E0004001E000400
745 
+1E0004001E0004001E0004003C0008003C0008003C0008003C0008003C0008003C000800380010
746 
+003800100038001000380020003C0040001C0040001C0080000E0100000706000001F800001D20
747 
+799E22>I<FFF003FE1F8000F80F0000600F0000400F0000400F80008007800180078001000780
748 
+02000780020007C0040003C0040003C0080003C0080003C0100003E0100001E0200001E0200001
749 
+E0400001E0400001F0800000F1000000F1000000F2000000F2000000FC0000007C000000780000
750 
+007800000070000000700000002000001F207A9E22>I<03FFC0FFC0007F007E00003E00380000
751 
+1E003000001E002000000F004000000F008000000F81000000078200000007C600000003C40000
752 
+0003E800000001F000000001F000000000F000000000F800000000F8000000017C000000023C00
753 
+0000043C0000000C1E000000081E000000101F000000200F000000400F800000C0078000008007
754 
+C000010003C000070003E0001F8007E000FFE01FFE00221F7F9E22>88 D<FFF003FF1F8000F80F
755 
+0000600F8000400780008007C0018003C0010003E0020001E0040001F00C0001F0080000F01000
756 
+00F8200000786000007C4000003C8000003F0000001F0000001E0000001E0000001E0000001C00
757 
+00003C0000003C0000003C0000003C0000003C00000038000000780000007C00000FFFC000201F
758 
+7A9E22>I<060308041008201020104020402080408040B85CF87CF87CF87C7038100E779F17>
759 
+92 D<07F8000C0C001E06001E07001C070000070000070000070000FF0007C7001E07003C0E00
760 
+780E00F00E10F00E10F00E10F01E10F02E20784F401F878014147D9317>97
761 
+D<0700003F00000F00000700000700000E00000E00000E00000E00000E00000E00001C00001C7C
762 
+001D87001E03801C01C01C01C03801C03801E03801E03801E03801E03801E07003C07003C07003
763 
+80700780700700700E00E81C00C4380083E00013207B9F19>I<01FC07060E0F1C0F380E780070
764 
+00F000F000F000F000E000E000E000E000F0027004300818300FC010147C9314>I<0000700003
765 
+F00000F00000700000700000E00000E00000E00000E00000E00000E00001C000F9C00305C00E03
766 
+C01C03C03801C0780380700380F00380F00380F00380F00380E00700E00700E00700E00700E007
767 
+00700F00301E00186F000F8FE014207C9F19>I<00F800070E000E07001C070038038078038070
768 
+0380F00380F00380FFFF80F00000E00000E00000E00000E00000F001007002003004001C180007
769 
+E00011147D9314>I<0007800018C00031E00061E000E1C000C00001C00001C00001C00001C000
770 
+01C0000380007FF800038000038000038000038000070000070000070000070000070000070000
771 
+0E00000E00000E00000E00000E00000E00001C00001E0000FFE00013207E9F0E>I<00000E003E
772 
+1100E1A301C1C20381E00780E00701E00F01E00F01E00F01E00703C007038007870004FC000800
773 
+000800001800001C00000FFF000FFFC007FFE01800F0300030600030C00030C00030C000306000
774 
+603000C01C070007FC00181F809417>I<00E00007E00001E00000E00000E00001C00001C00001
775 
+C00001C00001C00001C000038000038F800390E003A0E003C0600380600780E00700E00700E007
776 
+00E00700E00700E00E01C00E01C00E01C00E01C00E01C00E01C01C03801E03C0FFCFF815207E9F
777 
+19>I<01C003E003E003C0018000000000000000000000000003801F8007800380038007000700
778 
+07000700070007000E000E000E000E000E000E001C001E00FF800B1F7F9E0C>I<00E007E001E0
779 
+00E000E001C001C001C001C001C001C00380038003800380038003800700070007000700070007
780 
+000E000E000E000E000E000E001C001E00FFC00B207F9F0C>108 D<0387C07C001F9861860007
781 
+A072070003C0340300038038030007807807000700700700070070070007007007000700700700
782 
+07007007000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E001C01C01C
783 
+001E01E01E00FFCFFCFFC022147E9326>I<038F801F90E007A0E003C0600380600780E00700E0
784 
+0700E00700E00700E00700E00E01C00E01C00E01C00E01C00E01C00E01C01C03801E03C0FFCFF8
785 
+15147E9319>I<00FC000387000E01801C00C03800E03800E07000F0F000F0F000F0F000F0F000
786 
+F0E001E0E001E0E001C0E003C0F00380700700380E001C1C0007E00014147D9317>I<00E3E007
787 
+EC3800F01C00E01E00E00E01C00E01C00F01C00F01C00F01C00F01C00F03801E03801E03801C03
788 
+803C0380380380700740E00721C0071F000700000700000700000E00000E00000E00000E00001E
789 
+0000FFC000181D809319>I<038E001FB38007C78003C780038300078000070000070000070000
790 
+0700000700000E00000E00000E00000E00000E00000E00001C00001E0000FFE00011147E9312>
791 
+114 D<01F2060E080618061802380438001E001FE00FF003F8003C401C400C400C600C6018E010
792 
+D0608FC00F147E9312>I<0080010001000100030007000F001E00FFF80E000E000E000E001C00
793 
+1C001C001C001C001C00380038203820382038203840384018800F000D1C7C9B12>I<1C0380FC
794 
+1F803C07801C03801C0380380700380700380700380700380700380700700E00700E00700E0070
795 
+0E00701E00701E00703C00305E001F9FC012147B9319>I<FF83F81E00E01C00C01C00800E0080
796 
+0E01000E02000E02000F040007040007080007080007100003900003A00003E00003C000038000
797 
+01800001000015147C9318>I<1FF0FF03C07801C06001C04000E08000E180007300007600003C
798 
+00003C00001C00002E00004E000087000107000203800603800C01C03E03E0FF07FC18147F9318
799 
+>120 D<0FF83F8001E00E0001C00C0001C0080000E0180000E0100000E0200000E0200000F040
800 
+000070400000708000007080000071000000390000003A0000003E0000003C0000003800000018
801 
+0000001000000010000000200000002000000040000070C00000F0800000F1000000E20000007C
802 
+000000191D809318>I<07FFE00701E00401C00C0380080700080E00101C000038000070000070
803 
+0000E00001C0000380800700800E00801C01001C0100380300700E00FFFE0013147F9314>I
804 
+E /Fk 55 123 df<00FC7C0183C607078E0607040E07000E07000E07000E07000E07000E0700FF
805 
+FFF00E07000E07000E07000E07000E07000E07000E07000E07000E07000E07000E07000E07000E
806 
+07000E07007F0FF0171A809916>11 D<00FC000182000703000607000E02000E00000E00000E00
807 
+000E00000E0000FFFF000E07000E07000E07000E07000E07000E07000E07000E07000E07000E07
808 
+000E07000E07000E07000E07007F0FE0131A809915>I<60F0F0F0F0F0F0606060606060606060
809 
+60200000000060F0F060041A7D990B>33 D<60C0F1E0F9F068D0081008100810102010202040C1
810 
+800C0B7F9913>I<60F0F868080808101020C0050B7D990B>39 D<00800100020004000C000800
811 
+18003000300030006000600060006000E000E000E000E000E000E000E000E000E000E000600060
812 
+0060006000300030003000180008000C00040002000100008009267D9B0F>I<80004000200010
813 
+00180008000C000600060006000300030003000300038003800380038003800380038003800380
814 
+038003000300030003000600060006000C0008001800100020004000800009267E9B0F>I<60F0
815 
+F07010101020204080040B7D830B>44 D<FFC0FFC00A0280880D>I<60F0F06004047D830B>I<01
816 
+E006100C1818383038300070006000E000E7C0E860F030F018E018E01CE01CE01C601C601C7018
817 
+30183030186007C00E187E9713>54 D<078018603030201860186018601870103C303E600F8007
818 
+C019F030F86038401CC00CC00CC00CC00C6008201018600FC00E187E9713>56
819 
+D<60F0F060000000000000000060F0F06004107D8F0B>58 D<60F0F060000000000000000060F0
820 
+F0701010102020408004177D8F0B>I<000C0000000C0000000C0000001E0000001E0000003F00
821 
+0000270000002700000043800000438000004380000081C0000081C0000081C0000100E0000100
822 
+E00001FFE000020070000200700006007800040038000400380008001C0008001C001C001E00FF
823 
+00FFC01A1A7F991D>65 D<FFFF000E01C00E00E00E00700E00780E00780E00780E00780E00780E
824 
+00F00E00E00E03C00FFF800E01E00E00700E00780E003C0E003C0E003C0E003C0E003C0E00380E
825 
+00780E00F00E01E0FFFF80161A7E991B>I<003F0201C0C603002E0E001E1C000E1C0006380006
826 
+780002700002700002F00000F00000F00000F00000F00000F00000700002700002780002380004
827 
+1C00041C00080E000803003001C0C0003F00171A7E991C>I<FFFFE00E00E00E00600E00200E00
828 
+300E00100E00100E00100E04000E04000E04000E0C000FFC000E0C000E04000E04000E04000E00
829 
+000E00000E00000E00000E00000E00000E00000E0000FFF000141A7E9919>70
830 
+D<FFE7FF0E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700FFF
831 
+F00E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E0070FFE7
832 
+FF181A7E991D>72 D<FFE00E000E000E000E000E000E000E000E000E000E000E000E000E000E00
833 
+0E000E000E000E000E000E000E000E000E000E00FFE00B1A7F990E>I<FFF0000E00000E00000E
834 
+00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E
835 
+00000E00200E00200E00200E00600E00400E00400E00C00E03C0FFFFC0131A7E9918>76
836 
+D<FF0003FC0F0003C00F0003C00B8005C00B8005C00B8005C009C009C009C009C009C009C008E0
837 
+11C008E011C008E011C0087021C0087021C0083841C0083841C0083841C0081C81C0081C81C008
838 
+1C81C0080F01C0080F01C0080F01C0080601C01C0601C0FF861FFC1E1A7E9923>I<FE01FF0F00
839 
+380F00100B80100B801009C01008E01008E010087010087010083810081C10081C10080E10080E
840 
+100807100803900803900801D00801D00800F00800700800700800301C0030FF8010181A7E991D
841 
+>I<FFFF000E03C00E00E00E00700E00700E00780E00780E00780E00780E00700E00700E00E00E
842 
+03C00FFF000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0000FF
843 
+E000151A7E991A>80 D<FFFC00000E0780000E01C0000E00E0000E00F0000E00F0000E00F0000E
844 
+00F0000E00F0000E00E0000E01C0000E0780000FFC00000E0600000E0300000E0180000E01C000
845 
+0E01C0000E01C0000E01E0000E01E0000E01E0000E01E0800E00F0800E007100FFE03E00191A7E
846 
+991C>82 D<0FC21836200E6006C006C002C002C002E00070007E003FE01FF807FC003E000E0007
847 
+0003800380038003C002C006E004D81887E0101A7E9915>I<7FFFFF00701C0700401C0100401C
848 
+0100C01C0180801C0080801C0080801C0080001C0000001C0000001C0000001C0000001C000000
849 
+1C0000001C0000001C0000001C0000001C0000001C0000001C0000001C0000001C0000001C0000
850 
+001C0000001C000003FFE000191A7F991C>I<FF83FF0FF03C007801C01C007800801C00780080
851 
+0E007801000E007801000E009C010007009C020007009C020007010E020007010E020003810E04
852 
+000382070400038207040001C207080001C403880001C403880000E403900000E403900000E801
853 
+D000007801E000007801E000007000E000007000E000003000C0000020004000241A7F9927>87
854 
+D<1830204040804080810081008100B160F9F078F030600C0B7B9913>92
855 
+D<3F8070C070E020700070007007F01C7030707070E070E071E071E0F171FB1E3C10107E8F13>
856 
+97 D<FC00001C00001C00001C00001C00001C00001C00001C00001C00001C00001CF8001F0E00
857 
+1E07001C03801C01801C01C01C01C01C01C01C01C01C01C01C01C01C03801C03001E07001B0C00
858 
+10F000121A7F9915>I<07F80C1C381C30087000E000E000E000E000E000E0007000300438080C
859 
+1807E00E107F8F11>I<007E00000E00000E00000E00000E00000E00000E00000E00000E00000E
860 
+0003CE000C3E00380E00300E00700E00E00E00E00E00E00E00E00E00E00E00E00E00600E00700E
861 
+00381E001C2E0007CFC0121A7F9915>I<07C01C3030187018600CE00CFFFCE000E000E000E000
862 
+6000300438080C1807E00E107F8F11>I<01F0031807380E100E000E000E000E000E000E00FFC0
863 
+0E000E000E000E000E000E000E000E000E000E000E000E000E000E007FE00D1A80990C>I<0FCE
864 
+187330307038703870387038303018602FC02000600070003FF03FFC1FFE600FC003C003C003C0
865 
+036006381C07E010187F8F13>I<FC00001C00001C00001C00001C00001C00001C00001C00001C
866 
+00001C00001CF8001D0C001E0E001E0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E001C
867 
+0E001C0E001C0E001C0E00FF9FC0121A7F9915>I<18003C003C00180000000000000000000000
868 
+0000FC001C001C001C001C001C001C001C001C001C001C001C001C001C001C00FF80091A80990A
869 
+>I<018003C003C001800000000000000000000000000FC001C001C001C001C001C001C001C001
870 
+C001C001C001C001C001C001C001C001C001C001C041C0E180E3007E000A2182990C>I<FC0000
871 
+1C00001C00001C00001C00001C00001C00001C00001C00001C00001C3F801C1E001C18001C1000
872 
+1C20001C40001DC0001FE0001CE0001C70001C78001C38001C1C001C1E001C1F00FF3FC0121A7F
873 
+9914>I<FC001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C
874 
+001C001C001C001C001C001C001C00FF80091A80990A>I<FC7C1F001D8E63801E0781C01E0781
875 
+C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C07
876 
+01C01C0701C0FF9FE7F81D107F8F20>I<FCF8001D0C001E0E001E0E001C0E001C0E001C0E001C
877 
+0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E00FF9FC012107F8F15>I<07E01C38300C
878 
+700E6006E007E007E007E007E007E0076006700E381C1C3807E010107F8F13>I<FCF8001F0E00
879 
+1E07001C03801C03801C01C01C01C01C01C01C01C01C01C01C01C01C03801C03001E07001F0C00
880 
+1CF0001C00001C00001C00001C00001C00001C0000FF800012177F8F15>I<03C2000C2600381E
881 
+00300E00700E00E00E00E00E00E00E00E00E00E00E00E00E00700E00700E00381E001C2E0007CE
882 
+00000E00000E00000E00000E00000E00000E00007FC012177F8F14>I<FCE01D701E701E201C00
883 
+1C001C001C001C001C001C001C001C001C001C00FFC00C107F8F0F>I<1F2060E04020C020C020
884 
+F0007F003FC01FE000F080708030C030C020F0408F800C107F8F0F>I<0400040004000C000C00
885 
+1C003C00FFC01C001C001C001C001C001C001C001C001C201C201C201C201C200E4003800B177F
886 
+960F>I<FC7E001C0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E
887 
+001C0E001C1E000C2E0007CFC012107F8F15>I<FF1F803C06001C04001C04001E0C000E08000E
888 
+080007100007100007900003A00003A00001C00001C00001C00000800011107F8F14>I<FF3F9F
889 
+803C0E0700380E06001C1604001C1704001E170C000E2308000E2388000F239800074190000741
890 
+D00003C1E0000380E0000380E0000180C0000100400019107F8F1C>I<FF3F803C1C001C18000E
891 
+100007200007600003C00001C00001E00003E000027000043800083800181C00381E00FC3FC012
892 
+107F8F14>I<FF1F803C06001C04001C04001E0C000E08000E080007100007100007900003A000
893 
+03A00001C00001C00001C000008000008000010000010000E10000E20000E4000078000011177F
894 
+8F14>I<7FF86070407040E041C041C00380070007000E081C081C08381070107030FFF00D107F
895 
+8F11>I E /Fl 10 58 df<1F00318060C04040C060C060C060C060C060C060C060C060404060C0
896 
+31801F000B107F8F0F>48 D<0C003C00CC000C000C000C000C000C000C000C000C000C000C000C
897 
+000C00FF8009107E8F0F>I<1F00618040C08060C0600060006000C00180030006000C00102020
898 
+207FC0FFC00B107F8F0F>I<1F00218060C060C000C0008001800F00008000400060C060C06080
899 
+4060801F000B107F8F0F>I<0300030007000F000B001300330023004300C300FFE00300030003
900 
+0003001FE00B107F8F0F>I<20803F002C002000200020002F0030802040006000600060C06080
901 
+C061801F000B107F8F0F>I<0780184030C060C06000C000CF00F080E040C060C060C060406060
902 
+C030801F000B107F8F0F>I<40007FE07FC08080808001000200040004000C0008000800180018
903 
+001800180018000B117E900F>I<1F00318060C060C060C071803F000F00338061C0C060C060C0
904 
+60404060801F000B107F8F0F>I<1F00318060C0C040C060C060C06040E021E01E600060004060
905 
+C0608043003E000B107F8F0F>I E /Fm 11 58 df<003000003000003000003000003000003000
906 
+003000003000003000003000003000FFFFFCFFFFFC003000003000003000003000003000003000
907 
+00300000300000300000300000300016187E931B>43 D<07C018303018701C600C600CE00EE00E
908 
+E00EE00EE00EE00EE00EE00EE00E600C600C701C30181C7007C00F157F9412>48
909 
+D<03000700FF000700070007000700070007000700070007000700070007000700070007000700
910 
+07007FF00C157E9412>I<0F8030E040708030C038E0384038003800700070006000C001800300
911 
+06000C08080810183FF07FF0FFF00D157E9412>I<0FE030306018701C701C001C001800380060
912 
+07E000300018000C000E000EE00EE00EC00C401830300FE00F157F9412>I<00300030007000F0
913 
+01F001700270047008701870107020704070C070FFFE0070007000700070007003FE0F157F9412
914 
+>I<20303FE03FC0240020002000200020002F8030E020700030003800384038E038E038803040
915 
+6020C01F000D157E9412>I<01F00608080C181C301C70006000E000E3E0EC30F018F00CE00EE0
916 
+0EE00E600E600E300C3018183007C00F157F9412>I<40007FFE7FFC7FF8C00880108020004000
917 
+8000800100010003000200060006000E000E000E000E000E0004000F167E9512>I<07E0183020
918 
+18600C600C700C78183E101F600FC00FF018F8607C601EC00EC006C006C004600C38300FE00F15
919 
+7F9412>I<07C0183030186018E00CE00CE00EE00EE00E601E301E186E0F8E000E000C001C7018
920 
+7018603020C01F800F157F9412>I E /Fn 9 121 df<FFFFFFC0FFFFFFC01A027C8B23>0
921 
+D<01800180018001800180C183F18F399C0FF003C003C00FF0399CF18FC1830180018001800180
922 
+018010147D9417>3 D<03C00FF01FF83FFC7FFE7FFEFFFFFFFFFFFFFFFFFFFFFFFF7FFE7FFE3F
923 
+FC1FF80FF003C010127D9317>15 D<FFFFFFF07FFFFFF000000000000000000000000000000000
924 
+000000000000000000000000FFFFFFF0FFFFFFF000000000000000000000000000000000000000
925 
+0000000000000000007FFFFFF0FFFFFFF01C147D9423>17 D<C0000000F00000003C0000000F00
926 
+000003C0000000F0000000380000000E0000000780000001E0000000780000001E000000078000
927 
+0001C00000078000001E00000078000001E00000078000000E00000038000000F0000003C00000
928 
+0F0000003C00000070000000C00000000000000000000000000000000000000000000000000000
929 
+00000000007FFFFF80FFFFFFC01A247C9C23>21 D<000002000000000300000000030000000001
930 
+8000000000C000000000C00000000060007FFFFFF000FFFFFFFC000000000E0000000003800000
931 
+0001F0000000007C00000000F000000003C000000007000000000C00FFFFFFF8007FFFFFF00000
932 
+00006000000000C00000000180000000018000000003000000000300000000020000261A7D972D
933 
+>41 D<400001C0000360000660000660000630000C30000C30000C1800181800181800180FFFF0
934 
+0FFFF00C00300600600600600600600300C00300C001818001818001818000C30000C30000C300
935 
+006600006600006600003C00003C00003C000018000018001821809F19>56
936 
+D<00040000000C0000000C0000000C0000000C0000000C0000000C0000000C0000000C0000000C
937 
+0000000C0000000C0000000C0000000C0000000C0000000C0000000C0000000C0000000C000000
938 
+0C0000000C0000000C0000000C0000000C0000000C0000000C0000FFFFFFE0FFFFFFE01B1C7C9B
939 
+23>63 D<0F80184030207010E030E070E020E000E00060007000300018000600198030C0706060
940 
+70E030E038E038E03860387030307018600CC0030000C000600070003000380038203870386038
941 
+4070206010C00F800D297D9F14>120 D E /Fo 50 123 df<00003F03E00000C386700001878C
942 
+F00003879CF00003031860000700380000070038000007003800000E003800000E007000000E00
943 
+7000000E00700000FFFFFF80001C007000001C00E000001C00E000001C00E000001C00E0000038
944 
+00E000003801C000003801C000003801C000003801C000007001C0000070038000007003800000
945 
+700380000070038000006003800000E007000000E007000000E007000000E007000000C0060000
946 
+01C00E000001C00E000031860C0000798F180000F31E100000620C6000003C07C000002429829F
947 
+1C>11 D<00003FE00000E010000180380003807800030078000700300007000000070000000700
948 
+00000E0000000E0000000E000000FFFFE0000E00E0001C01C0001C01C0001C01C0001C01C0001C
949 
+03800038038000380380003803800038070000380700007007000070071000700E2000700E2000
950 
+700E2000E00E2000E0064000E0038000E0000000C0000001C0000001C000003180000079800000
951 
+F3000000620000003C0000001D29829F1A>I<1C3C3C3C3C040408081020204080060E7D840E>
952 
+44 D<7FF0FFE07FE00C037D8A10>I<70F8F8F0E005057B840E>I<00000040000000C000000180
953 
+000001800000030000000300000006000000060000000C00000018000000180000003000000030
954 
+00000060000000C0000000C0000001800000018000000300000003000000060000000C0000000C
955 
+0000001800000018000000300000003000000060000000C0000000C00000018000000180000003
956 
+00000003000000060000000C0000000C0000001800000018000000300000003000000060000000
957 
+C0000000C0000000800000001A2D7FA117>I<000F800030E000E07001C0700380300380380700
958 
+380F00780F00780E00781E00781E00703C00F03C00F03C00F03C00F07801E07801E07801E07801
959 
+C07003C0F003C0F00380F00780F00700700700700E00701C003038001870000FC000151F7C9D17
960 
+>I<000200020006000E003C00DC031C001C0038003800380038007000700070007000E000E000
961 
+E000E001C001C001C001C003800380038003800780FFF80F1E7B9D17>I<001F000061800080E0
962 
+0100E00200700220700420700410700820F00820F00820F00840E00881E00703C0000380000700
963 
+000C000018000060000080000300000400000800401000401000802001807E030047FF0041FE00
964 
+80FC00807800141F7C9D17>I<070F1F1F0E0000000000000000000070F8F8F0E008147B930E>
965 
+58 D<00000200000006000000060000000E0000001E0000001E0000003F0000002F0000004F00
966 
+00004F0000008F0000010F0000010F0000020F0000020F0000040F00000C0F0000080F0000100F
967 
+0000100F0000200F80003FFF800040078000C00780008007800100078001000780020007800200
968 
+0780060007801E000F80FF807FF81D207E9F22>65 D<0000FE0200078186001C004C0038003C00
969 
+60003C00C0001C01C0001803800018070000180F0000181E0000101E0000103C0000003C000000
970 
+78000000780000007800000078000000F0000000F0000000F0000000F0000000F0000080700000
971 
+8070000080700001003800010038000200180004000C001800060020000381C00000FE00001F21
972 
+7A9F21>67 D<01FFFFFC001E0038001E0018001E0008001E0008003C0008003C0008003C000800
973 
+3C00080078001000780800007808000078080000F0100000F0300000FFF00000F0300001E02000
974 
+01E0200001E0200001E0200003C0000003C0000003C0000003C000000780000007800000078000
975 
+00078000000F800000FFF800001E1F7D9E1E>70 D<0000FC040007030C001C00980030007800E0
976 
+007801C000380380003003800030070000300E0000301E0000201E0000203C0000003C00000078
977 
+000000780000007800000078000000F0000000F000FFF0F0000780F0000780F0000F0070000F00
978 
+70000F0070000F0070001E0038001E0018003E001C002E000E00CC000383040000FC00001E217A
979 
+9F23>I<01FFF3FFE0001F003E00001E003C00001E003C00001E003C00003C007800003C007800
980 
+003C007800003C007800007800F000007800F000007800F000007800F00000F001E00000FFFFE0
981 
+0000F001E00000F001E00001E003C00001E003C00001E003C00001E003C00003C007800003C007
982 
+800003C007800003C007800007800F000007800F000007800F000007800F00000F801F0000FFF1
983 
+FFE000231F7D9E22>I<01FFF0001F00001E00001E00001E00003C00003C00003C00003C000078
984 
+0000780000780000780000F00000F00000F00000F00001E00001E00001E00001E00003C00003C0
985 
+0003C00003C0000780000780000780000780000F8000FFF800141F7D9E12>I<01FFF800001F00
986 
+00001E0000001E0000001E0000003C0000003C0000003C0000003C000000780000007800000078
987 
+00000078000000F0000000F0000000F0000000F0000001E0000001E0000001E0000001E0008003
988 
+C0010003C0010003C0030003C00200078006000780060007800C0007801C000F007800FFFFF800
989 
+191F7D9E1D>76 D<01FE00007FC0001E0000FC00001E0000F80000170001780000170001780000
990 
+270002F00000270004F00000270004F00000270008F00000470009E00000470011E00000470021
991 
+E00000470021E00000870043C00000838043C00000838083C00000838083C00001038107800001
992 
+03820780000103820780000103840780000203840F00000203880F00000203900F00000203900F
993 
+00000401E01E00000401E01E00000401C01E00000C01801E00001C01803E0000FF8103FFC0002A
994 
+1F7D9E29>I<01FF007FE0001F000F00001F0004000017800400001780040000278008000023C0
995 
+08000023C008000023C008000041E010000041E010000041F010000040F010000080F020000080
996 
+7820000080782000008078200001003C400001003C400001003C400001001E400002001E800002
997 
+001E800002000F800002000F800004000F0000040007000004000700000C000700001C00020000
998 
+FF80020000231F7D9E22>I<0001FC0000070700001C01C0003000E000E0006001C00070038000
999 
+7007800038070000380E0000381E0000381C0000383C0000383C00003878000078780000787800
1000 
+007878000078F00000F0F00000F0F00000E0F00001E0F00001C0F00003C0700003807000070078
1001 
+000F0038001E0038003C001C0070000E00E0000783800001FC00001D217A9F23>I<01FFFF8000
1002 
+1E00E0001E0070001E0038001E003C003C003C003C003C003C003C003C003C0078007800780078
1003 
+007800F0007800E000F003C000F00F0000FFFC0000F0000001E0000001E0000001E0000001E000
1004 
+0003C0000003C0000003C0000003C00000078000000780000007800000078000000F800000FFF0
1005 
+00001E1F7D9E1F>I<0007E040001C18C0003005800060038000C0038001C00180018001000380
1006 
+010003800100038001000380000003C0000003C0000003F8000001FF800001FFE000007FF00000
1007 
+1FF0000001F8000000780000007800000038000000380020003800200038002000300060007000
1008 
+600060006000E0007000C000E8038000C606000081F800001A217D9F1A>83
1009 
+D<0FFFFFF01E0780E0180780201007802020078020200F0020600F0020400F0020400F0020801E
1010 
+0040001E0000001E0000001E0000003C0000003C0000003C0000003C0000007800000078000000
1011 
+7800000078000000F0000000F0000000F0000000F0000001E0000001E0000001E0000001E00000
1012 
+03E00000FFFF00001C1F789E21>I<FFF007FC0F8000E00F0000C00F0000800F0001000F000100
1013 
+0F0002000F0004000F0004000F8008000780080007801000078020000780200007804000078040
1014 
+0007808000078100000781000007C2000003C2000003C4000003C8000003C8000003D0000003D0
1015 
+000003E0000003C0000003C000000380000001800000010000001E20779E22>86
1016 
+D<00F1800389C00707800E03801C03803C0380380700780700780700780700F00E00F00E00F00E
1017 
+00F00E20F01C40F01C40703C40705C40308C800F070013147C9317>97 D<07803F800700070007
1018 
+0007000E000E000E000E001C001C001CF01D0C3A0E3C0E380F380F700F700F700F700FE01EE01E
1019 
+E01EE01CE03CE038607060E031C01F0010207B9F15>I<007E0001C1000300800E07801E07801C
1020 
+07003C0200780000780000780000F00000F00000F00000F00000F0000070010070020030040018
1021 
+380007C00011147C9315>I<0000780003F80000700000700000700000700000E00000E00000E0
1022 
+0000E00001C00001C000F1C00389C00707800E03801C03803C0380380700780700780700780700
1023 
+F00E00F00E00F00E00F00E20F01C40F01C40703C40705C40308C800F070015207C9F17>I<007C
1024 
+01C207010E011C013C013802780C7BF07C00F000F000F000F0007000700170023804183807C010
1025 
+147C9315>I<00007800019C00033C00033C000718000700000700000E00000E00000E00000E00
1026 
+000E0001FFE0001C00001C00001C00001C00003800003800003800003800003800007000007000
1027 
+00700000700000700000700000E00000E00000E00000E00000C00001C00001C000018000318000
1028 
+7B0000F300006600003C00001629829F0E>I<003C6000E27001C1E00380E00700E00F00E00E01
1029 
+C01E01C01E01C01E01C03C03803C03803C03803C03803C07003C07001C0F001C17000C2E0003CE
1030 
+00000E00000E00001C00001C00301C00783800F0700060E0003F8000141D7E9315>I<01E0000F
1031 
+E00001C00001C00001C00001C000038000038000038000038000070000070000071E000763000E
1032 
+81800F01C00E01C00E01C01C03801C03801C03801C0380380700380700380700380E10700E2070
1033 
+0C20701C20700C40E00CC060070014207D9F17>I<00C001E001E001C000000000000000000000
1034 
+000000000E003300230043804300470087000E000E000E001C001C001C00384038803080708031
1035 
+0033001C000B1F7C9E0E>I<0001800003C00003C0000380000000000000000000000000000000
1036 
+000000000000003C00004600008700008700010700010700020E00000E00000E00000E00001C00
1037 
+001C00001C00001C0000380000380000380000380000700000700000700000700000E00000E000
1038 
+30E00079C000F180006300003C00001228829E0E>I<01E0000FE00001C00001C00001C00001C0
1039 
+000380000380000380000380000700000700000703C00704200E08E00E11E00E21E00E40C01C80
1040 
+001D00001E00001FC00038E000387000387000383840707080707080707080703100E03100601E
1041 
+0013207D9F15>I<03C01FC0038003800380038007000700070007000E000E000E000E001C001C
1042 
+001C001C0038003800380038007000700070007100E200E200E200E200640038000A207C9F0C>
1043 
+I<1C0F80F0002630C318004740640C004780680E004700700E004700700E008E00E01C000E00E0
1044 
+1C000E00E01C000E00E01C001C01C038001C01C038001C01C038001C01C0708038038071003803
1045 
+806100380380E10038038062007007006600300300380021147C9325>I<1C0F802630C0474060
1046 
+4780604700704700708E00E00E00E00E00E00E00E01C01C01C01C01C01C01C0384380388380308
1047 
+3807083803107003303001C016147C931A>I<007C0001C3000301800E01C01E01C01C01E03C01
1048 
+E07801E07801E07801E0F003C0F003C0F003C0F00780F00700700F00700E0030180018700007C0
1049 
+0013147C9317>I<01C1E002621804741C04781C04701E04701E08E01E00E01E00E01E00E01E01
1050 
+C03C01C03C01C03C01C0380380780380700380E003C1C0072380071E000700000700000E00000E
1051 
+00000E00000E00001C00001C0000FFC000171D809317>I<00F0400388C00705800E03801C0380
1052 
+3C0380380700780700780700780700F00E00F00E00F00E00F00E00F01C00F01C00703C00705C00
1053 
+30B8000F380000380000380000700000700000700000700000E00000E0000FFE00121D7C9315>
1054 
+I<1C1E002661004783804787804707804703008E00000E00000E00000E00001C00001C00001C00
1055 
+001C000038000038000038000038000070000030000011147C9313>I<00FC030206010C030C07
1056 
+0C060C000F800FF007F803FC003E000E700EF00CF00CE008401020601F8010147D9313>I<0180
1057 
+01C0038003800380038007000700FFF007000E000E000E000E001C001C001C001C003800380038
1058 
+003820704070407080708031001E000C1C7C9B0F>I<0E00C03300E02301C04381C04301C04701
1059 
+C08703800E03800E03800E03801C07001C07001C07001C07101C0E20180E20180E201C1E200C26
1060 
+4007C38014147C9318>I<0E03803307802307C04383C04301C04700C08700800E00800E00800E
1061 
+00801C01001C01001C01001C02001C02001C04001C04001C08000E300003C00012147C9315>I<
1062 
+0E00C1C03300E3C02301C3E04381C1E04301C0E04701C060870380400E0380400E0380400E0380
1063 
+401C0700801C0700801C0700801C0701001C0701001C0602001C0F02000C0F04000E13080003E1
1064 
+F0001B147C931E>I<0383800CC4401068E01071E02071E02070C040E00000E00000E00000E000
1065 
+01C00001C00001C00001C040638080F38080F38100E5810084C60078780013147D9315>I<0E00
1066 
+C03300E02301C04381C04301C04701C08703800E03800E03800E03801C07001C07001C07001C07
1067 
+001C0E00180E00180E001C1E000C3C0007DC00001C00001C00003800F03800F07000E06000C0C0
1068 
+004380003E0000131D7C9316>I<01C04003E08007F1800C1F0008020000040000080000100000
1069 
+20000040000080000100000200000401000802001002003E0C0063FC0041F80080E00012147D93
1070 
+13>I E /Fp 81 125 df<001F83E000F06E3001C078780380F8780300F0300700700007007000
1071 
+0700700007007000070070000700700007007000FFFFFF80070070000700700007007000070070
1072 
+000700700007007000070070000700700007007000070070000700700007007000070070000700
1073 
+7000070070000700700007007000070070007FE3FF001D20809F1B>11 D<003F0000E0C001C0C0
1074 
+0381E00701E00701E0070000070000070000070000070000070000FFFFE00700E00700E00700E0
1075 
+0700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E0
1076 
+0700E00700E07FC3FE1720809F19>I<003FE000E0E001C1E00381E00700E00700E00700E00700
1077 
+E00700E00700E00700E00700E0FFFFE00700E00700E00700E00700E00700E00700E00700E00700
1078 
+E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E07FE7FE1720809F19
1079 
+>I<001F81F80000F04F040001C07C06000380F80F000300F00F000700F00F0007007000000700
1080 
+7000000700700000070070000007007000000700700000FFFFFFFF000700700700070070070007
1081 
+007007000700700700070070070007007007000700700700070070070007007007000700700700
1082 
+070070070007007007000700700700070070070007007007000700700700070070070007007007
1083 
+007FE3FE3FF02420809F26>I<70F8F8F8F8F8F8F8707070707070707070702020202020000000
1084 
+000070F8F8F87005217CA00D>33 D<7038F87CFC7EFC7E743A0402040204020804080410081008
1085 
+201040200F0E7E9F17>I<70F8FCFC74040404080810102040060E7C9F0D>39
1086 
+D<0020004000800100020006000C000C00180018003000300030007000600060006000E000E000
1087 
+E000E000E000E000E000E000E000E000E000E0006000600060007000300030003000180018000C
1088 
+000C000600020001000080004000200B2E7DA112>I<800040002000100008000C000600060003
1089 
+00030001800180018001C000C000C000C000E000E000E000E000E000E000E000E000E000E000E0
1090 
+00E000C000C000C001C001800180018003000300060006000C00080010002000400080000B2E7D
1091 
+A112>I<70F8FCFC74040404080810102040060E7C840D>44 D<FFC0FFC00A027F8A0F>I<70F8F8
1092 
+F87005057C840D>I<000100030003000600060006000C000C000C001800180018003000300030
1093 
+00600060006000C000C000C00180018001800300030003000600060006000C000C000C00180018
1094 
+001800300030003000600060006000C000C000C000102D7DA117>I<03F0000E1C001C0E001806
1095 
+00380700700380700380700380700380F003C0F003C0F003C0F003C0F003C0F003C0F003C0F003
1096 
+C0F003C0F003C0F003C0F003C0F003C07003807003807003807807803807001806001C0E000E1C
1097 
+0003F000121F7E9D17>I<018003800F80F3800380038003800380038003800380038003800380
1098 
+0380038003800380038003800380038003800380038003800380038007C0FFFE0F1E7C9D17>I<
1099 
+03F0000C1C00100E00200700400780800780F007C0F803C0F803C0F803C02007C00007C0000780
1100 
+000780000F00000E00001C0000380000700000600000C0000180000300000600400C0040180040
1101 
+1000803FFF807FFF80FFFF80121E7E9D17>I<03F0000C1C00100E00200F00780F807807807807
1102 
+80380F80000F80000F00000F00000E00001C0000380003F000003C00000E00000F000007800007
1103 
+800007C02007C0F807C0F807C0F807C0F00780400780400F00200E001C3C0003F000121F7E9D17
1104 
+>I<000600000600000E00000E00001E00002E00002E00004E00008E00008E00010E00020E0002
1105 
+0E00040E00080E00080E00100E00200E00200E00400E00C00E00FFFFF0000E00000E00000E0000
1106 
+0E00000E00000E00000E0000FFE0141E7F9D17>I<1803001FFE001FFC001FF8001FE000100000
1107 
+10000010000010000010000010000011F000161C00180E001007001007800003800003800003C0
1108 
+0003C00003C07003C0F003C0F003C0E00380400380400700200600100E000C380003E000121F7E
1109 
+9D17>I<007C000182000701000E03800C07801C0780380300380000780000700000700000F1F0
1110 
+00F21C00F40600F80700F80380F80380F003C0F003C0F003C0F003C0F003C07003C07003C07003
1111 
+803803803807001807000C0E00061C0001F000121F7E9D17>I<4000007FFFC07FFF807FFF8040
1112 
+010080020080020080040000080000080000100000200000200000400000400000C00000C00001
1113 
+C00001800003800003800003800003800007800007800007800007800007800007800007800003
1114 
+0000121F7D9D17>I<03F0000C0C00100600300300200180600180600180600180700180780300
1115 
+3E03003F06001FC8000FF00003F80007FC000C7E00103F00300F806003804001C0C001C0C000C0
1116 
+C000C0C000C0C000806001802001001002000C0C0003F000121F7E9D17>I<03F0000E18001C0C
1117 
+00380600380700700700700380F00380F00380F003C0F003C0F003C0F003C0F003C07007C07007
1118 
+C03807C0180BC00E13C003E3C0000380000380000380000700300700780600780E00700C002018
1119 
+001070000FC000121F7E9D17>I<70F8F8F8700000000000000000000070F8F8F87005147C930D>
1120 
+I<70F8F8F8700000000000000000000070F0F8F878080808101010202040051D7C930D>I<7FFF
1121 
+FFE0FFFFFFF00000000000000000000000000000000000000000000000000000000000000000FF
1122 
+FFFFF07FFFFFE01C0C7D9023>61 D<0FC0307040384038E03CF03CF03C603C0038007000E000C0
1123 
+01800180010003000200020002000200020002000000000000000000000007000F800F800F8007
1124 
+000E207D9F15>63 D<000100000003800000038000000380000007C0000007C0000007C0000009
1125 
+E0000009E0000009E0000010F0000010F0000010F00000207800002078000020780000403C0000
1126 
+403C0000403C0000801E0000801E0000FFFE0001000F0001000F0001000F000200078002000780
1127 
+02000780040003C00E0003C01F0007E0FFC03FFE1F207F9F22>65 D<FFFFE0000F80380007801E
1128 
+0007801F0007800F0007800F8007800F8007800F8007800F8007800F8007800F0007801F000780
1129 
+1E0007803C0007FFF00007803C0007801E0007800F0007800F8007800780078007C0078007C007
1130 
+8007C0078007C0078007C00780078007800F8007800F0007801F000F803C00FFFFF0001A1F7E9E
1131 
+20>I<000FC040007030C001C009C0038005C0070003C00E0001C01E0000C01C0000C03C0000C0
1132 
+7C0000407C00004078000040F8000000F8000000F8000000F8000000F8000000F8000000F80000
1133 
+00F8000000F8000000780000007C0000407C0000403C0000401C0000401E0000800E0000800700
1134 
+01000380020001C0040000703800000FC0001A217D9F21>I<FFFFE0000F803C0007801E000780
1135 
+070007800380078003C0078001E0078001E0078001F0078000F0078000F0078000F8078000F807
1136 
+8000F8078000F8078000F8078000F8078000F8078000F8078000F8078000F0078000F0078000F0
1137 
+078001E0078001E0078003C0078003800780070007800E000F803C00FFFFE0001D1F7E9E23>I<
1138 
+FFFFFF000F800F0007800300078003000780010007800180078000800780008007800080078080
1139 
+800780800007808000078080000781800007FF8000078180000780800007808000078080000780
1140 
+8000078000200780002007800020078000400780004007800040078000C0078000C0078001800F
1141 
+800F80FFFFFF801B1F7E9E1F>I<FFFFFF000F800F000780030007800300078001000780018007
1142 
+800080078000800780008007800080078080000780800007808000078080000781800007FF8000
1143 
+078180000780800007808000078080000780800007800000078000000780000007800000078000
1144 
+000780000007800000078000000FC00000FFFE0000191F7E9E1E>I<000FE0200078186000E004
1145 
+E0038002E0070001E00F0000E01E0000601E0000603C0000603C0000207C00002078000020F800
1146 
+0000F8000000F8000000F8000000F8000000F8000000F8000000F8007FFCF80003E0780001E07C
1147 
+0001E03C0001E03C0001E01E0001E01E0001E00F0001E0070001E0038002E000E0046000781820
1148 
+000FE0001E217D9F24>I<FFF8FFF80F800F8007800F0007800F0007800F0007800F0007800F00
1149 
+07800F0007800F0007800F0007800F0007800F0007800F0007800F0007FFFF0007800F0007800F
1150 
+0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F000780
1151 
+0F0007800F0007800F000F800F80FFF8FFF81D1F7E9E22>I<FFFC0FC007800780078007800780
1152 
+078007800780078007800780078007800780078007800780078007800780078007800780078007
1153 
+80078007800FC0FFFC0E1F7F9E10>I<0FFFC0007C00003C00003C00003C00003C00003C00003C
1154 
+00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C
1155 
+00003C00003C00203C00F83C00F83C00F83C00F0380040780040700030E0000F800012207E9E17
1156 
+>I<FFFC0FFC0FC003E00780018007800100078002000780040007800800078010000780200007
1157 
+80400007808000078100000783000007878000078F80000793C0000791E00007A1E00007C0F000
1158 
+0780F0000780780007803C0007803C0007801E0007801E0007800F000780078007800780078007
1159 
+C00FC007E0FFFC3FFC1E1F7E9E23>I<FFFE000FC0000780000780000780000780000780000780
1160 
+000780000780000780000780000780000780000780000780000780000780000780000780000780
1161 
+0207800207800207800207800607800407800407800C07801C0F807CFFFFFC171F7E9E1C>I<FF
1162 
+80001FF80F80001F800780001F0005C0002F0005C0002F0005C0002F0004E0004F0004E0004F00
1163 
+0470008F000470008F000470008F000438010F000438010F000438010F00041C020F00041C020F
1164 
+00041C020F00040E040F00040E040F00040E040F000407080F000407080F000407080F00040390
1165 
+0F000403900F000401E00F000401E00F000401E00F000E00C00F001F00C01F80FFE0C1FFF8251F
1166 
+7E9E2A>I<FF803FF807C007C007C0038005E0010005E0010004F001000478010004780100043C
1167 
+0100043C0100041E0100040F0100040F010004078100040781000403C1000401E1000401E10004
1168 
+00F1000400F1000400790004003D0004003D0004001F0004001F0004000F000400070004000700
1169 
+0E0003001F000300FFE001001D1F7E9E22>I<001F800000F0F00001C0380007801E000F000F00
1170 
+0E0007001E0007803C0003C03C0003C07C0003E0780001E0780001E0F80001F0F80001F0F80001
1171 
+F0F80001F0F80001F0F80001F0F80001F0F80001F0F80001F0780001E07C0003E07C0003E03C00
1172 
+03C03C0003C01E0007800E0007000F000F0007801E0001C0380000F0F000001F80001C217D9F23
1173 
+>I<FFFFE0000F80780007801C0007801E0007800F0007800F8007800F8007800F8007800F8007
1174 
+800F8007800F8007800F0007801E0007801C000780780007FFE000078000000780000007800000
1175 
+078000000780000007800000078000000780000007800000078000000780000007800000078000
1176 
+000FC00000FFFC0000191F7E9E1F>I<FFFF80000F80F0000780780007803C0007801E0007801E
1177 
+0007801F0007801F0007801F0007801F0007801E0007801E0007803C00078078000780F00007FF
1178 
+80000781C0000780E0000780F0000780700007807800078078000780780007807C0007807C0007
1179 
+807C0007807C0407807E0407803E040FC01E08FFFC0F10000003E01E207E9E21>82
1180 
+D<07E0800C1980100780300380600180600180E00180E00080E00080E00080F00000F000007800
1181 
+007F00003FF0001FFC000FFE0003FF00001F800007800003C00003C00001C08001C08001C08001
1182 
+C08001C0C00180C00380E00300F00600CE0C0081F80012217D9F19>I<7FFFFFE0780F01E0600F
1183 
+0060400F0020400F0020C00F0030800F0010800F0010800F0010800F0010000F0000000F000000
1184 
+0F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000
1185 
+000F0000000F0000000F0000000F0000000F0000000F0000000F0000001F800007FFFE001C1F7E
1186 
+9E21>I<FFFC3FF80FC007C0078003800780010007800100078001000780010007800100078001
1187 
+000780010007800100078001000780010007800100078001000780010007800100078001000780
1188 
+01000780010007800100078001000780010007800100038002000380020001C0020001C0040000
1189 
+E008000070180000382000000FC0001D207E9E22>I<FFF003FE1F8000F80F0000600F80006007
1190 
+8000400780004003C0008003C0008003C0008001E0010001E0010001F0010000F0020000F00200
1191 
+00F806000078040000780400003C0800003C0800003C0800001E1000001E1000001F3000000F20
1192 
+00000F20000007C0000007C0000007C000000380000003800000038000000100001F207F9E22>
1193 
+I<FFF07FF81FF01F800FC007C00F00078003800F00078001000F0007C00100078007C002000780
1194 
+07C00200078007C0020003C009E0040003C009E0040003C009E0040003E010F00C0001E010F008
1195 
+0001E010F0080001F02078080000F02078100000F02078100000F0403C10000078403C20000078
1196 
+403C20000078C03E2000003C801E4000003C801E4000003C801E4000001F000F8000001F000F80
1197 
+00001F000F8000001E00078000000E00070000000E00070000000C000300000004000200002C20
1198 
+7F9E2F>I<FFF003FF1F8000F80F8000600780004007C0004003E0008001E0008001F0010000F0
1199 
+030000F80200007C0400003C0400003E0800001E0800001F1000000FB0000007A0000007C00000
1200 
+03C0000003C0000003C0000003C0000003C0000003C0000003C0000003C0000003C0000003C000
1201 
+0003C0000007C000007FFE00201F7F9E22>89 D<FEFEC0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0
1202 
+C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0FEFE072D7CA10D>91
1203 
+D<080410082010201040204020804080408040B85CFC7EFC7E7C3E381C0F0E7B9F17>I<FEFE06
1204 
+060606060606060606060606060606060606060606060606060606060606060606060606060606
1205 
+06FEFE072D7FA10D>I<1FE000303000781800781C00300E00000E00000E00000E0000FE00078E
1206 
+001E0E00380E00780E00F00E10F00E10F00E10F01E10781E103867200F83C014147E9317>97
1207 
+D<0E0000FE00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E3E
1208 
+000EC3800F01C00F00E00E00E00E00700E00700E00780E00780E00780E00780E00780E00780E00
1209 
+700E00700E00E00F00E00D01C00CC300083E0015207F9F19>I<03F80E0C1C1E381E380C700070
1210 
+00F000F000F000F000F000F00070007000380138011C020E0C03F010147E9314>I<000380003F
1211 
+8000038000038000038000038000038000038000038000038000038000038003E380061B801C07
1212 
+80380380380380700380700380F00380F00380F00380F00380F00380F003807003807003803803
1213 
+803807801C07800E1B8003E3F815207E9F19>I<03F0000E1C001C0E0038070038070070070070
1214 
+0380F00380F00380FFFF80F00000F00000F000007000007000003800801800800C010007060001
1215 
+F80011147F9314>I<007C00C6018F038F07060700070007000700070007000700FFF007000700
1216 
+07000700070007000700070007000700070007000700070007000700070007007FF01020809F0E
1217 
+>I<0000E003E3300E3C301C1C30380E00780F00780F00780F00780F00780F00380E001C1C001E
1218 
+380033E0002000002000003000003000003FFE001FFF800FFFC03001E0600070C00030C00030C0
1219 
+0030C000306000603000C01C038003FC00141F7F9417>I<0E0000FE00000E00000E00000E0000
1220 
+0E00000E00000E00000E00000E00000E00000E00000E3E000E43000E81800F01C00F01C00E01C0
1221 
+0E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C0
1222 
+FFE7FC16207F9F19>I<1C001E003E001E001C000000000000000000000000000E007E000E000E
1223 
+000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E00FFC00A1F809E0C>
1224 
+I<00E001F001F001F000E0000000000000000000000000007007F000F000700070007000700070
1225 
+00700070007000700070007000700070007000700070007000700070007000706070F060F0C061
1226 
+803F000C28829E0E>I<0E0000FE00000E00000E00000E00000E00000E00000E00000E00000E00
1227 
+000E00000E00000E0FF00E03C00E03000E02000E04000E08000E10000E30000E70000EF8000F38
1228 
+000E1C000E1E000E0E000E07000E07800E03800E03C00E03E0FFCFF815207F9F18>I<0E00FE00
1229 
+0E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
1230 
+000E000E000E000E000E000E000E000E000E00FFE00B20809F0C>I<0E1F01F000FE618618000E
1231 
+81C81C000F00F00E000F00F00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E00
1232 
+0E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E
1233 
+000E00E00E00FFE7FE7FE023147F9326>I<0E3E00FE43000E81800F01C00F01C00E01C00E01C0
1234 
+0E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C0FFE7FC
1235 
+16147F9319>I<01F800070E001C03803801C03801C07000E07000E0F000F0F000F0F000F0F000
1236 
+F0F000F0F000F07000E07000E03801C03801C01C0380070E0001F80014147F9317>I<0E3E00FE
1237 
+C3800F01C00F00E00E00E00E00F00E00700E00780E00780E00780E00780E00780E00780E00700E
1238 
+00F00E00E00F01E00F01C00EC3000E3E000E00000E00000E00000E00000E00000E00000E00000E
1239 
+0000FFE000151D7F9319>I<03E0800619801C05803C0780380380780380700380F00380F00380
1240 
+F00380F00380F00380F003807003807803803803803807801C0B800E138003E380000380000380
1241 
+000380000380000380000380000380000380003FF8151D7E9318>I<0E78FE8C0F1E0F1E0F0C0E
1242 
+000E000E000E000E000E000E000E000E000E000E000E000E000E00FFE00F147F9312>I<1F9030
1243 
+704030C010C010C010E00078007F803FE00FF00070803880188018C018C018E030D0608F800D14
1244 
+7E9312>I<020002000200060006000E000E003E00FFF80E000E000E000E000E000E000E000E00
1245 
+0E000E000E000E080E080E080E080E080610031001E00D1C7F9B12>I<0E01C0FE1FC00E01C00E
1246 
+01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E
1247 
+03C00603C0030DC001F1FC16147F9319>I<FF83F81E01E01C00C00E00800E00800E0080070100
1248 
+07010003820003820003820001C40001C40001EC0000E80000E800007000007000007000002000
1249 
+15147F9318>I<FF9FE1FC3C0780701C0300601C0380200E0380400E0380400E03C0400707C080
1250 
+0704C0800704E080038861000388710003C8730001D0320001D03A0000F03C0000E01C0000E01C
1251 
+0000601800004008001E147F9321>I<7FC3FC0F01E00701C007018003810001C20000E40000EC
1252 
+00007800003800003C00007C00004E000087000107000303800201C00601E01E01E0FF07FE1714
1253 
+809318>I<FF83F81E01E01C00C00E00800E00800E008007010007010003820003820003820001
1254 
+C40001C40001EC0000E80000E800007000007000007000002000002000004000004000004000F0
1255 
+8000F08000F100006200003C0000151D7F9318>I<3FFF380E200E201C40384078407000E001E0
1256 
+01C00380078007010E011E011C0338027006700EFFFE10147F9314>I<FFFFFC1601808C17>I<FF
1257 
+FFFFFFFFF02C01808C2D>I E /Fq 48 122 df<1C0038007F00FE007F00FE00FF81FF00FFC1FF
1258 
+80FFC1FF807FC0FF807FC0FF801CC0398000C0018000C001800180030001800300018003000300
1259 
+06000300060006000C000C00180018003000300060002000400019157EA924>34
1260 
+D<1C007F007F00FF80FFC0FFC07FC07FC01CC000C000C00180018001800300030006000C001800
1261 
+300020000A157B8813>44 D<00000300000007800000078000000F8000000F0000000F0000001F
1262 
+0000001E0000003E0000003C0000003C0000007C0000007800000078000000F8000000F0000001
1263 
+F0000001E0000001E0000003E0000003C0000003C0000007C00000078000000F8000000F000000
1264 
+0F0000001F0000001E0000003E0000003C0000003C0000007C0000007800000078000000F80000
1265 
+00F0000001F0000001E0000001E0000003E0000003C0000003C0000007C00000078000000F8000
1266 
+000F0000000F0000001F0000001E0000001E0000003E0000003C0000007C000000780000007800
1267 
+0000F8000000F0000000F000000060000000193C7CAC22>47 D<003F800001FFF00007E0FC000F
1268 
+C07E001F803F001F803F003F001F803F001F807F001FC07F001FC07F001FC07F001FC0FF001FE0
1269 
+FF001FE0FF001FE0FF001FE0FF001FE0FF001FE0FF001FE0FF001FE0FF001FE0FF001FE0FF001F
1270 
+E0FF001FE0FF001FE0FF001FE0FF001FE07F001FC07F001FC07F001FC07F001FC03F001F803F00
1271 
+1F801F803F001F803F000FC07E0007E0FC0001FFF000003F80001B277DA622>I<000E00001E00
1272 
+007E0007FE00FFFE00FFFE00F8FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE00
1273 
+00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE00
1274 
+00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE007FFFFE7FFFFE7FFFFE17277BA622>
1275 
+I<00FF800003FFF0000FFFFC001F03FE003800FF007C007F80FE003FC0FF003FC0FF003FE0FF00
1276 
+1FE0FF001FE07E001FE03C003FE000003FE000003FC000003FC000007F8000007F000000FE0000
1277 
+00FC000001F8000003F0000003E00000078000000F0000001E0000003C00E0007000E000E000E0
1278 
+01C001C0038001C0070001C00FFFFFC01FFFFFC03FFFFFC07FFFFFC0FFFFFF80FFFFFF80FFFFFF
1279 
+801B277DA622>I<007F800003FFF00007FFFC000F81FE001F00FF003F80FF003F807F803F807F
1280 
+803F807F801F807F800F007F800000FF000000FF000000FE000001FC000001F8000007F00000FF
1281 
+C00000FFF0000001FC0000007E0000007F0000007F8000003FC000003FC000003FE000003FE03C
1282 
+003FE07E003FE0FF003FE0FF003FE0FF003FC0FF007FC07E007F807C007F003F01FE001FFFFC00
1283 
+07FFF00000FF80001B277DA622>I<00000E0000001E0000003E0000007E000000FE000000FE00
1284 
+0001FE000003FE0000077E00000E7E00000E7E00001C7E0000387E0000707E0000E07E0000E07E
1285 
+0001C07E0003807E0007007E000E007E000E007E001C007E0038007E0070007E00E0007E00FFFF
1286 
+FFF8FFFFFFF8FFFFFFF80000FE000000FE000000FE000000FE000000FE000000FE000000FE0000
1287 
+00FE00007FFFF8007FFFF8007FFFF81D277EA622>I<0C0003000F803F000FFFFE000FFFFC000F
1288 
+FFF8000FFFF0000FFFE0000FFFC0000FFE00000E0000000E0000000E0000000E0000000E000000
1289 
+0E0000000E7FC0000FFFF8000F80FC000E003E000C003F0000001F8000001FC000001FC000001F
1290 
+E000001FE018001FE07C001FE0FE001FE0FE001FE0FE001FE0FE001FC0FC001FC078003F807800
1291 
+3F803C007F001F01FE000FFFF80003FFF00000FF80001B277DA622>I<0007F000003FFC0000FF
1292 
+FE0001FC0F0003F01F8007E03F800FC03F801FC03F801F803F803F801F003F8000007F0000007F
1293 
+0000007F000000FF000000FF0FC000FF3FF800FF707C00FFC03E00FFC03F00FF801F80FF801FC0
1294 
+FF001FC0FF001FE0FF001FE0FF001FE07F001FE07F001FE07F001FE07F001FE03F001FE03F001F
1295 
+C01F801FC01F803F800FC03F0007E07E0003FFFC0000FFF000003FC0001B277DA622>I<380000
1296 
+003E0000003FFFFFF03FFFFFF03FFFFFF07FFFFFE07FFFFFC07FFFFF807FFFFF0070000E007000
1297 
+0E0070001C00E0003800E0007000E000E0000000E0000001C00000038000000780000007800000
1298 
+0F0000000F0000001F0000001F0000003F0000003E0000003E0000007E0000007E0000007E0000
1299 
+007E000000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE0000007C00
1300 
+00003800001C297CA822>I<003FC00001FFF00003FFFC0007C07E000F003F001E001F001E000F
1301 
+803E000F803E000F803F000F803F000F803FC00F003FF01F001FFC1E001FFE3C000FFFF80007FF
1302 
+E00003FFF80001FFFC0001FFFE0007FFFF000F0FFF801E03FFC03C01FFC07C007FE078001FE0F8
1303 
+0007E0F80007E0F80003E0F80003E0F80003E0F80003C07C0003C07C0007803F000F001FC03E00
1304 
+0FFFFC0003FFF800007FC0001B277DA622>I<007F800001FFF00007FFF8000FE0FC001F807E00
1305 
+3F803F007F003F007F001F80FF001F80FF001FC0FF001FC0FF001FC0FF001FE0FF001FE0FF001F
1306 
+E0FF001FE07F001FE07F003FE03F003FE01F807FE00F807FE007C1DFE003FF9FE0007E1FE00000
1307 
+1FE000001FC000001FC000001FC000003F801F003F803F803F003F803F003F807E003F807C001F
1308 
+01F8001E03F0000FFFE00007FF800001FE00001B277DA622>I<000003800000000007C0000000
1309 
+0007C0000000000FE0000000000FE0000000000FE0000000001FF0000000001FF0000000003FF8
1310 
+000000003FF8000000003FF80000000073FC0000000073FC00000000F3FE00000000E1FE000000
1311 
+00E1FE00000001C0FF00000001C0FF00000003C0FF80000003807F80000007807FC0000007003F
1312 
+C0000007003FC000000E003FE000000E001FE000001E001FF000001C000FF000001FFFFFF00000
1313 
+3FFFFFF800003FFFFFF80000780007FC0000700003FC0000700003FC0000E00001FE0000E00001
1314 
+FE0001E00001FF0001C00000FF0001C00000FF00FFFE001FFFFEFFFE001FFFFEFFFE001FFFFE2F
1315 
+297EA834>65 D<00003FF001800003FFFE0380000FFFFF8780003FF007DF8000FF8001FF8001FE
1316 
+00007F8003FC00003F8007F000001F800FF000000F801FE0000007801FE0000007803FC0000007
1317 
+803FC0000003807FC0000003807F80000003807F8000000000FF8000000000FF8000000000FF80
1318 
+00000000FF8000000000FF8000000000FF8000000000FF8000000000FF8000000000FF80000000
1319 
+007F80000000007F80000000007FC0000003803FC0000003803FC0000003801FE0000003801FE0
1320 
+000007000FF00000070007F000000E0003FC00001E0001FE00003C0000FF8000F800003FF007E0
1321 
+00000FFFFFC0000003FFFF000000003FF8000029297CA832>67 D<FFFFFFFFE0FFFFFFFFE0FFFF
1322 
+FFFFE003FC001FE003FC0007F003FC0001F003FC0001F003FC0000F003FC00007003FC00007003
1323 
+FC00007003FC01C07803FC01C03803FC01C03803FC01C03803FC03C00003FC03C00003FC0FC000
1324 
+03FFFFC00003FFFFC00003FFFFC00003FC0FC00003FC03C00003FC03C00003FC01C00E03FC01C0
1325 
+0E03FC01C00E03FC01C01C03FC00001C03FC00001C03FC00001C03FC00003C03FC00003803FC00
1326 
+007803FC0000F803FC0001F803FC0003F803FC001FF8FFFFFFFFF0FFFFFFFFF0FFFFFFFFF02729
1327 
+7DA82D>69 D<FFFFFFFFC0FFFFFFFFC0FFFFFFFFC003FC003FC003FC000FE003FC0003E003FC00
1328 
+01E003FC0001E003FC0000E003FC0000E003FC0000E003FC0000F003FC03807003FC03807003FC
1329 
+03807003FC03800003FC07800003FC07800003FC1F800003FFFF800003FFFF800003FFFF800003
1330 
+FC1F800003FC07800003FC07800003FC03800003FC03800003FC03800003FC03800003FC000000
1331 
+03FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC0000
1332 
+00FFFFFC0000FFFFFC0000FFFFFC000024297DA82B>I<00007FE003000003FFFC0700001FFFFF
1333 
+0F00003FF00FFF0000FF8001FF0001FE0000FF0003F800003F0007F000003F000FF000001F001F
1334 
+E000000F001FE000000F003FC000000F003FC0000007007FC0000007007F80000007007F800000
1335 
+0000FF8000000000FF8000000000FF8000000000FF8000000000FF8000000000FF8000000000FF
1336 
+8000000000FF8000000000FF8001FFFFF87F8001FFFFF87F8001FFFFF87FC00000FF003FC00000
1337 
+FF003FC00000FF001FE00000FF001FE00000FF000FF00000FF0007F00000FF0003F80000FF0001
1338 
+FE0000FF0000FF8001FF00003FF007BF00001FFFFF1F000003FFFE0F0000007FF003002D297CA8
1339 
+36>I<FFFFFCFFFFFCFFFFFC01FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE00
1340 
+01FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE00
1341 
+01FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE00
1342 
+FFFFFCFFFFFCFFFFFC16297EA81A>73 D<FFFE0000001FFFC0FFFE0000001FFFC0FFFF0000003F
1343 
+FFC003FF0000003FF00003FF0000003FF00003BF80000077F00003BF80000077F000039FC00000
1344 
+E7F000039FC00000E7F000038FE00001C7F000038FE00001C7F0000387F0000387F0000387F000
1345 
+0387F0000387F0000387F0000383F8000707F0000383F8000707F0000381FC000E07F0000381FC
1346 
+000E07F0000380FE001C07F0000380FE001C07F0000380FF003807F00003807F003807F0000380
1347 
+7F003807F00003803F807007F00003803F807007F00003801FC0E007F00003801FC0E007F00003
1348 
+800FE1C007F00003800FE1C007F00003800FE1C007F000038007F38007F000038007F38007F000
1349 
+038003FF0007F000038003FF0007F000038001FE0007F000038001FE0007F000038000FC0007F0
1350 
+00038000FC0007F000FFFE00FC01FFFFC0FFFE007801FFFFC0FFFE007801FFFFC03A297DA841>
1351 
+77 D<0000FFE000000007FFFC0000003FC07F8000007F001FC00001FC0007F00003F80003F800
1352 
+07F00001FC000FF00001FE001FE00000FF001FE00000FF003FC000007F803FC000007F807FC000
1353 
+007FC07F8000003FC07F8000003FC07F8000003FC0FF8000003FE0FF8000003FE0FF8000003FE0
1354 
+FF8000003FE0FF8000003FE0FF8000003FE0FF8000003FE0FF8000003FE0FF8000003FE0FF8000
1355 
+003FE07F8000003FC07FC000007FC07FC000007FC03FC000007F803FC000007F801FE00000FF00
1356 
+1FE00000FF000FF00001FE0007F00001FC0003F80003F80001FC0007F00000FF001FE000003FC0
1357 
+7F8000000FFFFE00000000FFE000002B297CA834>79 D<FFFFFFF800FFFFFFFF00FFFFFFFFC003
1358 
+FC003FE003FC000FF003FC0007F803FC0007FC03FC0003FC03FC0003FE03FC0003FE03FC0003FE
1359 
+03FC0003FE03FC0003FE03FC0003FE03FC0003FE03FC0003FC03FC0007FC03FC0007F803FC000F
1360 
+F003FC003FE003FFFFFF8003FFFFFE0003FC00000003FC00000003FC00000003FC00000003FC00
1361 
+000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC
1362 
+00000003FC00000003FC00000003FC000000FFFFF00000FFFFF00000FFFFF0000027297DA82F>
1363 
+I<FFFFFFE00000FFFFFFFE0000FFFFFFFF800003FC007FE00003FC000FF00003FC0007F80003FC
1364 
+0007FC0003FC0003FC0003FC0003FE0003FC0003FE0003FC0003FE0003FC0003FE0003FC0003FE
1365 
+0003FC0003FE0003FC0003FC0003FC0007F80003FC0007F80003FC001FE00003FC007FC00003FF
1366 
+FFFE000003FFFFF0000003FC00FC000003FC007F000003FC003F800003FC003F800003FC001FC0
1367 
+0003FC001FE00003FC001FE00003FC001FE00003FC001FE00003FC001FE00003FC001FF00003FC
1368 
+001FF00003FC001FF00003FC001FF00703FC001FF80703FC000FF80703FC0007F80EFFFFF003FE
1369 
+1CFFFFF001FFF8FFFFF0003FF030297DA834>82 D<7FFFFFFFFFC07FFFFFFFFFC07FFFFFFFFFC0
1370 
+7F803FC03FC07E003FC007C078003FC003C078003FC003C070003FC001C0F0003FC001E0F0003F
1371 
+C001E0E0003FC000E0E0003FC000E0E0003FC000E0E0003FC000E0E0003FC000E000003FC00000
1372 
+00003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003F
1373 
+C0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC00000
1374 
+00003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003F
1375 
+C0000000003FC00000007FFFFFE000007FFFFFE000007FFFFFE0002B287EA730>84
1376 
+D<FFFFF0003FFF80FFFFF0003FFF80FFFFF0003FFF8003FE000001E00001FE000001C00001FF00
1377 
+0003C00000FF000003800000FF0000038000007F8000070000007F8000070000007FC0000F0000
1378 
+003FC0000E0000003FE0001E0000001FE0001C0000001FF0001C0000000FF000380000000FF000
1379 
+3800000007F8007000000007F8007000000007FC00F000000003FC00E000000003FE01E0000000
1380 
+01FE01C000000001FF01C000000000FF038000000000FF038000000000FF8780000000007F8700
1381 
+000000007FCF00000000003FCE00000000003FFE00000000001FFC00000000001FFC0000000000
1382 
+0FF800000000000FF800000000000FF8000000000007F0000000000007F0000000000003E00000
1383 
+00000003E0000000000001C000000031297FA834>86 D<010002000300060006000C000C001800
1384 
+1800300030006000300060006000C0006000C0006000C000C0018000C0018000CE019C00FF81FF
1385 
+00FF81FF00FFC1FF80FFC1FF807FC0FF803F807F003F807F000E001C00191578A924>92
1386 
+D<01FF800007FFF0000F81F8001FC07E001FC07E001FC03F000F803F8007003F8000003F800000
1387 
+3F8000003F80000FFF8000FFFF8007FC3F800FE03F803F803F803F003F807F003F80FE003F80FE
1388 
+003F80FE003F80FE003F807E007F807F00DF803F839FFC0FFF0FFC01FC03FC1E1B7E9A21>97
1389 
+D<001FF80000FFFE0003F01F0007E03F800FC03F801F803F803F801F007F800E007F0000007F00
1390 
+0000FF000000FF000000FF000000FF000000FF000000FF000000FF0000007F0000007F0000007F
1391 
+8000003F8001C01F8001C00FC0038007E0070003F01E0000FFFC00001FE0001A1B7E9A1F>99
1392 
+D<00003FF80000003FF80000003FF800000003F800000003F800000003F800000003F800000003
1393 
+F800000003F800000003F800000003F800000003F800000003F800000003F800000003F800001F
1394 
+E3F80000FFFBF80003F03FF80007E00FF8000FC007F8001F8003F8003F8003F8007F0003F8007F
1395 
+0003F8007F0003F800FF0003F800FF0003F800FF0003F800FF0003F800FF0003F800FF0003F800
1396 
+FF0003F8007F0003F8007F0003F8007F0003F8003F8003F8001F8003F8000F8007F80007C00FF8
1397 
+0003F03BFF8000FFF3FF80003FC3FF80212A7EA926>I<003FE00001FFF80003F07E0007C01F00
1398 
+0F801F801F800F803F800FC07F000FC07F0007C07F0007E0FF0007E0FF0007E0FFFFFFE0FFFFFF
1399 
+E0FF000000FF000000FF0000007F0000007F0000007F0000003F8000E01F8000E00FC001C007E0
1400 
+038003F81F0000FFFE00001FF0001B1B7E9A20>I<0007F0003FFC00FE3E01F87F03F87F03F07F
1401 
+07F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007F000
1402 
+07F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F000
1403 
+07F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF80182A7EA915>I<00FF
1404 
+81F003FFE7F80FC1FE7C1F80FC7C1F007C383F007E107F007F007F007F007F007F007F007F007F
1405 
+007F007F007F003F007E001F007C001F80FC000FC1F8001FFFE00018FF80003800000038000000
1406 
+3C0000003E0000003FFFF8001FFFFF001FFFFF800FFFFFC007FFFFE01FFFFFF03E0007F07C0001
1407 
+F8F80000F8F80000F8F80000F8F80000F87C0001F03C0001E01F0007C00FC01F8003FFFE00007F
1408 
+F0001E287E9A22>I<FFE0000000FFE0000000FFE00000000FE00000000FE00000000FE0000000
1409 
+0FE00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE00000
1410 
+000FE00000000FE07F00000FE1FFC0000FE787E0000FEE03F0000FF803F0000FF803F8000FF003
1411 
+F8000FF003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE0
1412 
+03F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000F
1413 
+E003F8000FE003F800FFFE3FFF80FFFE3FFF80FFFE3FFF80212A7DA926>I<07000F801FC03FE0
1414 
+3FE03FE01FC00F8007000000000000000000000000000000FFE0FFE0FFE00FE00FE00FE00FE00F
1415 
+E00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE
1416 
+0F2B7DAA14>I<FFE00000FFE00000FFE000000FE000000FE000000FE000000FE000000FE00000
1417 
+0FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE01FFC0FE01FFC0FE01F
1418 
+FC0FE007800FE00F000FE01E000FE03C000FE078000FE0E0000FE3C0000FE7C0000FEFE0000FFF
1419 
+E0000FFFF0000FF3F8000FE3F8000FC1FC000FC0FE000FC07F000FC07F000FC03F800FC01FC00F
1420 
+C00FC00FC00FE0FFFC3FFEFFFC3FFEFFFC3FFE1F2A7EA924>107 D<FFE0FFE0FFE00FE00FE00F
1421 
+E00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0
1422 
+0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2A7DA914
1423 
+>I<FFC07F800FF000FFC1FFE03FFC00FFC383F0707E000FC603F8C07F000FCC01F9803F000FD8
1424 
+01FF003F800FF001FE003F800FF001FE003F800FE001FC003F800FE001FC003F800FE001FC003F
1425 
+800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001
1426 
+FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F80
1427 
+0FE001FC003F800FE001FC003F80FFFE1FFFC3FFF8FFFE1FFFC3FFF8FFFE1FFFC3FFF8351B7D9A
1428 
+3A>I<FFC07F0000FFC1FFC000FFC787E0000FCE03F0000FD803F0000FD803F8000FF003F8000F
1429 
+F003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F800
1430 
+0FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8
1431 
+000FE003F800FFFE3FFF80FFFE3FFF80FFFE3FFF80211B7D9A26>I<003FE00001FFFC0003F07E
1432 
+000FC01F801F800FC03F800FE03F0007E07F0007F07F0007F07F0007F0FF0007F8FF0007F8FF00
1433 
+07F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F87F0007F07F0007F03F800FE03F800FE01F
1434 
+800FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22>I<FFE1FE0000FFE7FF8000FFFE07
1435 
+E0000FF803F0000FF001F8000FE000FC000FE000FE000FE000FF000FE0007F000FE0007F000FE0
1436 
+007F800FE0007F800FE0007F800FE0007F800FE0007F800FE0007F800FE0007F800FE0007F000F
1437 
+E000FF000FE000FF000FE000FE000FE001FC000FF001F8000FF803F0000FFE0FE0000FE7FF8000
1438 
+0FE1FC00000FE00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE00000
1439 
+000FE00000000FE0000000FFFE000000FFFE000000FFFE00000021277E9A26>I<FFC1F0FFC7FC
1440 
+FFCE3E0FD87F0FD87F0FF07F0FF03E0FF01C0FE0000FE0000FE0000FE0000FE0000FE0000FE000
1441 
+0FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000FFFF00FFFF00FFFF00181B7E
1442 
+9A1C>114 D<03FE300FFFF01E03F03800F0700070F00070F00070F80070FC0000FFE0007FFE00
1443 
+7FFF803FFFE01FFFF007FFF800FFF80003FC0000FC60007CE0003CF0003CF00038F80038FC0070
1444 
+FF01E0F7FFC0C1FF00161B7E9A1B>I<00700000700000700000700000F00000F00000F00001F0
1445 
+0003F00003F00007F0001FFFF0FFFFF0FFFFF007F00007F00007F00007F00007F00007F00007F0
1446 
+0007F00007F00007F00007F00007F00007F00007F03807F03807F03807F03807F03807F03803F0
1447 
+3803F87001F86000FFC0001F8015267FA51B>I<FFE03FF800FFE03FF800FFE03FF8000FE003F8
1448 
+000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003
1449 
+F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE0
1450 
+03F8000FE003F8000FE007F80007E007F80007E00FF80003F03BFF8001FFF3FF80003FC3FF8021
1451 
+1B7D9A26>I<FFFE03FF80FFFE03FF80FFFE03FF8007F000700007F000700007F800F00003F800
1452 
+E00003FC01E00001FC01C00001FC01C00000FE03800000FE038000007F070000007F070000007F
1453 
+8F0000003F8E0000003FDE0000001FDC0000001FDC0000000FF80000000FF80000000FF8000000
1454 
+07F000000007F000000003E000000003E000000001C00000211B7F9A24>I<FFFE7FFC0FFEFFFE
1455 
+7FFC0FFEFFFE7FFC0FFE0FE007E000E007F003F001C007F003F001C007F807F803C003F807F803
1456 
+8003F807F8038001FC0EFC070001FC0EFC070001FE1EFC0F0000FE1C7E0E0000FE1C7E0E0000FF
1457 
+383F1E00007F383F1C00007F783F3C00003FF01FB800003FF01FB800003FF01FF800001FE00FF0
1458 
+00001FE00FF000000FC007E000000FC007E000000FC007E00000078003C00000078003C0002F1B
1459 
+7F9A32>I<FFFC0FFF00FFFC0FFF00FFFC0FFF0007F003C00003F807800001FC07800000FE0F00
1460 
+0000FF1E0000007F3C0000003FF80000001FF00000000FF00000000FF000000007F000000007F8
1461 
+0000000FFC0000001FFE0000001EFE0000003C7F000000783F800000F01FC00001E01FE00001C0
1462 
+0FE00003C007F000FFF01FFF80FFF01FFF80FFF01FFF80211B7F9A24>I<FFFE03FF80FFFE03FF
1463 
+80FFFE03FF8007F000700007F000700007F800F00003F800E00003FC01E00001FC01C00001FC01
1464 
+C00000FE03800000FE038000007F070000007F070000007F8F0000003F8E0000003FDE0000001F
1465 
+DC0000001FDC0000000FF80000000FF80000000FF800000007F000000007F000000003E0000000
1466 
+03E000000001C000000001C000000003800000000380000038078000007C07000000FE0F000000
1467 
+FE0E000000FE1E000000FE3C0000007C780000003FE00000000FC000000021277F9A24>I
1468 
+E /Fr 33 122 df<70F8F8F87005057C840E>46 D<0001800000018000000180000003C0000003
1469 
+C0000003C0000005E0000005E000000DF0000008F0000008F0000010F800001078000010780000
1470 
+203C0000203C0000203C0000401E0000401E0000401E0000800F0000800F0000FFFF0001000780
1471 
+01000780030007C0020003C0020003C0040003E0040001E0040001E00C0000F00C0000F03E0001
1472 
+F8FF800FFF20237EA225>65 D<0007E0100038183000E0063001C00170038000F0070000F00E00
1473 
+00701E0000701C0000303C0000303C0000307C0000107800001078000010F8000000F8000000F8
1474 
+000000F8000000F8000000F8000000F8000000F800000078000000780000107C0000103C000010
1475 
+3C0000101C0000201E0000200E000040070000400380008001C0010000E0020000381C000007E0
1476 
+001C247DA223>67 D<FFFFF0000F801E0007800700078003C0078001C0078000E0078000F00780
1477 
+0078078000780780007C0780003C0780003C0780003C0780003E0780003E0780003E0780003E07
1478 
+80003E0780003E0780003E0780003E0780003E0780003C0780003C0780007C0780007807800078
1479 
+078000F0078000E0078001E0078003C0078007000F801E00FFFFF8001F227EA125>I<FFFFFFC0
1480 
+0F8007C0078001C0078000C0078000400780004007800060078000200780002007800020078020
1481 
+20078020000780200007802000078060000780E00007FFE0000780E00007806000078020000780
1482 
+200007802000078020000780000007800000078000000780000007800000078000000780000007
1483 
+800000078000000FC00000FFFE00001B227EA120>70 D<FFFC3FFF0FC003F0078001E0078001E0
1484 
+078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
1485 
+E0078001E0078001E007FFFFE0078001E0078001E0078001E0078001E0078001E0078001E00780
1486 
+01E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E00FC003F0FF
1487 
+FC3FFF20227EA125>72 D<03FFF0001F00000F00000F00000F00000F00000F00000F00000F0000
1488 
+0F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F0000
1489 
+0F00000F00000F00000F00700F00F80F00F80F00F80E00F01E00401C0020380018700007C00014
1490 
+237EA119>74 D<FFFE00000FC00000078000000780000007800000078000000780000007800000
1491 
+078000000780000007800000078000000780000007800000078000000780000007800000078000
1492 
+000780000007800000078000000780000007800080078000800780008007800080078001800780
1493 
+018007800100078003000780030007800F000F803F00FFFFFF0019227EA11E>76
1494 
+D<FF8007FF07C000F807C0007005E0002004F0002004F0002004780020047C0020043C0020041E
1495 
+0020041F0020040F002004078020040780200403C0200401E0200401E0200400F0200400F82004
1496 
+00782004003C2004003E2004001E2004000F2004000F20040007A0040003E0040003E0040001E0
1497 
+040001E0040000E00E0000601F000060FFE0002020227EA125>78 D<FFFFF0000F803C0007800F
1498 
+0007800780078007C0078003C0078003E0078003E0078003E0078003E0078003E0078003E00780
1499 
+03C0078007C00780078007800F0007803C0007FFF0000780000007800000078000000780000007
1500 
+800000078000000780000007800000078000000780000007800000078000000780000007800000
1501 
+0FC00000FFFC00001B227EA121>80 D<03F0200C0C601802603001E07000E0600060E00060E000
1502 
+60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003FC00007
1503 
+E00001E00000F00000F0000070800070800070800070800070C00060C00060E000C0F000C0C801
1504 
+80C6070081FC0014247DA21B>83 D<FFFC07FF0FC000F807800070078000200780002007800020
1505 
+078000200780002007800020078000200780002007800020078000200780002007800020078000
1506 
+200780002007800020078000200780002007800020078000200780002007800020078000200780
1507 
+00200380004003C0004003C0004001C0008000E000800060010000300600001C08000003F00020
1508 
+237EA125>85 D<FFF0007FC01F80001F000F80000C00078000080007C000180003E000100001E0
1509 
+00200001F000200000F000400000F800C000007C008000003C010000003E010000001E02000000
1510 
+1F040000000F84000000078800000007D800000003D000000003E000000001E000000001E00000
1511 
+0001E000000001E000000001E000000001E000000001E000000001E000000001E000000001E000
1512 
+000001E000000001E000000003E00000003FFF000022227FA125>89 D<0FE0001838003C0C003C
1513 
+0E0018070000070000070000070000FF0007C7001E07003C0700780700700700F00708F00708F0
1514 
+0708F00F087817083C23900FC1E015157E9418>97 D<0E0000FE00001E00000E00000E00000E00
1515 
+000E00000E00000E00000E00000E00000E00000E00000E00000E1F000E61C00E80600F00300E00
1516 
+380E003C0E001C0E001E0E001E0E001E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00
1517 
+700C80600C41C0083F0017237FA21B>I<01FE000703000C07801C0780380300780000700000F0
1518 
+0000F00000F00000F00000F00000F00000F000007000007800403800401C00800C010007060001
1519 
+F80012157E9416>I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E0
1520 
+0000E00000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0
1521 
+F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE17237E
1522 
+A21B>I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F00000F00000F000
1523 
+00F00000F000007000007800203800201C00400E008007030000FC0013157F9416>I<003C00C6
1524 
+018F038F030F070007000700070007000700070007000700FFF807000700070007000700070007
1525 
+000700070007000700070007000700070007000700070007807FF8102380A20F>I<0E0000FE00
1526 
+001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E1F
1527 
+800E60C00E80E00F00700F00700E00700E00700E00700E00700E00700E00700E00700E00700E00
1528 
+700E00700E00700E00700E00700E00700E0070FFE7FF18237FA21B>104
1529 
+D<1C001E003E001E001C00000000000000000000000000000000000E00FE001E000E000E000E00
1530 
+0E000E000E000E000E000E000E000E000E000E000E000E000E000E00FFC00A227FA10E>I<0E00
1531 
+00FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
1532 
+000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8000F1C000E1E000E0E
1533 
+000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE17237FA21A>107
1534 
+D<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E00
1535 
+0E000E000E000E000E000E000E000E000E000E000E000E000E000E000E00FFE00B237FA20E>I<
1536 
+0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E003800E00E003800E00E003800
1537 
+E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038
1538 
+00E00E003800E00E003800E00E003800E00E003800E0FFE3FF8FFE27157F942A>I<0E1F80FE60
1539 
+C01E80E00F00700F00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00
1540 
+700E00700E00700E00700E00700E0070FFE7FF18157F941B>I<01FC000707000C01801800C038
1541 
+00E0700070700070F00078F00078F00078F00078F00078F00078F000787000707800F03800E01C
1542 
+01C00E038007070001FC0015157F9418>I<0E1F00FE61C00E80600F00700E00380E003C0E001C
1543 
+0E001E0E001E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C0
1544 
+0E3F000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B>
1545 
+I<0E3CFE461E8F0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E00
1546 
+0F00FFF010157F9413>114 D<0F8830786018C018C008C008E008F0007F803FE00FF001F8003C
1547 
+801C800C800CC00CC008E018D0308FC00E157E9413>I<02000200020002000600060006000E00
1548 
+1E003E00FFF80E000E000E000E000E000E000E000E000E000E000E000E040E040E040E040E040E
1549 
+040708030801F00E1F7F9E13>I<0E0070FE07F01E00F00E00700E00700E00700E00700E00700E
1550 
+00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006017003827800FC7F18
1551 
+157F941B>I<FFC1FE1E00780E00300E00200E002007004007004003808003808003808001C100
1552 
+01C10000E20000E20000E20000740000740000380000380000380000100017157F941A>I<FFC1
1553 
+FE1E00780E00300E00200E002007004007004003808003808003808001C10001C10000E20000E2
1554 
+0000E200007400007400003800003800003800001000001000002000002000002000004000F040
1555 
+00F08000F180004300003C0000171F7F941A>121 D E /Fs 17 118 df<000003000000000003
1556 
+00000000000300000000000780000000000780000000000FC0000000000FC0000000000FC00000
1557 
+000017E00000000013E00000000013E00000000023F00000000021F00000000021F00000000040
1558 
+F80000000040F80000000040F800000000807C00000000807C00000001807E00000001003E0000
1559 
+0001003E00000002003F00000002001F00000002001F00000004000F80000004000F8000000400
1560 
+0F800000080007C00000080007C00000180007E000001FFFFFE000001FFFFFE00000200003F000
1561 
+00200001F00000200001F00000400001F80000400000F80000400000F800008000007C00008000
1562 
+007C00008000007C00010000003E00010000003E00030000003F00030000001F00070000001F00
1563 
+1F8000003F80FFE00003FFFCFFE00003FFFC2E327EB132>65 D<00001FE000800000FFFC018000
1564 
+07F00F0180000F80018380003E0000C38000780000278000F00000178001E000000F8003C00000
1565 
+0F800780000007800780000003800F00000003801F00000001801E00000001803E00000001803C
1566 
+00000001803C00000000807C00000000807C0000000080780000000000F80000000000F8000000
1567 
+0000F80000000000F80000000000F80000000000F80000000000F80000000000F80000000000F8
1568 
+0000000000F80000000000F800000FFFFC7800000FFFFC7C0000001FC07C0000000F803C000000
1569 
+0F803C0000000F803E0000000F801E0000000F801F0000000F800F0000000F80078000000F8007
1570 
+C000000F8003C000000F8001E000000F8000F000001780007C00001780003E00006380000F8000
1571 
+C3800007F00781800000FFFE008000001FF000002E337CB134>71 D<FFFF807FFFC0FFFF807FFF
1572 
+C007F00003F80003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E0
1573 
+0001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F0
1574 
+0003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E0
1575 
+0001F00003E00001F00003FFFFFFF00003FFFFFFF00003E00001F00003E00001F00003E00001F0
1576 
+0003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E0
1577 
+0001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F0
1578 
+0003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00007F00003F800FFFF
1579 
+807FFFC0FFFF807FFFC02A317CB032>I<FFFF80FFFF8007F00003E00003E00003E00003E00003
1580 
+E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003
1581 
+E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003
1582 
+E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00007
1583 
+F000FFFF80FFFF8011317DB017>I<00FE00000303C0000C00E00010007000100038003C003C00
1584 
+3E001C003E001E003E001E0008001E0000001E0000001E0000001E00000FFE0000FC1E0003E01E
1585 
+000F801E001F001E003E001E003C001E007C001E00F8001E04F8001E04F8001E04F8003E04F800
1586 
+3E0478003E047C005E043E008F080F0307F003FC03E01E1F7D9E21>97 D<003F8000E060038018
1587 
+0700040F00041E001E1C003E3C003E7C003E7C0008780000F80000F80000F80000F80000F80000
1588 
+F80000F80000F80000F800007800007C00007C00003C00011E00011E00020F0002070004038018
1589 
+00E060003F80181F7D9E1D>99 D<000001E000003FE000003FE0000003E0000001E0000001E000
1590 
+0001E0000001E0000001E0000001E0000001E0000001E0000001E0000001E0000001E0000001E0
1591 
+000001E0000001E0000001E0001F81E000F061E001C019E0078005E00F0003E00E0003E01E0001
1592 
+E03C0001E03C0001E07C0001E0780001E0F80001E0F80001E0F80001E0F80001E0F80001E0F800
1593 
+01E0F80001E0F80001E0F80001E0780001E0780001E03C0001E03C0001E01C0001E01E0003E00E
1594 
+0005E0070009E0038011F000E061FF003F81FF20327DB125>I<003F800000E0E0000380380007
1595 
+003C000E001E001E001E001C000F003C000F007C000F0078000F8078000780F8000780F8000780
1596 
+FFFFFF80F8000000F8000000F8000000F8000000F8000000F8000000780000007C0000003C0000
1597 
+003C0000801E0000800E0001000F0002000780020001C00C0000F03000001FC000191F7E9E1D>
1598 
+I<07000F801F801F800F800700000000000000000000000000000000000000000000000780FF80
1599 
+FF800F800780078007800780078007800780078007800780078007800780078007800780078007
1600 
+800780078007800780078007800FC0FFF8FFF80D307EAF12>105 D<07800000FF800000FF8000
1601 
+000F80000007800000078000000780000007800000078000000780000007800000078000000780
1602 
+000007800000078000000780000007800000078000000780000007801FFC07801FFC078007E007
1603 
+800780078006000780040007800800078010000780600007808000078100000783800007878000
1604 
+078FC0000793C00007A1E00007C1F0000780F0000780780007807C0007803C0007803E0007801F
1605 
+0007800F0007800F80078007C0078003C0078003E00FC007F8FFFC0FFFFFFC0FFF20327EB123>
1606 
+107 D<0780FF80FF800F8007800780078007800780078007800780078007800780078007800780
1607 
+078007800780078007800780078007800780078007800780078007800780078007800780078007
1608 
+800780078007800780078007800780078007800FC0FFFCFFFC0E327EB112>I<0780FE0000FF83
1609 
+078000FF8C03C0000F9001E00007A001E00007A000F00007C000F00007C000F000078000F00007
1610 
+8000F000078000F000078000F000078000F000078000F000078000F000078000F000078000F000
1611 
+078000F000078000F000078000F000078000F000078000F000078000F000078000F000078000F0
1612 
+00078000F000078000F000078000F0000FC001F800FFFC1FFF80FFFC1FFF80211F7E9E25>110
1613 
+D<001FC00000F0780001C01C00070007000F0007801E0003C01C0001C03C0001E03C0001E07800
1614 
+00F0780000F0780000F0F80000F8F80000F8F80000F8F80000F8F80000F8F80000F8F80000F8F8
1615 
+0000F8780000F07C0001F03C0001E03C0001E01E0003C01E0003C00F00078007800F0001C01C00
1616 
+00F07800001FC0001D1F7E9E21>I<0783E0FF8C18FF907C0F907C07A07C07C03807C00007C000
1617 
+07C000078000078000078000078000078000078000078000078000078000078000078000078000
1618 
+0780000780000780000780000780000780000780000FC000FFFE00FFFE00161F7E9E19>114
1619 
+D<01FC100E03301800F0300070600030E00030E00010E00010E00010F00010F800007E00003FF0
1620 
+001FFF000FFFC003FFE0003FF00001F80000F880003C80003C80001CC0001CC0001CE0001CE000
1621 
+18F00038F00030CC0060C301C080FE00161F7E9E1A>I<00400000400000400000400000400000
1622 
+C00000C00000C00001C00001C00003C00007C0000FC0001FFFE0FFFFE003C00003C00003C00003
1623 
+C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003
1624 
+C01003C01003C01003C01003C01003C01003C01003C01001C02001E02000E0400078C0001F0014
1625 
+2C7FAB19>I<078000F000FF801FF000FF801FF0000F8001F000078000F000078000F000078000
1626 
+F000078000F000078000F000078000F000078000F000078000F000078000F000078000F0000780
1627 
+00F000078000F000078000F000078000F000078000F000078000F000078000F000078000F00007
1628 
+8000F000078001F000078001F000078001F000038002F00003C004F00001C008F800007030FF80
1629 
+001FC0FF80211F7E9E25>I E end
1630 
+%%EndProlog
1631 
+%%BeginSetup
1632 
+%%Feature: *Resolution 300
1633 
+TeXDict begin @letter /letter where {pop letter} if
1634 
+%%EndSetup
1635 
+%%Page: 1 1
1636 
+bop 501 287 a Fs(A)21 b(Gen)n(tle)h(In)n(tro)r(duction)g(to)g(Hask)n(ell)432
1637 
+443 y Fr(P)o(aul)16 b(Hudak)395 501 y(Y)l(ale)g(Univ)o(ersit)o(y)203
1638 
+559 y(Departmen)o(t)e(of)j(Computer)e(Science)1228 443 y(Joseph)i(H.)f(F)l
1639 
+(asel)1145 501 y(Univ)o(ersit)o(y)e(of)i(California)1044 559
1640 
+y(Los)h(Alamos)e(National)h(Lab)q(oratory)0 788 y Fq(1)69 b(In)n(tro)r
1641 
+(duction)0 920 y Fp(Our)20 b(purp)q(ose)h(in)f(writing)g(this)h(tutorial)e
1642 
+(is)i(not)e(to)g(teac)o(h)h(programming,)g(nor)f(ev)o(en)h(to)f(teac)o(h)h
1643 
+(functional)0 977 y(programming.)j(Rather,)17 b(it)f(is)h(in)o(tended)h(to)e
1644 
+(serv)o(e)g(as)g(a)h(supplemen)o(t)g(to)f(the)h(Hask)o(ell)g(Rep)q(ort)g([3)o
1645 
+(],)f(whic)o(h)h(is)0 1033 y(otherwise)11 b(a)g(rather)g(dense)h(tec)o
1646 
+(hnical)g(exp)q(osition.)20 b(Our)11 b(goal)g(is)h(to)e(pro)o(vide)i(a)f(gen)
1647 
+o(tle)g(in)o(tro)q(duction)i(to)d(Hask)o(ell)0 1090 y(for)k(someone)g(who)g
1648 
+(has)g(exp)q(erience)j(with)e(at)f(least)g(one)h(other)f(language,)g
1649 
+(preferably)h(a)f(functional)i(language)0 1146 y(\(ev)o(en)k(if)h(only)g(an)f
1650 
+(\\almost-functional")h(language)f(suc)o(h)h(as)f(ML)g(or)g(Sc)o(heme\).)35
1651 
+b(If)21 b(the)f(reader)h(wishes)g(to)0 1202 y(learn)15 b(more)g(ab)q(out)g
1652 
+(the)g(functional)h(programming)e(st)o(yle,)h(w)o(e)f(highly)j(recommend)e
1653 
+(Bird)g(and)h(W)l(adler's)e(text)0 1259 y Fo(Intr)n(o)n(duction)k(to)g(F)m
1654 
+(unctional)f(Pr)n(o)n(gr)n(amming)g Fp([1)o(],)g(whic)o(h)i(uses)e(a)g
1655 
+(language)h(su\016cien)o(tly)h(similar)f(to)f(Hask)o(ell)0
1656 
+1315 y(to)h(mak)o(e)g(translation)h(b)q(et)o(w)o(een)f(the)h(t)o(w)o(o)e
1657 
+(quite)i(easy)l(.)30 b(F)l(or)18 b(a)h(useful)g(surv)o(ey)g(of)f(functional)i
1658 
+(programming)0 1372 y(languages)14 b(and)g(tec)o(hniques,)h(including)h(some)
1659 
+e(of)f(the)h(language)g(design)h(principals)h(used)e(in)h(Hask)o(ell,)f(see)g
1660 
+([2].)71 1457 y(Our)j(general)g(strategy)f(for)g(in)o(tro)q(ducing)i
1661 
+(language)f(features)g(is)g(this:)24 b(motiv)m(ate)17 b(the)g(idea,)g
1662 
+(de\014ne)h(some)0 1514 y(terms,)12 b(giv)o(e)i(some)e(examples,)i(and)f
1663 
+(then)g(p)q(oin)o(t)g(to)g(the)g(Rep)q(ort)g(for)f(details.)20
1664 
+b(W)l(e)13 b(suggest,)g(ho)o(w)o(ev)o(er,)f(that)g(the)0 1570
1665 
+y(reader)17 b(completely)h(ignore)f(the)g(details)g(un)o(til)h(this)f(do)q
1666 
+(cumen)o(t)g(has)g(b)q(een)h(completely)g(read.)24 b(On)18
1667 
+b(the)e(other)0 1627 y(hand,)g(Hask)o(ell's)h(Standard)f(Prelude)i(\(in)e
1668 
+(App)q(endix)i(A)f(of)e(the)i(Rep)q(ort\))f(con)o(tains)g(lots)g(of)g(useful)
1669 
+h(examples)0 1683 y(of)h(Hask)o(ell)h(co)q(de;)i(w)o(e)d(encourage)g(a)h
1670 
+(thorough)e(reading)i(once)g(this)g(tutorial)g(is)g(completed.)30
1671 
+b(This)19 b(will)h(not)0 1740 y(only)d(giv)o(e)g(the)f(reader)h(a)f(feel)i
1672 
+(for)d(what)h(real)h(Hask)o(ell)h(co)q(de)f(lo)q(oks)g(lik)o(e,)g(but)g(will)
1673 
+h(also)e(familiarize)j(her)e(with)0 1796 y(Hask)o(ell's)f(standard)e(set)h
1674 
+(of)g(prede\014ned)i(functions)f(and)f(t)o(yp)q(es.)71 1882
1675 
+y([W)l(e)e(ha)o(v)o(e)g(also)h(tak)o(en)f(the)h(course)g(of)f(not)g(la)o
1676 
+(ying)h(out)g(a)f(plethora)h(of)f(lexical)j(syn)o(tax)d(rules)h(at)f(the)h
1677 
+(outset.)0 1938 y(Rather,)i(w)o(e)g(in)o(tro)q(duce)h(them)f(incremen)o
1678 
+(tally)i(as)e(our)f(examples)i(demand,)g(and)f(enclose)h(them)f(in)h(brac)o
1679 
+(k)o(ets,)0 1995 y(as)f(with)i(this)f(paragraph.)24 b(This)18
1680 
+b(is)f(in)h(stark)e(con)o(trast)f(to)h(the)h(organization)g(of)g(the)g(Rep)q
1681 
+(ort,)g(although)g(the)0 2051 y(Rep)q(ort)h(remains)g(the)f(authoritativ)o(e)
1682 
+g(source)h(for)e(details)j(\(references)e(suc)o(h)h(as)f(\\)p
1683 
+Fn(x)p Fp(2.1")f(refer)h(to)g(sections)h(in)0 2107 y(the)d(Rep)q(ort\).])71
1684 
+2193 y(Hask)o(ell)g(is)h(a)e Fo(typ)n(eful)h Fp(programming)f(language:)922
1685 
+2177 y Fm(1)962 2193 y Fp(T)o(yp)q(es)h(are)f(p)q(erv)m(asiv)o(e,)i(and)f
1686 
+(the)g(new)o(comer)f(is)i(b)q(est)f(o\013)0 2249 y(b)q(ecoming)f(w)o(ell-a)o
1687 
+(w)o(are)e(of)h(the)f(full)i(p)q(o)o(w)o(er)f(and)f(complexit)o(y)i(of)e
1688 
+(Hask)o(ell's)h(t)o(yp)q(e)g(system)f(from)g(the)h(outset.)19
1689 
+b(F)l(or)0 2306 y(those)12 b(whose)g(only)g(exp)q(erience)i(is)f(with)f
1690 
+(relativ)o(ely)h(\\un)o(t)o(yp)q(eful")g(languages)f(suc)o(h)g(as)g(Basic)g
1691 
+(or)g(Lisp,)h(this)g(ma)o(y)0 2362 y(b)q(e)f(a)e(di\016cult)i(adjustmen)o(t;)
1692 
+g(for)e(those)h(familiar)g(with)h(P)o(ascal,)f(Mo)q(dula,)h(or)e(ev)o(en)h
1693 
+(ML,)g(the)g(adjustmen)o(t)f(should)0 2419 y(b)q(e)19 b(easier)h(but)e(still)
1694 
+j(not)d(insigni\014can)o(t,)j(since)f(Hask)o(ell's)f(t)o(yp)q(e)g(system)f
1695 
+(is)i(di\013eren)o(t)f(and)f(somewhat)g(ric)o(her)0 2475 y(than)g(most.)29
1696 
+b(In)19 b(an)o(y)g(case,)g(\\t)o(yp)q(eful)g(programming")e(is)i(part)f(of)g
1697 
+(the)h(Hask)o(ell)g(programming)f(exp)q(erience,)0 2532 y(and)d(cannot)g(b)q
1698 
+(e)h(a)o(v)o(oided.)p 0 2571 780 2 v 52 2598 a Fl(1)69 2614
1699 
+y Fk(A)d(phrase)h(due)f(to)g(Luca)g(Cardelli.)940 2738 y Fp(T-1)p
1700 
+eop
1701 
+%%Page: 2 2
1702 
+bop 0 -40 a Fp(T-2)906 b Fj(2)45 b(V)-5 b(ALUES,)16 b(TYPES,)e(AND)h(OTHER)h
1703 
+(GOODIES)0 105 y Fq(2)69 b(V)-6 b(alues,)23 b(T)n(yp)r(es,)g(and)g(Other)g
1704 
+(Go)r(o)r(dies)0 228 y Fp(Because)g(Hask)o(ell)g(is)f(a)g(purely)i
1705 
+(functional)f(language,)h(all)f(computations)f(are)g(done)g(via)g(the)h(ev)m
1706 
+(aluation)0 285 y(of)18 b Fo(expr)n(essions)e Fp(\(syn)o(tactic)i(terms\))f
1707 
+(to)g(yield)j Fo(values)e Fp(\(abstract)f(en)o(tities)h(that)g(w)o(e)g
1708 
+(regard)f(as)h(answ)o(ers\).)27 b(In)0 341 y(particular,)12
1709 
+b(there)g(are)f(no)g Fo(c)n(ommands)g Fp(that)f(op)q(erate)h(b)o(y)g
1710 
+(implicit)j(side)e(e\013ects)f(to)g(a)g(global)h(store.)17
1711 
+b(In)12 b(addition,)0 398 y(ev)o(ery)j(v)m(alue)g(has)g(an)f(asso)q(ciated)h
1712 
+Fo(typ)n(e)p Fp(.)20 b(\(In)o(tuitiv)o(ely)l(,)c(w)o(e)e(can)h(think)g(of)g
1713 
+(t)o(yp)q(es)f(as)g(sets)h(of)f(v)m(alues.\))20 b(Examples)0
1714 
+454 y(of)f(expressions)g(include)j(atomic)c(v)m(alues)j(suc)o(h)e(as)g(the)g
1715 
+(in)o(teger)g Fi(5)p Fp(,)g(the)g(c)o(haracter)f Fi('a')p Fp(,)i(and)f(the)g
1716 
+(successor)0 511 y(function)d Fi(succ)o Fp(,)f(as)g(w)o(ell)h(as)f
1717 
+(structured)g(v)m(alues)i(suc)o(h)e(as)g(the)g(list)h Fi([1,2,3])e
1718 
+Fp(and)i(the)f(pair)h Fi(\('b',4\))o Fp(.)71 589 y(Just)f(as)h(expressions)g
1719 
+(denote)g(v)m(alues,)h Fo(typ)n(e)f(expr)n(essions)f Fp(are)g(syn)o(tactic)h
1720 
+(terms)f(that)g(denote)h Fo(typ)n(e)g(values)0 645 y Fp(\(or)10
1721 
+b(just)h Fo(typ)n(es)p Fp(\).)18 b(Examples)11 b(of)g(t)o(yp)q(e)g
1722 
+(expressions)h(include)i(the)d(atomic)g(t)o(yp)q(es)g Fi(Int)f
1723 
+Fp(\(\014xed-precision)k(in)o(tegers\),)0 702 y Fi(Char)h Fp(\(ascii)h(c)o
1724 
+(haracters\),)d Fi(Int->Int)h Fp(\(functions)i(mapping)g Fi(Int)f
1725 
+Fp(to)f Fi(Int)p Fp(\),)h(as)f(w)o(ell)j(as)d(the)i(structured)f(t)o(yp)q(es)
1726 
+0 758 y Fi([Int])f Fp(\(homogeneous)h(lists)h(of)f(in)o(tegers\))g(and)g
1727 
+Fi(\(Char,Int\))f Fp(\(c)o(haracter/in)o(teger)g(pairs\).)71
1728 
+837 y(All)h(Hask)o(ell)g(v)m(alues)g(are)f(\\\014rst-class"|they)g(ma)o(y)g
1729 
+(b)q(e)g(passed)h(as)e(argumen)o(ts)h(to)f(functions,)i(returned)f(as)0
1730 
+893 y(results,)i(placed)g(in)h(data)e(structures,)g(etc.)21
1731 
+b(Hask)o(ell)16 b(t)o(yp)q(es,)g(on)f(the)h(other)f(hand,)h(are)f
1732 
+Fo(not)h Fp(\014rst-class.)21 b(T)o(yp)q(es)0 949 y(in)16 b(a)e(sense)h
1733 
+Fo(describ)n(e)f Fp(v)m(alues,)i(and)f(the)f(asso)q(ciation)i(of)e(a)g(v)m
1734 
+(alue)i(with)f(its)g(t)o(yp)q(e)g(is)g(called)i(a)d Fo(typing)p
1735 
+Fp(.)20 b(Using)15 b(the)0 1006 y(examples)h(of)f(v)m(alues)h(and)f(t)o(yp)q
1736 
+(es)h(ab)q(o)o(v)o(e,)e(w)o(e)h(write)g(t)o(ypings)h(as)e(follo)o(ws:)691
1737 
+1115 y Fi(5)48 b(::)23 b(Int)667 1171 y('a')h(::)f(Char)643
1738 
+1228 y(succ)h(::)f(Int)h(->)f(Int)572 1284 y([1,2,3])g(::)g([Int])572
1739 
+1341 y(\('b',4\))g(::)g(\(Char,Int\))0 1450 y Fp(The)15 b Fi(::)g
1740 
+Fp(can)h(b)q(e)g(read)f(\\has)f(t)o(yp)q(e.")71 1528 y(F)l(unctions)i(in)h
1741 
+(Hask)o(ell)g(are)f(normally)h(de\014ned)h(b)o(y)e(a)f(series)i(of)f
1742 
+Fo(e)n(quations)p Fp(.)22 b(F)l(or)16 b(example,)h(the)f(successor)0
1743 
+1585 y(function)g Fi(succ)f Fp(can)g(b)q(e)h(de\014ned)g(b)o(y)g(the)f
1744 
+(single)h(equation:)71 1694 y Fi(succ)23 b(n)238 b(=)24 b(n+1)0
1745 
+1803 y Fp(An)16 b(equation)g(is)g(an)g(example)h(of)e(a)g Fo(de)n(clar)n
1746 
+(ation)p Fp(.)21 b(Another)16 b(kind)h(of)e(declaration)i(is)f(a)f
1747 
+Fo(typ)n(e)i(signatur)n(e)f(de)n(cla-)0 1859 y(r)n(ation)f
1748 
+Fp(\()p Fn(x)p Fp(4.4.1\),)e(with)i(whic)o(h)h(w)o(e)f(can)h(declare)g(an)f
1749 
+(explicit)i(t)o(yping)f(for)e Fi(succ)p Fp(:)71 1971 y Fi(succ)285
1750 
+b(::)24 b(Int)f(->)h(Int)0 2080 y Fp(W)l(e)15 b(will)i(ha)o(v)o(e)e(m)o(uc)o
1751 
+(h)g(more)g(to)f(sa)o(y)h(ab)q(out)g(function)h(de\014nitions)h(in)f(Section)
1752 
+g(3.)71 2158 y(F)l(or)i(p)q(edagogical)i(purp)q(oses,)g(when)g(w)o(e)f(wish)h
1753 
+(to)e(indicate)j(that)d(an)h(expression)h Fh(e)1562 2165 y
1754 
+Fm(1)1601 2158 y Fp(ev)m(aluates,)h(or)d(\\re-)0 2214 y(duces,")d(to)g
1755 
+(another)g(expression)h(or)e(v)m(alue)j Fh(e)795 2221 y Fm(2)815
1756 
+2214 y Fp(,)e(w)o(e)f(will)j(write:)838 2307 y Fh(e)859 2314
1757 
+y Fm(1)952 2307 y Fn(\))74 b Fh(e)1092 2314 y Fm(2)0 2400 y
1758 
+Fp(F)l(or)15 b(example,)g(note)g(that:)712 2457 y Fi(succ)23
1759 
+b(\(succ)g(3\))73 b Fn(\))h Fi(5)71 2557 y Fp(Hask)o(ell's)17
1760 
+b Fo(static)h(typ)n(e)h(system)d Fp(de\014nes)j(the)e(formal)g(relationship)i
1761 
+(b)q(et)o(w)o(een)f(t)o(yp)q(es)f(and)h(v)m(alues)g(\()p Fn(x)p
1762 
+Fp(4.1.3\).)0 2614 y(The)11 b(static)f(t)o(yp)q(e)h(system)f(ensures)i(that)d
1763 
+(Hask)o(ell)j(programs)d(are)i Fo(typ)n(e)h(safe)p Fp(;)f(that)f(is,)i(that)e
1764 
+(the)h(programmer)e(has)p eop
1765 
+%%Page: 3 3
1766 
+bop 0 -40 a Fj(2.1)45 b(P)o(olymorphic)15 b(T)o(yp)q(es)1390
1767 
+b Fp(T-3)0 105 y(not)13 b(mismatc)o(hed)h(t)o(yp)q(es)f(in)h(some)f(w)o(a)o
1768 
+(y)l(.)19 b(F)l(or)12 b(example,)i(w)o(e)f(cannot)h(generally)g(add)g
1769 
+(together)e(t)o(w)o(o)g(c)o(haracters,)0 162 y(so)17 b(the)g(expression)h
1770 
+Fi('a'+'b')d Fp(is)j(ill-t)o(yp)q(ed.)28 b(The)17 b(main)g(adv)m(an)o(tage)g
1771 
+(of)f(statically)i(t)o(yp)q(ed)f(languages)g(is)h(w)o(ell-)0
1772 
+218 y(kno)o(wn:)g(All)c(t)o(yp)q(e)e(errors)g(are)g(detected)h(at)f
1773 
+(compile-time.)21 b(This)13 b(not)f(only)g(aids)h(the)g(user)f(in)i
1774 
+(reasoning)e(ab)q(out)0 274 y(programs,)17 b(but)h(also)g(p)q(ermits)g(a)f
1775 
+(compiler)j(to)d(generate)g(more)h(e\016cien)o(t)g(co)q(de)h(\(for)d
1776 
+(example,)j(no)f(run-time)0 331 y(t)o(yp)q(e)d(tags)f(or)h(tests)g(are)g
1777 
+(required\).)71 410 y(The)h(t)o(yp)q(e)g(system)f(also)h(ensures)h(that)e
1778 
+(user-supplied)k(t)o(yp)q(e)d(signatures)g(are)g(correct.)22
1779 
+b(In)16 b(fact,)g(Hask)o(ell's)0 467 y(t)o(yp)q(e)h(system)f(is)h(p)q(o)o(w)o
1780 
+(erful)g(enough)g(to)f(allo)o(w)h(us)f(to)g(a)o(v)o(oid)h(writing)g(an)o(y)f
1781 
+(t)o(yp)q(e)h(signatures)f(at)g(all,)1743 450 y Fm(2)1781 467
1782 
+y Fp(in)h(whic)o(h)0 523 y(case)d(w)o(e)h(sa)o(y)e(that)h(the)h(t)o(yp)q(e)f
1783 
+(system)g Fo(infers)g Fp(the)g(correct)g(t)o(yp)q(es)h(for)e(us.)20
1784 
+b(Nev)o(ertheless,)15 b(judicious)h(placemen)o(t)0 580 y(of)f(t)o(yp)q(e)g
1785 
+(signatures)g(is)h(a)f(go)q(o)q(d)g(idea,)h(as)e(w)o(e)h(did)i(for)d
1786 
+Fi(succ)p Fp(,)g(since)j(it)e(impro)o(v)o(es)g(readabilit)o(y)i(and)e(helps)h
1787 
+(bring)0 636 y(programming)f(errors)f(to)h(ligh)o(t.)71 715
1788 
+y([The)e(reader)g(will)j(note)d(that)g(w)o(e)g(ha)o(v)o(e)g(capitalized)j
1789 
+(iden)o(ti\014ers)f(that)e(denote)g(sp)q(eci\014c)j(t)o(yp)q(es,)d(suc)o(h)h
1790 
+(as)f Fi(Int)0 772 y Fp(and)18 b Fi(Char)o Fp(,)g(but)g(not)g(iden)o
1791 
+(ti\014ers)h(that)e(denote)h(v)m(alues,)h(suc)o(h)f(as)g Fi(succ)o
1792 
+Fp(.)28 b(This)18 b(is)g(not)g(just)f(a)h(con)o(v)o(en)o(tion:)25
1793 
+b(it)0 828 y(is)16 b(enforced)g(b)o(y)g(Hask)o(ell's)g(lexical)i(syn)o(tax.)i
1794 
+(In)c(fact,)f(the)h(case)f(of)h(the)f(other)h(c)o(haracters)e(matters,)h(to)q
1795 
+(o:)20 b Fi(foo)o Fp(,)0 885 y Fi(fOo)p Fp(,)14 b(and)i Fi(fOO)e
1796 
+Fp(are)h(all)i(distinct)f(iden)o(ti\014ers.])0 1028 y Fg(2.1)56
1797 
+b(P)n(olymorphic)17 b(T)n(yp)r(es)0 1137 y Fp(Hask)o(ell)k(also)g(incorp)q
1798 
+(orates)f Fo(p)n(olymorphic)h Fp(t)o(yp)q(es|t)o(yp)q(es)g(that)f(are)g(univ)
1799 
+o(ersally)i(quan)o(ti\014ed)g(in)f(some)f(w)o(a)o(y)0 1194
1800 
+y(o)o(v)o(er)d Fo(al)r(l)g Fp(t)o(yp)q(es.)27 b(P)o(olymorphic)18
1801 
+b(t)o(yp)q(e)f(expressions)i(essen)o(tially)g(describ)q(e)g
1802 
+Fo(families)e Fp(of)g(t)o(yp)q(es.)27 b(F)l(or)16 b(example,)0
1803 
+1250 y(\()p Fn(8)p Fi(a)p Fp(\))p Fi([a])21 b Fp(is)h(the)g(family)h(of)f(t)o
1804 
+(yp)q(es)f(consisting)i(of,)g(for)e(ev)o(ery)h(t)o(yp)q(e)g
1805 
+Fi(a)p Fp(,)h(the)f(t)o(yp)q(e)g(of)g(lists)h(of)e Fi(a)p Fp(.)40
1806 
+b(Lists)22 b(of)0 1306 y(in)o(tegers)15 b(\(e.g.)f Fi([1,2,3])o
1807 
+Fp(\),)g(lists)i(of)f(c)o(haracters)f(\()p Fi(['a','b','c'])n
1808 
+Fp(\),)g(ev)o(en)h(lists)h(of)f(lists)h(of)e(in)o(tegers,)h(etc.,)f(are)0
1809 
+1363 y(all)j(mem)o(b)q(ers)e(of)h(this)g(family)l(.)22 b(\(Note,)15
1810 
+b(ho)o(w)o(ev)o(er,)f(that)h Fi([2,'b'])g Fp(is)h Fo(not)f
1811 
+Fp(a)h(v)m(alid)h(example,)f(since)h(there)f(is)g(no)0 1419
1812 
+y(single)h(t)o(yp)q(e)e(that)f(con)o(tains)i(b)q(oth)f Fi(2)g
1813 
+Fp(and)g Fi('b')p Fp(.\))71 1499 y([Iden)o(ti\014ers)21 b(suc)o(h)f(as)44
1814 
+b Fi(a)g Fp(ab)q(o)o(v)o(e)20 b(are)g(called)i Fo(typ)n(e)f(variables)p
1815 
+Fp(,)g(and)f(are)g(uncapitalized)j(to)d(distinguish)0 1555
1816 
+y(them)d(from)g(sp)q(eci\014c)i(t)o(yp)q(es)f(suc)o(h)f(as)g
1817 
+Fi(Int)p Fp(.)26 b(F)l(urthermore,)17 b(since)i(Hask)o(ell)f(has)f(only)h
1818 
+(univ)o(ersally)h(quan)o(ti\014ed)0 1612 y(t)o(yp)q(es,)c(there)g(is)h(no)f
1819 
+(need)h(to)f(explicitly)j(write)d(out)g(the)g(sym)o(b)q(ol)g(for)g(univ)o
1820 
+(ersal)h(quan)o(ti\014cation,)g(and)f(th)o(us)g(w)o(e)0 1668
1821 
+y(simply)g(write)f Fi([a])f Fp(in)i(the)f(example)g(ab)q(o)o(v)o(e.)19
1822 
+b(In)c(other)e(w)o(ords,)g(all)i(t)o(yp)q(e)f(v)m(ariables)h(are)e
1823 
+(implicitly)k(univ)o(ersally)0 1725 y(quan)o(ti\014ed.])71
1824 
+1804 y(Lists)g(are)g(a)g(commonly)h(used)g(data)e(structure)i(in)g
1825 
+(functional)g(languages,)g(and)f(are)g(a)g(go)q(o)q(d)g(v)o(ehicle)j(for)0
1826 
+1860 y(explaining)f(the)e(principals)j(of)c(p)q(olymorphism.)27
1827 
+b(The)17 b(list)h Fi([1,2,3])e Fp(in)i(Hask)o(ell)f(is)h(actually)g
1828 
+(shorthand)f(for)0 1917 y(the)i(list)g Fi(1:\(2:\(3:[]\)\))o
1829 
+Fp(,)g(where)g Fi([])f Fp(is)i(the)e(empt)o(y)h(list)g(and)g
1830 
+Fi(:)g Fp(is)g(the)g(in\014x)h(op)q(erator)e(that)g(adds)g(its)h(\014rst)0
1831 
+1973 y(argumen)o(t)f(to)g(the)h(fron)o(t)f(of)h(its)g(second)g(argumen)o(t)f
1832 
+(\(a)g(list\).)1093 1957 y Fm(3)1145 1973 y Fp(Since)i Fi(:)f
1833 
+Fp(is)g(righ)o(t)g(asso)q(ciativ)o(e,)g(w)o(e)g(can)g(also)0
1834 
+2030 y(write)c(this)h(list)g(as)f Fi(1:2:3:[])o Fp(.)71 2109
1835 
+y(As)c(an)h(example)g(of)f(a)h(user-de\014ned)h(function)f(that)f(op)q
1836 
+(erates)h(on)f(lists,)i(consider)f(the)g(problem)g(of)g(coun)o(ting)0
1837 
+2165 y(the)j(n)o(um)o(b)q(er)h(of)f(elemen)o(ts)g(in)h(a)f(list:)71
1838 
+2266 y Fi(length)428 b(::)24 b([a])f(->)h(Int)71 2322 y(length)46
1839 
+b([])334 b(=)24 b(0)71 2379 y(length)f(\(x:xs\))261 b(=)24
1840 
+b(1)g(+)f(length)h(xs)0 2488 y Fp(This)14 b(de\014nition)i(is)e(almost)g
1841 
+(self-explanatory)l(.)20 b(W)l(e)14 b(can)g(read)g(the)g(equations)g(as)f(sa)
1842 
+o(ying:)19 b(\\The)14 b(length)g(of)g(the)p 0 2525 780 2 v
1843 
+52 2552 a Fl(2)69 2568 y Fk(With)g(a)f(few)g(exceptions)i(to)d(b)q(e)i
1844 
+(describ)q(ed)h(later.)52 2598 y Fl(3)69 2614 y Ff(:)e Fk(and)g
1845 
+Ff([])f Fk(are)h(lik)o(e)i(Lisp's)e Ff(cons)f Fk(and)h Ff(nil)o
1846 
+Fk(,)g(resp)q(ectiv)o(ely)m(.)p eop
1847 
+%%Page: 4 4
1848 
+bop 0 -40 a Fp(T-4)906 b Fj(2)45 b(V)-5 b(ALUES,)16 b(TYPES,)e(AND)h(OTHER)h
1849 
+(GOODIES)0 105 y Fp(empt)o(y)g(list)i(is)f(0,)f(and)h(the)g(length)g(of)f(a)h
1850 
+(list)g(whose)g(\014rst)f(elemen)o(t)h(is)h Fi(x)e Fp(and)h(remainder)g(is)g
1851 
+Fi(xs)g Fp(is)g(1)f(plus)i(the)0 162 y(length)g(of)f Fi(xs)p
1852 
+Fp(.")26 b(\(Note)16 b(the)i(naming)f(con)o(v)o(en)o(tion)h(used)g(here;)g
1853 
+Fi(xs)f Fp(is)h(the)f(plural)i(of)e Fi(x)p Fp(,)g(and)h(should)g(b)q(e)g
1854 
+(read)0 218 y(that)c(w)o(a)o(y)l(.\))71 300 y(Although)20 b(in)o(tuitiv)o(e,)
1855 
+h(this)f(example)g(highligh)o(ts)h(an)e(imp)q(ortan)o(t)g(asp)q(ect)h(of)f
1856 
+(Hask)o(ell)h(that)f(is)h(y)o(et)f(to)f(b)q(e)0 357 y(explained:)k
1857 
+Fo(p)n(attern)17 b(matching)p Fp(.)j(The)15 b(left-hand)i(sides)f(of)f(the)g
1858 
+(equations)h(con)o(tain)f Fo(p)n(atterns)g Fp(suc)o(h)h(as)f
1859 
+Fi([])g Fp(and)0 413 y Fi(x:xs)o Fp(.)28 b(In)19 b(a)e(function)i
1860 
+(application)g(these)f(patterns)g(are)f Fo(matche)n(d)i Fp(against)e(actual)h
1861 
+(parameters)f(in)i(a)e(fairly)0 469 y(in)o(tuitiv)o(e)c(w)o(a)o(y)d(\()p
1862 
+Fi([])h Fp(only)h(matc)o(hes)f(the)h(empt)o(y)f(list,)i(and)e
1863 
+Fi(x:xs)g Fp(will)i(successfully)h(matc)o(h)d(an)o(y)g(list)h(with)g(at)f
1864 
+(least)0 526 y(one)17 b(elemen)o(t,)g(binding)i Fi(x)d Fp(to)g(the)h(\014rst)
1865 
+f(elemen)o(t)i(and)e Fi(xs)h Fp(to)f(the)h(rest)f(of)g(the)h(list\).)24
1866 
+b(If)17 b(the)g(matc)o(h)f(succeeds,)0 582 y(the)h(righ)o(t-hand)g(side)g(is)
1867 
+h(ev)m(aluated)f(and)g(returned)g(as)f(the)h(result)g(of)f(the)h
1868 
+(application.)26 b(If)17 b(it)g(fails,)g(the)g(next)0 639 y(equation)f(is)f
1869 
+(tried,)h(and)f(if)h(all)g(equations)f(fail,)h(an)f(error)g(results.)71
1870 
+721 y(De\014ning)e(functions)g(b)o(y)f(pattern)f(matc)o(hing)i(is)f(quite)h
1871 
+(common)f(in)h(Hask)o(ell,)g(and)g(the)f(user)g(should)h(b)q(ecome)0
1872 
+777 y(familiar)j(with)g(the)f(v)m(arious)h(kinds)g(of)f(patterns)g(that)g
1873 
+(are)g(allo)o(w)o(ed;)g(w)o(e)g(will)i(return)e(to)g(this)h(issue)g(in)g
1874 
+(Section)0 834 y(3.14.)71 916 y Fi(length)i Fp(is)i(also)f(an)g(example)i(of)
1875 
+e(a)g Fo(p)n(olymorphic)h(function)p Fp(.)32 b(It)20 b(can)f(b)q(e)h(applied)
1876 
+h(to)e(a)g(list)h(con)o(taining)0 972 y(elemen)o(ts)c(of)f(an)o(y)f(t)o(yp)q
1877 
+(e.)20 b(F)l(or)15 b(example:)600 1071 y Fi(length)23 b([1,2,3])245
1878 
+b Fn(\))102 b Fp(3)600 1128 y Fi(length)23 b(['a','b','c'])101
1879 
+b Fn(\))h Fp(3)600 1184 y Fi(length)23 b([[],[],[]])173 b Fn(\))102
1880 
+b Fp(3)71 1309 y(Here)15 b(are)g(t)o(w)o(o)f(other)h(useful)h(p)q(olymorphic)
1881 
+h(functions)f(on)f(lists)h(that)e(will)j(b)q(e)f(used)g(later:)71
1882 
+1418 y Fi(head)476 b(::)24 b([a])f(->)h(a)71 1475 y(head)f(\(x:xs\))309
1883 
+b(=)48 b(x)71 1554 y(tail)476 b(::)24 b([a])f(->)h([a])71 1611
1884 
+y(tail)f(\(x:xs\))309 b(=)48 b(xs)71 1770 y Fp(With)10 b(p)q(olymorphic)i(t)o
1885 
+(yp)q(es,)g(w)o(e)e(\014nd)h(that)f(some)g(t)o(yp)q(es)h(are)f(in)h(a)g
1886 
+(sense)g(strictly)g Fo(mor)n(e)h(gener)n(al)d Fp(than)i(others.)0
1887 
+1827 y(F)l(or)18 b(example,)h(the)f(t)o(yp)q(e)h Fi([a])e Fp(is)i(more)f
1888 
+(general)h(than)f Fi([Char])o Fp(.)29 b(In)19 b(other)f(w)o(ords,)f(the)i
1889 
+(latter)f(t)o(yp)q(e)g(can)g(b)q(e)0 1883 y(deriv)o(ed)12 b(from)e(the)h
1890 
+(former)f(b)o(y)h(a)g(suitable)h(substitution)g(for)e Fi(a)p
1891 
+Fp(.)18 b(With)12 b(regard)e(to)g(this)i(generalization)g(ordering,)0
1892 
+1940 y(Hask)o(ell's)21 b(t)o(yp)q(e)g(system)g(p)q(ossesses)g(t)o(w)o(o)e
1893 
+(imp)q(ortan)o(t)h(prop)q(erties:)32 b(First,)22 b(ev)o(ery)e(w)o(ell-t)o(yp)
1894 
+q(ed)j(expression)e(is)0 1996 y(guaran)o(teed)16 b(to)f(ha)o(v)o(e)h(a)g
1895 
+(unique)i Fo(princip)n(al)d Fp(t)o(yp)q(e)i(\(explained)g(b)q(elo)o(w\),)g
1896 
+(and)f(second,)h(the)f(principal)j(t)o(yp)q(e)d(can)0 2053
1897 
+y(b)q(e)k Fo(inferr)n(e)n(d)f Fp(automatically)h(\()p Fn(x)o
1898 
+Fp(4.1.3\).)31 b(In)20 b(comparison)g(to)f(a)g Fo(monomorphic)n(al)r(ly)i
1899 
+(typ)n(e)n(d)e Fp(language)h(suc)o(h)f(as)0 2109 y(P)o(ascal,)c(the)h(reader)
1900 
+g(will)i(\014nd)e(that)f Fo(p)n(olymorphism)i Fp(impro)o(v)o(es)e(expressiv)o
1901 
+(eness,)i(and)f Fo(typ)n(e)h(infer)n(enc)n(e)d Fp(lessens)0
1902 
+2166 y(the)h(burden)h(of)f(t)o(yp)q(es)g(on)h(the)f(programmer.)71
1903 
+2248 y(An)f(expression's)h(or)e(function's)i(principal)h(t)o(yp)q(e)f(is)f
1904 
+(the)g(least)h(general)f(t)o(yp)q(e)h(that,)e(in)o(tuitiv)o(ely)l(,)j(\\con)o
1905 
+(tains)0 2304 y(all)22 b(instances)f(of)f(the)h(expression.")37
1906 
+b(F)l(or)20 b(example,)j(the)e(principal)i(t)o(yp)q(e)d(of)h
1907 
+Fi(head)f Fp(is)h Fi([a]->a)o Fp(;)i(the)e(t)o(yp)q(es)0 2361
1908 
+y Fi([b]->a)o Fp(,)15 b Fi(a->a)o Fp(,)f(or)g(ev)o(en)39 b
1909 
+Fi(a)g Fp(are)14 b Fo(to)n(o)i(gener)n(al)p Fp(,)d(whereas)i(something)g(lik)
1910 
+o(e)g Fi([Int]->Int)f Fp(is)h Fo(to)n(o)h(sp)n(e)n(ci\014c)p
1911 
+Fp(.)i(The)0 2417 y(existence)c(of)e(unique)h(principal)i(t)o(yp)q(es)d(is)h
1912 
+(the)g(hallmark)g(feature)f(of)g(the)g Fo(Hind)r(ley-Milner)h(typ)n(e)g
1913 
+(system)p Fp(,)f(whic)o(h)0 2473 y(forms)g(the)g(basis)h(of)f(the)h(t)o(yp)q
1914 
+(e)f(systems)g(of)g(Hask)o(ell,)h(ML,)g(Miranda,)1191 2457
1915 
+y Fm(4)1223 2473 y Fp(and)g(sev)o(eral)f(other)g(\(mostly)g(functional\))0
1916 
+2530 y(languages.)p 0 2571 780 2 v 52 2598 a Fl(4)69 2614 y
1917 
+Fk(\\Miranda")j(is)f(a)f(trademark)h(of)e(Researc)o(h)i(Soft)o(w)o(are,)f
1918 
+(Ltd.)p eop
1919 
+%%Page: 5 5
1920 
+bop 0 -40 a Fj(2.2)45 b(User-De\014ned)16 b(T)o(yp)q(es)1384
1921 
+b Fp(T-5)0 105 y Fg(2.2)56 b(User-De\014ned)17 b(T)n(yp)r(es)0
1922 
+217 y Fp(W)l(e)f(can)h(de\014ne)g(our)f(o)o(wn)f(t)o(yp)q(es)i(in)g(Hask)o
1923 
+(ell)g(using)g(a)f Fi(data)f Fp(declaration,)i(whic)o(h)g(w)o(e)f(in)o(tro)q
1924 
+(duce)h(via)f(a)g(series)0 273 y(of)f(examples)h(\()p Fn(x)p
1925 
+Fp(4.2.1\).)71 355 y(An)f(imp)q(ortan)o(t)g(prede\014ned)i(t)o(yp)q(e)e(in)h
1926 
+(Hask)o(ell)g(is)g(that)e(of)h(truth)g(v)m(alues:)71 464 y
1927 
+Fi(data)23 b(Bool)357 b(=)24 b(False)f(|)h(True)0 573 y Fp(The)17
1928 
+b(t)o(yp)q(e)h(b)q(eing)g(de\014ned)h(here)e(is)h Fi(Bool)o
1929 
+Fp(,)g(and)f(it)g(has)g(exactly)h(t)o(w)o(o)e(v)m(alues:)25
1930 
+b Fi(True)16 b Fp(and)i Fi(False)o Fp(.)26 b Fi(Bool)16 b Fp(is)i(an)0
1931 
+630 y(example)g(of)e(a)h(\(n)o(ullary\))g Fo(typ)n(e)h(c)n(onstructor)p
1932 
+Fp(,)f(and)h Fi(True)e Fp(and)h Fi(False)g Fp(are)f(\(also)h(n)o(ullary\))h
1933 
+Fo(data)g(c)n(onstructors)0 686 y Fp(\(or)c(just)h Fo(c)n(onstructors)p
1934 
+Fp(,)g(for)f(short\).)71 768 y(Similarly)l(,)j(w)o(e)e(migh)o(t)g(wish)g(to)g
1935 
+(de\014ne)h(a)f(color)g(t)o(yp)q(e:)71 877 y Fi(data)23 b(Color)333
1936 
+b(=)24 b(Red)f(|)h(Green)f(|)h(Blue)f(|)h(Indigo)f(|)h(Violet)0
1937 
+986 y Fp(Both)18 b Fi(Bool)f Fp(and)h Fi(Color)f Fp(are)g(examples)i(of)e
1938 
+Fo(enumer)n(ate)n(d)h(typ)n(es)p Fp(,)g(since)h(they)f(consist)g(of)f(a)h
1939 
+(\014nite)g(n)o(um)o(b)q(er)g(of)0 1043 y(n)o(ullary)e(data)f(constructors.)
1940 
+71 1125 y(Here)g(is)h(an)f(example)h(of)f(a)g(t)o(yp)q(e)g(with)g(just)g(one)
1941 
+h(data)e(constructor:)71 1234 y Fi(data)23 b(Point)g(a)286
1942 
+b(=)24 b(Pt)g(a)f(a)0 1343 y Fp(Because)13 b(of)g(the)g(single)h
1943 
+(constructor,)e(a)g(t)o(yp)q(e)h(lik)o(e)h Fi(Point)e Fp(is)i(often)e(called)
1944 
+j(a)d Fo(tuple)i(typ)n(e)p Fp(,)f(since)h(it)f(is)g(essen)o(tially)0
1945 
+1399 y(just)h(a)h(cartesian)f(pro)q(duct)h(\(in)g(this)g(case)g(binary\))g
1946 
+(of)f(other)g(t)o(yp)q(es.)1189 1383 y Fm(5)1228 1399 y Fp(In)i(con)o(trast,)
1947 
+d(m)o(ulti-constructor)h(t)o(yp)q(es,)0 1456 y(suc)o(h)i(as)e
1948 
+Fi(Bool)h Fp(and)g Fi(Color)p Fp(,)f(are)h(called)i(\(disjoin)o(t\))e
1949 
+Fo(union)g Fp(t)o(yp)q(es.)71 1538 y(More)c(imp)q(ortan)o(tly)l(,)h(ho)o(w)o
1950 
+(ev)o(er,)f Fi(Point)g Fp(is)i(an)e(example)i(of)e(a)h Fo(p)n(olymorphic)g
1951 
+Fp(t)o(yp)q(e:)18 b(for)11 b(an)o(y)h(t)o(yp)q(e)f Fh(t)p Fp(,)i(it)f
1952 
+(de\014nes)0 1594 y(the)17 b(t)o(yp)q(e)h(of)f(cartesian)g(p)q(oin)o(ts)h
1953 
+(that)f(use)g Fh(t)h Fp(as)f(the)h(co)q(ordinate)f(t)o(yp)q(e.)27
1954 
+b Fi(Point)17 b Fp(can)g(no)o(w)g(b)q(e)h(seen)g(clearly)g(as)0
1955 
+1651 y(a)g(unary)g(t)o(yp)q(e)g(constructor,)f(since)j(from)d(the)h(t)o(yp)q
1956 
+(e)g Fh(t)h Fp(it)f(constructs)g(a)f(new)i(t)o(yp)q(e)f Fi(Point)23
1957 
+b Fh(t)p Fp(.)29 b(\(In)18 b(the)g(same)0 1707 y(sense,)e(using)h(the)f(list)
1958 
+h(example)g(giv)o(en)g(earlier,)g Fi([)p 884 1707 14 2 v 16
1959 
+w(])f Fp(is)h(also)f(a)f(t)o(yp)q(e)i(constructor)e(\(where)h(w)o(e)g(ha)o(v)
1960 
+o(e)f(used)i(\\)p 1914 1707 V 16 w(")0 1764 y(to)g(denote)i(the)f(missing)h
1961 
+(argumen)o(t\):)24 b(giv)o(en)19 b(an)o(y)f(t)o(yp)q(e)g Fh(t)g
1962 
+Fp(w)o(e)g(can)g(\\apply")h Fi([)p 1404 1764 V 16 w(])f Fp(to)f(yield)j(a)e
1963 
+(new)g(t)o(yp)q(e)g Fi([)p Fh(t)p Fi(])p Fp(.)0 1820 y(Similarly)l(,)p
1964 
+203 1820 V 32 w Fi(->)p 267 1820 V 28 w Fp(is)c(a)e(t)o(yp)q(e)h
1965 
+(constructor:)18 b(giv)o(en)13 b(t)o(w)o(o)f(t)o(yp)q(es)g
1966 
+Fh(t)i Fp(and)f Fh(u)p Fp(,)f Fh(t)p Fi(->)q Fh(u)g Fp(is)i(the)f(t)o(yp)q(e)
1967 
+f(of)h(functions)g(mapping)0 1876 y(elemen)o(ts)j(of)f(t)o(yp)q(e)g
1968 
+Fh(t)g Fp(to)g(elemen)o(ts)h(of)f(t)o(yp)q(e)g Fh(u)p Fp(.\))71
1969 
+1958 y(Note)f(that)g(the)g(t)o(yp)q(e)h(of)f(the)h(binary)g(constructor)f
1970 
+Fi(Pt)g Fp(is)h Fi(a)24 b(->)g(a)f(->)h(Point)f(a)p Fp(,)14
1971 
+b(and)h(th)o(us)g(the)f(follo)o(wing)0 2015 y(t)o(ypings)h(are)g(v)m(alid:)71
1972 
+2124 y Fi(Pt)47 b(2.0)g(3.0)286 b(::)24 b(Point)f(Float)71
1973 
+2180 y(Pt)47 b('a')g('b')286 b(::)24 b(Point)f(Char)71 2237
1974 
+y(Pt)g(True)g(False)262 b(::)24 b(Point)f(Bool)0 2346 y Fp(On)16
1975 
+b(the)f(other)g(hand,)g(an)g(expression)h(suc)o(h)g(as)f Fi(Pt)23
1976 
+b('a')h(1)15 b Fp(is)g(ill-t)o(yp)q(ed.)71 2428 y(It)h(is)h(imp)q(ortan)o(t)f
1977 
+(to)g(distinguish)i(b)q(et)o(w)o(een)f(applying)g(a)f Fo(c)n(onstructor)h
1978 
+Fp(to)f(yield)i(a)e Fo(value)p Fp(,)g(and)g(applying)i(a)0
1979 
+2484 y Fo(typ)n(e)i(c)n(onstructor)e Fp(to)h(yield)h(a)f Fo(typ)n(e)p
1980 
+Fp(;)h(the)f(former)f(happ)q(ens)i(at)e(run-time)i(and)f(is)h(ho)o(w)e(w)o(e)
1981 
+h(compute)g(things)p 0 2525 780 2 v 52 2552 a Fl(5)69 2568
1982 
+y Fk(T)m(uples)13 b(are)g(somewhat)g(lik)o(e)h Fe(r)n(e)n(c)n(or)n(ds)d
1983 
+Fk(in)i(other)g(languages,)h(except)f(that)g(the)g(elemen)o(ts)g(are)g(p)q
1984 
+(ositional,)i(rather)e(than)g(ha)o(ving)0 2614 y(names)h(\(lab)q(els\))g
1985 
+(asso)q(ciated)h(with)f(them.)p eop
1986 
+%%Page: 6 6
1987 
+bop 0 -40 a Fp(T-6)906 b Fj(2)45 b(V)-5 b(ALUES,)16 b(TYPES,)e(AND)h(OTHER)h
1988 
+(GOODIES)0 105 y Fp(in)g(Hask)o(ell,)h(whereas)e(the)h(latter)f(happ)q(ens)i
1989 
+(at)e(compile-time)i(and)f(is)g(part)f(of)g(the)h(t)o(yp)q(e)g(system's)f
1990 
+(pro)q(cess)g(of)0 162 y(ensuring)h(t)o(yp)q(e)f(safet)o(y)l(.)0
1991 
+298 y Fg(2.3)56 b(Recursiv)n(e)17 b(T)n(yp)r(es)0 402 y Fp(T)o(yp)q(es)e(can)
1992 
+h(also)f(b)q(e)h(recursiv)o(e,)f(as)g(in:)71 511 y Fi(data)23
1993 
+b(Tree)g(a)310 b(=)24 b(Leaf)f(a)h(|)g(Branch)f(\(Tree)g(a\))h(\(Tree)f(a\))0
1994 
+620 y Fp(Here)11 b(w)o(e)g(ha)o(v)o(e)f(de\014ned)i(a)f(p)q(olymorphic)h
1995 
+(binary)g(tree)e(t)o(yp)q(e)h(whose)g(elemen)o(ts)g(are)g(either)h(leaf)f(no)
1996 
+q(des)g(con)o(taining)0 677 y(a)k(v)m(alue)h(of)f(t)o(yp)q(e)g
1997 
+Fi(a)p Fp(,)g(or)g(in)o(ternal)h(no)q(des)g(\(\\branc)o(hes"\))e(con)o
1998 
+(taining)i(\(recursiv)o(ely\))g(t)o(w)o(o)e(sub-trees.)71 751
1999 
+y(When)e(reading)g(data)f(declarations)h(suc)o(h)g(as)f(this,)i(remem)o(b)q
2000 
+(er)f(that)f Fi(Tree)g Fp(is)h(a)f(t)o(yp)q(e)h(constructor,)f(whereas)0
2001 
+808 y Fi(Branch)k Fp(and)i Fi(Leaf)f Fp(are)g(data)f(constructors.)22
2002 
+b(Aside)c(from)d(establishing)j(a)e(connection)i(b)q(et)o(w)o(een)e(these)h
2003 
+(con-)0 864 y(structors,)d(the)h(ab)q(o)o(v)o(e)g(declaration)h(is)g(essen)o
2004 
+(tially)g(de\014ning)h(the)e(follo)o(wing)h(t)o(yp)q(es)f(for)g
2005 
+Fi(Branch)f Fp(and)i Fi(Leaf)o Fp(:)71 973 y Fi(Branch)428
2006 
+b(::)24 b(Tree)f(a)h(->)g(Tree)f(a)h(->)f(Tree)g(a)71 1030
2007 
+y(Leaf)476 b(::)24 b(a)g(->)f(Tree)h(a)71 1182 y Fp(With)18
2008 
+b(this)h(example)g(w)o(e)f(ha)o(v)o(e)f(de\014ned)j(a)e(t)o(yp)q(e)g
2009 
+(su\016cien)o(tly)i(ric)o(h)f(to)e(allo)o(w)i(de\014ning)g(some)f(in)o
2010 
+(teresting)0 1238 y(\(recursiv)o(e\))f(functions)h(that)e(use)h(it.)26
2011 
+b(F)l(or)16 b(example,)i(supp)q(ose)g(w)o(e)e(wish)i(to)e(de\014ne)i(a)f
2012 
+(function)h Fi(fringe)e Fp(that)0 1295 y(returns)c(a)h(list)g(of)f(all)h(the)
2013 
+g(elemen)o(ts)g(in)g(the)g(lea)o(v)o(es)g(of)f(a)g(tree)g(from)g(left)h(to)f
2014 
+(righ)o(t.)18 b(It's)13 b(usually)g(helpful)i(to)d(write)0
2015 
+1351 y(do)o(wn)k(the)g(t)o(yp)q(e)g(of)g(new)g(functions)h(\014rst;)f(in)h
2016 
+(this)f(case)g(w)o(e)g(see)h(that)e(the)h(t)o(yp)q(e)g(should)h(b)q(e)g
2017 
+Fi(Tree)23 b(a)h(->)g([a])o Fp(.)0 1408 y(That)16 b(is,)h Fi(fringe)e
2018 
+Fp(is)i(a)f(p)q(olymorphic)i(function)f(that,)f(for)g(an)o(y)g(t)o(yp)q(e)g
2019 
+Fi(a)p Fp(,)h(maps)f(trees)g(of)g Fi(a)g Fp(in)o(to)g(lists)i(of)e
2020 
+Fi(a)o Fp(.)24 b(A)0 1464 y(suitable)16 b(de\014nition)h(follo)o(ws:)71
2021 
+1564 y Fi(fringe)23 b(::)g(Tree)h(a)f(->)h([a])71 1621 y(fringe)f(\(Leaf)g
2022 
+(x\))286 b(=)24 b([x])71 1677 y(fringe)f(\(Branch)g(left)g(right\))g(=)h
2023 
+(fringe)f(left)g(++)h(fringe)f(right)0 1789 y Fp(Where)13 b
2024 
+Fi(++)f Fp(is)i(the)f(in\014x)h(op)q(erator)e(that)g(concatenates)g(t)o(w)o
2025 
+(o)g(lists)h(\(its)g(full)h(de\014nition)h(will)g(b)q(e)e(giv)o(en)g(in)h
2026 
+(Section)0 1845 y(3.2\).)20 b(As)15 b(with)h(the)g Fi(length)e
2027 
+Fp(example)j(giv)o(en)f(earlier,)g Fi(fringe)f Fp(is)h(de\014ned)h(using)f
2028 
+(pattern)f(matc)o(hing,)g(except)0 1902 y(that)j(here)g(w)o(e)g(see)h
2029 
+(patterns)f(in)o(v)o(olving)i(user-de\014ned)g(constructors:)25
2030 
+b Fi(Leaf)18 b Fp(and)g Fi(Branch)o Fp(.)30 b([Note)17 b(that)h(the)0
2031 
+1958 y(formal)d(parameters)f(are)h(easily)h(iden)o(ti\014ed)i(as)c(the)i
2032 
+(ones)f(b)q(eginning)i(with)f(lo)o(w)o(er-case)f(letters.])0
2033 
+2095 y Fg(2.4)56 b(T)n(yp)r(e)18 b(Synon)n(yms)0 2199 y Fp(F)l(or)g(con)o(v)o
2034 
+(enience,)i(Hask)o(ell)g(pro)o(vides)e(a)h(w)o(a)o(y)e(to)h(de\014ne)h
2035 
+Fo(typ)n(e)h(synonyms)p Fp(;)e(i.e.)g(names)h(for)f(commonly)g(used)0
2036 
+2255 y(t)o(yp)q(es.)i(T)o(yp)q(e)15 b(synon)o(yms)g(are)g(created)g(using)h
2037 
+(a)f Fi(type)g Fp(declaration)h(\()p Fn(x)p Fp(4.2.2\).)h(Here)f(are)f(sev)o
2038 
+(eral)g(examples:)71 2367 y Fi(type)23 b(String)309 b(=)24
2039 
+b([Char])71 2423 y(type)f(Person)309 b(=)24 b(\(Name,Address\))71
2040 
+2480 y(type)f(Name)357 b(=)24 b(String)71 2536 y(data)f(Address)285
2041 
+b(=)24 b(None)f(|)h(Addr)f(String)p eop
2042 
+%%Page: 7 7
2043 
+bop 0 -40 a Fj(2.5)45 b(Built-in)17 b(T)o(yp)q(es)e(Are)h(Not)e(Sp)q(ecial)
2044 
+1157 b Fp(T-7)71 105 y(T)o(yp)q(e)18 b(synon)o(yms)g(do)g(not)g(de\014ne)i
2045 
+(new)f(t)o(yp)q(es,)f(but)h(simply)h(giv)o(e)e(new)h(names)f(for)g(existing)h
2046 
+(t)o(yp)q(es.)30 b(F)l(or)0 162 y(example,)15 b(the)g(t)o(yp)q(e)f
2047 
+Fi(Person)23 b(->)h(Name)14 b Fp(is)h(precisely)h(equiv)m(alen)o(t)h(to)d
2048 
+Fi(\(String,Address\))21 b(->)j(String)o Fp(.)c(The)0 218 y(new)f(names)f
2049 
+(are)g(often)g(shorter)g(than)g(the)h(t)o(yp)q(es)f(they)g(are)h(synon)o
2050 
+(ymous)f(with,)h(but)f(this)h(is)g(not)f(the)g(only)0 274 y(purp)q(ose)13
2051 
+b(of)e(t)o(yp)q(e)h(synon)o(yms:)18 b(they)12 b(can)g(also)g(impro)o(v)o(e)g
2052 
+(readabilit)o(y)h(of)e(programs)g(b)o(y)h(b)q(eing)h(more)e(mnemonic;)0
2053 
+331 y(indeed,)17 b(the)e(ab)q(o)o(v)o(e)g(examples)h(highligh)o(t)g(this.)21
2054 
+b(W)l(e)15 b(can)g(ev)o(en)h(giv)o(e)f(new)h(names)f(to)f(p)q(olymorphic)j(t)
2055 
+o(yp)q(es:)71 440 y Fi(type)23 b(AssocList)g(a)g(b)334 b(=)24
2056 
+b([\(a,b\)])0 549 y Fp(This)16 b(is)f(the)h(t)o(yp)q(e)f(of)g(\\asso)q
2057 
+(ciation)g(lists")h(whic)o(h)g(asso)q(ciate)f(v)m(alues)h(of)f(t)o(yp)q(e)g
2058 
+Fi(a)g Fp(with)h(those)f(of)g(t)o(yp)q(e)g Fi(b)p Fp(.)0 723
2059 
+y Fg(2.5)56 b(Built-in)17 b(T)n(yp)r(es)h(Are)g(Not)g(Sp)r(ecial)0
2060 
+845 y Fp(Earlier)12 b(w)o(e)e(in)o(tro)q(duced)j(sev)o(eral)e(\\built-in")i
2061 
+(t)o(yp)q(es)d(suc)o(h)i(as)e(lists,)j(tuples,)f(in)o(tegers,)f(and)h(c)o
2062 
+(haracters.)17 b(W)l(e)11 b(ha)o(v)o(e)0 902 y(also)k(sho)o(wn)g(ho)o(w)g
2063 
+(new)g(user-de\014ned)i(t)o(yp)q(es)f(can)f(b)q(e)h(de\014ned.)21
2064 
+b(Aside)c(from)d(sp)q(ecial)j(syn)o(tax,)d(are)h(the)h(built-in)0
2065 
+958 y(t)o(yp)q(es)e(in)h(an)o(y)f(w)o(a)o(y)f(more)h(sp)q(ecial)i(than)e(the)
2066 
+g(user-de\014ned)i(ones?)k(The)14 b(answ)o(er)g(is)h Fo(no)p
2067 
+Fp(.)k(The)14 b(sp)q(ecial)i(syn)o(tax)d(is)0 1015 y(for)i(con)o(v)o(enience)
2068 
+h(and)g(for)e(consistency)i(with)g(historical)g(con)o(v)o(en)o(tion,)f(but)h
2069 
+(has)f(no)g(seman)o(tic)g(consequence.)71 1104 y(W)l(e)d(can)h(emphasize)h
2070 
+(this)f(p)q(oin)o(t)g(b)o(y)f(considering)i(what)e(the)h(t)o(yp)q(e)f
2071 
+(declarations)h(w)o(ould)g(lo)q(ok)g(lik)o(e)h(for)e(these)0
2072 
+1161 y(built-in)19 b(t)o(yp)q(es)e(if)g(in)h(fact)e(w)o(e)g(w)o(ere)h(allo)o
2073 
+(w)o(ed)g(to)f(use)h(the)g(sp)q(ecial)h(syn)o(tax)e(in)i(de\014ning)g(them.)
2074 
+24 b(F)l(or)16 b(example,)0 1217 y(the)f Fi(Char)g Fp(t)o(yp)q(e)g(migh)o(t)g
2075 
+(b)q(e)h(written)f(as:)71 1326 y Fi(data)23 b(Char)166 b(=)24
2076 
+b('a')g(|)f('b')h(|)f('c')h(|)g(...)214 b(--)24 b(This)f(is)h(not)f(valid)452
2077 
+1382 y(|)h('A')g(|)f('B')h(|)f('C')h(|)g(...)214 b(--)24 b(Haskell)f(code!)
2078 
+452 1439 y(|)h('1')g(|)f('2')h(|)f('3')h(|)g(...)452 1495 y(...)0
2079 
+1604 y Fp(These)14 b(constructor)f(names)h(are)g(not)f(syn)o(tactically)i(v)m
2080 
+(alid;)h(to)d(\014x)h(them)g(w)o(e)g(w)o(ould)g(ha)o(v)o(e)f(to)h(write)g
2081 
+(something)0 1661 y(lik)o(e:)71 1761 y Fi(data)23 b(Char)166
2082 
+b(=)24 b(Ca)g(|)f(Cb)h(|)g(Cc)f(|)h(...)452 1818 y(|)g(CA)g(|)f(CB)h(|)g(CC)f
2083 
+(|)h(...)452 1874 y(|)g(C1)g(|)f(C2)h(|)g(C3)f(|)h(...)452
2084 
+1930 y(...)0 2040 y Fp(Ev)o(en)18 b(though)g(these)g(constructors)f(are)g
2085 
+(more)h(concise,)h(they)f(are)g(quite)g(uncon)o(v)o(en)o(tional)h(for)e
2086 
+(represen)o(ting)0 2096 y(c)o(haracters.)71 2185 y(In)k(an)o(y)g(case,)h
2087 
+(writing)g(\\pseudo-Hask)o(ell")g(co)q(de)g(in)g(this)g(w)o(a)o(y)e(helps)i
2088 
+(us)f(to)g(see)g(through)g(the)g(sp)q(ecial)0 2242 y(syn)o(tax.)h(W)l(e)16
2089 
+b(see)g(no)o(w)g(that)f Fi(Char)h Fp(is)g(just)g(an)g(en)o(umerated)g(t)o(yp)
2090 
+q(e)g(consisting)h(of)f(a)g(large)g(n)o(um)o(b)q(er)g(of)g(n)o(ullary)0
2091 
+2298 y(constructors.)j(Thinking)d(of)e Fi(Char)g Fp(in)i(this)f(w)o(a)o(y)e
2092 
+(mak)o(es)h(it)h(clear)g(wh)o(y)l(,)g(for)f(example,)h(w)o(e)f(can)h
2093 
+(pattern-matc)o(h)0 2355 y(against)j(c)o(haracters)g(in)i(function)f
2094 
+(de\014nitions;)j(i.e.,)e(w)o(e)e(w)o(ould)h(exp)q(ect)h(to)e(b)q(e)h(able)g
2095 
+(to)g(do)f(so)h(for)f(an)o(y)g(of)g(a)0 2411 y(t)o(yp)q(e's)d(constructors.)
2096 
+71 2501 y([This)20 b(example)i(also)e(demonstrates)g(the)h(use)g(of)f
2097 
+Fo(c)n(omments)f Fp(in)j(Hask)o(ell;)i(the)c(c)o(haracters)g
2098 
+Fi(--)g Fp(and)h(all)0 2557 y(subsequen)o(t)f(c)o(haracters)e(to)g(the)h(end)
2099 
+g(of)g(the)g(line)h(are)f(ignored.)32 b(Hask)o(ell)19 b(also)g(p)q(ermits)h
2100 
+Fo(neste)n(d)e Fp(commen)o(ts)0 2614 y(whic)o(h)e(ha)o(v)o(e)f(the)g(form)g
2101 
+Fi({-)o Fh(:)8 b(:)g(:)n Fi(-})15 b Fp(and)h(can)f(app)q(ear)g(an)o(ywhere)g
2102 
+(\()p Fn(x)p Fp(2.2\).])p eop
2103 
+%%Page: 8 8
2104 
+bop 0 -40 a Fp(T-8)906 b Fj(2)45 b(V)-5 b(ALUES,)16 b(TYPES,)e(AND)h(OTHER)h
2105 
+(GOODIES)71 105 y Fp(Similarly)l(,)h(w)o(e)e(could)h(de\014ne)g
2106 
+Fi(Int)f Fp(and)g Fi(Integer)f Fp(b)o(y:)71 215 y Fi(data)23
2107 
+b(Int)119 b(=)24 b(-65532)f(|)g(...)h(|)f(-1)h(|)g(0)g(|)f(1)h(|)g(...)f(|)h
2108 
+(65532)47 b(--)24 b(more)f(pseudo-code)71 272 y(data)g(Integer)g(=)167
2109 
+b(...)23 b(-2)h(|)f(-1)h(|)g(0)g(|)f(1)h(|)g(2)f(...)0 381
2110 
+y Fp(where)15 b Fi(-65532)g Fp(and)g Fi(65532)p Fp(,)f(sa)o(y)l(,)h(are)g
2111 
+(the)g(maxim)o(um)g(and)h(minim)o(um)g(\014xed)g(precision)h(in)o(tegers)e
2112 
+(for)g(a)f(giv)o(en)0 437 y(implemen)o(tation.)22 b Fi(Int)15
2113 
+b Fp(is)h(a)f(m)o(uc)o(h)h(larger)f(en)o(umeration)h(than)f
2114 
+Fi(Char)p Fp(,)g(but)h(it's)f(still)i(\014nite!)22 b(In)16
2115 
+b(con)o(trast,)e(the)0 494 y(pseudo-co)q(de)h(for)f Fi(Integer)f
2116 
+Fp(\(the)g(t)o(yp)q(e)h(of)g(arbitrary)f(precision)j(in)o(tegers\))e(is)g(in)
2117 
+o(tended)h(to)f(con)o(v)o(ey)g(an)f Fo(in\014nite)0 550 y Fp(en)o(umeration.)
2118 
+71 671 y(T)l(uples)j(are)f(also)g(easy)g(to)g(de\014ne)h(pla)o(ying)g(this)g
2119 
+(game:)71 780 y Fi(data)23 b(\(a,b\))333 b(=)24 b(\(a,b\))596
2120 
+b(--)24 b(more)f(pseudo-code)71 836 y(data)g(\(a,b,c\))285
2121 
+b(=)24 b(\(a,b,c\))71 893 y(data)f(\(a,b,c,d\))237 b(=)24 b(\(a,b,c,d\))94
2122 
+949 y(.)597 b(.)94 1006 y(.)g(.)94 1062 y(.)g(.)0 1171 y Fp(Eac)o(h)12
2123 
+b(declaration)h(ab)q(o)o(v)o(e)e(de\014nes)j(a)d(tuple)i(t)o(yp)q(e)g(of)e(a)
2124 
+h(particular)h(length,)g(with)f Fi(\(...\))g Fp(pla)o(ying)h(a)e(role)i(in)g
2125 
+(b)q(oth)0 1228 y(the)g(expresssion)g(syn)o(tax)f(\(as)f(data)h
2126 
+(constructor\))g(and)g(t)o(yp)q(e-expression)i(syn)o(tax)e(\(as)f(t)o(yp)q(e)
2127 
+i(constructor\).)18 b(The)0 1284 y(v)o(ertical)11 b(dots)f(after)g(the)g
2128 
+(last)h(declaration)g(are)f(in)o(tended)i(to)e(con)o(v)o(ey)g(an)h
2129 
+(in\014nite)h(n)o(um)o(b)q(er)f(of)f(suc)o(h)h(declarations,)0
2130 
+1341 y(re\015ecting)16 b(the)f(fact)g(that)g(tuples)h(of)e(all)j(lengths)e
2131 
+(are)g(allo)o(w)o(ed)h(in)g(Hask)o(ell.)71 1461 y(Lists)f(are)g(also)g
2132 
+(easily)i(handled,)f(and)f(more)g(in)o(terestingly)l(,)h(they)g(are)f
2133 
+(recursiv)o(e:)94 1570 y Fi(data)24 b([a])357 b(=)24 b([])g(|)f(a)h(:)g([a])
2134 
+429 b(--)24 b(more)f(pseudo-code)0 1679 y Fp(W)l(e)13 b(can)g(no)o(w)g(see)g
2135 
+(clearly)i(what)d(w)o(e)h(describ)q(ed)i(ab)q(out)e(lists)h(earlier:)20
2136 
+b Fi([])12 b Fp(is)i(the)f(empt)o(y)g(list,)h(and)f Fi(:)g
2137 
+Fp(is)h(the)f(in\014x)0 1736 y(list)20 b(constructor;)f(th)o(us)g
2138 
+Fi([1,2,3])f Fp(m)o(ust)g(b)q(e)i(equiv)m(alen)o(t)g(to)e(the)h(list)h
2139 
+Fi(1:2:3:[])o Fp(.)31 b(\()p Fi(:)18 b Fp(is)i(righ)o(t)e(asso)q(ciativ)o
2140 
+(e.\))0 1792 y(The)d(t)o(yp)q(e)h(of)e Fi([])h Fp(is)h Fi([a])p
2141 
+Fp(,)e(and)i(the)f(t)o(yp)q(e)g(of)g Fi(:)g Fp(is)h Fi(a->[a]->[a])n
2142 
+Fp(.)71 1913 y([The)i(w)o(a)o(y)f Fi(:)h Fp(is)h(de\014ned)h(here)f(is)g
2143 
+(actually)g(legal)g(syn)o(tax|in\014x)h(constructors)d(are)h(p)q(ermitted)h
2144 
+(in)h Fi(data)0 1969 y Fp(declarations,)13 b(and)f(are)g(distinguished)j
2145 
+(from)c(in\014x)j(op)q(erators)d(\(for)g(pattern-matc)o(hing)h(purp)q(oses\))
2146 
+g(b)o(y)g(the)h(fact)0 2026 y(that)h(they)i(m)o(ust)e(b)q(egin)j(with)e(a)g
2147 
+Fi(:)g Fp(\(a)g(prop)q(ert)o(y)g(trivially)i(satis\014ed)e(b)o(y)g
2148 
+Fi(:)p Fp(\).])71 2146 y(A)o(t)i(this)i(p)q(oin)o(t)f(the)g(reader)g(should)h
2149 
+(note)f(carefully)h(the)f(di\013erences)i(b)q(et)o(w)o(een)e(tuples)h(and)f
2150 
+(lists,)h(whic)o(h)0 2203 y(the)g(ab)q(o)o(v)o(e)f(de\014nitions)i(mak)o(e)e
2151 
+(abundan)o(tly)h(clear.)31 b(In)19 b(particular,)h(note)e(the)h(recursiv)o(e)
2152 
+g(nature)f(of)h(the)f(list)0 2259 y(t)o(yp)q(e)f(whose)g(elemen)o(ts)h(are)e
2153 
+(homogeneous)h(and)g(of)g(arbitrary)f(length,)i(and)f(the)g(non-recursiv)o(e)
2154 
+h(nature)f(of)f(a)0 2316 y(\(particular\))g(tuple)h(t)o(yp)q(e)f(whose)g
2155 
+(elemen)o(ts)h(are)e(heterogenous)h(and)g(of)g(\014xed)g(length.)23
2156 
+b(The)17 b(t)o(yping)f(rules)h(for)0 2372 y(tuples)f(and)f(lists)h(should)h
2157 
+(no)o(w)d(also)h(b)q(e)h(clear:)71 2493 y(F)l(or)e Fi(\()p
2158 
+Fh(e)197 2500 y Fm(1)216 2493 y Fi(,)p Fh(e)261 2500 y Fm(2)281
2159 
+2493 y Fi(,)8 b Fh(:)g(:)g(:)d Fi(,)p Fh(e)418 2500 y Fd(n)442
2160 
+2493 y Fi(\))p Fh(;)22 b(n)13 b Fn(\025)g Fp(2,)h(if)h Fh(t)696
2161 
+2500 y Fd(i)725 2493 y Fp(is)h(the)e(t)o(yp)q(e)h(of)g Fh(e)1023
2162 
+2500 y Fd(i)1037 2493 y Fp(,)f(then)i(the)e(t)o(yp)q(e)h(of)g(the)g(tuple)g
2163 
+(is)h Fi(\()p Fh(t)1678 2500 y Fm(1)1698 2493 y Fi(,)p Fh(t)1738
2164 
+2500 y Fm(2)1758 2493 y Fi(,)7 b Fh(:)h(:)g(:)e Fi(,)p Fh(t)1890
2165 
+2500 y Fd(n)1914 2493 y Fi(\))o Fp(.)71 2614 y(F)l(or)14 b
2166 
+Fi([)p Fh(e)197 2621 y Fm(1)217 2614 y Fi(,)p Fh(e)262 2621
2167 
+y Fm(2)282 2614 y Fi(,)7 b Fh(:)h(:)g(:)e Fi(,)p Fh(e)419 2621
2168 
+y Fd(n)442 2614 y Fi(])p Fh(;)22 b(n)13 b Fn(\025)g Fp(0,)i(eac)o(h)g
2169 
+Fh(e)763 2621 y Fd(i)792 2614 y Fp(m)o(ust)g(ha)o(v)o(e)g(the)g(same)g(t)o
2170 
+(yp)q(e)g Fh(t)p Fp(,)h(and)f(the)g(t)o(yp)q(e)g(of)g(the)h(list)g(is)f
2171 
+Fi([)p Fh(t)p Fi(])p Fp(.)p eop
2172 
+%%Page: 9 9
2173 
+bop 0 -40 a Fj(2.5)45 b(Built-in)17 b(T)o(yp)q(es)e(Are)h(Not)e(Sp)q(ecial)
2174 
+1157 b Fp(T-9)0 105 y Fc(2.5.1)52 b(List)18 b(Comprehensions)e(and)i
2175 
+(Arithmetic)g(Sequences)0 211 y Fp(As)13 b(with)g(Lisp)h(dialects,)h(lists)e
2176 
+(are)g(p)q(erv)m(asiv)o(e)h(in)g(Hask)o(ell,)g(and)f(as)f(with)i(other)e
2177 
+(functional)i(languages,)f(there)g(is)0 268 y(y)o(et)e(more)g(syn)o(tactic)h
2178 
+(sugar)f(to)f(aid)j(in)f(their)g(creation.)19 b(Aside)12 b(from)f(the)h
2179 
+(constructors)e(for)h(lists)i(just)e(discussed,)0 324 y(Hask)o(ell)16
2180 
+b(pro)o(vides)g(an)f(expression)h(kno)o(wn)f(as)g(a)g Fo(list)g(c)n(ompr)n
2181 
+(ehension)f Fp(that)h(is)g(b)q(est)h(explained)h(b)o(y)e(example:)71
2182 
+433 y Fi([)23 b(f)h(x)g(|)f(x)h(<-)g(xs)f(])0 542 y Fp(This)17
2183 
+b(expression)f(can)h(in)o(tuitiv)o(ely)h(b)q(e)e(read)g(as)g(\\the)g(list)g
2184 
+(of)g(all)h Fi(f)24 b(x)15 b Fp(suc)o(h)i(that)e Fi(x)h Fp(is)g(dra)o(wn)g
2185 
+(from)f Fi(xs)p Fp(.")22 b(The)0 599 y(similarit)o(y)d(to)f(set)g(notation)f
2186 
+(is)i(not)e(a)h(coincidence.)31 b(The)19 b(phrase)f Fi(x<-xs)f
2187 
+Fp(is)i(called)g(a)f Fo(gener)n(ator)p Fp(,)g(of)g(whic)o(h)0
2188 
+655 y(more)d(than)g(one)g(is)h(allo)o(w)o(ed,)f(as)g(in:)71
2189 
+764 y Fi([)23 b(\(x,y\))g(|)h(x<-xs,)f(y<-ys)g(])0 873 y Fp(This)17
2190 
+b(list)f(comprehension)i(forms)d(the)h(cartesian)g(pro)q(duct)g(of)g(the)g(t)
2191 
+o(w)o(o)e(lists)j Fi(xs)f Fp(and)g Fi(ys)o Fp(.)22 b(The)17
2192 
+b(elemen)o(ts)f(are)0 930 y(selected)f(as)f(if)h(the)f(generators)g(w)o(ere)g
2193 
+(\\nested")g(from)f(left)i(to)e(righ)o(t)h(\(with)h(the)f(righ)o(tmost)f
2194 
+(generator)g(v)m(arying)0 986 y(fastest\);)g(th)o(us,)i(if)h
2195 
+Fi(xs)f Fp(is)g Fi([1,2])g Fp(and)g Fi(ys)g Fp(is)h Fi([3,4])o
2196 
+Fp(,)f(the)g(result)h(is)g Fi([\(1,3\),\(1,4\),\(2,3\),\(2,4)o(\)])m
2197 
+Fp(.)71 1063 y(Besides)h(generators,)e(b)q(o)q(olean)i(expressions)g(called)g
2198 
+Fo(guar)n(ds)g Fp(are)e(p)q(ermitted.)24 b(Guards)15 b(place)i(constrain)o
2199 
+(ts)0 1119 y(on)d(the)g(elemen)o(ts)h(generated.)k(F)l(or)13
2200 
+b(example,)i(here)f(is)h(a)f(concise)h(de\014nition)h(of)d(ev)o(eryb)q(o)q
2201 
+(dy's)h(fa)o(v)o(orite)f(sorting)0 1176 y(algorithm:)71 1285
2202 
+y Fi(quicksort)46 b([])262 b(=)48 b([])71 1341 y(quicksort)22
2203 
+b(\(x:xs\))190 b(=)48 b(quicksort)23 b([y)g(|)h(y)g(<-)f(xs,)h(y<x)f(])643
2204 
+1398 y(++)h([x])643 1454 y(++)g(quicksort)f([y)g(|)h(y)g(<-)f(xs,)h(y>=x])71
2205 
+1609 y Fp(T)l(o)16 b(further)h(supp)q(ort)g(the)g(use)g(of)g(lists,)h(Hask)o
2206 
+(ell)f(has)g(sp)q(ecial)i(syn)o(tax)d(for)h Fo(arithmetic)h(se)n(quenc)n(es)p
2207 
+Fp(,)d(whic)o(h)0 1665 y(are)g(b)q(est)g(explained)j(b)o(y)d(a)g(series)g(of)
2208 
+g(examples:)360 1750 y Fi([1..10])133 b Fn(\))88 b Fi([1,2,3,4,5,6,7,8,9,10])
2209 
+360 1806 y([1,3..10])d Fn(\))j Fi([1,3,5,7,9])360 1862 y([1,3..])133
2210 
+b Fn(\))88 b Fi([1,3,5,7,9,)22 b(...)76 b Fp(\(in\014nite)16
2211 
+b(sequence\))0 1947 y(More)f(will)h(b)q(e)g(said)g(ab)q(out)f(arithmetic)h
2212 
+(sequences)g(in)g(Section)g(5.2,)e(and)i(\\in\014nite)g(lists")g(in)g
2213 
+(Section)g(3.4.)0 2085 y Fc(2.5.2)52 b(Strings)0 2192 y Fp(As)15
2214 
+b(another)f(example)h(of)f(syn)o(tactic)h(sugar)f(for)g(built-in)j(t)o(yp)q
2215 
+(es,)d(w)o(e)h(note)f(that)g(the)g(literal)i(string)f Fi("hello")e
2216 
+Fp(is)0 2248 y(actually)h(shorthand)f(for)f(the)h(list)h(of)f(c)o(haracters)f
2217 
+Fi(['h','e','l','l','o'])m Fp(.)19 b(Indeed,)c(the)e(t)o(yp)q(e)g(of)g
2218 
+Fi("hello")0 2305 y Fp(is)j Fi(String)o Fp(,)f(where)g Fi(String)f
2219 
+Fp(is)i(a)f(prede\014ned)i(t)o(yp)q(e)e(synon)o(ym)g(\(that)f(w)o(e)h(ga)o(v)
2220 
+o(e)f(as)h(an)g(earlier)h(example\):)71 2416 y Fi(type)23 b(String)309
2221 
+b(=)24 b([Char])0 2525 y Fp(This)16 b(means)f(w)o(e)g(can)g(use)h
2222 
+(prede\014ned)h(p)q(olymorphic)f(list)g(functions)g(to)f(op)q(erate)g(on)g
2223 
+(strings.)20 b(F)l(or)14 b(example:)497 2614 y Fi("hello")23
2224 
+b(++)h(")f(world")73 b Fn(\))h Fi("hello)23 b(world")p eop
2225 
+%%Page: 10 10
2226 
+bop 0 -40 a Fp(T-10)1513 b Fj(3)45 b(FUNCTIONS)0 105 y Fq(3)69
2227 
+b(F)-6 b(unctions)0 266 y Fp(Since)15 b(Hask)o(ell)g(is)f(a)f(functional)i
2228 
+(language,)f(one)f(w)o(ould)h(exp)q(ect)h(functions)f(to)f(pla)o(y)h(a)f(ma)s
2229 
+(jor)g(role,)g(and)h(indeed)0 323 y(they)h(do.)20 b(In)c(this)g(section,)f(w)
2230 
+o(e)g(lo)q(ok)g(at)g(sev)o(eral)g(asp)q(ects)h(of)e(functions)i(in)g(Hask)o
2231 
+(ell.)71 428 y(First,)e(consider)i(this)g(de\014nition)h(of)e(a)g(function)h
2232 
+(whic)o(h)g(adds)f(its)g(t)o(w)o(o)f(argumen)o(ts:)71 537 y
2233 
+Fi(add)500 b(::)24 b(Int)f(->)h(Int)f(->)h(Int)71 593 y(add)f(x)h(y)405
2234 
+b(=)24 b(x)g(+)f(y)0 709 y Fp(This)18 b(is)g(an)f(example)i(of)e(a)g
2235 
+Fo(currie)n(d)h Fp(function.)826 692 y Fm(6)873 709 y Fp(An)g(application)h
2236 
+(of)e Fi(add)g Fp(has)g(the)h(form)f Fi(add)23 b Fh(e)1720
2237 
+716 y Fm(1)1757 709 y Fh(e)1778 716 y Fm(2)1798 709 y Fp(,)18
2238 
+b(and)f(is)0 765 y(equiv)m(alen)o(t)c(to)d Fi(\(add)24 b Fh(e)404
2239 
+772 y Fm(1)423 765 y Fi(\))g Fh(e)492 772 y Fm(2)512 765 y
2240 
+Fp(,)12 b(since)g(function)g(application)h(asso)q(ciates)e(to)f(the)h
2241 
+Fo(left)p Fp(.)18 b(In)12 b(other)f(w)o(ords,)g(applying)0
2242 
+822 y Fi(add)k Fp(to)g(one)h(argumen)o(t)f(yields)i(a)f(new)g(function)g
2243 
+(whic)o(h)h(is)f(then)g(applied)i(to)d(the)g(second)i(argumen)o(t.)j(This)c
2244 
+(is)0 878 y(consisten)o(t)g(with)h(the)f(t)o(yp)q(e)g(of)f
2245 
+Fi(add)p Fp(,)h Fi(Int->Int->Int)n Fp(,)g(whic)o(h)h(is)f(equiv)m(alen)o(t)i
2246 
+(to)d Fi(Int->\(Int->Int\))n Fp(;)h(i.e.)g Fi(->)0 934 y Fp(asso)q(ciates)f
2247 
+(to)f(the)h Fo(right)p Fp(.)21 b(Indeed,)16 b(using)g Fi(add)o
2248 
+Fp(,)f(w)o(e)g(can)g(de\014ne)h Fi(succ)e Fp(in)i(a)f(di\013eren)o(t)g(w)o(a)
2249 
+o(y)f(from)h(what)f(w)o(e)h(did)0 991 y(earlier:)71 1091 y
2250 
+Fi(succ)476 b(=)24 b(add)f(1)0 1200 y Fp(This)16 b(is)h(an)f(example)g(of)g
2251 
+(the)g Fo(p)n(artial)h(applic)n(ation)f Fp(of)f(a)h(curried)h(function,)f
2252 
+(and)g(is)h(one)f(w)o(a)o(y)e(that)i(a)f(function)0 1257 y(can)20
2253 
+b(b)q(e)h(returned)g(as)f(a)f(v)m(alue.)36 b(Let's)20 b(consider)i(a)d(case)i
2254 
+(in)g(whic)o(h)g(it's)f(useful)h(to)e(pass)h(a)g(function)h(as)f(an)0
2255 
+1313 y(argumen)o(t.)f(The)d(w)o(ell-kno)o(wn)g Fi(map)e Fp(function)i(is)g(a)
2256 
+f(p)q(erfect)h(example:)71 1423 y Fi(map)500 b(::)24 b(\(a->b\))f(->)h([a])f
2257 
+(->)h([b])71 1480 y(map)f(f)48 b([])357 b(=)24 b([])71 1536
2258 
+y(map)f(f)h(\(x:xs\))285 b(=)24 b(f)g(x)f(:)h(map)g(f)f(xs)0
2259 
+1648 y Fp([F)l(unction)16 b(application)h(has)f(higher)g(precedence)i(than)d
2260 
+(an)o(y)h(in\014x)g(op)q(erator,)f(and)h(th)o(us)f(the)h(righ)o(t-hand)g
2261 
+(side)0 1704 y(of)h(the)h(second)g(equation)f(parses)h(as)f
2262 
+Fi(\(f)23 b(x\))h(:)g(\(map)f(f)h(xs\))o Fp(.])52 b Fi(map)17
2263 
+b Fp(is)h(a)f(p)q(olymorphic)i(function,)f(and)g(its)0 1761
2264 
+y(t)o(yp)q(e)j(indicates)h(clearly)g(that)e(its)g(\014rst)h(argumen)o(t)f(is)
2265 
+h(a)f(function;)k(note)c(also)h(that)f(the)h(t)o(w)o(o)e Fi(a)p
2266 
+Fp('s)h(m)o(ust)g(b)q(e)0 1817 y(instan)o(tiated)e(with)h(the)f(same)g(t)o
2267 
+(yp)q(e)g(\(lik)o(ewise)i(for)d(the)i Fi(b)p Fp('s\).)27 b(As)19
2268 
+b(an)f(example)h(of)e(the)i(use)f(of)g Fi(map)o Fp(,)h(w)o(e)f(can)0
2269 
+1874 y(incremen)o(t)e(the)f(elemen)o(ts)h(in)g(a)f(list:)569
2270 
+2011 y Fi(map)23 b(\(add)h(1\))f([1,2,3])72 b Fn(\))i Fi([2,3,4])71
2271 
+2197 y Fp(These)18 b(examples)h(demonstrate)e(the)h(\014rst-class)g(nature)g
2272 
+(of)g(functions,)h(whic)o(h)g(when)f(used)h(in)g(this)f(w)o(a)o(y)0
2273 
+2254 y(are)d(usually)h(called)h Fo(higher-or)n(der)f Fp(functions.)p
2274 
+0 2341 780 2 v 52 2368 a Fl(6)69 2383 y Fk(The)i(name)h Fe(curry)e
2275 
+Fk(deriv)o(es)i(from)f(the)h(p)q(erson)g(who)f(p)q(opularized)j(the)e(idea:)
2276 
+28 b(Hask)o(ell)20 b(Curry)m(.)32 b(T)m(o)18 b(get)g(the)g(e\013ect)h(of)e
2277 
+(an)0 2429 y Fe(uncurrie)n(d)11 b Fk(function,)j(w)o(e)e(could)j(use)e(a)g
2278 
+Fe(tuple)p Fk(,)e(as)i(in:)71 2518 y Ff(add)18 b(\(x,y\))292
2279 
+b(=)20 b(x)f(+)g(y)0 2614 y Fk(But)13 b(then)h(w)o(e)e(see)h(that)h(this)f(v)
2280 
+o(ersion)i(of)e Ff(add)e Fk(is)j(really)h(just)e(a)g(function)h(of)f(one)g
2281 
+(argumen)o(t!)p eop
2282 
+%%Page: 11 11
2283 
+bop 0 -40 a Fj(3.1)45 b(Lam)o(b)q(da)15 b(Abstractions)1324
2284 
+b Fp(T-11)0 105 y Fg(3.1)56 b(Lam)n(b)r(da)17 b(Abstractions)0
2285 
+215 y Fp(Instead)c(of)f(using)i(equations)e(to)g(de\014ne)i(functions,)g(w)o
2286 
+(e)e(can)h(also)f(de\014ne)i(them)f(\\anon)o(ymously")f(via)h(a)f
2287 
+Fo(lamb)n(da)0 271 y(abstr)n(action)p Fp(.)19 b(F)l(or)c(example,)g(a)g
2288 
+(function)h(equiv)m(alen)o(t)g(to)f Fi(succ)f Fp(could)i(b)q(e)g(written)f
2289 
+(as)f Fi(\\x)24 b(->)g(x+1)o Fp(.)c(Similarly)l(,)0 328 y(the)15
2290 
+b(function)h Fi(add)f Fp(is)h(equiv)m(alen)o(t)h(to)e Fi(\\x)23
2291 
+b(->)h(\\y)f(->)h(x+y)p Fp(.)c(Nested)15 b(lam)o(b)q(da)h(abstractions)f(suc)
2292 
+o(h)g(as)g(this)h(ma)o(y)0 384 y(b)q(e)g(written)f(using)h(the)f(equiv)m
2293 
+(alen)o(t)i(shorthand)e(notation)g Fi(\\x)24 b(y)f(->)h(x+y)p
2294 
+Fp(.)19 b(In)d(fact,)e(the)i(equations:)71 494 y Fi(succ)23
2295 
+b(x)429 b(=)24 b(x+1)71 551 y(add)47 b(x)24 b(y)381 b(=)24
2296 
+b(x+y)0 660 y Fp(are)15 b(really)h(shorthand)f(for:)71 769
2297 
+y Fi(succ)476 b(=)24 b(\\x)71 b(->)24 b(x+1)71 825 y(add)500
2298 
+b(=)24 b(\\x)g(y)f(->)h(x+y)0 934 y Fp(W)l(e)15 b(will)i(ha)o(v)o(e)e(more)g
2299 
+(to)f(sa)o(y)h(ab)q(out)g(suc)o(h)g(equiv)m(alences)j(later.)71
2300 
+1015 y(In)d(general,)h(giv)o(en)f(that)g Fi(x)g Fp(has)g(t)o(yp)q(e)g
2301 
+Fh(t)752 1022 y Fm(1)788 1015 y Fp(and)g Fi(exp)g Fp(has)g(t)o(yp)q(e)g
2302 
+Fh(t)1162 1022 y Fm(2)1182 1015 y Fp(,)g(then)g Fi(\\x->exp)g
2303 
+Fp(has)g(t)o(yp)q(e)g Fh(t)1695 1022 y Fm(1)1715 1015 y Fi(->)p
2304 
+Fh(t)1779 1022 y Fm(2)1799 1015 y Fp(.)0 1160 y Fg(3.2)56 b(In\014x)18
2305 
+b(Op)r(erators)0 1270 y Fp(In\014x)c(op)q(erators)d(are)i(really)h(just)e
2306 
+(functions,)i(and)f(can)g(also)f(b)q(e)i(de\014ned)g(using)f(equations.)20
2307 
+b(F)l(or)12 b(example,)i(here)0 1326 y(is)i(the)f(de\014nition)i(of)e(Hask)o
2308 
+(ell's)g(list)h(concatenation)g(op)q(erator:)71 1435 y Fi(\(++\))476
2309 
+b(::)24 b([a])f(->)h([a])f(->)h([a])71 1491 y([])119 b(++)23
2310 
+b(ys)286 b(=)48 b(ys)71 1548 y(\(x:xs\))23 b(++)g(ys)286 b(=)48
2311 
+b(x)24 b(:)f(\(xs++ys\))0 1660 y Fp([Lexically)l(,)17 b(in\014x)f(op)q
2312 
+(erators)d(consist)i(en)o(tirely)h(of)f(\\sym)o(b)q(ols,")f(as)g(opp)q(osed)i
2313 
+(to)e(normal)g(iden)o(ti\014ers)j(whic)o(h)e(are)0 1716 y(alphan)o(umeric)20
2314 
+b(\()p Fn(x)p Fp(2.3\).)30 b(Hask)o(ell)20 b(has)e(no)h(pre\014x)h(op)q
2315 
+(erators,)e(with)h(the)g(exception)h(of)f(min)o(us)g(\()p Fi(-)p
2316 
+Fp(\),)g(whic)o(h)g(is)0 1772 y(b)q(oth)c(in\014x)i(and)e(pre\014x.])71
2317 
+1853 y(As)f(another)h(example,)g(an)f(imp)q(ortan)o(t)h(in\014x)g(op)q
2318 
+(erator)f(on)h(functions)g(is)g(that)f(for)g Fo(function)i(c)n(omp)n(osition)
2319 
+p Fp(:)71 1962 y Fi(\(.\))500 b(::)24 b(\(b->c\))f(->)h(\(a->b\))f(->)g
2320 
+(\(a->c\))71 2018 y(f)g(.)h(g)453 b(=)24 b(\\)g(x)f(->)h(f)g(\(g)f(x\))0
2321 
+2239 y Fc(3.2.1)52 b(Sections)0 2349 y Fp(Since)16 b(in\014x)g(op)q(erators)e
2322 
+(are)h(really)h(just)f(functions,)g(it)g(mak)o(es)f(sense)i(to)e(b)q(e)i
2323 
+(able)f(to)g(partially)h(apply)f(them)g(as)0 2405 y(w)o(ell.)21
2324 
+b(In)16 b(Hask)o(ell)g(the)f(partial)h(application)g(of)f(an)g(in\014x)i(op)q
2325 
+(erator)d(is)i(called)g(a)f Fo(se)n(ction)p Fp(.)k(F)l(or)c(example:)676
2326 
+2500 y Fi(\(x+\))102 b Fn(\021)126 b Fi(\\y)24 b(->)f(x+y)676
2327 
+2557 y(\(+y\))102 b Fn(\021)126 b Fi(\\x)24 b(->)f(x+y)688
2328 
+2613 y(\(+\))114 b Fn(\021)102 b Fi(\\x)24 b(y)g(->)f(x+y)p
2329 
+eop
2330 
+%%Page: 12 12
2331 
+bop 0 -40 a Fp(T-12)1513 b Fj(3)45 b(FUNCTIONS)0 105 y Fp([The)15
2332 
+b(paren)o(theses)g(are)g(mandatory)l(.])71 199 y(The)20 b(last)f(form)g(of)g
2333 
+(section)i(giv)o(en)f(ab)q(o)o(v)o(e)f(essen)o(tially)i(co)q(erces)g(an)e
2334 
+(in\014x)i(op)q(erator)e(in)o(to)h(an)f(equiv)m(alen)o(t)0
2335 
+255 y(functional)h(v)m(alue,)h(and)e(is)g(handy)g(when)h(passing)f(an)g
2336 
+(in\014x)h(op)q(erator)e(as)g(an)h(argumen)o(t)f(to)h(a)f(function,)i(as)0
2337 
+312 y(in)i Fi(map)h(\(+\))g([1,2,3])d Fp(\(the)h(reader)f(should)i(v)o(erify)
2338 
+f(that)f(this)h(returns)f(a)h(list)g(of)g(functions!\).)36
2339 
+b(It)21 b(is)g(also)0 368 y(necessary)15 b(when)g(giving)g(a)g(function)g(t)o
2340 
+(yp)q(e)g(signature,)f(as)h(in)g(the)g(examples)g(of)f Fi(\(++\))g
2341 
+Fp(and)h Fi(\(.\))f Fp(giv)o(en)h(earlier.)71 462 y(W)l(e)20
2342 
+b(can)h(no)o(w)g(see)g(that)f Fi(add)g Fp(de\014ned)i(earlier)g(is)f(just)g
2343 
+Fi(\(+\))p Fp(,)g(and)g Fi(succ)f Fp(is)i(just)e Fi(\(+1\))p
2344 
+Fp(!)36 b(Indeed,)24 b(these)0 518 y(de\014nitions)17 b(w)o(ould)f(do)f(just)
2345 
+g(\014ne:)71 627 y Fi(succ)476 b(=)24 b(\(+1\))71 684 y(add)500
2346 
+b(=)24 b(\(+\))71 855 y Fp(W)l(e)14 b(can)g(co)q(erce)h(an)f(in\014x)h(op)q
2347 
+(erator)e(in)o(to)h(a)g(functional)h(v)m(alue,)g(but)g(can)f(w)o(e)g(go)f
2348 
+(the)h(other)g(w)o(a)o(y?)19 b(Y)l(es|w)o(e)0 912 y(simply)g(enclose)g(an)f
2349 
+(iden)o(ti\014er)h(b)q(ound)g(to)e(a)h(functional)h(v)m(alue)g(in)g(bac)o
2350 
+(kquotes.)27 b(F)l(or)17 b(example,)i Fi(x)24 b(`add`)f(y)0
2351 
+968 y Fp(is)17 b(the)g(same)g(as)f Fi(add)23 b(x)h(y)p Fp(.)480
2352 
+952 y Fm(7)524 968 y Fp(Some)17 b(functions)h(read)e(b)q(etter)h(this)g(w)o
2353 
+(a)o(y)l(.)24 b(An)17 b(example)h(is)f(the)g(prede\014ned)h(list)0
2354 
+1025 y(mem)o(b)q(ership)13 b(predicate)g Fi(elem)p Fp(;)f(the)g(expression)h
2355 
+Fi(x)24 b(`elem`)f(xs)12 b Fp(can)g(b)q(e)h(read)f(in)o(tuitiv)o(ely)i(as)d
2356 
+(\\)p Fi(x)h Fp(is)g(an)g(elemen)o(t)0 1081 y(of)j Fi(xs)o
2357 
+Fp(.")71 1175 y([There)c(are)g(some)g(sp)q(ecial)i(rules)f(regarding)g
2358 
+(sections)g(in)o(v)o(olving)g(the)g(pre\014x/in\014x)g(op)q(erator)f
2359 
+Fi(-)g Fp(\()p Fn(x)p Fp(3.4,)p Fn(x)o Fp(3.3\).])71 1269 y(A)o(t)16
2360 
+b(this)i(p)q(oin)o(t,)g(the)f(reader)g(ma)o(y)g(b)q(e)h(confused)g(at)e(ha)o
2361 
+(ving)i(so)f(man)o(y)g(w)o(a)o(ys)f(to)g(de\014ne)j(a)e(function!)27
2362 
+b(The)0 1325 y(decision)18 b(to)d(pro)o(vide)h(these)g(mec)o(hanisms)g
2363 
+(partly)g(re\015ects)g(historical)h(con)o(v)o(en)o(tions,)e(and)h(partly)g
2364 
+(re\015ects)g(the)0 1382 y(desire)g(for)f(consistency)h(\(for)e(example,)i
2365 
+(in)g(the)f(treatmen)o(t)f(of)h(in\014x)h(vs.)k(regular)15
2366 
+b(functions\).)0 1568 y Fc(3.2.2)52 b(Fixit)o(y)17 b(Declarations)0
2367 
+1697 y Fp(A)f Fo(\014xity)g(de)n(clar)n(ation)f Fp(can)h(b)q(e)h(giv)o(en)f
2368 
+(for)f(an)o(y)g(in\014x)i(op)q(erator)e(or)g(constructor)g(\(including)j
2369 
+(those)e(made)g(from)0 1754 y(ordinary)j(iden)o(ti\014ers,)j(suc)o(h)d(as)g
2370 
+Fi(`elem`)o Fp(\).)754 1737 y Fm(8)805 1754 y Fp(This)h(declaration)g(sp)q
2371 
+(eci\014es)g(a)f(precedence)i(lev)o(el)g(from)d(0)h(to)f(9)0
2372 
+1810 y(\(with)e(9)g(b)q(eing)i(the)e(strongest;)f(normal)i(application)h(is)e
2373 
+(assumed)h(to)e(ha)o(v)o(e)h(a)g(precedence)i(lev)o(el)g(of)e(10\),)f(and)0
2374 
+1867 y(left-,)g(righ)o(t-,)g(or)g(non-asso)q(ciativit)o(y)l(.)21
2375 
+b(F)l(or)14 b(example,)i(the)f(\014xit)o(y)h(declarations)f(for)g
2376 
+Fi(++)g Fp(and)g Fi(.)g Fp(are:)71 1976 y Fi(infixr)23 b(5)g(++)71
2377 
+2032 y(infixr)g(9)g(.)0 2141 y Fp(Both)18 b(of)g(these)g(sp)q(ecify)i(righ)o
2378 
+(t-asso)q(ciativit)o(y)l(,)f(the)g(\014rst)e(with)i(a)f(precedence)i(lev)o
2379 
+(el)g(of)d(5,)i(the)f(other)g(9.)29 b(Left)0 2198 y(asso)q(ciativit)o(y)15
2380 
+b(is)h(sp)q(eci\014ed)g(via)g Fi(infixl)o Fp(,)e(and)h(non-asso)q(ciativit)o
2381 
+(y)h(b)o(y)f Fi(infix)o Fp(.)20 b(Also,)14 b(the)h(\014xit)o(y)g(of)g(more)f
2382 
+(than)0 2254 y(one)h(op)q(erator)f(ma)o(y)g(b)q(e)h(sp)q(eci\014ed)i(with)f
2383 
+(the)e(same)h(\014xit)o(y)g(declaration.)21 b(If)15 b(no)f(\014xit)o(y)h
2384 
+(declaration)h(is)f(giv)o(en)h(for)0 2310 y(a)c(particular)h(op)q(erator,)f
2385 
+(it)h(defaults)g(to)f Fi(infixl)23 b(9)p Fp(.)c(\(See)13 b
2386 
+Fn(x)p Fp(5.7)e(for)h(a)g(detailed)i(de\014nition)h(of)d(the)h(asso)q
2387 
+(ciativit)o(y)0 2367 y(rules.\))p 0 2434 780 2 v 52 2461 a
2388 
+Fl(7)69 2477 y Fk(Note)g(carefully)i(that)e Ff(add)f Fk(is)i(enclosed)h(in)e
2389 
+Fe(b)n(ackquotes)p Fk(,)c(not)14 b Fe(ap)n(ostr)n(ophes)9 b
2390 
+Fk(as)14 b(used)f(in)h(the)g(syn)o(tax)g(of)e(c)o(haracters;)i(i.e.)j
2391 
+Ff('f')12 b Fk(is)0 2522 y(a)g(c)o(haracter,)h(whereas)g Ff(`f`)e
2392 
+Fk(is)i(an)f(in\014x)i(op)q(erator.)k(F)m(ortunately)m(,)13
2393 
+b(most)f(ASCI)q(I)g(terminals)i(distingui)q(sh)h(these)e(m)o(uc)o(h)g(b)q
2394 
+(etter)f(than)0 2568 y(the)h(t)o(yp)q(efon)o(t)h(used)f(in)h(this)g(man)o
2395 
+(uscript.)52 2598 y Fl(8)69 2614 y Fk(Fixit)o(y)f(declarations)i(m)o(ust)c
2396 
+(only)i(app)q(ear)g(at)e(the)h(v)o(ery)g(b)q(eginning)j(of)c(a)g(Hask)o(ell)j
2397 
+Fe(mo)n(dule)p Fk(,)c(as)h(will)i(b)q(e)f(describ)q(ed)i(in)e(Section)h(6.)p
2398 
+eop
2399 
+%%Page: 13 13
2400 
+bop 0 -40 a Fj(3.3)45 b(F)l(unctions)15 b(are)g(Non-strict)1269
2401 
+b Fp(T-13)0 105 y Fg(3.3)56 b(F)-5 b(unctions)19 b(are)f(Non-strict)0
2402 
+215 y Fp(Supp)q(ose)e Fi(bot)f Fp(is)h(de\014ned)g(b)o(y:)71
2403 
+324 y Fi(bot)500 b(=)24 b(bot)0 433 y Fp(In)c(other)e(w)o(ords,)h
2404 
+Fi(bot)g Fp(is)h(a)e(non-terminating)i(expression.)33 b(Abstractly)l(,)20
2405 
+b(w)o(e)e(denote)i(the)f Fo(value)g Fp(of)g(a)g(non-)0 489
2406 
+y(terminating)d(expression)h(as)f Fn(?)g Fp(\(read)g(\\b)q(ottom"\).)21
2407 
+b(Expressions)16 b(that)g(result)g(in)h(some)f(kind)h(of)e(a)h(run-time)0
2408 
+546 y(error,)e(suc)o(h)i(as)e Fi(1/0)p Fp(,)h(also)g(ha)o(v)o(e)g(this)g(v)m
2409 
+(alue.)71 626 y(A)f(function)i Fi(f)e Fp(is)h(said)g(to)f(b)q(e)i
2410 
+Fo(strict)e Fp(if,)h(when)g(applied)h(to)e(a)h(non)o(terminating)g
2411 
+(expression,)g(it)g(also)f(fails)i(to)0 682 y(terminate.)j(In)14
2412 
+b(other)g(w)o(ords,)e Fi(f)i Fp(is)g(strict)f(i\013)h(the)f(v)m(alue)i(of)e
2413 
+Fi(f)24 b(bot)13 b Fp(is)h Fn(?)p Fp(.)20 b(F)l(or)13 b(most)f(programming)h
2414 
+(languages,)0 739 y Fo(al)r(l)k Fp(functions)h(are)e(strict.)25
2415 
+b(But)17 b(this)h(is)f(not)g(so)g(in)g(Hask)o(ell.)27 b(As)17
2416 
+b(a)f(simple)j(example,)f(consider)g Fi(const1)o Fp(,)f(the)0
2417 
+795 y(constan)o(t)d(1)h(function,)h(de\014ned)g(b)o(y:)71 904
2418 
+y Fi(const1)23 b(x)381 b(=)24 b(1)0 1013 y Fp(The)18 b(v)m(alue)h(of)f
2419 
+Fi(const1)23 b(bot)17 b Fp(in)i(Hask)o(ell)f(is)h Fi(1)p Fp(.)27
2420 
+b(Op)q(erationally)20 b(sp)q(eaking,)f(since)g Fi(const1)e
2421 
+Fp(do)q(es)h(not)g(\\need")0 1070 y(the)d(v)m(alue)g(of)f(its)h(argumen)o(t,)
2422 
+f(it)g(nev)o(er)h(attempts)e(to)h(ev)m(aluate)i(it,)e(and)h(th)o(us)f(nev)o
2423 
+(er)h(gets)f(caugh)o(t)g(in)h(a)f(non)o(ter-)0 1126 y(minating)k
2424 
+(computation.)26 b(F)l(or)16 b(this)i(reason,)f(non-strict)h(functions)g(are)
2425 
+e(also)i(called)g(\\lazy)g(functions,")g(and)0 1183 y(are)d(said)h(to)e(ev)m
2426 
+(aluate)i(their)g(argumen)o(ts)e(\\lazily)l(,")i(or)f(\\b)o(y)g(need.")71
2427 
+1263 y(Since)e(error)e(and)h(non)o(terminating)h(v)m(alues)g(are)e(seman)o
2428 
+(tically)j(the)e(same)f(in)i(Hask)o(ell,)g(the)f(ab)q(o)o(v)o(e)g(argumen)o
2429 
+(t)0 1319 y(also)j(holds)h(for)f(errors.)k(F)l(or)14 b(example,)i
2430 
+Fi(const1)23 b(\(1/0\))15 b Fp(also)g(ev)m(aluates)h(prop)q(erly)g(to)e
2431 
+Fi(1)p Fp(.)71 1400 y(Non-strict)h(functions)i(are)f(extremely)g(useful)h(in)
2432 
+g(a)e(v)m(ariet)o(y)h(of)g(con)o(texts.)21 b(The)16 b(main)g(adv)m(an)o(tage)
2433 
+f(is)i(that)0 1456 y(they)d(free)f(the)h(programmer)f(from)f(man)o(y)i
2434 
+(concerns)g(ab)q(out)f(ev)m(aluation)i(order.)k(Computationally)14
2435 
+b(exp)q(ensiv)o(e)0 1513 y(v)m(alues)j(ma)o(y)f(b)q(e)h(passed)g(as)e
2436 
+(argumen)o(ts)h(to)g(functions)h(without)f(fear)g(of)g(them)g(b)q(eing)h
2437 
+(computed)g(if)g(they)f(are)0 1569 y(not)f(needed.)21 b(An)15
2438 
+b(imp)q(ortan)o(t)g(example)h(of)f(this)h(is)f(a)g(p)q(ossibly)i
2439 
+Fo(in\014nite)d Fp(data)g(structure.)0 1714 y Fg(3.4)56 b(\\In\014nite")17
2440 
+b(Data)i(Structures)0 1824 y Fp(One)13 b(adv)m(an)o(tage)f(of)g(the)g
2441 
+(non-strict)h(nature)f(of)g(Hask)o(ell)h(is)g(that)f(data)g(constructors)f
2442 
+(are)h(non-strict,)h(to)q(o.)18 b(This)0 1880 y(should)h(not)e(b)q(e)i
2443 
+(surprising,)g(since)g(constructors)e(are)g(really)i(just)e(a)h(sp)q(ecial)h
2444 
+(kind)g(of)e(function)i(\(the)e(distin-)0 1937 y(guishing)h(feature)e(b)q
2445 
+(eing)i(that)e(they)g(can)h(b)q(e)g(used)g(in)g(pattern)f(matc)o(hing\).)24
2446 
+b(F)l(or)16 b(example,)h(the)g(constructor)0 1993 y(for)e(lists,)g
2447 
+Fi(\(:\))p Fp(,)g(is)g(non-strict.)71 2073 y(Non-strict)g(constructors)f(p)q
2448 
+(ermit)h(the)g(de\014nition)i(of)e(\(conceptually\))h Fo(in\014nite)d
2449 
+Fp(data)i(structures.)k(Here)c(is)0 2130 y(an)g(in\014nite)i(list)f(of)f
2450 
+(ones:)71 2230 y Fi(ones)476 b(=)24 b(1)g(:)f(ones)0 2339 y
2451 
+Fp(P)o(erhaps)15 b(more)g(in)o(teresting)h(is)f(the)h(function)g
2452 
+Fi(numsFrom)o Fp(:)71 2448 y Fi(numsFrom)22 b(n)334 b(=)24
2453 
+b(n)g(:)f(numsFrom)g(\(n+1\))0 2557 y Fp(Th)o(us)10 b Fi(numsFrom)23
2454 
+b(n)11 b Fp(is)g(the)f(in\014nite)j(list)e(of)f(successiv)o(e)i(in)o(tegers)e
2455 
+(b)q(eginning)j(with)e Fi(n)p Fp(.)18 b(F)l(rom)10 b(it)g(w)o(e)h(can)f
2456 
+(construct)0 2614 y(an)15 b(in\014nite)i(list)f(of)f(squares:)p
2457 
+eop
2458 
+%%Page: 14 14
2459 
+bop 0 -40 a Fp(T-14)1513 b Fj(3)45 b(FUNCTIONS)71 160 y Fi(squares)404
2460 
+b(=)24 b(map)f(\(^2\))h(\(numsfrom)e(0\))0 271 y Fp(\(Note)15
2461 
+b(the)g(use)g(of)g(a)g(section;)g Fi(^)g Fp(is)h(the)f(in\014x)i(exp)q(onen)o
2462 
+(tiation)f(op)q(erator.\))71 353 y(Of)c(course,)h(ev)o(en)o(tually)g(w)o(e)f
2463 
+(exp)q(ect)i(to)d(extract)h(some)g(\014nite)i(p)q(ortion)e(of)g(the)h(list)g
2464 
+(for)f(actual)g(computation,)0 409 y(and)17 b(there)f(are)h(lots)f(of)g
2465 
+(prede\014ned)j(functions)e(in)h(Hask)o(ell)f(that)f(do)g(this)i(sort)d(of)h
2466 
+(thing:)24 b Fi(take)o Fp(,)17 b Fi(takeWhile)n Fp(,)0 466
2467 
+y Fi(filter)o Fp(,)g(and)h(others)f(\(see)g(the)g(p)q(ortion)h(of)e(the)i
2468 
+(Standard)f(Prelude)h(called)h Fi(PreludeList)n Fp(\).)26 b(F)l(or)16
2469 
+b(example,)0 522 y Fi(take)f Fp(remo)o(v)o(es)f(the)h(\014rst)g
2470 
+Fi(n)g Fp(elemen)o(ts)h(from)e(a)h(list:)569 625 y Fi(take)23
2471 
+b(5)h(squares)72 b Fn(\))i Fi([0,1,4,9,16])71 753 y Fp(The)14
2472 
+b(de\014nition)i(of)d Fi(ones)g Fp(ab)q(o)o(v)o(e)h(is)h(an)e(example)i(of)f
2473 
+(a)f Fo(cir)n(cular)j(list)p Fp(.)i(In)d(most)e(circumstances)i(this)f(has)g
2474 
+(an)0 809 y(imp)q(ortan)o(t)h(impact)h(on)g(e\016ciency)l(,)h(since)g(an)f
2475 
+(implemen)o(tation)h(can)f(b)q(e)h(exp)q(ected)g(to)e(implemen)o(t)i(the)f
2476 
+(list)g(as)0 866 y(a)f(true)g(circular)h(structure,)f(th)o(us)g(sa)o(ving)g
2477 
+(space.)71 947 y(F)l(or)10 b(another)h(example)i(of)e(the)g(use)h(of)f
2478 
+(circularit)o(y)l(,)i(the)f(Fib)q(onacci)h(sequence)f(can)g(b)q(e)g(computed)
2479 
+g(e\016cien)o(tly)0 1004 y(as)j(the)g(follo)o(wing)h(in\014nite)h(sequence:)
2480 
+71 1113 y Fi(fib)309 b(=)24 b(1)g(:)g(1)f(:)h([)g(a+b)f(|)h(\(a,b\))f(<-)h
2481 
+(zip)f(fib)h(\(tail)f(fib\))g(])0 1222 y Fp(where)e Fi(zip)g
2482 
+Fp(is)g(a)g(Standard)g(Prelude)h(function)g(that)e(returns)h(the)g(pairwise)h
2483 
+(in)o(terlea)o(ving)g(of)e(its)i(t)o(w)o(o)d(list)0 1278 y(argumen)o(ts:)71
2484 
+1387 y Fi(zip)k(\(x:xs\))g(\(y:ys\))166 b(=)24 b(\(x,y\))f(:)h(zip)f(xs)h(ys)
2485 
+71 1444 y(zip)47 b(xs)119 b(ys)238 b(=)24 b([])0 1553 y Fp(Note)16
2486 
+b(ho)o(w)g Fi(fib)o Fp(,)g(an)h(in\014nite)h(list,)f(is)f(de\014ned)i(in)f
2487 
+(terms)f(of)g(itself,)h(as)e(if)i(it)g(w)o(ere)f(\\c)o(hasing)g(its)g(tail.")
2488 
+24 b(Indeed,)0 1609 y(w)o(e)15 b(can)g(dra)o(w)g(a)g(picture)h(of)f(this)g
2489 
+(computation)g(as)g(sho)o(wn)g(in)h(Figure)g(1a.)71 1691 y(F)l(or)e(another)h
2490 
+(application)i(of)e(in\014nite)i(lists,)e(see)h(Section)g(4.4.)0
2491 
+1839 y Fg(3.5)56 b(The)18 b(Error)g(F)-5 b(unction)0 1950 y
2492 
+Fp(Hask)o(ell)20 b(has)f(a)g(built-in)i(function)f(called)h
2493 
+Fi(error)d Fp(whose)h(t)o(yp)q(e)g(is)h Fi(String->a)o Fp(.)31
2494 
+b(This)20 b(is)f(a)g(somewhat)g(o)q(dd)0 2007 y(function:)k(F)l(rom)15
2495 
+b(its)h(t)o(yp)q(e)g(it)h(lo)q(oks)f(as)g(if)h(it)f(is)h(returning)f(a)g(v)m
2496 
+(alue)h(of)f(a)g(p)q(olymorphic)i(t)o(yp)q(e)e(ab)q(out)g(whic)o(h)h(it)0
2497 
+2063 y(kno)o(ws)e(nothing,)g(since)h(it)g(nev)o(er)f(receiv)o(es)h(a)f(v)m
2498 
+(alue)h(of)f(that)g(t)o(yp)q(e)g(as)g(an)g(argumen)o(t!)71
2499 
+2145 y(In)h(fact,)f(there)h Fo(is)g Fp(one)g(v)m(alue)h(\\shared")e(b)o(y)h
2500 
+(all)h(t)o(yp)q(es:)k Fn(?)p Fp(.)h(Indeed,)c(seman)o(tically)f(that)e(is)h
2501 
+(exactly)h(what)0 2201 y(v)m(alue)c(is)g(alw)o(a)o(ys)e(returned)h(b)o(y)g
2502 
+Fi(error)f Fp(\(recall)i(that)e(all)i(errors)e(ha)o(v)o(e)h(v)m(alue)h
2503 
+Fn(?)p Fp(\).)19 b(Ho)o(w)o(ev)o(er,)11 b(w)o(e)h(can)g(exp)q(ect)h(that)0
2504 
+2258 y(a)g(reasonable)g(implemen)o(tation)i(will)g(prin)o(t)e(the)g(string)h
2505 
+(argumen)o(t)e(to)g Fi(error)h Fp(for)f(diagnostic)i(purp)q(oses.)20
2506 
+b(Th)o(us)0 2314 y(this)e(function)g(is)g(useful)g(when)g(w)o(e)f(wish)h(to)f
2507 
+(terminate)g(a)g(program)g(when)h(something)f(has)g(\\gone)g(wrong.")0
2508 
+2371 y(F)l(or)e(example,)g(the)h(actual)f(de\014nition)i(of)e
2509 
+Fi(head)f Fp(tak)o(en)h(from)f(the)i(Standard)f(Prelude)h(is:)71
2510 
+2480 y Fi(head)23 b(\(x:xs\))309 b(=)48 b(x)71 2536 y(head)f([])381
2511 
+b(=)48 b(error)23 b("head{PreludeList}:)e(head)j([]")p eop
2512 
+%%Page: 15 15
2513 
+bop 1857 -40 a Fp(T-15)33 869 y @beginspecial 5.156800 @llx
2514 
+435.382507 @lly 327.294495 @urx 781.187195 @ury 1800 @rwi @setspecial
2515 
+%%BeginDocument: fib.eps
2516 
+/FHIODict 30 dict def
2517 
+FHIODict begin
2518 
+/bdf{bind def}bind def
2519 
+/d{setdash}bdf
2520 
+/h{closepath}bdf
2521 
+/H{}bdf
2522 
+/J{setlinecap}bdf
2523 
+/j{setlinejoin}bdf
2524 
+/M{setmiterlimit}bdf
2525 
+/n{newpath}bdf
2526 
+/N{newpath}bdf
2527 
+/q{gsave}bdf
2528 
+/Q{grestore}bdf
2529 
+/w{setlinewidth}bdf
2530 
+/u{}bdf
2531 
+/U{}bdf
2532 
+/sepdef{
2533 
+dup where not
2534 
+{
2535 
+FreeHandSepDict
2536 
+}
2537 
+if
2538 
+3 1 roll exch put
2539 
+}bdf
2540 
+/`
2541 
+{end %. FreeHandDict
2542 
+/-save0- save def
2543 
+pop pop pop pop pop
2544 
+concat
2545 
+userdict begin
2546 
+/showpage {} def
2547 
+0 setgray 0 setlinecap 1 setlinewidth
2548 
+0 setlinejoin 10 setmiterlimit [] 0 setdash newpath
2549 
+/languagelevel where {pop languagelevel 1 ne{false setstrokeadjust false setoverprint}if}if
2550 
+} bdf
2551 
+/~
2552 
+{end
2553 
+-save0- restore
2554 
+FreeHandDict begin
2555 
+}bdf
2556 
+/FreeHandDict 190 dict def
2557 
+FreeHandDict begin
2558 
+/currentpacking where{pop true setpacking}if
2559 
+/xdf{exch def}bdf
2560 
+/ndf{1 index where{pop pop pop}{dup xcheck{bind}if def}ifelse}bdf
2561 
+/min{2 copy gt{exch}if pop}bdf
2562 
+/max{2 copy lt{exch}if pop}bdf
2563 
+/isLino statusdict /product get (Lino) anchorsearch{pop pop true}{pop false}ifelse def
2564 
+/dr{transform .25 sub round .25 add
2565 
+exch .25 sub round .25 add exch itransform}bdf
2566 
+/C{dr curveto}bdf
2567 
+/L{dr lineto}bdf
2568 
+/m{dr moveto}bdf
2569 
+/printerRes
2570 
+gsave
2571 
+matrix defaultmatrix setmatrix
2572 
+72 72 dtransform
2573 
+abs exch abs
2574 
+max
2575 
+grestore
2576 
+def
2577 
+/maxsteps 256 def
2578 
+/calcgraysteps {
2579 
+currentscreen pop exch
2580 
+printerRes exch div exch
2581 
+2 copy
2582 
+sin mul round dup mul
2583 
+3 1 roll
2584 
+cos mul round dup mul
2585 
+add 1 add
2586 
+dup maxsteps gt {pop maxsteps} if
2587 
+} bdf
2588 
+/bottom -0 def
2589 
+/delta -0 def
2590 
+/frac -0 def
2591 
+/left -0 def
2592 
+/numsteps -0 def
2593 
+/numsteps1 -0 def
2594 
+/radius -0 def
2595 
+/right -0 def
2596 
+/top -0 def
2597 
+/xt -0 def
2598 
+/yt -0 def
2599 
+/df currentflat def
2600 
+/tempstr 1 string def
2601 
+/clipflatness currentflat def
2602 
+/inverted?
2603 
+0 currenttransfer exec .5 ge def
2604 
+/colorexists
2605 
+systemdict/setcmykcolor known def
2606 
+/tc1 [0 0 0 1] def
2607 
+/tc2 [0 0 0 1] def
2608 
+/fc [0 0 0 1] def
2609 
+/sc [0 0 0 1] def
2610 
+/concatprocs{
2611 
+/proc2 exch cvlit def/proc1 exch cvlit def
2612 
+/newproc proc1 length proc2 length add array def
2613 
+newproc 0 proc1 putinterval newproc proc1 length proc2 putinterval
2614 
+newproc cvx}bdf
2615 
+/storerect{/top xdf/right xdf/bottom xdf/left xdf}bdf
2616 
+/rectpath{newpath left bottom m left top L
2617 
+right top L right bottom L closepath}bdf
2618 
+/i{dup 0 eq
2619 
+{pop df dup}
2620 
+{dup} ifelse
2621 
+/clipflatness xdf setflat
2622 
+}bdf
2623 
+version cvr 38.0 le
2624 
+{/setrgbcolor{
2625 
+currenttransfer exec 3 1 roll
2626 
+currenttransfer exec 3 1 roll
2627 
+currenttransfer exec 3 1 roll
2628 
+setrgbcolor}bdf}if
2629 
+/gettint{0 get}bdf
2630 
+/puttint{0 exch put}bdf
2631 
+/vms {/vmsv save def} bdf
2632 
+/vmr {vmsv restore} bdf
2633 
+/vmrs{vmsv restore /vmsv save def}bdf
2634 
+/eomode{
2635 
+{/filler /eofill load def /clipper /eoclip load def}
2636 
+{/filler /fill load def /clipper /clip load def}
2637 
+ifelse
2638 
+}bdf
2639 
+/CD{/NF exch def{exch dup/FID ne 1 index/UniqueID ne and{exch NF 3 1 roll put}
2640 
+{pop pop}ifelse}forall NF}bdf
2641 
+/MN{1 index length/Len exch def
2642 
+dup length Len add string dup
2643 
+Len 4 -1 roll putinterval dup 0 4 -1 roll putinterval}bdf
2644 
+/RC{4 -1 roll /ourvec xdf 256 string cvs(|______)anchorsearch
2645 
+{1 index MN cvn/NewN exch def cvn
2646 
+findfont dup maxlength dict CD dup/FontName NewN put dup
2647 
+/Encoding ourvec put NewN exch definefont pop}{pop}ifelse}bdf
2648 
+/RF{dup FontDirectory exch known{pop 3 -1 roll pop}{RC}ifelse}bdf
2649 
+/FF{dup 256 string cvs(|______)exch MN cvn dup FontDirectory exch known
2650 
+{exch pop findfont 3 -1 roll pop}{pop dup findfont dup maxlength dict CD dup dup
2651 
+/Encoding exch /Encoding get 256 array copy 7 -1 roll {3 -1 roll dup 4 -2 roll put}forall put definefont}ifelse}bdf
2652 
+userdict begin /BDFontDict 20 dict def end
2653 
+BDFontDict begin
2654 
+/bu{}def
2655 
+/bn{}def
2656 
+/setTxMode{av 70 ge{pop}if pop}def
2657 
+/gm{m}def
2658 
+/show{pop}def
2659 
+/gr{pop}def
2660 
+/fnt{pop pop pop}def
2661 
+/fs{pop}def
2662 
+/fz{pop}def
2663 
+/lin{pop pop}def
2664 
+end
2665 
+/MacVec 256 array def
2666 
+MacVec 0 /Helvetica findfont
2667 
+/Encoding get 0 128 getinterval putinterval
2668 
+MacVec 127 /DEL put MacVec 16#27 /quotesingle put MacVec 16#60 /grave put
2669 
+/NUL/SOH/STX/ETX/EOT/ENQ/ACK/BEL/BS/HT/LF/VT/FF/CR/SO/SI
2670 
+/DLE/DC1/DC2/DC3/DC4/NAK/SYN/ETB/CAN/EM/SUB/ESC/FS/GS/RS/US
2671 
+MacVec 0 32 getinterval astore pop
2672 
+/Adieresis/Aring/Ccedilla/Eacute/Ntilde/Odieresis/Udieresis/aacute
2673 
+/agrave/acircumflex/adieresis/atilde/aring/ccedilla/eacute/egrave
2674 
+/ecircumflex/edieresis/iacute/igrave/icircumflex/idieresis/ntilde/oacute
2675 
+/ograve/ocircumflex/odieresis/otilde/uacute/ugrave/ucircumflex/udieresis
2676 
+/dagger/degree/cent/sterling/section/bullet/paragraph/germandbls
2677 
+/register/copyright/trademark/acute/dieresis/notequal/AE/Oslash
2678 
+/infinity/plusminus/lessequal/greaterequal/yen/mu/partialdiff/summation
2679 
+/product/pi/integral/ordfeminine/ordmasculine/Omega/ae/oslash
2680 
+/questiondown/exclamdown/logicalnot/radical/florin/approxequal/Delta/guillemotleft
2681 
+/guillemotright/ellipsis/nbspace/Agrave/Atilde/Otilde/OE/oe
2682 
+/endash/emdash/quotedblleft/quotedblright/quoteleft/quoteright/divide/lozenge
2683 
+/ydieresis/Ydieresis/fraction/currency/guilsinglleft/guilsinglright/fi/fl
2684 
+/daggerdbl/periodcentered/quotesinglbase/quotedblbase
2685 
+/perthousand/Acircumflex/Ecircumflex/Aacute
2686 
+/Edieresis/Egrave/Iacute/Icircumflex/Idieresis/Igrave/Oacute/Ocircumflex
2687 
+/apple/Ograve/Uacute/Ucircumflex/Ugrave/dotlessi/circumflex/tilde
2688 
+/macron/breve/dotaccent/ring/cedilla/hungarumlaut/ogonek/caron
2689 
+MacVec 128 128 getinterval astore pop
2690 
+/fps{
2691 
+currentflat
2692 
+exch
2693 
+dup 0 le{pop 1}if
2694 
+{
2695 
+dup setflat 3 index stopped
2696 
+{1.3 mul dup 3 index gt{pop setflat pop pop stop}if}
2697 
+{exit}
2698 
+ifelse
2699 
+}loop
2700 
+pop setflat pop pop
2701 
+}bdf
2702 
+/fp{100 currentflat fps}bdf
2703 
+/clipper{clip}bdf
2704 
+/W{/clipper load 100 clipflatness fps}bdf
2705 
+/fixtrans1 {
2706 
+dup{ic mul ic sub 1 add}concatprocs exch
2707 
+dup{im mul im sub 1 add}concatprocs exch
2708 
+dup{iy mul iy sub 1 add}concatprocs exch
2709 
+{ik mul ik sub 1 add}concatprocs
2710 
+}bdf
2711 
+/fixtrans2 {
2712 
+currentcolortransfer
2713 
+5 -1 roll exch concatprocs 7 1 roll
2714 
+4 -1 roll exch concatprocs 6 1 roll
2715 
+3 -1 roll exch concatprocs 5 1 roll
2716 
+concatprocs 4 1 roll
2717 
+setcolortransfer
2718 
+}bdf
2719 
+end%. FreeHandDict
2720 
+end%. FHIODict
2721 
+FHIODict begin
2722 
+FreeHandDict begin
2723 
+5.1568 435.3825 327.2945 781.1872 storerect rectpath clip newpath
2724 
+/onlyk{false}ndf
2725 
+/ccmyk{dup 5 -1 roll sub 0 max exch}ndf
2726 
+/setcmykcolor{1 exch sub ccmyk ccmyk ccmyk pop setrgbcolor}ndf
2727 
+/setcmykcoloroverprint{4{dup -1 eq{pop 0}if 4 1 roll}repeat setcmykcolor}ndf
2728 
+/findcmykcustomcolor{5 /packedarray where{pop packedarray}{array astore readonly}ifelse}ndf
2729 
+/setcustomcolor{exch aload pop pop 4{4 index mul 4 1 roll}repeat setcmykcolor pop}ndf
2730 
+/setseparationgray{1 exch sub dup dup dup setcmykcolor}ndf
2731 
+/setoverprint{pop}ndf
2732 
+/currentoverprint false ndf
2733 
+/colorimage{pop pop
2734 
+[5 -1 roll/exec cvx 6 -1 roll/exec cvx 7 -1 roll/exec cvx 8 -1 roll/exec cvx
2735 
+/cmykbufs2gray cvx]cvx image}
2736 
+version cvr 47.1 le isLino and{userdict begin bdf end}{ndf}ifelse
2737 
+/cci1 {
2738 
+currentcolortransfer
2739 
+{ik mul ik sub 1 add}concatprocs 4 1 roll
2740 
+{iy mul iy sub 1 add}concatprocs 4 1 roll
2741 
+{im mul im sub 1 add}concatprocs 4 1 roll
2742 
+{ic mul ic sub 1 add}concatprocs 4 1 roll
2743 
+setcolortransfer
2744 
+}ndf
2745 
+/cci2 {
2746 
+{invbuf dup length magentabuf length ne
2747 
+{dup length dup dup
2748 
+/magentabuf exch string def
2749 
+/yellowbuf exch string def
2750 
+/blackbuf exch string def}if
2751 
+dup magentabuf copy yellowbuf copy blackbuf copy pop}concatprocs
2752 
+}ndf
2753 
+/customcolorimage{colorexists{
2754 
+aload pop pop 4 array astore
2755 
+setimagecmyk
2756 
+cci1
2757 
+/magentabuf 0 string def
2758 
+/yellowbuf 0 string def
2759 
+/blackbuf 0 string def
2760 
+cci2 {magentabuf}{yellowbuf}{blackbuf}true 4 colorimage}
2761 
+{pop image}ifelse}ndf
2762 
+/separationimage{image}ndf
2763 
+/newcmykcustomcolor{6 /packedarray where{pop packedarray}{array astore readonly}ifelse}ndf
2764 
+/inkoverprint false ndf
2765 
+/setinkoverprint{pop}ndf
2766 
+/overprintprocess{pop}ndf
2767 
+/setspotcolor
2768 
+{spots exch get 0 5 getinterval exch setcustomcolor}ndf
2769 
+/currentcolortransfer{currenttransfer dup dup dup}ndf
2770 
+/setcolortransfer{systemdict begin settransfer end pop pop pop}ndf
2771 
+/getcmyk {
2772 
+dup length 4 eq
2773 
+{aload pop}
2774 
+{aload pop spots exch get 0 4 getinterval aload pop 4
2775 
+{4 index mul 4 1 roll}repeat 5 -1 roll pop} ifelse
2776 
+}bdf
2777 
+/setimagecmyk{
2778 
+getcmyk/ik xdf /iy xdf /im xdf /ic xdf
2779 
+}ndf
2780 
+/autospread{pop}ndf
2781 
+/fhsetspreadsize{pop}ndf
2782 
+/strokeopf false def
2783 
+/fillopf false def
2784 
+/R{0 ne /strokeopf xdf}bdf
2785 
+/O{0 ne /fillopf xdf}bdf
2786 
+/filler{fill}bdf
2787 
+/F{fc fhsetcolor fillopf setoverprint false autospread
2788 
+gsave /filler load fp grestore false setoverprint}bdf
2789 
+/f{closepath F}bdf
2790 
+/S{sc fhsetcolor strokeopf setoverprint true autospread {stroke}fp false setoverprint}bdf
2791 
+/s{closepath S}bdf
2792 
+/B{fc fhsetcolor fillopf setoverprint gsave /filler load fp grestore
2793 
+sc fhsetcolor strokeopf setoverprint true autospread {stroke}fp false setoverprint}bdf
2794 
+/b{closepath B}bdf
2795 
+colorexists not{/setcolorscreen {setscreen pop pop pop pop pop pop pop pop pop}bdf}if
2796 
+/fhsetcolor{dup length 4 eq
2797 
+{aload overprintprocess setcmykcolor}
2798 
+{aload 1 get spots exch get 5 get setinkoverprint setspotcolor}
2799 
+ifelse
2800 
+}ndf
2801 
+/settextcolor{dup fhsetcolor dup length 4 eq
2802 
+{onlyk{3 get 1.0 eq{true setinkoverprint}if}{pop}ifelse}
2803 
+{pop}
2804 
+ifelse
2805 
+}ndf
2806 
+/ka{/fc xdf}bdf
2807 
+/Ka{/sc xdf}bdf
2808 
+/xa{/fc xdf} bdf
2809 
+/Xa{/sc xdf} bdf
2810 
+/bc2[0 0]def
2811 
+/bc4[0 0 0 0]def
2812 
+/absmax{2 copy abs exch abs gt{exch}if pop}bdf
2813 
+/calcstep
2814 
+{ colorexists not and{calcgraysteps}{maxsteps}ifelse
2815 
+tc1 length 4 eq
2816 
+{
2817 
+0 1 3
2818 
+{tc1 1 index get
2819 
+tc2 3 -1 roll get
2820 
+sub
2821 
+}for
2822 
+absmax absmax absmax
2823 
+}
2824 
+{
2825 
+bc2 tc1 1 get 1 exch put
2826 
+tc1 gettint tc2 gettint
2827 
+sub abs
2828 
+}
2829 
+ifelse
2830 
+mul abs round dup 0 eq{pop 1}if
2831 
+dup /numsteps xdf 1 sub dup 0 eq{pop 1}if /numsteps1 xdf
2832 
+}bdf
2833 
+/cblend{
2834 
+tc1 length 4 eq
2835 
+{
2836 
+0 1 3
2837 
+{bc4 exch
2838 
+tc1 1 index get
2839 
+tc2 2 index get
2840 
+1 index sub
2841 
+frac mul add put
2842 
+}for bc4
2843 
+}
2844 
+{
2845 
+bc2
2846 
+tc1 gettint
2847 
+tc2 gettint
2848 
+1 index sub
2849 
+frac mul add
2850 
+puttint bc2
2851 
+}
2852 
+ifelse
2853 
+fhsetcolor
2854 
+}bdf
2855 
+/logtaper{/frac frac 9 mul 1 add log def}bdf
2856 
+FHIODict begin
2857 
+/origmtx matrix currentmatrix def
2858 
+/iminv false def
2859 
+/invbuf{0 1 2 index length 1 sub{dup 2 index exch get 255 exch sub 2 index 3 1 roll put}for}bdf
2860 
+/cyanrp{currentfile cyanbuf readhexstring pop iminv{invbuf}if}def
2861 
+/magentarp{cyanbuf magentabuf copy}bdf
2862 
+/yellowrp{cyanbuf yellowbuf copy}bdf
2863 
+/blackrp{cyanbuf blackbuf copy}bdf
2864 
+/fixtransfer{
2865 
+colorexists
2866 
+{fixtrans1 fixtrans2}
2867 
+{{dup 1 exch sub currentgray mul add}concatprocs
2868 
+currenttransfer exch concatprocs
2869 
+systemdict begin settransfer end}ifelse
2870 
+}ndf
2871 
+/cmykbufs2gray{
2872 
+dup length 0 1 3 -1 roll 1 sub
2873 
+{4 index 1 index get
2874 
+4 index 2 index get
2875 
+4 index 3 index get
2876 
+4 index 4 index get
2877 
+255 exch sub ccmyk ccmyk ccmyk pop 5 mul exch 45 mul add exch 14 mul add -6 bitshift
2878 
+2 index 3 1 roll put}for
2879 
+4 1 roll pop pop pop
2880 
+}bdf
2881 
+end
2882 
+/textopf false def
2883 
+/curtextmtx{}def
2884 
+/otw .25 def
2885 
+/msf{dup/curtextmtx xdf makefont setfont}bdf
2886 
+/makesetfont/msf load def
2887 
+/curtextheight{.707104 .707104 curtextmtx dtransform
2888 
+dup mul exch dup mul add sqrt}bdf
2889 
+/ta{1 index
2890 
+{tempstr 0 2 index put tempstr 2 index
2891 
+gsave exec grestore
2892 
+tempstr stringwidth rmoveto
2893 
+5 index eq{6 index 6 index rmoveto}if
2894 
+3 index 3 index rmoveto
2895 
+}forall 7{pop}repeat}bdf
2896 
+/sts{settextcolor textopf setoverprint/ts{awidthshow}def exec false setoverprint}bdf
2897 
+/stol{setlinewidth settextcolor textopf setoverprint newpath
2898 
+/ts{{false charpath stroke}ta}def exec false setoverprint}bdf
2899 
+/currentpacking where{pop false setpacking}if
2900 
+/spots[1 0 0 0 (Process Cyan) false newcmykcustomcolor
2901 
+0 1 0 0 (Process Magenta) false newcmykcustomcolor
2902 
+0 0 1 0 (Process Yellow) false newcmykcustomcolor
2903 
+0 0 0 1 (Process Black) false newcmykcustomcolor
2904 
+0 0 0 0  (White) false
2905 
+newcmykcustomcolor
2906 
+]def
2907 
+0 dict dup begin
2908 
+end
2909 
+/f0 /Symbol FF def
2910 
+[] 0 d
2911 
+3.863708 M
2912 
+1 w
2913 
+0 j
2914 
+0 J
2915 
+0 O
2916 
+0 R
2917 
+0 i
2918 
+false eomode
2919 
+[0 0 0 1] Ka
2920 
+[0 0 0 1] ka
2921 
+vms
2922 
+u
2923 
+vmrs
2924 
+MacVec 256 array copy
2925 
+/f1 /|______Helvetica-Bold dup RF findfont def
2926 
+{
2927 
+f1 [18 0 0 18 0 0] makesetfont
2928 
+9.656845 613.020248 m
2929 
+0 0 32 0 0 (1) ts
2930 
+}
2931 
+[0 0 0 1]
2932 
+sts
2933 
+78.6568 699.0202 m
2934 
+78.6568 745.0202 L
2935 
+2 J
2936 
+S
2937 
+78.6568 745.0202 m
2938 
+83.6568 745.0202 L
2939 
+78.6568 757.0202 L
2940 
+73.6568 745.0202 L
2941 
+78.6568 745.0202 L
2942 
+f
2943 
+n
2944 
+160.6568 624.0202 m
2945 
+162.6568 627.0202 L
2946 
+165.6568 631.0202 L
2947 
+168.6568 634.0202 L
2948 
+171.6568 636.0202 L
2949 
+175.6568 639.0202 L
2950 
+178.6568 641.0202 L
2951 
+180.6568 642.0202 L
2952 
+182.6568 643.0202 L
2953 
+184.6568 644.0202 L
2954 
+186.6568 645.0202 L
2955 
+188.6568 646.0202 L
2956 
+190.6568 647.0202 L
2957 
+192.6568 647.0202 L
2958 
+194.6568 648.0202 L
2959 
+196.6568 648.0202 L
2960 
+198.6568 649.0202 L
2961 
+200.6568 649.0202 L
2962 
+202.6568 650.0202 L
2963 
+205.6568 650.0202 L
2964 
+207.6568 650.0202 L
2965 
+209.6568 650.0202 L
2966 
+211.6568 651.0202 L
2967 
+213.6568 651.0202 L
2968 
+215.6568 651.0202 L
2969 
+217.6568 650.0202 L
2970 
+219.6568 650.0202 L
2971 
+221.6568 650.0202 L
2972 
+223.6568 650.0202 L
2973 
+225.6568 649.0202 L
2974 
+227.6568 649.0202 L
2975 
+231.6568 648.0202 L
2976 
+235.6568 646.0202 L
2977 
+238.6568 644.0202 L
2978 
+241.6568 642.0202 L
2979 
+244.6568 640.0202 L
2980 
+247.6568 637.0202 L
2981 
+249.6568 635.0202 L
2982 
+251.6568 632.0202 L
2983 
+253.6568 630.0202 L
2984 
+255.6568 628.0202 L
2985 
+257.6568 625.0202 L
2986 
+258.6568 623.0202 L
2987 
+260.6568 621.0202 L
2988 
+262.6568 618.0202 L
2989 
+263.6568 616.0202 L
2990 
+265.6568 613.0202 L
2991 
+267.6568 611.0202 L
2992 
+268.6568 608.0202 L
2993 
+270.6568 606.0202 L
2994 
+271.6568 603.0202 L
2995 
+272.6568 601.0202 L
2996 
+274.6568 598.0202 L
2997 
+275.6568 595.0202 L
2998 
+276.6568 593.0202 L
2999 
+277.6568 590.0202 L
3000 
+279.6568 588.0202 L
3001 
+280.6568 585.0202 L
3002 
+281.6568 582.0202 L
3003 
+282.6568 580.0202 L
3004 
+283.6568 577.0202 L
3005 
+284.6568 574.0202 L
3006 
+285.6568 572.0202 L
3007 
+286.6568 569.0202 L
3008 
+286.6568 566.0202 L
3009 
+287.6568 563.0202 L
3010 
+288.6568 561.0202 L
3011 
+289.6568 558.0202 L
3012 
+289.6568 555.0202 L
3013 
+290.6568 552.0202 L
3014 
+291.6568 550.0202 L
3015 
+291.6568 547.0202 L
3016 
+292.6568 544.0202 L
3017 
+292.6568 541.0202 L
3018 
+293.6568 538.0202 L
3019 
+293.6568 536.0202 L
3020 
+293.6568 533.0202 L
3021 
+294.6568 530.0202 L
3022 
+294.6568 527.0202 L
3023 
+294.6568 524.0202 L
3024 
+295.6568 521.0202 L
3025 
+295.6568 519.0202 L
3026 
+295.6568 516.0202 L
3027 
+295.6568 513.0202 L
3028 
+295.6568 510.0202 L
3029 
+295.6568 506.0202 L
3030 
+295.6568 503.0202 L
3031 
+295.6568 500.0202 L
3032 
+294.6568 498.0202 L
3033 
+294.6568 495.0202 L
3034 
+293.6568 493.0202 L
3035 
+293.6568 491.0202 L
3036 
+292.6568 489.0202 L
3037 
+291.6568 487.0202 L
3038 
+290.6568 486.0202 L
3039 
+289.6568 484.0202 L
3040 
+288.6568 483.0202 L
3041 
+286.6568 481.0202 L
3042 
+284.6568 480.0202 L
3043 
+281.6568 481.0202 L
3044 
+279.6568 481.0202 L
3045 
+276.6568 482.0202 L
3046 
+274.6568 484.0202 L
3047 
+235.6568 520.0202 L
3048 
+S
3049 
+91.6568 694.0202 m
3050 
+93.6568 696.0202 L
3051 
+95.6568 698.0202 L
3052 
+97.6568 700.0202 L
3053 
+100.6568 702.0202 L
3054 
+102.6568 703.0202 L
3055 
+104.6568 705.0202 L
3056 
+107.6568 706.0202 L
3057 
+109.6568 708.0202 L
3058 
+112.6568 709.0202 L
3059 
+114.6568 710.0202 L
3060 
+117.6568 711.0202 L
3061 
+119.6568 713.0202 L
3062 
+122.6568 714.0202 L
3063 
+125.6568 715.0202 L
3064 
+128.6568 715.0202 L
3065 
+130.6568 716.0202 L
3066 
+133.6568 717.0202 L
3067 
+136.6568 718.0202 L
3068 
+139.6568 718.0202 L
3069 
+142.6568 719.0202 L
3070 
+145.6568 719.0202 L
3071 
+148.6568 720.0202 L
3072 
+151.6568 720.0202 L
3073 
+154.6568 720.0202 L
3074 
+156.6568 720.0202 L
3075 
+159.6568 720.0202 L
3076 
+162.6568 720.0202 L
3077 
+165.6568 720.0202 L
3078 
+168.6568 720.0202 L
3079 
+171.6568 720.0202 L
3080 
+174.6568 720.0202 L
3081 
+177.6568 720.0202 L
3082 
+180.6568 720.0202 L
3083 
+183.6568 719.0202 L
3084 
+186.6568 719.0202 L
3085 
+189.6568 719.0202 L
3086 
+192.6568 718.0202 L
3087 
+195.6568 718.0202 L
3088 
+198.6568 717.0202 L
3089 
+201.6568 716.0202 L
3090 
+203.6568 716.0202 L
3091 
+206.6568 715.0202 L
3092 
+209.6568 714.0202 L
3093 
+212.6568 714.0202 L
3094 
+214.6568 713.0202 L
3095 
+217.6568 712.0202 L
3096 
+220.6568 711.0202 L
3097 
+222.6568 710.0202 L
3098 
+225.6568 709.0202 L
3099 
+228.6568 707.0202 L
3100 
+232.6568 706.0202 L
3101 
+235.6568 704.0202 L
3102 
+238.6568 703.0202 L
3103 
+241.6568 701.0202 L
3104 
+244.6568 699.0202 L
3105 
+246.6568 697.0202 L
3106 
+249.6568 695.0202 L
3107 
+252.6568 693.0202 L
3108 
+255.6568 691.0202 L
3109 
+257.6568 689.0202 L
3110 
+260.6568 687.0202 L
3111 
+262.6568 684.0202 L
3112 
+265.6568 682.0202 L
3113 
+267.6568 679.0202 L
3114 
+270.6568 677.0202 L
3115 
+272.6568 674.0202 L
3116 
+274.6568 672.0202 L
3117 
+276.6568 669.0202 L
3118 
+278.6568 666.0202 L
3119 
+280.6568 663.0202 L
3120 
+282.6568 660.0202 L
3121 
+284.6568 657.0202 L
3122 
+286.6568 655.0202 L
3123 
+288.6568 652.0202 L
3124 
+290.6568 649.0202 L
3125 
+292.6568 646.0202 L
3126 
+294.6568 642.0202 L
3127 
+295.6568 639.0202 L
3128 
+297.6568 636.0202 L
3129 
+298.6568 633.0202 L
3130 
+300.6568 630.0202 L
3131 
+301.6568 626.0202 L
3132 
+303.6568 623.0202 L
3133 
+304.6568 620.0202 L
3134 
+305.6568 617.0202 L
3135 
+307.6568 613.0202 L
3136 
+308.6568 610.0202 L
3137 
+309.6568 607.0202 L
3138 
+310.6568 603.0202 L
3139 
+311.6568 600.0202 L
3140 
+312.6568 597.0202 L
3141 
+313.6568 593.0202 L
3142 
+314.6568 590.0202 L
3143 
+315.6568 587.0202 L
3144 
+315.6568 583.0202 L
3145 
+316.6568 580.0202 L
3146 
+316.6568 578.0202 L
3147 
+317.6568 575.0202 L
3148 
+318.6568 573.0202 L
3149 
+318.6568 570.0202 L
3150 
+319.6568 567.0202 L
3151 
+319.6568 564.0202 L
3152 
+320.6568 562.0202 L
3153 
+320.6568 559.0202 L
3154 
+321.6568 556.0202 L
3155 
+321.6568 553.0202 L
3156 
+322.6568 550.0202 L
3157 
+322.6568 547.0202 L
3158 
+323.6568 544.0202 L
3159 
+323.6568 541.0202 L
3160 
+324.6568 538.0202 L
3161 
+324.6568 534.0202 L
3162 
+324.6568 531.0202 L
3163 
+325.6568 528.0202 L
3164 
+325.6568 525.0202 L
3165 
+325.6568 522.0202 L
3166 
+325.6568 519.0202 L
3167 
+326.6568 515.0202 L
3168 
+326.6568 512.0202 L
3169 
+326.6568 509.0202 L
3170 
+326.6568 506.0202 L
3171 
+326.6568 503.0202 L
3172 
+325.6568 500.0202 L
3173 
+325.6568 497.0202 L
3174 
+325.6568 494.0202 L
3175 
+324.6568 491.0202 L
3176 
+324.6568 488.0202 L
3177 
+323.6568 486.0202 L
3178 
+323.6568 483.0202 L
3179 
+322.6568 480.0202 L
3180 
+321.6568 477.0202 L
3181 
+320.6568 475.0202 L
3182 
+319.6568 472.0202 L
3183 
+318.6568 470.0202 L
3184 
+317.6568 468.0202 L
3185 
+315.6568 466.0202 L
3186 
+314.6568 464.0202 L
3187 
+312.6568 462.0202 L
3188 
+311.6568 460.0202 L
3189 
+309.6568 458.0202 L
3190 
+307.6568 456.0202 L
3191 
+305.6568 455.0202 L
3192 
+302.6568 453.0202 L
3193 
+300.6568 452.0202 L
3194 
+297.6568 451.0202 L
3195 
+294.6568 449.0202 L
3196 
+291.6568 448.0202 L
3197 
+288.6568 447.0202 L
3198 
+285.6568 446.0202 L
3199 
+282.6568 445.0202 L
3200 
+279.6568 444.0202 L
3201 
+276.6568 443.0202 L
3202 
+273.6568 442.0202 L
3203 
+270.6568 441.0202 L
3204 
+267.6568 440.0202 L
3205 
+263.6568 439.0202 L
3206 
+260.6568 439.0202 L
3207 
+257.6568 438.0202 L
3208 
+253.6568 438.0202 L
3209 
+250.6568 437.0202 L
3210 
+247.6568 437.0202 L
3211 
+244.6568 437.0202 L
3212 
+240.6568 436.0202 L
3213 
+237.6568 436.0202 L
3214 
+234.6568 436.0202 L
3215 
+230.6568 436.0202 L
3216 
+227.6568 436.0202 L
3217 
+224.6568 436.0202 L
3218 
+221.6568 436.0202 L
3219 
+218.6568 437.0202 L
3220 
+214.6568 437.0202 L
3221 
+211.6568 437.0202 L
3222 
+208.6568 438.0202 L
3223 
+205.6568 439.0202 L
3224 
+202.6568 439.0202 L
3225 
+199.6568 440.0202 L
3226 
+196.6568 441.0202 L
3227 
+194.6568 442.0202 L
3228 
+191.6568 443.0202 L
3229 
+188.6568 444.0202 L
3230 
+185.6568 445.0202 L
3231 
+183.6568 447.0202 L
3232 
+180.6568 448.0202 L
3233 
+178.6568 450.0202 L
3234 
+176.6568 451.0202 L
3235 
+173.6568 453.0202 L
3236 
+171.6568 455.0202 L
3237 
+169.6568 456.0202 L
3238 
+167.6568 458.0202 L
3239 
+165.6568 461.0202 L
3240 
+164.6568 463.0202 L
3241 
+162.6568 465.0202 L
3242 
+161.6568 467.0202 L
3243 
+160.6568 469.0202 L
3244 
+160.6568 471.0202 L
3245 
+160.6568 473.0202 L
3246 
+160.6568 476.0202 L
3247 
+160.6568 478.0202 L
3248 
+161.6568 481.0202 L
3249 
+162.6568 483.0202 L
3250 
+163.6568 486.0202 L
3251 
+165.6568 488.0202 L
3252 
+166.6568 491.0202 L
3253 
+168.6568 494.0202 L
3254 
+170.6568 496.0202 L
3255 
+172.6568 499.0202 L
3256 
+174.6568 502.0202 L
3257 
+177.6568 505.0202 L
3258 
+179.6568 507.0202 L
3259 
+181.6568 510.0202 L
3260 
+184.6568 513.0202 L
3261 
+186.6568 515.0202 L
3262 
+188.6568 518.0202 L
3263 
+191.6568 520.0202 L
3264 
+193.6568 523.0202 L
3265 
+195.6568 525.0202 L
3266 
+S
3267 
+u
3268 
+134.6568 623.0202 m
3269 
+101.6568 657.0202 L
3270 
+S
3271 
+101.6568 657.0202 m
3272 
+105.6568 661.0202 L
3273 
+93.6568 666.0202 L
3274 
+98.6568 653.0202 L
3275 
+101.6568 657.0202 L
3276 
+f
3277 
+n
3278 
+U
3279 
+u
3280 
+202.6568 554.0202 m
3281 
+171.6568 586.0202 L
3282 
+S
3283 
+171.6568 586.0202 m
3284 
+174.6568 590.0202 L
3285 
+162.6568 595.0202 L
3286 
+167.6568 582.0202 L
3287 
+171.6568 586.0202 L
3288 
+f
3289 
+n
3290 
+U
3291 
+u
3292 
+u
3293 
+60.1568 680.5202 m
3294 
+60.1568 691.0138 68.6633 699.5202 79.1568 699.5202 C
3295 
+89.6504 699.5202 98.1568 691.0138 98.1568 680.5202 C
3296 
+98.1568 670.0267 89.6504 661.5202 79.1568 661.5202 C
3297 
+68.6633 661.5202 60.1568 670.0267 60.1568 680.5202 C
3298 
+[0 0 0 0] ka
3299 
+b
3300 
+U
3301 
+vmrs
3302 
+0 dict dup begin
3303 
+end
3304 
+/f2 /Symbol FF def
3305 
+{
3306 
+f2 [36 0 0 36 0 0] makesetfont
3307 
+73.656845 672.020248 m
3308 
+0 0 32 0 0 (:) ts
3309 
+}
3310 
+[0 0 0 1]
3311 
+sts
3312 
+U
3313 
+u
3314 
+u
3315 
+129.1568 610.5202 m
3316 
+129.1568 621.0138 137.6633 629.5202 148.1568 629.5202 C
3317 
+158.6504 629.5202 167.1568 621.0138 167.1568 610.5202 C
3318 
+167.1568 600.0267 158.6504 591.5202 148.1568 591.5202 C
3319 
+137.6633 591.5202 129.1568 600.0267 129.1568 610.5202 C
3320 
+[0 0 0 0] ka
3321 
+2 J
3322 
+b
3323 
+U
3324 
+vmrs
3325 
+0 dict dup begin
3326 
+end
3327 
+/f2 /Symbol FF def
3328 
+{
3329 
+f2 [36 0 0 36 0 0] makesetfont
3330 
+142.656845 602.020248 m
3331 
+0 0 32 0 0 (:) ts
3332 
+}
3333 
+[0 0 0 1]
3334 
+sts
3335 
+U
3336 
+u
3337 
+199.1568 541.5202 m
3338 
+199.1568 552.0138 207.6633 560.5202 218.1568 560.5202 C
3339 
+228.6504 560.5202 237.1568 552.0138 237.1568 541.5202 C
3340 
+237.1568 531.0267 228.6504 522.5202 218.1568 522.5202 C
3341 
+207.6633 522.5202 199.1568 531.0267 199.1568 541.5202 C
3342 
+[0 0 0 0] ka
3343 
+2 J
3344 
+b
3345 
+U
3346 
+vmrs
3347 
+0 dict dup begin
3348 
+end
3349 
+/f2 /Symbol FF def
3350 
+{
3351 
+f2 [36 0 0 36 0 0] makesetfont
3352 
+208.12738 532.080994 m
3353 
+0 0 32 0 0 (+) ts
3354 
+}
3355 
+[0 0 0 1]
3356 
+sts
3357 
+u
3358 
+22.6568 624.0202 m
3359 
+55.6568 658.0202 L
3360 
+2 J
3361 
+S
3362 
+55.6568 658.0202 m
3363 
+58.6568 654.0202 L
3364 
+63.6568 667.0202 L
3365 
+51.6568 662.0202 L
3366 
+55.6568 658.0202 L
3367 
+f
3368 
+n
3369 
+U
3370 
+u
3371 
+90.6568 551.0202 m
3372 
+123.6568 585.0202 L
3373 
+S
3374 
+123.6568 585.0202 m
3375 
+126.6568 581.0202 L
3376 
+131.6568 594.0202 L
3377 
+119.6568 589.0202 L
3378 
+123.6568 585.0202 L
3379 
+f
3380 
+n
3381 
+U
3382 
+u
3383 
+192.6568 520.0202 m
3384 
+191.6568 519.0202 L
3385 
+S
3386 
+191.6568 519.0202 m
3387 
+195.6568 515.0202 L
3388 
+200.6568 528.0202 L
3389 
+187.6568 523.0202 L
3390 
+191.6568 519.0202 L
3391 
+f
3392 
+n
3393 
+U
3394 
+u
3395 
+237.6568 518.0202 m
3396 
+240.6568 515.0202 L
3397 
+S
3398 
+240.6568 515.0202 m
3399 
+244.6568 519.0202 L
3400 
+231.6568 524.0202 L
3401 
+236.6568 511.0202 L
3402 
+240.6568 515.0202 L
3403 
+f
3404 
+n
3405 
+U
3406 
+vmrs
3407 
+MacVec 256 array copy
3408 
+/f1 /|______Helvetica-Bold dup RF findfont def
3409 
+{
3410 
+f1 [18 0 0 18 0 0] makesetfont
3411 
+76.656845 538.020248 m
3412 
+0 0 32 0 0 (1) ts
3413 
+}
3414 
+[0 0 0 1]
3415 
+sts
3416 
+vmrs
3417 
+MacVec 256 array copy
3418 
+/f1 /|______Helvetica-Bold dup RF findfont def
3419 
+{
3420 
+f1 [18 0 0 18 0 0] makesetfont
3421 
+126.656845 724.020248 m
3422 
+0 0 32 0 0 (1,1,2,3,5,...) ts
3423 
+}
3424 
+[0 0 0 1]
3425 
+sts
3426 
+vmrs
3427 
+MacVec 256 array copy
3428 
+/f1 /|______Helvetica-Bold dup RF findfont def
3429 
+{
3430 
+f1 [18 0 0 18 0 0] makesetfont
3431 
+164.656845 655.020248 m
3432 
+0 0 32 0 0 (1,2,3,5,8,...) ts
3433 
+}
3434 
+[0 0 0 1]
3435 
+sts
3436 
+vmrs
3437 
+MacVec 256 array copy
3438 
+/f3 /|______Times-BoldItalic dup RF findfont def
3439 
+{
3440 
+f3 [18 0 0 18 0 0] makesetfont
3441 
+69.656845 763.020248 m
3442 
+0 0 32 0 0 (fib) ts
3443 
+}
3444 
+[0 0 0 1]
3445 
+sts
3446 
+U
3447 
+vmr
3448 
+end  % FreeHandDict
3449 
+end  % FHIODict
3450 
+%%EndDocument
3451 
+ @endspecial 1134 w @beginspecial 14.258400 @llx 620.398376
3452 
+@lly 377.258392 @urx 783.398376 @ury 1800 @rwi @setspecial
3453 
+%%BeginDocument: io.eps
3454 
+/FHIODict 30 dict def
3455 
+FHIODict begin
3456 
+/bdf{bind def}bind def
3457 
+/d{setdash}bdf
3458 
+/h{closepath}bdf
3459 
+/H{}bdf
3460 
+/J{setlinecap}bdf
3461 
+/j{setlinejoin}bdf
3462 
+/M{setmiterlimit}bdf
3463 
+/n{newpath}bdf
3464 
+/N{newpath}bdf
3465 
+/q{gsave}bdf
3466 
+/Q{grestore}bdf
3467 
+/w{setlinewidth}bdf
3468 
+/u{}bdf
3469 
+/U{}bdf
3470 
+/sepdef{
3471 
+dup where not
3472 
+{
3473 
+FreeHandSepDict
3474 
+}
3475 
+if
3476 
+3 1 roll exch put
3477 
+}bdf
3478 
+/`
3479 
+{end %. FreeHandDict
3480 
+/-save0- save def
3481 
+pop pop pop pop pop
3482 
+concat
3483 
+userdict begin
3484 
+/showpage {} def
3485 
+0 setgray 0 setlinecap 1 setlinewidth
3486 
+0 setlinejoin 10 setmiterlimit [] 0 setdash newpath
3487 
+/languagelevel where {pop languagelevel 1 ne{false setstrokeadjust false setoverprint}if}if
3488 
+} bdf
3489 
+/~
3490 
+{end
3491 
+-save0- restore
3492 
+FreeHandDict begin
3493 
+}bdf
3494 
+/FreeHandDict 190 dict def
3495 
+FreeHandDict begin
3496 
+/currentpacking where{pop true setpacking}if
3497 
+/xdf{exch def}bdf
3498 
+/ndf{1 index where{pop pop pop}{dup xcheck{bind}if def}ifelse}bdf
3499 
+/min{2 copy gt{exch}if pop}bdf
3500 
+/max{2 copy lt{exch}if pop}bdf
3501 
+/isLino statusdict /product get (Lino) anchorsearch{pop pop true}{pop false}ifelse def
3502 
+/dr{transform .25 sub round .25 add
3503 
+exch .25 sub round .25 add exch itransform}bdf
3504 
+/C{dr curveto}bdf
3505 
+/L{dr lineto}bdf
3506 
+/m{dr moveto}bdf
3507 
+/printerRes
3508 
+gsave
3509 
+matrix defaultmatrix setmatrix
3510 
+72 72 dtransform
3511 
+abs exch abs
3512 
+max
3513 
+grestore
3514 
+def
3515 
+/maxsteps 256 def
3516 
+/calcgraysteps {
3517 
+currentscreen pop exch
3518 
+printerRes exch div exch
3519 
+2 copy
3520 
+sin mul round dup mul
3521 
+3 1 roll
3522 
+cos mul round dup mul
3523 
+add 1 add
3524 
+dup maxsteps gt {pop maxsteps} if
3525 
+} bdf
3526 
+/bottom -0 def
3527 
+/delta -0 def
3528 
+/frac -0 def
3529 
+/left -0 def
3530 
+/numsteps -0 def
3531 
+/numsteps1 -0 def
3532 
+/radius -0 def
3533 
+/right -0 def
3534 
+/top -0 def
3535 
+/xt -0 def
3536 
+/yt -0 def
3537 
+/df currentflat def
3538 
+/tempstr 1 string def
3539 
+/clipflatness currentflat def
3540 
+/inverted?
3541 
+0 currenttransfer exec .5 ge def
3542 
+/colorexists
3543 
+systemdict/setcmykcolor known def
3544 
+/tc1 [0 0 0 1] def
3545 
+/tc2 [0 0 0 1] def
3546 
+/fc [0 0 0 1] def
3547 
+/sc [0 0 0 1] def
3548 
+/concatprocs{
3549 
+/proc2 exch cvlit def/proc1 exch cvlit def
3550 
+/newproc proc1 length proc2 length add array def
3551 
+newproc 0 proc1 putinterval newproc proc1 length proc2 putinterval
3552 
+newproc cvx}bdf
3553 
+/storerect{/top xdf/right xdf/bottom xdf/left xdf}bdf
3554 
+/rectpath{newpath left bottom m left top L
3555 
+right top L right bottom L closepath}bdf
3556 
+/i{dup 0 eq
3557 
+{pop df dup}
3558 
+{dup} ifelse
3559 
+/clipflatness xdf setflat
3560 
+}bdf
3561 
+version cvr 38.0 le
3562 
+{/setrgbcolor{
3563 
+currenttransfer exec 3 1 roll
3564 
+currenttransfer exec 3 1 roll
3565 
+currenttransfer exec 3 1 roll
3566 
+setrgbcolor}bdf}if
3567 
+/gettint{0 get}bdf
3568 
+/puttint{0 exch put}bdf
3569 
+/vms {/vmsv save def} bdf
3570 
+/vmr {vmsv restore} bdf
3571 
+/vmrs{vmsv restore /vmsv save def}bdf
3572 
+/eomode{
3573 
+{/filler /eofill load def /clipper /eoclip load def}
3574 
+{/filler /fill load def /clipper /clip load def}
3575 
+ifelse
3576 
+}bdf
3577 
+/CD{/NF exch def{exch dup/FID ne 1 index/UniqueID ne and{exch NF 3 1 roll put}
3578 
+{pop pop}ifelse}forall NF}bdf
3579 
+/MN{1 index length/Len exch def
3580 
+dup length Len add string dup
3581 
+Len 4 -1 roll putinterval dup 0 4 -1 roll putinterval}bdf
3582 
+/RC{4 -1 roll /ourvec xdf 256 string cvs(|______)anchorsearch
3583 
+{1 index MN cvn/NewN exch def cvn
3584 
+findfont dup maxlength dict CD dup/FontName NewN put dup
3585 
+/Encoding ourvec put NewN exch definefont pop}{pop}ifelse}bdf
3586 
+/RF{dup FontDirectory exch known{pop 3 -1 roll pop}{RC}ifelse}bdf
3587 
+/FF{dup 256 string cvs(|______)exch MN cvn dup FontDirectory exch known
3588 
+{exch pop findfont 3 -1 roll pop}{pop dup findfont dup maxlength dict CD dup dup
3589 
+/Encoding exch /Encoding get 256 array copy 7 -1 roll {3 -1 roll dup 4 -2 roll put}forall put definefont}ifelse}bdf
3590 
+userdict begin /BDFontDict 20 dict def end
3591 
+BDFontDict begin
3592 
+/bu{}def
3593 
+/bn{}def
3594 
+/setTxMode{av 70 ge{pop}if pop}def
3595 
+/gm{m}def
3596 
+/show{pop}def
3597 
+/gr{pop}def
3598 
+/fnt{pop pop pop}def
3599 
+/fs{pop}def
3600 
+/fz{pop}def
3601 
+/lin{pop pop}def
3602 
+end
3603 
+/MacVec 256 array def
3604 
+MacVec 0 /Helvetica findfont
3605 
+/Encoding get 0 128 getinterval putinterval
3606 
+MacVec 127 /DEL put MacVec 16#27 /quotesingle put MacVec 16#60 /grave put
3607 
+/NUL/SOH/STX/ETX/EOT/ENQ/ACK/BEL/BS/HT/LF/VT/FF/CR/SO/SI
3608 
+/DLE/DC1/DC2/DC3/DC4/NAK/SYN/ETB/CAN/EM/SUB/ESC/FS/GS/RS/US
3609 
+MacVec 0 32 getinterval astore pop
3610 
+/Adieresis/Aring/Ccedilla/Eacute/Ntilde/Odieresis/Udieresis/aacute
3611 
+/agrave/acircumflex/adieresis/atilde/aring/ccedilla/eacute/egrave
3612 
+/ecircumflex/edieresis/iacute/igrave/icircumflex/idieresis/ntilde/oacute
3613 
+/ograve/ocircumflex/odieresis/otilde/uacute/ugrave/ucircumflex/udieresis
3614 
+/dagger/degree/cent/sterling/section/bullet/paragraph/germandbls
3615 
+/register/copyright/trademark/acute/dieresis/notequal/AE/Oslash
3616 
+/infinity/plusminus/lessequal/greaterequal/yen/mu/partialdiff/summation
3617 
+/product/pi/integral/ordfeminine/ordmasculine/Omega/ae/oslash
3618 
+/questiondown/exclamdown/logicalnot/radical/florin/approxequal/Delta/guillemotleft
3619 
+/guillemotright/ellipsis/nbspace/Agrave/Atilde/Otilde/OE/oe
3620 
+/endash/emdash/quotedblleft/quotedblright/quoteleft/quoteright/divide/lozenge
3621 
+/ydieresis/Ydieresis/fraction/currency/guilsinglleft/guilsinglright/fi/fl
3622 
+/daggerdbl/periodcentered/quotesinglbase/quotedblbase
3623 
+/perthousand/Acircumflex/Ecircumflex/Aacute
3624 
+/Edieresis/Egrave/Iacute/Icircumflex/Idieresis/Igrave/Oacute/Ocircumflex
3625 
+/apple/Ograve/Uacute/Ucircumflex/Ugrave/dotlessi/circumflex/tilde
3626 
+/macron/breve/dotaccent/ring/cedilla/hungarumlaut/ogonek/caron
3627 
+MacVec 128 128 getinterval astore pop
3628 
+/fps{
3629 
+currentflat
3630 
+exch
3631 
+dup 0 le{pop 1}if
3632 
+{
3633 
+dup setflat 3 index stopped
3634 
+{1.3 mul dup 3 index gt{pop setflat pop pop stop}if}
3635 
+{exit}
3636 
+ifelse
3637 
+}loop
3638 
+pop setflat pop pop
3639 
+}bdf
3640 
+/fp{100 currentflat fps}bdf
3641 
+/clipper{clip}bdf
3642 
+/W{/clipper load 100 clipflatness fps}bdf
3643 
+/fixtrans1 {
3644 
+dup{ic mul ic sub 1 add}concatprocs exch
3645 
+dup{im mul im sub 1 add}concatprocs exch
3646 
+dup{iy mul iy sub 1 add}concatprocs exch
3647 
+{ik mul ik sub 1 add}concatprocs
3648 
+}bdf
3649 
+/fixtrans2 {
3650 
+currentcolortransfer
3651 
+5 -1 roll exch concatprocs 7 1 roll
3652 
+4 -1 roll exch concatprocs 6 1 roll
3653 
+3 -1 roll exch concatprocs 5 1 roll
3654 
+concatprocs 4 1 roll
3655 
+setcolortransfer
3656 
+}bdf
3657 
+end%. FreeHandDict
3658 
+end%. FHIODict
3659 
+FHIODict begin
3660 
+FreeHandDict begin
3661 
+14.2584 620.3984 377.2584 783.3984 storerect rectpath clip newpath
3662 
+/onlyk{false}ndf
3663 
+/ccmyk{dup 5 -1 roll sub 0 max exch}ndf
3664 
+/setcmykcolor{1 exch sub ccmyk ccmyk ccmyk pop setrgbcolor}ndf
3665 
+/setcmykcoloroverprint{4{dup -1 eq{pop 0}if 4 1 roll}repeat setcmykcolor}ndf
3666 
+/findcmykcustomcolor{5 /packedarray where{pop packedarray}{array astore readonly}ifelse}ndf
3667 
+/setcustomcolor{exch aload pop pop 4{4 index mul 4 1 roll}repeat setcmykcolor pop}ndf
3668 
+/setseparationgray{1 exch sub dup dup dup setcmykcolor}ndf
3669 
+/setoverprint{pop}ndf
3670 
+/currentoverprint false ndf
3671 
+/colorimage{pop pop
3672 
+[5 -1 roll/exec cvx 6 -1 roll/exec cvx 7 -1 roll/exec cvx 8 -1 roll/exec cvx
3673 
+/cmykbufs2gray cvx]cvx image}
3674 
+version cvr 47.1 le isLino and{userdict begin bdf end}{ndf}ifelse
3675 
+/cci1 {
3676 
+currentcolortransfer
3677 
+{ik mul ik sub 1 add}concatprocs 4 1 roll
3678 
+{iy mul iy sub 1 add}concatprocs 4 1 roll
3679 
+{im mul im sub 1 add}concatprocs 4 1 roll
3680 
+{ic mul ic sub 1 add}concatprocs 4 1 roll
3681 
+setcolortransfer
3682 
+}ndf
3683 
+/cci2 {
3684 
+{invbuf dup length magentabuf length ne
3685 
+{dup length dup dup
3686 
+/magentabuf exch string def
3687 
+/yellowbuf exch string def
3688 
+/blackbuf exch string def}if
3689 
+dup magentabuf copy yellowbuf copy blackbuf copy pop}concatprocs
3690 
+}ndf
3691 
+/customcolorimage{colorexists{
3692 
+aload pop pop 4 array astore
3693 
+setimagecmyk
3694 
+cci1
3695 
+/magentabuf 0 string def
3696 
+/yellowbuf 0 string def
3697 
+/blackbuf 0 string def
3698 
+cci2 {magentabuf}{yellowbuf}{blackbuf}true 4 colorimage}
3699 
+{pop image}ifelse}ndf
3700 
+/separationimage{image}ndf
3701 
+/newcmykcustomcolor{6 /packedarray where{pop packedarray}{array astore readonly}ifelse}ndf
3702 
+/inkoverprint false ndf
3703 
+/setinkoverprint{pop}ndf
3704 
+/overprintprocess{pop}ndf
3705 
+/setspotcolor
3706 
+{spots exch get 0 5 getinterval exch setcustomcolor}ndf
3707 
+/currentcolortransfer{currenttransfer dup dup dup}ndf
3708 
+/setcolortransfer{systemdict begin settransfer end pop pop pop}ndf
3709 
+/getcmyk {
3710 
+dup length 4 eq
3711 
+{aload pop}
3712 
+{aload pop spots exch get 0 4 getinterval aload pop 4
3713 
+{4 index mul 4 1 roll}repeat 5 -1 roll pop} ifelse
3714 
+}bdf
3715 
+/setimagecmyk{
3716 
+getcmyk/ik xdf /iy xdf /im xdf /ic xdf
3717 
+}ndf
3718 
+/autospread{pop}ndf
3719 
+/fhsetspreadsize{pop}ndf
3720 
+/strokeopf false def
3721 
+/fillopf false def
3722 
+/R{0 ne /strokeopf xdf}bdf
3723 
+/O{0 ne /fillopf xdf}bdf
3724 
+/filler{fill}bdf
3725 
+/F{fc fhsetcolor fillopf setoverprint false autospread
3726 
+gsave /filler load fp grestore false setoverprint}bdf
3727 
+/f{closepath F}bdf
3728 
+/S{sc fhsetcolor strokeopf setoverprint true autospread {stroke}fp false setoverprint}bdf
3729 
+/s{closepath S}bdf
3730 
+/B{fc fhsetcolor fillopf setoverprint gsave /filler load fp grestore
3731 
+sc fhsetcolor strokeopf setoverprint true autospread {stroke}fp false setoverprint}bdf
3732 
+/b{closepath B}bdf
3733 
+colorexists not{/setcolorscreen {setscreen pop pop pop pop pop pop pop pop pop}bdf}if
3734 
+/fhsetcolor{dup length 4 eq
3735 
+{aload overprintprocess setcmykcolor}
3736 
+{aload 1 get spots exch get 5 get setinkoverprint setspotcolor}
3737 
+ifelse
3738 
+}ndf
3739 
+/settextcolor{dup fhsetcolor dup length 4 eq
3740 
+{onlyk{3 get 1.0 eq{true setinkoverprint}if}{pop}ifelse}
3741 
+{pop}
3742 
+ifelse
3743 
+}ndf
3744 
+/ka{/fc xdf}bdf
3745 
+/Ka{/sc xdf}bdf
3746 
+/xa{/fc xdf} bdf
3747 
+/Xa{/sc xdf} bdf
3748 
+/bc2[0 0]def
3749 
+/bc4[0 0 0 0]def
3750 
+/absmax{2 copy abs exch abs gt{exch}if pop}bdf
3751 
+/calcstep
3752 
+{ colorexists not and{calcgraysteps}{maxsteps}ifelse
3753 
+tc1 length 4 eq
3754 
+{
3755 
+0 1 3
3756 
+{tc1 1 index get
3757 
+tc2 3 -1 roll get
3758 
+sub
3759 
+}for
3760 
+absmax absmax absmax
3761 
+}
3762 
+{
3763 
+bc2 tc1 1 get 1 exch put
3764 
+tc1 gettint tc2 gettint
3765 
+sub abs
3766 
+}
3767 
+ifelse
3768 
+mul abs round dup 0 eq{pop 1}if
3769 
+dup /numsteps xdf 1 sub dup 0 eq{pop 1}if /numsteps1 xdf
3770 
+}bdf
3771 
+/cblend{
3772 
+tc1 length 4 eq
3773 
+{
3774 
+0 1 3
3775 
+{bc4 exch
3776 
+tc1 1 index get
3777 
+tc2 2 index get
3778 
+1 index sub
3779 
+frac mul add put
3780 
+}for bc4
3781 
+}
3782 
+{
3783 
+bc2
3784 
+tc1 gettint
3785 
+tc2 gettint
3786 
+1 index sub
3787 
+frac mul add
3788 
+puttint bc2
3789 
+}
3790 
+ifelse
3791 
+fhsetcolor
3792 
+}bdf
3793 
+/logtaper{/frac frac 9 mul 1 add log def}bdf
3794 
+FHIODict begin
3795 
+/origmtx matrix currentmatrix def
3796 
+/iminv false def
3797 
+/invbuf{0 1 2 index length 1 sub{dup 2 index exch get 255 exch sub 2 index 3 1 roll put}for}bdf
3798 
+/cyanrp{currentfile cyanbuf readhexstring pop iminv{invbuf}if}def
3799 
+/magentarp{cyanbuf magentabuf copy}bdf
3800 
+/yellowrp{cyanbuf yellowbuf copy}bdf
3801 
+/blackrp{cyanbuf blackbuf copy}bdf
3802 
+/fixtransfer{
3803 
+colorexists
3804 
+{fixtrans1 fixtrans2}
3805 
+{{dup 1 exch sub currentgray mul add}concatprocs
3806 
+currenttransfer exch concatprocs
3807 
+systemdict begin settransfer end}ifelse
3808 
+}ndf
3809 
+/cmykbufs2gray{
3810 
+dup length 0 1 3 -1 roll 1 sub
3811 
+{4 index 1 index get
3812 
+4 index 2 index get
3813 
+4 index 3 index get
3814 
+4 index 4 index get
3815 
+255 exch sub ccmyk ccmyk ccmyk pop 5 mul exch 45 mul add exch 14 mul add -6 bitshift
3816 
+2 index 3 1 roll put}for
3817 
+4 1 roll pop pop pop
3818 
+}bdf
3819 
+end
3820 
+/textopf false def
3821 
+/curtextmtx{}def
3822 
+/otw .25 def
3823 
+/msf{dup/curtextmtx xdf makefont setfont}bdf
3824 
+/makesetfont/msf load def
3825 
+/curtextheight{.707104 .707104 curtextmtx dtransform
3826 
+dup mul exch dup mul add sqrt}bdf
3827 
+/ta{1 index
3828 
+{tempstr 0 2 index put tempstr 2 index
3829 
+gsave exec grestore
3830 
+tempstr stringwidth rmoveto
3831 
+5 index eq{6 index 6 index rmoveto}if
3832 
+3 index 3 index rmoveto
3833 
+}forall 7{pop}repeat}bdf
3834 
+/sts{settextcolor textopf setoverprint/ts{awidthshow}def exec false setoverprint}bdf
3835 
+/stol{setlinewidth settextcolor textopf setoverprint newpath
3836 
+/ts{{false charpath stroke}ta}def exec false setoverprint}bdf
3837 
+/currentpacking where{pop false setpacking}if
3838 
+/spots[1 0 0 0 (Process Cyan) false newcmykcustomcolor
3839 
+0 1 0 0 (Process Magenta) false newcmykcustomcolor
3840 
+0 0 1 0 (Process Yellow) false newcmykcustomcolor
3841 
+0 0 0 1 (Process Black) false newcmykcustomcolor
3842 
+0 0 0 0  (White) false
3843 
+newcmykcustomcolor
3844 
+]def
3845 
+0 dict dup begin
3846 
+end
3847 
+/f0 /Symbol FF def
3848 
+[] 0 d
3849 
+3.863708 M
3850 
+1 w
3851 
+0 j
3852 
+0 J
3853 
+0 O
3854 
+0 R
3855 
+0 i
3856 
+false eomode
3857 
+[0 0 0 1] Ka
3858 
+[0 0 0 1] ka
3859 
+vms
3860 
+u
3861 
+u
3862 
+u
3863 
+u
3864 
+u
3865 
+14.7584 767.5217 m
3866 
+119.7584 767.5217 L
3867 
+119.7584 710.5217 L
3868 
+14.7584 710.5217 L
3869 
+14.7584 767.5217 L
3870 
+[0 0 0 0] ka
3871 
+2 J
3872 
+b
3873 
+U
3874 
+vmrs
3875 
+MacVec 256 array copy
3876 
+/f1 /|______Helvetica-Bold dup RF findfont def
3877 
+{
3878 
+f1 [24 0 0 24 0 0] makesetfont
3879 
+34.258438 731.021698 m
3880 
+0 0 32 0 0 (client) ts
3881 
+}
3882 
+[0 0 0 1]
3883 
+sts
3884 
+U
3885 
+u
3886 
+271.7584 767.5217 m
3887 
+376.7584 767.5217 L
3888 
+376.7584 710.5217 L
3889 
+271.7584 710.5217 L
3890 
+271.7584 767.5217 L
3891 
+[0 0 0 0] ka
3892 
+2 J
3893 
+b
3894 
+U
3895 
+vmrs
3896 
+MacVec 256 array copy
3897 
+/f1 /|______Helvetica-Bold dup RF findfont def
3898 
+{
3899 
+f1 [24 0 0 24 0 0] makesetfont
3900 
+286.258438 732.021698 m
3901 
+0 0 32 0 0 (server) ts
3902 
+}
3903 
+[0 0 0 1]
3904 
+sts
3905 
+u
3906 
+119.2584 756.0217 m
3907 
+254.2584 756.0217 L
3908 
+2 J
3909 
+S
3910 
+254.2584 756.0217 m
3911 
+254.2584 751.0217 L
3912 
+266.2584 756.0217 L
3913 
+254.2584 761.0217 L
3914 
+254.2584 756.0217 L
3915 
+f
3916 
+n
3917 
+U
3918 
+u
3919 
+271.2584 721.0217 m
3920 
+135.2584 721.0217 L
3921 
+S
3922 
+135.2584 721.0217 m
3923 
+135.2584 726.0217 L
3924 
+123.2584 721.0217 L
3925 
+135.2584 716.0217 L
3926 
+135.2584 721.0217 L
3927 
+f
3928 
+n
3929 
+U
3930 
+u
3931 
+65.2584 653.0217 m
3932 
+65.2584 694.0217 L
3933 
+S
3934 
+65.2584 694.0217 m
3935 
+70.2584 694.0217 L
3936 
+65.2584 706.0217 L
3937 
+60.2584 694.0217 L
3938 
+65.2584 694.0217 L
3939 
+f
3940 
+n
3941 
+U
3942 
+vmrs
3943 
+MacVec 256 array copy
3944 
+/f2 /|______Courier-Bold dup RF findfont def
3945 
+{
3946 
+f2 [24 0 0 24 0 0] makesetfont
3947 
+163.258438 760.021698 m
3948 
+0 0 32 0 0 (reqs) ts
3949 
+}
3950 
+[0 0 0 1]
3951 
+sts
3952 
+vmrs
3953 
+MacVec 256 array copy
3954 
+/f2 /|______Courier-Bold dup RF findfont def
3955 
+{
3956 
+f2 [24 0 0 24 0 0] makesetfont
3957 
+158.258438 705.021698 m
3958 
+0 0 32 0 0 (resps) ts
3959 
+}
3960 
+[0 0 0 1]
3961 
+sts
3962 
+vmrs
3963 
+MacVec 256 array copy
3964 
+/f2 /|______Courier-Bold dup RF findfont def
3965 
+{
3966 
+f2 [24 0 0 24 0 0] makesetfont
3967 
+38.258438 633.021698 m
3968 
+0 0 32 0 0 (init) ts
3969 
+}
3970 
+[0 0 0 1]
3971 
+sts
3972 
+U
3973 
+U
3974 
+U
3975 
+vmr
3976 
+end  % FreeHandDict
3977 
+end  % FHIODict
3978 
+%%EndDocument
3979 
+ @endspecial 106 967 a(Figure)15 b(1:)20 b(\(a\))14 b(Circular)i(Fib)q
3980 
+(onacci)h(Sequence)331 b(\(b\))15 b(Serv)o(er/Clien)o(t)h(Sim)o(ulation)0
3981 
+1093 y Fq(4)69 b(Case)23 b(Expressions)g(and)h(P)n(attern)f(Matc)n(hing)0
3982 
+1215 y Fp(Earlier)c(w)o(e)e(ga)o(v)o(e)g(sev)o(eral)h(examples)h(of)e
3983 
+(pattern)h(matc)o(hing)g(in)g(de\014ning)i(functions|for)e(example)h
3984 
+Fi(length)0 1271 y Fp(and)f Fi(fringe)o Fp(.)28 b(In)19 b(this)f(section)g(w)
3985 
+o(e)g(will)h(lo)q(ok)f(at)g(the)g(pattern-matc)o(hing)f(pro)q(cess)h(in)h(m)o
3986 
+(uc)o(h)f(greater)f(detail)0 1328 y(\()p Fn(x)p Fp(3.14\).)151
3987 
+1311 y Fm(9)71 1404 y Fp(P)o(atterns)e(are)i(not)f(\\\014rst-class;")h(there)
3988 
+g(is)h(only)f(a)g(\014xed)g(set)g(of)f(di\013eren)o(t)i(kinds)f(of)g
3989 
+(patterns.)24 b(W)l(e)17 b(ha)o(v)o(e)0 1461 y(already)c(seen)g(sev)o(eral)g
3990 
+(examples)h(of)e Fo(data)j(c)n(onstructor)e Fp(patterns;)f(b)q(oth)h
3991 
+Fi(length)f Fp(and)h Fi(fringe)f Fp(de\014ned)i(earlier)0 1517
3992 
+y(use)i(suc)o(h)h(patterns,)e(the)h(former)f(on)h(the)g(constructors)f(of)g
3993 
+(a)h(\\built-in")i(t)o(yp)q(e)e(\(lists\),)g(the)g(latter)f(on)h(a)g(user-)0
3994 
+1574 y(de\014ned)e(t)o(yp)q(e)e(\()p Fi(Tree)o Fp(\).)19 b(Indeed,)14
3995 
+b(matc)o(hing)e(is)h(p)q(ermitted)g(using)h(the)e(constructors)g(of)g(an)o(y)
3996 
+g(t)o(yp)q(e,)g(user-de\014ned)0 1630 y(or)19 b(not.)31 b(This)20
3997 
+b(includes)h(tuples,)g(strings,)f(n)o(um)o(b)q(ers,)g(c)o(haracters,)f(etc.)
3998 
+32 b(F)l(or)18 b(example,)j(here's)e(a)g(con)o(triv)o(ed)0
3999 
+1686 y(function)d(that)f(matc)o(hes)f(against)h(a)g(tuple)h(of)f(\\constan)o
4000 
+(ts:")71 1795 y Fi(contrived)22 b(::)i(\([a],)f(Char,)g(\(Int,)g(Float\),)g
4001 
+(String,)g(Bool\))g(->)h(Bool)71 1852 y(contrived)94 b(\([],)47
4002 
+b('b',)g(\(1,)71 b(2.0\),)g("hi",)g(True\))23 b(=)h(False)0
4003 
+1964 y Fp(This)16 b(example)g(also)f(demonstrates)f(that)h
4004 
+Fo(nesting)f Fp(of)g(patterns)h(is)h(p)q(ermitted)g(\(to)e(arbitrary)h
4005 
+(depth\).)71 2040 y(T)l(ec)o(hnically)21 b(sp)q(eaking,)f Fo(formal)g(p)n(ar)
4006 
+n(ameters)881 2024 y Fm(10)937 2040 y Fp(are)f(also)f(patterns|it's)h(just)f
4007 
+(that)g(they)h Fo(never)g(fail)h(to)0 2097 y(match)f(a)g(value)p
4008 
+Fp(.)28 b(As)18 b(a)f(\\side)h(e\013ect")g(of)f(the)h(successful)h(matc)o(h,)
4009 
+e(the)h(formal)g(parameter)f(is)h(b)q(ound)h(to)e(the)0 2153
4010 
+y(v)m(alue)j(it)e(is)h(b)q(eing)h(matc)o(hed)e(against.)30
4011 
+b(F)l(or)18 b(this)g(reason)h(patterns)e(in)j(an)o(y)e(one)g(equation)h(are)f
4012 
+(not)h(allo)o(w)o(ed)0 2210 y(to)14 b(ha)o(v)o(e)h(more)f(than)h(one)f(o)q
4013 
+(ccurrence)i(of)f(the)g(same)f(formal)g(parameter)g(\(a)h(prop)q(ert)o(y)f
4014 
+(called)i Fo(line)n(arity)e Fn(x)q Fp(3.14,)0 2266 y Fn(x)p
4015 
+Fp(3.2,)p Fn(x)o Fp(4.4.2\).)71 2343 y(P)o(atterns)c(suc)o(h)i(as)e(formal)h
4016 
+(parameters)g(that)g(nev)o(er)g(fail)h(to)f(matc)o(h)g(are)g(said)h(to)e(b)q
4017 
+(e)i Fo(irr)n(efutable)p Fp(,)g(in)g(con)o(trast)0 2399 y(to)g
4018 
+Fo(r)n(efutable)h Fp(patterns)f(suc)o(h)h(as)f(the)h(ones)g(giv)o(en)g(in)h
4019 
+(the)e Fi(contrived)g Fp(example)h(ab)q(o)o(v)o(e.)19 b(There)13
4020 
+b(are)g(three)f(other)p 0 2434 780 2 v 52 2461 a Fl(9)69 2477
4021 
+y Fk(P)o(attern)k(matc)o(hing)h(in)f(Hask)o(ell)h(is)f(v)o(ery)g(di\013eren)o
4022 
+(t)h(from)e(that)g(found)h(in)h(logic)g(programming)g(languages)g(suc)o(h)f
4023 
+(as)g(Prolog;)0 2522 y(in)e(particular,)h(it)e(can)g(b)q(e)h(view)o(ed)g(as)f
4024 
+(\\one-w)o(a)o(y")g(matc)o(hing,)h(whereas)g(Prolog)g(allo)o(ws)g(\\t)o(w)o
4025 
+(o-w)o(a)o(y")f(matc)o(hing)i(\(via)e(uni\014cation\),)0 2568
4026 
+y(along)h(with)g(implicit)i(bac)o(ktrac)o(king)f(in)f(its)f(ev)n(aluation)j
4027 
+(mec)o(hanism.)37 2598 y Fl(10)69 2614 y Fk(The)d(Rep)q(ort)h(calls)g(these)g
4028 
+Fe(variables)p Fk(.)p eop
4029 
+%%Page: 16 16
4030 
+bop 0 -40 a Fp(T-16)700 b Fj(4)45 b(CASE)15 b(EXPRESSIONS)i(AND)e(P)l(A)l
4031 
+(TTERN)h(MA)l(TCHING)0 105 y Fp(kinds)k(of)f(irrefutable)i(patterns,)e(t)o(w)
4032 
+o(o)g(of)g(whic)o(h)h(w)o(e)f(will)i(in)o(tro)q(duce)f(no)o(w)f(\(the)h
4033 
+(other)f(w)o(e)g(will)i(dela)o(y)f(un)o(til)0 162 y(Section)c(4.4\).)0
4034 
+308 y Fc(As-patterns.)45 b Fp(Sometimes)16 b(it)h(is)f(con)o(v)o(enien)o(t)h
4035 
+(to)e(name)h(a)g(pattern)g(for)f(use)h(on)g(the)h(righ)o(t-hand)f(side.)24
4036 
+b(F)l(or)0 365 y(example,)16 b(a)f(function)h(that)e(duplicates)j(the)e
4037 
+(\014rst)g(elemen)o(t)h(in)g(a)f(list)h(migh)o(t)f(b)q(e)h(written)f(as:)71
4038 
+474 y Fi(f)23 b(\(x:xs\))381 b(=)24 b(x:x:xs)0 585 y Fp(\(Recall)17
4039 
+b(that)d Fi(:)h Fp(asso)q(ciates)g(to)g(the)g(righ)o(t.\))k(Note)c(that)g
4040 
+Fi(x:xs)f Fp(app)q(ears)i(b)q(oth)f(as)g(a)g(pattern)g(on)g(the)g(left-hand)0
4041 
+642 y(side,)k(and)f(an)f(expression)h(on)g(the)g(righ)o(t-hand)g(side.)28
4042 
+b(T)l(o)17 b(impro)o(v)o(e)g(readabilit)o(y)l(,)j(w)o(e)d(migh)o(t)g(prefer)h
4043 
+(to)f(write)0 698 y Fi(x:xs)e Fp(just)g(once,)g(whic)o(h)h(w)o(e)f(can)g(ac)o
4044 
+(hiev)o(e)h(using)g(an)f Fo(as-p)n(attern)g Fp(as)g(follo)o(ws:)1353
4045 
+682 y Fm(11)71 807 y Fi(f)23 b(s@\(x:xs\))309 b(=)24 b(x:s)0
4046 
+919 y Fp(T)l(ec)o(hnically)17 b(sp)q(eaking,)d(as-patterns)g(alw)o(a)o(ys)f
4047 
+(result)i(in)g(a)f(successful)h(matc)o(h,)f(although)g(the)g(sub-pattern)g
4048 
+(\(in)0 975 y(this)i(case)f Fi(x:xs)o Fp(\))g(could,)h(of)f(course,)g(fail.)0
4049 
+1122 y Fc(Wild-cards.)46 b Fp(Another)12 b(common)e(situation)i(is)g(matc)o
4050 
+(hing)f(against)g(a)g(v)m(alue)h(w)o(e)f(really)i(care)e(nothing)g(ab)q(out.)
4051 
+0 1179 y(F)l(or)k(example,)g(the)h(functions)f Fi(head)g Fp(and)g
4052 
+Fi(tail)g Fp(de\014ned)i(in)f(Section)g(2.1)e(can)h(b)q(e)h(rewritten)f(as:)
4053 
+71 1288 y Fi(head)23 b(\(_:xs\))309 b(=)24 b(x)71 1344 y(tail)f(\(x:_\))333
4054 
+b(=)24 b(xs)0 1453 y Fp(in)14 b(whic)o(h)h(w)o(e)e(ha)o(v)o(e)g(\\adv)o
4055 
+(ertised")h(the)f(fact)g(that)g(w)o(e)g(don't)g(care)h(what)f(a)g(certain)h
4056 
+(part)f(of)g(the)h(input)g(is.)20 b(Eac)o(h)0 1510 y(wild-card)15
4057 
+b(will)g(indep)q(enden)o(tly)h(matc)o(h)d(an)o(ything,)h(but)f(in)h(con)o
4058 
+(trast)f(to)f(a)h(formal)g(parameter,)g(eac)o(h)h(will)h(bind)0
4059 
+1566 y(nothing;)g(for)g(this)h(reason)e(more)h(than)g(one)g(are)g(allo)o(w)o
4060 
+(ed)h(in)g(an)f(equation.)0 1713 y Fc(n)p Fi(+)p Fc(k-patterns.)45
4061 
+b Fp(There)21 b(is)h(one)f(other)f(kind)i(of)e Fo(r)n(efutable)h
4062 
+Fp(pattern)f(in)i(Hask)o(ell,)h(called)f(an)f Fo(n)p Fi(+)o
4063 
+Fo(k-p)n(attern)p Fp(,)0 1769 y(whic)o(h)15 b(is)g(useful)h(when)f(writing)g
4064 
+(inductiv)o(e)h(de\014nitions)g(o)o(v)o(er)e(in)o(tegers.)20
4065 
+b(F)l(or)13 b(example,)j(here's)e(a)g(de\014nition)i(of)0 1826
4066 
+y(an)f(in\014x)h(op)q(erator)f Fi(^)g Fp(that)f(raises)i(its)f(\014rst)g
4067 
+(argumen)o(t)f(to)h(the)g(p)q(o)o(w)o(er)g(indicated)i(b)o(y)e(the)g(second:)
4068 
+71 1935 y Fi(x)23 b(^)48 b(0)429 b(=)24 b(1)71 1991 y(x)f(^)h(\(n+1\))357
4069 
+b(=)24 b(x*\(x^n\))0 2103 y Fp(\(A)15 b(more)g(e\016cien)o(t)h(de\014nition)h
4070 
+(of)d Fi(^)h Fp(is)h(giv)o(en)g(in)g(the)f(Standard)g(Prelude.\))71
4071 
+2185 y(In)e(general,)h(the)f(pattern)g Fi(n+)p Fh(k)h Fp(matc)o(hes)f(an)o(y)
4072 
+g(in)o(teger)g(v)m(alue)i Fh(v)f Fn(\025)f Fh(k)q Fp(,)g(and)h(binds)g
4073 
+Fi(n)f Fp(to)g Fh(v)7 b Fn(\000)f Fh(k)q Fp(.)20 b(n)p Fi(+)p
4074 
+Fp(k-patterns)0 2241 y(ha)o(v)o(e)15 b(the)g(adv)m(an)o(tage)f(of)g(making)i
4075 
+(de\014nitions)g(suc)o(h)g(as)e(the)h(ab)q(o)o(v)o(e)g(lo)q(ok)g(v)o(ery)g
4076 
+(similar)h(to)e(the)h(corresp)q(onding)0 2298 y(mathematical)g(de\014nition:)
4077 
+858 2342 y Fh(x)884 2326 y Fm(0)945 2342 y Fp(=)42 b(1)809
4078 
+2399 y Fh(x)835 2382 y Fd(n)p Fm(+1)945 2399 y Fp(=)g Fh(x)10
4079 
+b Fn(\003)g Fh(x)1117 2382 y Fd(n)0 2482 y Fp(\(See)15 b Fn(x)q
4080 
+Fp(3.14)f(for)g(a)h(formal)g(translation)g(of)g(n)p Fi(+)p
4081 
+Fp(k-patterns)g(in)o(to)g(a)g(more)g(primitiv)o(e)h(form.\))p
4082 
+0 2525 780 2 v 37 2552 a Fl(11)69 2568 y Fk(Another)e(adv)n(an)o(tage)h(to)e
4083 
+(doing)i(this)g(is)f(that)f(a)h(naiv)o(e)h(implemen)o(tation)h(migh)o(t)f
4084 
+(completely)g(reconstruct)g Ff(x:xs)c Fk(rather)j(than)0 2614
4085 
+y(re-use)f(the)g(v)n(alue)i(b)q(eing)f(matc)o(hed)g(against.)p
4086 
+eop
4087 
+%%Page: 17 17
4088 
+bop 0 -40 a Fj(4.1)45 b(P)o(attern-Matc)o(hing)14 b(Seman)o(tics)1187
4089 
+b Fp(T-17)0 105 y Fg(4.1)56 b(P)n(attern-Matc)n(hing)19 b(Seman)n(tics)0
4090 
+220 y Fp(So)e(far)f(w)o(e)h(ha)o(v)o(e)f(discussed)j(ho)o(w)d(individual)k
4091 
+(patterns)c(are)h(matc)o(hed,)g(ho)o(w)f(some)h(are)f(refutable,)i(some)e
4092 
+(are)0 277 y(irrefutable,)i(etc.)26 b(But)17 b(what)g(driv)o(es)h(the)f(o)o
4093 
+(v)o(erall)g(pro)q(cess?)27 b(In)18 b(what)e(order)h(are)g(the)g(matc)o(hes)g
4094 
+(attempted?)0 333 y(What)e(if)g(none)h(succeed?)22 b(These)15
4095 
+b(are)g(the)g(questions)h(addressed)g(in)g(this)g(section.)71
4096 
+418 y(A)c(particular)g(matc)o(h)g(of)g(a)f(pattern)h(to)f(a)h(v)m(alue)i(can)
4097 
+e(actually)h(yield)g(one)g(of)e(three)h(results:)19 b Fo(failur)n(e)p
4098 
+Fp(;)13 b Fo(suc)n(c)n(ess)0 474 y Fp(\(returning)h(a)f(binding)i(for)d(eac)o
4099 
+(h)i(formal)f(parameter)f(in)i(the)g(pattern\);)f(or)f Fo(diver)n(genc)n(e)g
4100 
+Fp(\(i.e.)h(non)o(termination\).)0 531 y(The)i(matc)o(hing)h(pro)q(cess)f
4101 
+(itself)h(o)q(ccurs)g(\\top-do)o(wn,)e(left-to-righ)o(t.")20
4102 
+b(F)l(ailure)c(of)f(a)g(pattern)g(an)o(ywhere)g(in)h(one)0
4103 
+587 y(equation)c(results)g(in)g(failure)h(of)e(the)h(whole)g(equation,)h(and)
4104 
+e(the)h(next)g(equation)g(is)g(then)g(tried.)19 b(If)12 b(all)h(equations)0
4105 
+644 y(fail,)j(the)f(v)m(alue)h(of)f(the)g(function)h(application)h(is)f
4106 
+Fn(?)p Fp(,)f(and)h(results)f(in)h(a)f(run-time)h(error.)71
4107 
+728 y(F)l(or)i(example,)k(if)e Fi([1,2])e Fp(is)i(matc)o(hed)g(against)f
4108 
+Fi([0,bot])o Fp(,)h(then)g Fi(1)f Fp(fails)i(to)e(matc)o(h)g
4109 
+Fi(0)o Fp(,)i(so)e(the)g(result)h(is)0 785 y(a)f(failed)j(matc)o(h.)33
4110 
+b(But)19 b(if)i Fi([1,2])e Fp(is)h(matc)o(hed)g(against)f Fi([bot,0])o
4111 
+Fp(,)i(then)f(matc)o(hing)f Fi(1)h Fp(against)f Fi(bot)h Fp(causes)0
4112 
+841 y(div)o(ergence)c(\(i.e.)f Fn(?)p Fp(\).)71 926 y(The)d(only)h(other)f(t)
4113 
+o(wist)g(to)f(this)i(set)f(of)g(rules)h(is)g(that)e(top-lev)o(el)j(patterns)e
4114 
+(ma)o(y)f(also)i(ha)o(v)o(e)e(a)h(b)q(o)q(olean)i Fo(guar)n(d)p
4115 
+Fp(,)0 982 y(as)h(in)h(this)f(de\014nition)i(of)e(a)g(function)h(that)f
4116 
+(forms)f(an)h(abstract)f(v)o(ersion)i(of)f(a)f(n)o(um)o(b)q(er's)h(sign:)71
4117 
+1091 y Fi(sign)23 b(x)h(|)47 b(x)24 b(>)48 b(0)190 b(=)72 b(1)238
4118 
+1147 y(|)47 b(x)24 b(==)g(0)190 b(=)72 b(0)238 1204 y(|)47
4119 
+b(x)24 b(<)48 b(0)190 b(=)48 b(-1)0 1313 y Fp(Note)16 b(that)f(a)h(sequence)i
4120 
+(of)e(guards)g(ma)o(y)f(b)q(e)i(pro)o(vided)g(for)f(the)g(same)g(pattern;)g
4121 
+(as)g(with)g(patterns,)g(they)g(are)0 1370 y(ev)m(aluated)g(top-do)o(wn,)f
4122 
+(and)g(the)g(\014rst)g(that)g(ev)m(aluates)h(to)e Fi(True)h
4123 
+Fp(results)g(in)h(a)f(successful)i(matc)o(h.)0 1527 y Fg(4.2)56
4124 
+b(An)19 b(Example)0 1642 y Fp(The)i(pattern-matc)o(hing)f(rules)i(can)f(ha)o
4125 
+(v)o(e)f(subtle)h(e\013ects)g(on)f(the)h(meaning)g(of)f(functions.)37
4126 
+b(F)l(or)20 b(example,)0 1698 y(consider)c(this)g(de\014nition)h(of)e
4127 
+Fi(take)o Fp(:)71 1799 y Fi(take)47 b(0)119 b(_)262 b(=)48
4128 
+b([])71 1855 y(take)f(_)119 b([])238 b(=)48 b([])71 1912 y(take)23
4129 
+b(\(n+1\))g(\(x:xs\))166 b(=)48 b(x)24 b(:)f(take)h(n)f(xs)0
4130 
+2023 y Fp(and)15 b(this)h(sligh)o(tly)g(di\013eren)o(t)g(v)o(ersion)f(\(the)g
4131 
+(\014rst)g(2)g(equations)g(ha)o(v)o(e)g(b)q(een)i(rev)o(ersed\):)71
4132 
+2135 y Fi(take1)47 b(_)119 b([])214 b(=)48 b([])71 2191 y(take1)f(0)119
4133 
+b(_)238 b(=)48 b([])71 2248 y(take1)23 b(\(n+1\))g(\(x:xs\))142
4134 
+b(=)48 b(x)24 b(:)f(take1)h(n)f(xs)0 2357 y Fp(No)o(w)15 b(note)g(the)g
4135 
+(follo)o(wing:)698 2414 y Fi(take)47 b(0)24 b(bot)111 b Fn(\))87
4136 
+b Fi([])698 2470 y(take1)23 b(0)h(bot)111 b Fn(\))87 b(?)698
4137 
+2557 y Fi(take)47 b(bot)24 b([])87 b Fn(\))g(?)698 2613 y Fi(take1)23
4138 
+b(bot)h([])87 b Fn(\))g Fi([])p eop
4139 
+%%Page: 18 18
4140 
+bop 0 -40 a Fp(T-18)700 b Fj(4)45 b(CASE)15 b(EXPRESSIONS)i(AND)e(P)l(A)l
4141 
+(TTERN)h(MA)l(TCHING)0 105 y Fp(W)l(e)h(see)h(that)f Fi(take)g
4142 
+Fp(is)h(\\more)e(de\014ned")j(with)f(resp)q(ect)f(to)g(its)h(second)g
4143 
+(argumen)o(t,)e(whereas)i Fi(take1)e Fp(is)i(more)0 162 y(de\014ned)h(with)f
4144 
+(resp)q(ect)g(to)f(its)h(\014rst.)27 b(It)18 b(is)g(di\016cult)h(to)f(sa)o(y)
4145 
+f(in)h(this)g(case)g(whic)o(h)h(de\014nition)g(is)f(b)q(etter.)28
4146 
+b(Just)0 218 y(remem)o(b)q(er)16 b(that)f(in)i(certain)g(applications,)g(it)g
4147 
+(ma)o(y)e(mak)o(e)g(a)h(di\013erence.)24 b(\(The)15 b(Standard)h(Prelude)i
4148 
+(includes)0 274 y(a)d(de\014nition)i(corresp)q(onding)f(to)f
4149 
+Fi(take)o Fp(.\))0 423 y Fg(4.3)56 b(Case)19 b(Expressions)0
4150 
+535 y Fp(P)o(attern)d(matc)o(hing)h(pro)o(vides)g(a)g(w)o(a)o(y)e(to)i
4151 
+(\\dispatc)o(h)g(con)o(trol")f(based)h(on)g(structural)g(prop)q(erties)g(of)g
4152 
+(a)f(v)m(alue.)0 591 y(Ho)o(w)o(ev)o(er,)21 b(in)h(man)o(y)e(circumstances)i
4153 
+(w)o(e)f(don't)g(wish)g(to)f(de\014ne)j(a)d Fo(function)h Fp(ev)o(ery)g(time)
4154 
+g(w)o(e)g(need)h(to)e(do)0 648 y(this,)c(but)g(so)g(far)g(w)o(e)f(ha)o(v)o(e)
4155 
+h(only)g(sho)o(wn)g(ho)o(w)g(to)f(do)h(pattern)g(matc)o(hing)g(in)h(function)
4156 
+f(de\014nitions.)25 b(Hask)o(ell's)0 704 y Fo(c)n(ase)16 b(expr)n(ession)e
4157 
+Fp(pro)o(vides)i(a)f(w)o(a)o(y)g(to)f(solv)o(e)i(this)g(problem.)21
4158 
+b(Indeed,)c(the)f(meaning)g(of)f(pattern)g(matc)o(hing)g(in)0
4159 
+761 y(function)k(de\014nitions)i(is)e(sp)q(eci\014ed)h(in)g(the)e(Rep)q(ort)h
4160 
+(in)h(terms)e(of)g(case)g(expressions,)i(whic)o(h)f(are)g(considered)0
4161 
+817 y(more)c(primitiv)o(e.)21 b(In)16 b(particular,)f(a)g(function)h
4162 
+(de\014nition)h(of)e(the)g(form:)787 916 y Fi(f)h Fo(p)850
4163 
+923 y Fb(11)917 916 y Fh(:)8 b(:)g(:)22 b Fo(p)1017 923 y Fb(1k)1074
4164 
+916 y Fi(=)16 b Fo(e)1135 923 y Fb(1)787 973 y Fh(:)8 b(:)g(:)787
4165 
+1029 y Fi(f)16 b Fo(p)850 1036 y Fb(n1)919 1029 y Fh(:)8 b(:)g(:)22
4166 
+b Fo(p)1019 1036 y Fb(nk)1077 1029 y Fi(=)16 b Fo(e)1138 1036
4167 
+y Fb(n)0 1129 y Fp(where)f(eac)o(h)h Fo(p)257 1136 y Fb(ij)301
4168 
+1129 y Fp(is)g(a)e(pattern,)h(is)g(seman)o(tically)i(equiv)m(alen)o(t)g(to:)
4169 
+288 1232 y Fi(f)23 b(x1)h(x2)g Fh(:)8 b(:)g(:)21 b Fi(xk)j(=)g(case)f(\(x1,)
4170 
+31 b Fh(:)8 b(:)g(:)e Fi(,)23 b(xk\))h(of)c(\()p Fo(p)1240
4171 
+1239 y Fb(11)1283 1232 y Fh(;)k(:)8 b(:)g(:)d(;)24 b Fo(p)1440
4172 
+1239 y Fb(1k)1480 1232 y Fi(\))g(->)16 b Fo(e)1613 1239 y Fb(1)1193
4173 
+1288 y Fh(:)8 b(:)g(:)1193 1344 y Fi(\()p Fo(p)1240 1351 y
4174 
+Fb(n1)1285 1344 y Fh(;)24 b(:)8 b(:)g(:)d(;)24 b Fo(p)1442
4175 
+1351 y Fb(nk)1484 1344 y Fi(\))g(->)16 b Fo(e)1617 1351 y Fb(n)0
4176 
+1446 y Fp(where)f(the)g Fi(xi)f Fp(are)h(new)g(iden)o(ti\014ers.)21
4177 
+b(\(F)l(or)14 b(a)g(more)h(general)g(translation)g(that)f(includes)j(guards,)
4178 
+d(see)h Fn(x)p Fp(4.4.2.\))0 1503 y(F)l(or)g(example,)g(the)h(de\014nition)h
4179 
+(of)d Fi(take)h Fp(giv)o(en)h(earlier)g(is)f(equiv)m(alen)o(t)i(to:)71
4180 
+1612 y Fi(take)23 b(m)h(ys)357 b(=)24 b(case)f(\(m,ys\))g(of)739
4181 
+1668 y(\(0,_\))166 b(->)48 b([])739 1725 y(\(_,[]\))142 b(->)48
4182 
+b([])739 1781 y(\(n+1,x:xs\))e(->)i(x)23 b(:)h(take)f(n)h(xs)71
4183 
+1941 y Fp(A)13 b(p)q(oin)o(t)g(not)g(made)g(earlier)h(is)g(that,)f(for)f(t)o
4184 
+(yp)q(e)h(correctness,)g(the)h(t)o(yp)q(es)f(of)g(the)g(righ)o(t-hand)g
4185 
+(sides)h(of)f(a)g(case)0 1997 y(expression)h(or)e(set)h(of)f(equations)h
4186 
+(comprising)h(a)e(function)i(de\014nition)h(m)o(ust)d(all)i(b)q(e)f(the)g
4187 
+(same;)g(more)f(precisely)l(,)0 2054 y(they)j(m)o(ust)g(all)h(share)f(a)g
4188 
+(common)g(principal)i(t)o(yp)q(e.)71 2136 y(The)j(pattern-matc)o(hing)g
4189 
+(rules)g(for)g(case)g(expressions)h(are)e(the)h(same)g(as)g(w)o(e)g(ha)o(v)o
4190 
+(e)f(giv)o(en)i(for)e(function)0 2192 y(de\014nitions,)h(so)d(there)h(is)g
4191 
+(really)h(nothing)f(new)g(to)f(learn)h(here,)h(other)e(than)h(to)f(note)h
4192 
+(the)f(con)o(v)o(enience)j(that)0 2248 y(case)d(expressions)g(o\013er.)24
4193 
+b(Indeed,)19 b(there's)d(one)h(use)g(of)g(a)f(case)h(expression)h(that)e(is)h
4194 
+(so)f(common)h(that)f(it)h(has)0 2305 y(sp)q(ecial)k(syn)o(tax:)27
4195 
+b(the)19 b Fo(c)n(onditional)g(expr)n(ession)p Fp(.)31 b(In)20
4196 
+b(Hask)o(ell,)g(conditional)h(expressions)f(ha)o(v)o(e)f(the)g(familiar)0
4197 
+2361 y(form:)756 2419 y Fi(if)c Fh(e)840 2426 y Fm(1)875 2419
4198 
+y Fi(then)g Fh(e)1007 2426 y Fm(2)1042 2419 y Fi(else)g Fh(e)1174
4199 
+2426 y Fm(3)0 2503 y Fp(whic)o(h)h(is)g(really)g(short-hand)f(for:)724
4200 
+2557 y Fi(case)f Fh(e)855 2564 y Fm(1)890 2557 y Fi(of)41 b(True)48
4201 
+b(->)15 b Fh(e)1207 2564 y Fm(2)979 2613 y Fi(False)24 b(->)15
4202 
+b Fh(e)1207 2620 y Fm(3)p eop
4203 
+%%Page: 19 19
4204 
+bop 0 -40 a Fj(4.4)45 b(Lazy)15 b(P)o(atterns)1473 b Fp(T-19)0
4205 
+105 y(F)l(rom)15 b(this)g(expansion)i(it)e(should)i(b)q(e)f(clear)g(that)e
4206 
+Fh(e)900 112 y Fm(1)936 105 y Fp(m)o(ust)h(ha)o(v)o(e)g(t)o(yp)q(e)g
4207 
+Fi(Bool)o Fp(,)g(and)h Fh(e)1489 112 y Fm(2)1524 105 y Fp(and)g
4208 
+Fh(e)1634 112 y Fm(3)1669 105 y Fp(m)o(ust)f(ha)o(v)o(e)g(the)0
4209 
+162 y(same)e(\(but)g(otherwise)h(arbitrary\))e(t)o(yp)q(e.)19
4210 
+b(In)14 b(other)f(w)o(ords,)f Fi(if)p 1104 162 14 2 v 16 w(then)p
4211 
+1216 162 V 16 w(else)p 1327 162 V 29 w Fp(when)i(view)o(ed)g(as)f(a)g
4212 
+(function)h(has)0 218 y(t)o(yp)q(e)h Fi(Bool->a->a->a)n Fp(.)0
4213 
+365 y Fg(4.4)56 b(Lazy)18 b(P)n(atterns)0 476 y Fp(There)e(is)f(one)h(other)f
4214 
+(kind)h(of)f(pattern)g(allo)o(w)o(ed)h(in)g(Hask)o(ell.)21
4215 
+b(It)16 b(is)g(called)h(a)e Fo(lazy)h(p)n(attern)p Fp(,)e(and)i(has)f(the)h
4216 
+(form)0 533 y Fi(~)p Fh(pat)p Fp(.)28 b(Lazy)18 b(patterns)f(are)h
4217 
+Fo(irr)n(efutable)p Fp(:)25 b(matc)o(hing)18 b(a)f(v)m(alue)j
4218 
+Fh(v)f Fp(against)e Fi(~)p Fh(pat)h Fp(alw)o(a)o(ys)g(succeeds,)h(regardless)
4219 
+0 589 y(of)c Fh(pat)p Fp(.)20 b(Op)q(erationally)d(sp)q(eaking,)f(if)g(an)f
4220 
+(iden)o(ti\014er)i(in)f Fh(pat)f Fp(is)h(later)f(\\used")h(on)f(the)g(righ)o
4221 
+(t-hand-side,)i(it)e(will)0 646 y(b)q(e)g(b)q(ound)h(to)e(that)g(p)q(ortion)h
4222 
+(of)g(the)f(v)m(alue)i(that)f(w)o(ould)g(result)g(if)g Fh(v)h
4223 
+Fp(w)o(ere)f(to)f(successfully)j(matc)o(h)d Fh(pat)p Fp(,)h(and)g
4224 
+Fn(?)0 702 y Fp(otherwise.)71 784 y(Lazy)22 b(patterns)g(are)g(useful)i(in)f
4225 
+(con)o(texts)f(where)h(in\014nite)h(lists)g(are)e(b)q(eing)h(de\014ned)h
4226 
+(recursiv)o(ely)l(.)44 b(F)l(or)0 840 y(example,)16 b(in\014nite)h(lists)e
4227 
+(are)g(an)g(excellen)o(t)i(v)o(ehicle)g(for)e(writing)g Fo(simulation)g
4228 
+Fp(programs,)f(and)h(in)h(this)g(con)o(text)0 897 y(the)h(in\014nite)j(lists)
4229 
+e(are)f(often)g(called)i Fo(str)n(e)n(ams)p Fp(.)25 b(Consider)18
4230 
+b(the)g(simple)g(case)g(of)f(sim)o(ulating)h(the)g(in)o(teractions)0
4231 
+953 y(b)q(et)o(w)o(een)g(a)f(serv)o(er)g(pro)q(cess)h Fi(server)f
4232 
+Fp(and)g(a)h(clien)o(t)g(pro)q(cess)g Fi(client)o Fp(,)g(where)g
4233 
+Fi(client)e Fp(sends)i(a)g(sequence)g(of)0 1010 y Fo(r)n(e)n(quests)c
4234 
+Fp(to)h Fi(server)o Fp(,)g(and)g Fi(server)g Fp(replies)i(to)d(eac)o(h)i
4235 
+(request)f(with)h(some)f(kind)h(of)f Fo(r)n(esp)n(onse)p Fp(.)k(This)d
4236 
+(situation)0 1066 y(is)i(sho)o(wn)e(pictorially)j(in)f(Figure)f(1b,)g(just)g
4237 
+(as)f(w)o(e)h(did)h(with)g(the)f(Fib)q(onacci)h(example.)26
4238 
+b(\(Note)17 b(that)f Fi(client)0 1122 y Fp(also)g(tak)o(es)f(an)h(initial)i
4239 
+(message)d(as)h(argumen)o(t.\))21 b(Using)c(streams)e(to)g(sim)o(ulate)h(the)
4240 
+h(message)e(sequences,)i(the)0 1179 y(Hask)o(ell)f(co)q(de)g(corresp)q
4241 
+(onding)g(to)f(this)g(diagram)g(is:)71 1288 y Fi(reqs)500 b(=)24
4242 
+b(client)f(init)g(resps)71 1344 y(resps)476 b(=)24 b(server)f(reqs)0
4243 
+1453 y Fp(These)16 b(recursiv)o(e)f(equations)h(are)f(a)g(direct)h(lexical)h
4244 
+(transliteration)e(of)g(the)g(diagram.)71 1535 y(Let)g(us)g(further)g(assume)
4245 
+g(that)g(the)g(structure)g(of)g(the)g(serv)o(er)g(and)g(clien)o(t)i(lo)q(ok)e
4246 
+(something)h(lik)o(e)g(this:)71 1644 y Fi(client)23 b(init)g(\(resp:resps\))f
4247 
+(=)i(init)f(:)h(client)f(\(next)g(resp\))g(resps)71 1700 y(server)142
4248 
+b(\(req:reqs\))70 b(=)24 b(process)f(req)g(:)h(server)f(reqs)0
4249 
+1809 y Fp(where)18 b(w)o(e)g(assume)g(that)g Fi(next)f Fp(is)i(a)f(function)h
4250 
+(that,)f(giv)o(en)g(a)g(resp)q(onse)h(from)e(the)i(serv)o(er,)f(determines)h
4251 
+(the)0 1866 y(next)i(request,)g(and)g Fi(process)f Fp(is)h(a)g(function)g
4252 
+(that)f(pro)q(cesses)h(a)f(request)h(from)f(the)h(clien)o(t,)i(returning)e
4253 
+(an)0 1922 y(appropriate)15 b(resp)q(onse.)71 2004 y(Unfortunately)l(,)d
4254 
+(this)f(program)f(has)h(a)g(serious)h(problem:)18 b(it)12 b(will)h(not)e(pro)
4255 
+q(duce)h(an)o(y)e(output!)19 b(The)11 b(problem)0 2060 y(is)h(that)e
4256 
+Fi(client)o Fp(,)i(as)f(used)g(in)h(the)g(recursiv)o(e)g(setting)f(of)g
4257 
+Fi(reqs)f Fp(and)i Fi(resps)o Fp(,)f(attempts)g(a)f(matc)o(h)h(on)g(the)g
4258 
+(resp)q(onse)0 2117 y(list)18 b(b)q(efore)g(it)g(has)g(submitted)g(its)g
4259 
+(\014rst)f(request!)27 b(In)19 b(other)e(w)o(ords,)g(the)h(pattern)f(matc)o
4260 
+(hing)h(is)g(b)q(eing)h(done)0 2173 y(\\to)q(o)14 b(early)l(.")20
4261 
+b(One)c(w)o(a)o(y)f(to)f(\014x)h(this)h(is)g(to)e(rede\014ne)j
4262 
+Fi(client)d Fp(as)h(follo)o(ws:)71 2282 y Fi(client)23 b(init)g(resps)214
4263 
+b(=)24 b(init)f(:)h(client)f(\(next)g(\(head)g(resps\)\))g(\(tail)g(resps\))0
4264 
+2391 y Fp(Although)15 b(w)o(ork)m(able,)f(this)g(solution)h(do)q(es)g(not)e
4265 
+(read)h(as)g(w)o(ell)h(as)f(that)f(giv)o(en)i(earlier.)20 b(A)14
4266 
+b(b)q(etter)g(solution)h(is)g(to)0 2448 y(use)h(a)e(lazy)i(pattern:)71
4267 
+2557 y Fi(client)23 b(init)g(~\(resp:resps\))f(=)i(init)f(:)h(client)f
4268 
+(\(next)g(resp\))g(resps)p eop
4269 
+%%Page: 20 20
4270 
+bop 0 -40 a Fp(T-20)700 b Fj(4)45 b(CASE)15 b(EXPRESSIONS)i(AND)e(P)l(A)l
4271 
+(TTERN)h(MA)l(TCHING)0 105 y Fp(Because)22 b(lazy)h(patterns)e(are)g
4272 
+(irrefutable,)j(the)e(matc)o(h)f(will)j(immediately)f(succeed,)h(allo)o(wing)
4273 
+f(the)f(initial)0 162 y(request)17 b(to)f(b)q(e)i(\\submitted,")g(in)f(turn)g
4274 
+(allo)o(wing)h(the)f(\014rst)g(resp)q(onse)h(to)e(b)q(e)i(generated;)f(the)h
4275 
+(engine)g(is)f(no)o(w)0 218 y(\\primed,")e(and)h(the)f(recursion)h(tak)o(es)e
4276 
+(care)h(of)g(the)g(rest.)71 306 y(As)g(an)g(example)h(of)f(this)g(program)f
4277 
+(in)i(action,)f(if)h(w)o(e)f(de\014ne:)71 415 y Fi(init)476
4278 
+b(=)24 b(0)71 472 y(next)f(resp)357 b(=)24 b(resp)71 528 y(process)e(req)310
4279 
+b(=)24 b(req+1)0 637 y Fp(then)16 b(w)o(e)e(see)i(that:)485
4280 
+704 y Fi(take)24 b(10)f(reqs)73 b Fn(\))h Fi([0,1,2,3,4,5,6,7,8,9])71
4281 
+830 y Fp(The)13 b(serv)o(er/clien)o(t)h(example)g(w)o(as)e(delib)q(erately)k
4282 
+(c)o(hosen)d(to)f(demonstrate)h(a)g(t)o(ypical)h(use)f(of)g(lazy)g(patterns)0
4283 
+887 y(and)19 b(streams,)f(and)g(also)h(to)f(aid)h(the)f(user)h(in)o(terested)
4284 
+g(in)g(using)h(Hask)o(ell's)f Fo(str)n(e)n(am-b)n(ase)n(d)f(I/O)p
4285 
+Fp(,)g(in)h(whic)o(h)g(a)0 943 y(Hask)o(ell)14 b(program)f(is)g(essen)o
4286 
+(tially)i(the)f(clien)o(t,)g(with)g(the)g(op)q(erating)f(system)g(acting)h
4287 
+(as)f(serv)o(er)g(\()p Fn(x)p Fp(7\).)18 b(Although)0 1000
4288 
+y(in)d(this)g(tutorial)f(w)o(e)g(will)i(only)f(discuss)g Fo(c)n
4289 
+(ontinuation-b)n(ase)n(d)g(I/O)f Fp(\(see)g(Section)h(8\),)e(the)i
4290 
+(stream-based)f(alter-)0 1056 y(nativ)o(e)j(is)h(an)f(excellen)o(t)i(example)
4291 
+f(of)e(the)h(use)h(of)e(lazy)i(patterns)f(and)g(streams.)24
4292 
+b(Indeed,)19 b(the)e(stream-based)0 1113 y(I/O)f(example)g(in)g(the)f(Rep)q
4293 
+(ort)h(uses)f(lazy)h(patterns.)71 1201 y(As)11 b(another)g(example)i(of)e
4294 
+(the)h(use)g(of)f(lazy)h(patterns,)g(consider)h(the)e(de\014nition)j(of)d
4295 
+(Fib)q(onacci)i(giv)o(en)f(earlier:)71 1310 y Fi(fib)309 b(=)24
4296 
+b(1)g(:)g(1)f(:)h([)g(a+b)f(|)h(\(a,b\))f(<-)h(zip)f(fib)h(\(tail)f(fib\))g
4297 
+(])0 1419 y Fp(W)l(e)15 b(migh)o(t)g(try)g(rewriting)h(this)f(using)h(an)f
4298 
+(as-pattern:)71 1528 y Fi(fib@\(1:tfib\))70 b(=)23 b(1)h(:)g(1)f(:)h([)g(a+b)
4299 
+f(|)h(\(a,b\))f(<-)h(zip)f(fib)h(tfib)f(])0 1639 y Fp(This)16
4300 
+b(v)o(ersion)g(of)f Fi(fib)g Fp(has)h(the)f(\(small)h(adv)m(an)o(tage\))f(of)
4301 
+g(not)g(using)i Fi(tail)e Fp(on)g(the)h(righ)o(t-hand)g(side,)g(since)h(it)e
4302 
+(is)0 1696 y(a)o(v)m(ailable)i(in)f(\\destructured")f(form)f(on)i(the)f
4303 
+(left-hand)h(side)g(as)f Fi(tfib)o Fp(.)71 1784 y([This)f(kind)h(of)f
4304 
+(equation)g(is)h(called)h(a)e Fo(p)n(attern)h(binding)e Fp(b)q(ecause)i(it)g
4305 
+(is)f(a)g(top-lev)o(el)h(equation)g(in)g(whic)o(h)g(the)0 1840
4306 
+y(en)o(tire)k(left-hand)g(side)g(is)g(a)f(pattern;)h(i.e.)f(b)q(oth)g
4307 
+Fi(fib)g Fp(and)h Fi(tfib)e Fp(b)q(ecome)i(b)q(ound)g(within)h(the)e(scop)q
4308 
+(e)h(of)f(the)0 1897 y(declaration.])71 1985 y(No)o(w,)12 b(using)h(the)g
4309 
+(same)g(reasoning)g(w)o(e)f(did)i(earlier,)g(w)o(e)f(should)h(b)q(e)f(led)h
4310 
+(to)e(b)q(eliev)o(e)j(that)d(this)i(program)d(will)0 2041 y(not)j(generate)h
4311 
+(an)o(y)f(output.)19 b(Curiously)l(,)d(ho)o(w)o(ev)o(er,)d(it)i
4312 
+Fo(do)n(es)p Fp(,)f(and)h(the)f(reason)h(is)g(simple:)21 b(in)15
4313 
+b(Hask)o(ell,)g(pattern)0 2098 y(bindings)i(are)e(assumed)g(to)f(ha)o(v)o(e)h
4314 
+(an)f(implicit)k Fi(~)d Fp(in)h(fron)o(t)e(of)g(them,)h(re\015ecting)h(the)f
4315 
+(most)f(common)g(b)q(eha)o(vior)0 2154 y(exp)q(ected)h(of)f(pattern)g
4316 
+(bindings,)i(and)e(a)o(v)o(oiding)h(some)f(anomalous)g(situations)g(whic)o(h)
4317 
+h(are)f(b)q(ey)o(ond)h(the)f(scop)q(e)0 2211 y(of)f(this)h(tutorial.)19
4318 
+b(Th)o(us)14 b(w)o(e)f(see)h(that)e(lazy)i(patterns)f(pla)o(y)h(an)g(imp)q
4319 
+(ortan)o(t)f(role)g(in)i(Hask)o(ell,)f(if)g(only)g(implicitly)l(.)0
4320 
+2380 y Fg(4.5)56 b(Lexical)16 b(Scoping)j(and)g(Nested)f(F)-5
4321 
+b(orms)0 2501 y Fp(It)14 b(is)h(often)f(desirable)i(to)e(create)g(a)g(nested)
4322 
+h(scop)q(e)g(within)g(an)f(expression,)h(for)f(the)g(purp)q(ose)h(of)f
4323 
+(creating)h(lo)q(cal)0 2557 y(bindings)i(not)f(seen)g(elsewhere|i.e.)23
4324 
+b(some)15 b(kind)h(of)g(\\blo)q(c)o(k-structuring")g(form.)k(In)c(Hask)o(ell)
4325 
+g(there)g(are)f(t)o(w)o(o)0 2614 y(w)o(a)o(ys)f(to)h(ac)o(hiev)o(e)g(this:)p
4326 
+eop
4327 
+%%Page: 21 21
4328 
+bop 0 -40 a Fj(4.6)45 b(La)o(y)o(out)1614 b Fp(T-21)0 105 y
4329 
+Fc(Let)23 b(Expressions.)44 b Fp(Hask)o(ell's)19 b Fo(let)h(expr)n(essions)d
4330 
+Fp(are)i(useful)h(whenev)o(er)g(a)e(nested)i(set)f(of)f(bindings)j(is)f(re-)0
4331 
+162 y(quired.)h(As)15 b(a)g(simple)i(example,)e(consider:)71
4332 
+271 y Fi(let)23 b(y)71 b(=)24 b(a*b)166 327 y(f)g(x)f(=)h(\(x+y\)/y)71
4333 
+383 y(in)f(f)h(c)g(+)f(f)h(d)0 493 y Fp(The)19 b(set)g(of)f(bindings)j
4334 
+(created)e(b)o(y)g(a)g Fi(let)f Fp(expression)i(is)f Fo(mutual)r(ly)i(r)n(e)n
4335 
+(cursive)p Fp(,)e(and)g(pattern)f(bindings)j(are)0 549 y(treated)c(as)g(lazy)
4336 
+i(patterns)e(\(i.e.)27 b(they)18 b(carry)f(an)h(implicit)i
4337 
+Fi(~)p Fp(\).)27 b(The)18 b(only)g(kind)h(of)e(declarations)h(p)q(ermitted)0
4338 
+605 y(are)d Fo(typ)n(e)h(signatur)n(es)p Fp(,)e Fo(function)i(bindings)p
4339 
+Fp(,)d(and)j Fo(p)n(attern)g(bindings)p Fp(.)0 780 y Fc(Where)j(Clauses.)45
4340 
+b Fp(Sometimes)18 b(it)f(is)h(con)o(v)o(enien)o(t)g(to)e(scop)q(e)i(bindings)
4341 
+h(o)o(v)o(er)d(sev)o(eral)i(guarded)f(equations,)0 836 y(whic)o(h)f(requires)
4342 
+g(a)f Fo(wher)n(e)h(clause)p Fp(:)71 945 y Fi(f)23 b(x)h(y)48
4343 
+b(|)f(y>z)262 b(=)48 b(...)238 1001 y(|)f(y==z)238 b(=)48 b(...)238
4344 
+1058 y(|)f(y<z)262 b(=)48 b(...)643 1114 y(where)23 b(z)h(=)g(x*x)0
4345 
+1224 y Fp(Note)14 b(that)h(this)g(cannot)f(b)q(e)i(done)f(with)g(a)g
4346 
+Fi(let)f Fp(expression,)h(whic)o(h)h(only)f(scop)q(es)h(o)o(v)o(er)e(the)g
4347 
+(expression)i(whic)o(h)0 1280 y(it)f(encloses.)20 b(A)15 b
4348 
+Fi(where)f Fp(clause)h(is)g(only)g(allo)o(w)o(ed)g(at)f(the)h(top)f(lev)o(el)
4349 
+i(of)e(a)g(set)g(of)g(equations)h(or)f(case)g(expression.)0
4350 
+1336 y(The)e(same)g(prop)q(erties)g(and)g(constrain)o(ts)g(on)g(bindings)h
4351 
+(in)g Fi(let)e Fp(expressions)i(apply)g(to)e(those)h(in)g Fi(where)g
4352 
+Fp(clauses.)71 1426 y(These)k(t)o(w)o(o)f(forms)g(of)h(nested)h(scop)q(e)f
4353 
+(seem)h(v)o(ery)e(similar,)j(but)e(remem)o(b)q(er)g(that)g(a)g
4354 
+Fi(let)f Fp(expression)i(is)g(an)0 1483 y Fo(expr)n(ession)p
4355 
+Fp(,)12 b(whereas)h(a)g Fi(where)f Fp(clause)i(is)g(not|it)f(is)h(part)e(of)h
4356 
+(the)g(syn)o(tax)f(of)h(function)h(declarations)g(and)f(case)0
4357 
+1539 y(expressions.)0 1715 y Fg(4.6)56 b(La)n(y)n(out)0 1839
4358 
+y Fp(The)15 b(reader)g(ma)o(y)f(ha)o(v)o(e)h(b)q(een)g(w)o(ondering)h(ho)o(w)
4359 
+e(it)h(is)h(that)e(Hask)o(ell)h(programs)f(a)o(v)o(oid)h(the)g(use)g(of)f
4360 
+(semicolons,)0 1895 y(or)e(some)h(other)f(kind)i(of)e(line)i(terminator,)e
4361 
+(to)g(mark)g(the)h(end)g(of)g(equations,)g(declarations,)g(etc.)19
4362 
+b(F)l(or)12 b(example,)0 1952 y(consider)k(this)g Fi(let)f
4363 
+Fp(expression)h(from)e(the)h(last)g(section:)71 2061 y Fi(let)23
4364 
+b(y)71 b(=)24 b(a*b)166 2117 y(f)g(x)f(=)h(\(x+y\)/y)71 2174
4365 
+y(in)f(f)h(c)g(+)f(f)h(d)0 2283 y Fp(Ho)o(w)15 b(do)q(es)g(the)g(parser)g
4366 
+(kno)o(w)g(not)g(to)f(parse)h(this)h(as:)71 2392 y Fi(let)23
4367 
+b(y)71 b(=)24 b(a*b)g(f)166 2448 y(x)71 b(=)24 b(\(x+y\)/y)71
4368 
+2504 y(in)f(f)h(c)g(+)f(f)h(d)0 2614 y Fp(?)p eop
4369 
+%%Page: 22 22
4370 
+bop 0 -40 a Fp(T-22)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g
4371 
+(AND)f(\\OOP")71 105 y Fp(The)j(answ)o(er)f(is)i(that)e(Hask)o(ell)i(uses)f
4372 
+(a)g(t)o(w)o(o-dimensional)h(syn)o(tax)e(called)i Fo(layout)g
4373 
+Fp(that)e(essen)o(tially)j(relies)0 162 y(on)e(declarations)h(b)q(eing)h
4374 
+(\\lined)g(up)f(in)g(columns.")30 b(In)19 b(the)f(ab)q(o)o(v)o(e)g(example,)i
4375 
+(note)e(that)g Fi(y)g Fp(and)g Fi(f)g Fp(b)q(egin)i(in)0 218
4376 
+y(the)d(same)g(column.)27 b(The)17 b(rules)h(for)e(la)o(y)o(out)h(are)g(sp)q
4377 
+(elled)i(out)e(in)h(detail)g(in)g(the)f(Rep)q(ort)h(\()p Fn(x)p
4378 
+Fp(1.5,)p Fn(x)n Fp(B.4\),)f(but)g(in)0 274 y(practice,)e(use)h(of)f(la)o(y)o
4379 
+(out)f(is)i(rather)f(in)o(tuitiv)o(e.)21 b(Just)15 b(remem)o(b)q(er)h(t)o(w)o
4380 
+(o)e(things:)71 358 y(First,)j(the)g(next)g(c)o(haracter)g(follo)o(wing)h(an)
4381 
+o(y)f(of)g(the)g(k)o(eyw)o(ords)f Fi(where)p Fp(,)h Fi(let)p
4382 
+Fp(,)g(or)g Fi(of)g Fp(is)g(what)g(determines)0 415 y(the)c(starting)f
4383 
+(column)i(for)e(the)h(declarations)h(in)g(the)f(where,)g(let,)g(or)g(case)g
4384 
+(expression)g(b)q(eing)i(written)d(\(the)h(rule)0 471 y(also)i(applies)i(to)d
4385 
+Fi(where)g Fp(used)i(in)g(the)f(class)h(and)f(instance)h(declarations)f(to)g
4386 
+(b)q(e)h(de\014ned)g(in)g(Section)g(5\).)j(Th)o(us)0 528 y(w)o(e)c(can)g(b)q
4387 
+(egin)i(the)e(declarations)h(on)f(the)g(same)g(line)i(as)e(the)g(k)o(eyw)o
4388 
+(ord,)f(the)h(next)h(line,)g(etc.)71 612 y(Second,)h(just)f(b)q(e)h(sure)f
4389 
+(that)g(the)g(starting)g(column)h(is)g(further)f(to)g(the)h(righ)o(t)f(than)g
4390 
+(the)g(starting)g(column)0 668 y(asso)q(ciated)f(with)g(the)g(immediately)i
4391 
+(surrounding)f(clause)g(\(otherwise)f(it)g(w)o(ould)g(b)q(e)h(am)o
4392 
+(biguous\).)j(The)c(\\ter-)0 725 y(mination")e(of)f(a)h(declaration)g(happ)q
4393 
+(ens)h(when)f(something)g(app)q(ears)g(at)f(or)g(to)g(the)h(left)g(of)f(the)h
4394 
+(starting)f(column)0 781 y(asso)q(ciated)j(with)h(that)e(binding)k(form.)689
4395 
+765 y Fm(12)71 865 y Fp(La)o(y)o(out)e(is)h(actually)h(shorthand)f(for)g(an)g
4396 
+Fo(explicit)f Fp(grouping)i(mec)o(hanism,)g(whic)o(h)f(deserv)o(es)h(men)o
4397 
+(tion)f(b)q(e-)0 921 y(cause)e(it)h(can)f(b)q(e)h(useful)g(under)g(certain)g
4398 
+(circumstances.)21 b(The)15 b Fi(let)g Fp(example)h(ab)q(o)o(v)o(e)f(is)g
4399 
+(equiv)m(alen)o(t)i(to:)71 1030 y Fi(let)23 b({)h(y)71 b(=)24
4400 
+b(a*b;)214 1087 y(f)f(x)h(=)g(\(x+y\)/y)f(})71 1143 y(in)g(f)h(c)g(+)f(f)h(d)
4401 
+0 1252 y Fp(Note)15 b(the)h(explicit)i(curly)e(braces)g(and)g(semicolons.)22
4402 
+b(One)16 b(w)o(a)o(y)f(in)h(whic)o(h)h(this)f(explicit)h(notation)f(is)g
4403 
+(useful)g(is)0 1309 y(when)g(more)e(than)i(one)f(declaration)h(is)g(desired)g
4404 
+(on)f(a)g(line;)h(for)f(example,)h(this)f(is)h(a)f(v)m(alid)i(expression:)71
4405 
+1418 y Fi(let)23 b(y)71 b(=)24 b(a*b;)47 b(z)24 b(=)g(a/b)166
4406 
+1474 y(f)g(x)f(=)h(\(x+y\)/z)71 1531 y(in)f(f)h(c)g(+)f(f)h(d)0
4407 
+1640 y Fp(F)l(or)15 b(another)f(example)i(of)f(the)g(expansion)i(of)d(la)o(y)
4408 
+o(out)h(in)o(to)g(explicit)i(delimiters,)g(see)f Fn(x)p Fp(1.5.)71
4409 
+1724 y(The)i(use)h(of)e(la)o(y)o(out)h(greatly)g(reduces)h(the)f(syn)o
4410 
+(tactic)g(clutter)h(asso)q(ciated)f(with)h(declaration)g(lists,)g(th)o(us)0
4411 
+1780 y(enhancing)e(readabilit)o(y)l(.)k(It)15 b(is)h(easy)f(to)f(learn,)i
4412 
+(and)f(its)h(use)f(is)h(encouraged.)0 1957 y Fq(5)69 b(T)n(yp)r(e)23
4413 
+b(Classes,)f(Ov)n(erloading,)g(and)i(\\OOP")0 2087 y Fp(There)17
4414 
+b(is)g(one)f(\014nal)i(feature)e(of)g(Hask)o(ell's)h(t)o(yp)q(e)g(system)f
4415 
+(that)g(sets)g(it)h(apart)e(from)h(other)g(languages,)h(and)f(is)0
4416 
+2144 y(probably)h(the)f(most)f(inno)o(v)m(ativ)o(e)i(asp)q(ect)f(of)g(Hask)o
4417 
+(ell's)g(design.)24 b(The)16 b(kind)h(of)f(p)q(olymorphism)h(that)f(w)o(e)f
4418 
+(ha)o(v)o(e)0 2200 y(talk)o(ed)g(ab)q(out)h(so)e(far)h(is)h(commonly)f
4419 
+(called)i Fo(p)n(ar)n(ametric)f Fp(p)q(olymorphism.)21 b(There)16
4420 
+b(is)f(another)g(kind)i(called)g Fo(ad)0 2256 y(ho)n(c)c Fp(p)q(olymorphism,)
4421 
+i(b)q(etter)f(kno)o(wn)f(as)g Fo(overlo)n(ading)p Fp(.)19 b(Here)13
4422 
+b(are)h(some)f(examples)h(of)f(ad)g(ho)q(c)h(p)q(olymorphism:)68
4423 
+2382 y Fn(\017)23 b Fp(The)15 b(literals)h Fi(1)p Fp(,)f Fi(2)p
4424 
+Fp(,)f(etc.)20 b(are)15 b(often)g(used)g(to)g(represen)o(t)g(b)q(oth)g
4425 
+(\014xed)h(and)f(arbitrary)g(precision)h(in)o(tegers.)68 2480
4426 
+y Fn(\017)23 b Fp(Numeric)16 b(op)q(erators)e(suc)o(h)i(as)e
4427 
+Fi(+)h Fp(are)g(often)g(de\014ned)i(to)d(w)o(ork)h(on)g(man)o(y)f(di\013eren)
4428 
+o(t)i(kinds)g(of)f(n)o(um)o(b)q(ers.)p 0 2525 780 2 v 37 2552
4429 
+a Fl(12)69 2568 y Fk(Hask)o(ell)e(observ)o(es)g(the)f(con)o(v)o(en)o(tion)h
4430 
+(that)f(tabs)g(coun)o(t)h(as)e(8)h(blanks;)h(th)o(us)g(care)e(m)o(ust)h(b)q
4431 
+(e)g(tak)o(en)g(when)g(using)h(an)f(editor)h(whic)o(h)0 2614
4432 
+y(ma)o(y)g(observ)o(e)h(some)f(other)h(con)o(v)o(en)o(tion.)p
4433 
+eop
4434 
+%%Page: 23 23
4435 
+bop 1857 -40 a Fp(T-23)68 105 y Fn(\017)23 b Fp(The)13 b(equalit)o(y)h(op)q
4436 
+(erator)e(\()p Fi(==)g Fp(in)i(Hask)o(ell\))g(usually)g(w)o(orks)e(on)h(n)o
4437 
+(um)o(b)q(ers)g(and)h(man)o(y)e(other)h(\(but)g(not)f(all\))114
4438 
+162 y(t)o(yp)q(es.)0 264 y(Note)i(that)g(these)h(o)o(v)o(erloaded)f(b)q(eha)o
4439 
+(viors)h(are)g Fo(di\013er)n(ent)f Fp(for)g(eac)o(h)g(t)o(yp)q(e)h(\(in)g
4440 
+(fact)f(the)h(b)q(eha)o(vior)g(is)g(sometimes)0 320 y(unde\014ned,)g(or)f
4441 
+(error\),)e(whereas)i(in)g(parametric)g(p)q(olymorphism)g(the)g(t)o(yp)q(e)g
4442 
+(truly)g(do)q(es)g(not)f(matter)g(\()p Fi(fringe)n Fp(,)0 377
4443 
+y(for)f(example,)i(really)g(do)q(esn't)f(care)g(what)g(kind)h(of)f(elemen)o
4444 
+(ts)g(are)g(found)g(in)h(the)g(lea)o(v)o(es)f(of)f(a)h(tree\).)19
4445 
+b(In)13 b(Hask)o(ell,)0 433 y Fo(typ)n(e)j(classes)e Fp(pro)o(vide)i(a)e
4446 
+(structured)i(w)o(a)o(y)e(to)g(con)o(trol)h(ad)g(ho)q(c)h(p)q(olymorphism,)g
4447 
+(or)f(o)o(v)o(erloading.)71 510 y(Let's)d(start)g(with)i(a)e(simple,)j(but)e
4448 
+(imp)q(ortan)o(t,)g(example:)19 b Fo(e)n(quality)p Fp(.)g(There)14
4449 
+b(are)e(man)o(y)h(t)o(yp)q(es)g(for)f(whic)o(h)i(w)o(e)0 566
4450 
+y(w)o(ould)f(lik)o(e)h(equalit)o(y)g(de\014ned,)g(but)f(some)f(for)g(whic)o
4451 
+(h)i(w)o(e)f(w)o(ould)g(not.)18 b(F)l(or)13 b(example,)g(comparing)g(the)g
4452 
+(equalit)o(y)0 623 y(of)g(functions)g(is)h(generally)g(considered)h
4453 
+(computationally)f(in)o(tractable,)f(whereas)g(w)o(e)g(often)g(w)o(an)o(t)f
4454 
+(to)g(compare)0 679 y(t)o(w)o(o)j(lists)i(for)e(equalit)o(y)l(.)418
4455 
+663 y Fm(13)480 679 y Fp(T)l(o)h(highligh)o(t)h(the)g(issue,)g(consider)g
4456 
+(this)f(de\014nition)i(of)e(the)g(function)h Fi(elem)f Fp(whic)o(h)0
4457 
+736 y(tests)f(for)f(mem)o(b)q(ership)j(in)f(a)e(list:)71 845
4458 
+y Fi(x)23 b(`elem`)47 b([])286 b(=)24 b(False)71 901 y(x)f(`elem`)g(\(y:ys\))
4459 
+214 b(=)24 b(x==y)f(||)h(\(x)g(`elem`)f(ys\))0 1013 y Fp([F)l(or)16
4460 
+b(the)h(st)o(ylistic)h(reason)f(w)o(e)f(discussed)j(in)f(Section)g(3.1,)e(w)o
4461 
+(e)g(ha)o(v)o(e)h(c)o(hosen)g(to)g(de\014ne)h Fi(elem)e Fp(in)i(in\014x)g
4462 
+(form.)0 1069 y Fi(==)d Fp(and)g Fi(||)g Fp(are)g(the)g(in\014x)i(op)q
4463 
+(erators)d(for)g(equalit)o(y)i(and)g(logical)g(or,)e(resp)q(ectiv)o(ely)l(.])
4464 
+0 1146 y(In)o(tuitiv)o(ely)h(sp)q(eaking,)f(the)g(t)o(yp)q(e)f(of)g
4465 
+Fi(elem)g Fp(\\ough)o(t")f(to)g(b)q(e:)20 b Fi(a->[a]->Bool)n
4466 
+Fp(.)f(But)14 b(this)f(w)o(ould)h(imply)h(that)d Fi(==)0 1202
4467 
+y Fp(has)i(t)o(yp)q(e)g Fi(a->a->Bool)n Fp(,)g(ev)o(en)g(though)g(w)o(e)g
4468 
+(just)f(said)i(that)e(w)o(e)h(don't)f(exp)q(ect)i Fi(==)e Fp(to)g(b)q(e)i
4469 
+(de\014ned)g(for)e(all)i(t)o(yp)q(es.)71 1279 y(F)l(urthermore,)20
4470 
+b(as)g(w)o(e)f(ha)o(v)o(e)h(noted)g(earlier,)i(ev)o(en)e(if)h
4471 
+Fi(==)f Fo(wer)n(e)g Fp(de\014ned)h(on)f(all)h(t)o(yp)q(es,)g(comparing)f(t)o
4472 
+(w)o(o)0 1335 y(lists)e(for)e(equalit)o(y)i(is)g Fo(very)g(di\013er)n(ent)e
4473 
+Fp(from)h(comparing)g(t)o(w)o(o)f(in)o(tegers.)25 b(In)18 b(this)g(sense,)f
4474 
+(w)o(e)g(exp)q(ect)h Fi(==)f Fp(to)f(b)q(e)0 1392 y Fo(overlo)n(ade)n(d)f
4475 
+Fp(to)g(carry)f(on)i(these)f(v)m(arious)h(tasks.)71 1468 y
4476 
+Fo(T)m(yp)n(e)h(classes)f Fp(con)o(v)o(enien)o(tly)j(solv)o(e)f(b)q(oth)g(of)
4477 
+f(these)h(problems)g(b)o(y)g(allo)o(wing)h(us)f(to)f(declare)h(whic)o(h)h(t)o
4478 
+(yp)q(es)0 1525 y(are)13 b Fo(instanc)n(es)e Fp(of)i(whic)o(h)i(class,)e(and)
4479 
+h(to)f(pro)o(vide)g(de\014nitions)j(of)c(the)i(o)o(v)o(erloaded)f
4480 
+Fo(op)n(er)n(ations)g Fp(asso)q(ciated)h(with)0 1581 y(a)h(class.)20
4481 
+b(F)l(or)15 b(example,)g(let's)h(de\014ne)g(a)f(t)o(yp)q(e)g(class)h(con)o
4482 
+(taining)g(an)f(equalit)o(y)h(op)q(erator:)71 1690 y Fi(class)23
4483 
+b(Eq)g(a)h(where)118 1747 y(\(==\))429 b(::)24 b(a)g(->)f(a)h(->)g(Bool)0
4484 
+1856 y Fp(Here)18 b Fi(Eq)g Fp(is)g(the)g(name)g(of)f(the)h(class)h(b)q(eing)
4485 
+g(de\014ned,)g(and)f Fi(==)g Fp(is)g(the)g(single)h(op)q(eration)f(in)h(the)f
4486 
+(class.)28 b(This)0 1912 y(declaration)13 b(ma)o(y)f(b)q(e)h(read)g(\\a)f(t)o
4487 
+(yp)q(e)g Fi(a)h Fp(is)g(an)f(instance)i(of)e(the)h(class)f
4488 
+Fi(Eq)h Fp(if)g(there)f(is)h(an)g(\(o)o(v)o(erloaded\))f(op)q(eration)0
4489 
+1969 y Fi(==)p Fp(,)i(of)g(the)h(appropriate)g(t)o(yp)q(e,)f(de\014ned)i(on)f
4490 
+(it.")20 b(\(Note)14 b(that)g Fi(==)g Fp(is)h(only)h(de\014ned)g(on)e(pairs)h
4491 
+(of)g(ob)s(jects)f(of)g(the)0 2025 y(same)h(t)o(yp)q(e.\))71
4492 
+2102 y(The)i(constrain)o(t)f(that)h(a)f(t)o(yp)q(e)i Fi(a)e
4493 
+Fp(m)o(ust)h(b)q(e)h(an)f(instance)g(of)g(the)g(class)g Fi(Eq)g
4494 
+Fp(is)h(written)f Fi(Eq)23 b(a)p Fp(.)j(Th)o(us)17 b Fi(Eq)23
4495 
+b(a)0 2158 y Fp(is)c(not)g(a)g(t)o(yp)q(e)g(expression,)h(but)f(rather)f(it)i
4496 
+(expresses)f(a)g(constrain)o(t)f(on)h(a)g(t)o(yp)q(e,)g(and)g(is)h(called)g
4497 
+(a)f Fo(c)n(ontext)p Fp(.)0 2215 y(Con)o(texts)14 b(are)h(app)q(ended)i(to)e
4498 
+(the)g(fron)o(t)f(of)h(t)o(yp)q(e)h(expressions.)21 b(F)l(or)14
4499 
+b(example,)i(the)f(e\013ect)g(of)g(the)h(ab)q(o)o(v)o(e)f(class)0
4500 
+2271 y(declaration)h(is)g(to)e(assign)i(the)f(follo)o(wing)h(t)o(yp)q(e)f(to)
4501 
+g Fi(==)o Fp(:)71 2380 y Fi(\(==\))476 b(::)24 b(\(Eq)f(a\))h(=>)g(a)f(->)h
4502 
+(a)g(->)f(Bool)p 0 2480 780 2 v 37 2506 a Fl(13)69 2522 y Fk(The)15
4503 
+b(kind)h(of)e(equalit)o(y)j(w)o(e)d(are)h(referring)h(to)f(here)g(is)g(\\v)n
4504 
+(alue)h(equalit)o(y)m(,")h(and)e(opp)q(osed)i(to)d(the)h(\\p)q(oin)o(ter)h
4505 
+(equalit)o(y")h(found,)0 2568 y(for)f(example,)h(in)g(Lisp's)g
4506 
+Ff(eq)o Fk(.)26 b(P)o(oin)o(ter)17 b(equalit)o(y)h(is)e(not)h(referen)o
4507 
+(tially)h(transparen)o(t,)g(and)e(th)o(us)h(do)q(es)f(not)g(sit)h(w)o(ell)g
4508 
+(in)f(a)g(purely)0 2614 y(functional)f(language.)p eop
4509 
+%%Page: 24 24
4510 
+bop 0 -40 a Fp(T-24)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g
4511 
+(AND)f(\\OOP")0 105 y Fp(This)e(should)g(b)q(e)g(read,)f(\\F)l(or)f(ev)o(ery)
4512 
+i(t)o(yp)q(e)f Fi(a)g Fp(that)f(is)i(an)f(instance)h(of)f(the)g(class)h
4513 
+Fi(Eq)o Fp(,)g Fi(==)f Fp(has)g(t)o(yp)q(e)g Fi(a->a->Bool)o
4514 
+Fp(.")0 162 y(This)i(is)g(the)g(t)o(yp)q(e)f(that)g(w)o(ould)h(b)q(e)g(used)h
4515 
+(for)e Fi(==)g Fp(in)h(the)g Fi(elem)f Fp(example,)h(and)g(indeed)h(the)f
4516 
+(constrain)o(t)f(imp)q(osed)0 218 y(b)o(y)i(the)g(con)o(text)g(propagates)f
4517 
+(to)h(the)g(principal)j(t)o(yp)q(e)d(for)f Fi(elem)p Fp(:)71
4518 
+327 y Fi(elem)476 b(::)24 b(\(Eq)f(a\))h(=>)g(a)f(->)h([a])f(->)h(Bool)0
4519 
+436 y Fp(This)11 b(should)g(b)q(e)g(read,)f(\\F)l(or)g(ev)o(ery)g(t)o(yp)q(e)
4520 
+g Fi(a)g Fp(that)f(is)i(an)f(instance)h(of)f(the)g(class)g
4521 
+Fi(Eq)p Fp(,)h Fi(elem)e Fp(has)i(t)o(yp)q(e)f Fi(a->[a]->Bool)n
4522 
+Fp(.")0 493 y(This)18 b(is)f(just)g(what)f(w)o(e)h(w)o(an)o(t|it)g(expresses)
4523 
+g(the)g(fact)g(that)f Fi(elem)g Fp(is)i(not)e(de\014ned)j(on)e
4524 
+Fo(al)r(l)f Fp(t)o(yp)q(es,)i(just)e(those)0 549 y(for)f(whic)o(h)h(w)o(e)f
4525 
+(kno)o(w)f(ho)o(w)h(to)f(compare)h(its)h(elemen)o(ts)g(for)e(equalit)o(y)l(.)
4526 
+71 625 y(So)f(far)h(so)f(go)q(o)q(d.)19 b(But)14 b(ho)o(w)g(do)f(w)o(e)h(sp)q
4527 
+(ecify)h(whic)o(h)g(t)o(yp)q(es)f(are)f(instances)i(of)e(the)h(class)g
4528 
+Fi(Eq)p Fp(,)g(and)g(the)g(actual)0 682 y(b)q(eha)o(vior)i(of)f
4529 
+Fi(==)f Fp(on)i(eac)o(h)f(of)g(those)f(t)o(yp)q(es?)21 b(This)16
4530 
+b(is)g(done)f(with)h(an)f Fo(instanc)n(e)g(de)n(clar)n(ation)p
4531 
+Fp(.)k(F)l(or)c(example:)71 791 y Fi(instance)22 b(Eq)i(Int)f(where)118
4532 
+847 y(x)h(==)g(y)381 b(=)48 b(intEq)23 b(x)h(y)0 956 y Fp(The)15
4533 
+b(de\014nition)h(of)e Fi(==)g Fp(is)i(called)g(a)e Fo(metho)n(d)p
4534 
+Fp(.)20 b Fi(intEq)14 b Fp(happ)q(ens)h(to)f(b)q(e)i(the)e(primitiv)o(e)i
4535 
+(function)f(that)f(compares)0 1013 y(in)o(tegers)i(for)g(equalit)o(y)l(,)h
4536 
+(but)f(in)h(general)g(an)o(y)f(v)m(alid)h(expression)g(is)g(allo)o(w)o(ed)g
4537 
+(on)f(the)g(righ)o(t-hand)h(side,)f(just)g(as)0 1069 y(for)e(an)o(y)f(other)h
4538 
+(function)h(de\014nition.)21 b(The)15 b(o)o(v)o(erall)f(declaration)h(is)g
4539 
+(essen)o(tially)g(sa)o(ying:)k(\\The)c(t)o(yp)q(e)f Fi(Int)f
4540 
+Fp(is)i(an)0 1126 y(instance)j(of)f(the)h(class)g Fi(Eq)p Fp(,)f(and)h(here)g
4541 
+(is)g(the)g(de\014nition)h(of)e(the)h(metho)q(d)g(corresp)q(onding)g(to)f
4542 
+(the)h(op)q(eration)0 1182 y Fi(==)p Fp(.")31 b(Giv)o(en)19
4543 
+b(this)h(declaration,)g(w)o(e)f(can)g(no)o(w)f(compare)h(\014xed)h(precision)
4544 
+h(in)o(tegers)e(for)f(equalit)o(y)i(using)g Fi(==)o Fp(.)0
4545 
+1239 y(Similarly:)71 1347 y Fi(instance)i(Eq)i(Float)f(where)118
4546 
+1404 y(x)h(==)g(y)381 b(=)48 b(floatEq)23 b(x)h(y)0 1513 y
4547 
+Fp(allo)o(ws)15 b(us)h(to)e(compare)h(\015oating)g(p)q(oin)o(t)h(n)o(um)o(b)q
4548 
+(ers)f(using)h Fi(==)p Fp(.)71 1589 y(Recursiv)o(e)g(t)o(yp)q(es)f(suc)o(h)h
4549 
+(as)f Fi(Tree)f Fp(de\014ned)j(earlier)f(can)f(also)g(b)q(e)h(handled:)71
4550 
+1698 y Fi(instance)22 b(\(Eq)i(a\))f(=>)h(Eq)g(\(Tree)f(a\))g(where)118
4551 
+1755 y(Leaf)h(a)214 b(==)24 b(Leaf)f(b)239 b(=)47 b(a)24 b(==)g(b)118
4552 
+1811 y(\(Branch)f(l1)h(r1\))f(==)h(\(Branch)f(l2)g(r2\))48
4553 
+b(=)f(\(l1==l2\))23 b(&&)h(\(r1==r2\))118 1868 y(_)334 b(==)24
4554 
+b(_)358 b(=)47 b(False)0 1979 y Fp(Note)16 b(the)g(con)o(text)40
4555 
+b Fi(Eq)23 b(a)40 b Fp(in)17 b(the)g(\014rst)e(line|this)k(is)e(necessary)g
4556 
+(b)q(ecause)g(the)f(elemen)o(ts)h(in)g(the)f(lea)o(v)o(es)h(\(of)0
4557 
+2036 y(t)o(yp)q(e)e Fi(a)p Fp(\))f(are)h(compared)g(for)f(equalit)o(y)i(in)g
4558 
+(line)h(2.)i(The)c(additional)i(constrain)o(t)d(is)i(essen)o(tially)g(sa)o
4559 
+(ying)f(that)f(w)o(e)0 2092 y(can)k(compare)f(trees)g(of)g
4560 
+Fi(a)p Fp('s)g(for)g(equalit)o(y)i(as)e(long)h(as)f(w)o(e)g(kno)o(w)g(ho)o(w)
4561 
+g(to)g(compare)g Fi(a)p Fp('s)g(for)g(equalit)o(y)l(.)28 b(If)18
4562 
+b(the)0 2149 y(con)o(text)d(w)o(ere)g(omitted,)f(a)h(static)g(t)o(yp)q(e)h
4563 
+(error)e(w)o(ould)i(result.)71 2225 y(The)h(Hask)o(ell)h(Rep)q(ort,)f(esp)q
4564 
+(ecially)j(the)d(Standard)g(Prelude,)i(con)o(tains)e(a)g(w)o(ealth)g(of)f
4565 
+(useful)j(examples)e(of)0 2281 y(t)o(yp)q(e)e(classes.)21 b(Indeed,)16
4566 
+b(a)f(class)g Fi(Eq)g Fp(is)h(de\014ned)h(that)d(is)i(sligh)o(tly)g(larger)f
4567 
+(than)g(the)h(one)f(de\014ned)h(earlier:)71 2392 y Fi(class)47
4568 
+b(Eq)23 b(a)48 b(where)118 2448 y(\(==\),)23 b(\(/=\))286 b(::)24
4569 
+b(a)g(->)f(a)h(->)g(Bool)118 2504 y(x)g(/=)g(y)381 b(=)48 b(not)23
4570 
+b(\(x)h(==)g(y\))0 2614 y Fp(This)15 b(is)g(an)g(example)g(of)g(a)f(class)h
4571 
+(with)g Fo(two)g Fp(op)q(erations,)g(one)f(for)g(equalit)o(y)l(,)i(the)e
4572 
+(other)h(for)f(inequalit)o(y)l(.)21 b(It)15 b(also)p eop
4573 
+%%Page: 25 25
4574 
+bop 1857 -40 a Fp(T-25)0 105 y(demonstrates)14 b(the)h(use)g(of)f(a)h
4575 
+Fo(default)h(metho)n(d)p Fp(,)f(in)h(this)f(case)g(for)f(the)h(inequalit)o(y)
4576 
+i(op)q(eration)e Fi(/=)o Fp(.)20 b(If)15 b(a)g(metho)q(d)0
4577 
+162 y(for)k(a)f(particular)i(op)q(eration)g(is)f(omitted)h(in)g(an)f
4578 
+(instance)h(declaration,)h(then)e(the)g(default)h(one)g(de\014ned)g(in)0
4579 
+218 y(the)e(class)g(declaration,)h(if)g(it)f(exists,)g(is)h(used)f(instead.)
4580 
+29 b(F)l(or)17 b(example,)i(the)f(three)g(instances)h(of)e
4581 
+Fi(Eq)h Fp(de\014ned)0 274 y(earlier)d(will)g(w)o(ork)e(p)q(erfectly)i(w)o
4582 
+(ell)g(with)g(the)f(ab)q(o)o(v)o(e)f(class)h(declaration,)h(yielding)h(just)e
4583 
+(the)g(righ)o(t)g(de\014nition)h(of)0 331 y(inequalit)o(y)i(that)d(w)o(e)h(w)
4584 
+o(an)o(t:)k(the)c(logical)i(negation)e(of)g(equalit)o(y)l(.)71
4585 
+408 y(Hask)o(ell)j(also)f(supp)q(orts)g(a)g(notion)g(of)g Fo(class)g
4586 
+(inclusion)p Fp(.)24 b(F)l(or)17 b(example,)h(w)o(e)f(ma)o(y)f(wish)i(to)e
4587 
+(de\014ne)j(a)e(class)0 464 y Fi(Ord)f Fp(whic)o(h)g Fo(inherits)g
4588 
+Fp(all)h(of)e(the)h(op)q(erations)g(in)h(Eq,)f(but)g(in)h(addition)g(has)f(a)
4589 
+f(set)h(of)g(comparison)g(op)q(erations)0 520 y(and)f(minim)o(um)i(and)e
4590 
+(maxim)o(um)g(functions:)71 621 y Fi(class)47 b(\(Eq)23 b(a\))h(=>)f(Ord)h(a)
4591 
+47 b(where)118 677 y(\(<\),)24 b(\(<=\),)f(\(>=\),)g(\(>\))47
4592 
+b(::)24 b(a)g(->)f(a)h(->)g(Bool)118 733 y(max,)g(min)333 b(::)24
4593 
+b(a)g(->)f(a)h(->)g(a)0 845 y Fp(Note)16 b(the)g(con)o(text)f(in)i(the)f
4594 
+Fi(class)g Fp(declaration.)23 b(W)l(e)16 b(sa)o(y)f(that)h
4595 
+Fi(Eq)f Fp(is)i(a)f Fo(sup)n(er)n(class)e Fp(of)i Fi(Ord)f
4596 
+Fp(\(con)o(v)o(ersely)l(,)h Fi(Ord)0 902 y Fp(is)h(a)f Fo(sub)n(class)f
4597 
+Fp(of)g Fi(Eq)p Fp(\),)h(and)h(an)o(y)f(instance)h(of)f Fi(Ord)f
4598 
+Fp(m)o(ust)h(also)g(b)q(e)h(an)g(instance)g(of)f Fi(Eq)o Fp(.)24
4599 
+b(\(In)16 b(the)h(next)f(Section)0 958 y(w)o(e)f(giv)o(e)g(a)g(fuller)i
4600 
+(de\014nition)g(or)d Fi(Ord)h Fp(tak)o(en)g(from)f(the)i(Standard)f
4601 
+(Prelude.\))71 1035 y(One)24 b(b)q(ene\014t)h(of)e(suc)o(h)h(class)g
4602 
+(inclusions)i(is)e(shorter)f(con)o(texts:)36 b(A)24 b(t)o(yp)q(e)f
4603 
+(expression)i(for)e(a)g(function)0 1091 y(that)17 b(uses)g(op)q(erations)h
4604 
+(from)e(b)q(oth)h(the)h Fi(Eq)f Fp(and)g Fi(Ord)g Fp(classes)h(can)f(use)h
4605 
+(the)f(con)o(text)g Fi(\(Ord)23 b(a\))p Fp(,)17 b(rather)g(than)0
4606 
+1147 y Fi(\(Eq)23 b(a,)h(Ord)f(a\))p Fp(,)18 b(since)i Fi(Ord)d
4607 
+Fp(\\implies")j Fi(Eq)o Fp(.)28 b(More)18 b(imp)q(ortan)o(tly)l(,)g(metho)q
4608 
+(ds)g(for)g(sub)q(class)h(op)q(erations)f(can)0 1204 y(assume)13
4609 
+b(the)h(existence)g(of)f(metho)q(ds)g(for)g(sup)q(erclass)h(op)q(erations.)20
4610 
+b(F)l(or)12 b(example,)i(the)g Fi(Ord)f Fp(declaration)h(in)g(the)0
4611 
+1260 y(Standard)h(Prelude)i(con)o(tains)e(this)g(default)h(metho)q(d)g(for)e
4612 
+Fi(\(<\))p Fp(:)166 1364 y Fi(x)24 b(<)f(y)358 b(=)48 b(x)24
4613 
+b(<=)f(y)h(&&)g(x)f(/=)h(y)71 1518 y Fp(As)15 b(an)g(example)h(of)f(the)g
4614 
+(use)g(of)g Fi(Ord)p Fp(,)g(the)g(principal)i(t)o(yping)f(of)f
4615 
+Fi(quicksort)f Fp(de\014ned)i(in)g(Section)g(2.5.1)e(is:)71
4616 
+1629 y Fi(quicksort)356 b(::)48 b(\(Ord)23 b(a\))h(=>)f([a])h(->)f([a])0
4617 
+1738 y Fp(In)g(other)g(w)o(ords,)g Fi(quicksort)e Fp(only)j(op)q(erates)e(on)
4618 
+h(lists)g(of)f(v)m(alues)i(of)f Fo(or)n(der)n(e)n(d)f Fp(t)o(yp)q(es.)42
4619 
+b(This)24 b(t)o(yping)f(for)0 1794 y Fi(quicksort)14 b Fp(arises)h(b)q
4620 
+(ecause)h(of)f(the)h(use)f(of)g(the)g(comparison)g(op)q(erators)g
4621 
+Fi(<)g Fp(and)g Fi(>=)g Fp(in)h(its)f(de\014nition.)71 1871
4622 
+y(Hask)o(ell)21 b(also)g(p)q(ermits)g Fo(multiple)h(inheritanc)n(e)p
4623 
+Fp(,)f(since)h(classes)f(ma)o(y)f(ha)o(v)o(e)g(more)h(than)f(one)h(sup)q
4624 
+(erclass.)0 1927 y(Name)16 b(con\015icts)g(are)g(a)o(v)o(oided)g(b)o(y)f(ha)o
4625 
+(ving)h(the)g(constrain)o(t)f(that)g(a)h(particular)g(op)q(eration)g(can)g(b)
4626 
+q(e)g(a)g(mem)o(b)q(er)0 1984 y(of)f(at)f(most)h(one)g(class)h(in)g(an)o(y)e
4627 
+(giv)o(en)i(scop)q(e.)71 2060 y(Con)o(texts)e(are)h(also)g(allo)o(w)o(ed)g
4628 
+(in)h Fi(data)f Fp(declarations;)h(see)f Fn(x)p Fp(4.2.1.)0
4629 
+2198 y Fc(A)k(Di\013eren)o(t)f(P)o(ersp)q(ectiv)o(e.)44 b Fp(Before)17
4630 
+b(going)g(on)f(to)g(further)h(examples)g(of)f(the)h(use)g(of)g(t)o(yp)q(e)f
4631 
+(classes,)i(it)e(is)0 2255 y(w)o(orth)c(p)q(oin)o(ting)i(out)f(t)o(w)o(o)e
4632 
+(other)i(viewp)q(oin)o(ts)h(of)f(Hask)o(ell's)g(t)o(yp)q(e)g(classes.)20
4633 
+b(The)13 b(\014rst)g(is)g(b)o(y)g(analogy)g(to)f(ob)s(ject-)0
4634 
+2311 y(orien)o(ted)j(programming)f(\(OOP\).)h(In)g(the)g(follo)o(wing)g
4635 
+(general)h(statemen)o(t)d(ab)q(out)i(OOP)l(,)g(simply)h(substituting)0
4636 
+2368 y Fo(typ)n(e)g(class)e Fp(for)h(class,)g(and)g Fo(typ)n(e)h
4637 
+Fp(for)e(ob)s(ject,)g(yields)j(a)e(v)m(alid)i(summary)e(of)f(Hask)o(ell's)i
4638 
+(t)o(yp)q(e)f(class)h(mec)o(hanism:)71 2444 y(\\)p Fo(Classes)c
4639 
+Fp(capture)j(common)g(sets)f(of)h Fo(op)n(er)n(ations)p Fp(.)k(A)c
4640 
+(particular)g Fo(obje)n(ct)g Fp(ma)o(y)f(b)q(e)i(an)f Fo(instanc)n(e)e
4641 
+Fp(of)h(a)h(class,)0 2501 y(and)i(will)i(ha)o(v)o(e)d(a)h Fo(metho)n(d)g
4642 
+Fp(corresp)q(onding)h(to)e(eac)o(h)h(op)q(eration.)25 b(Classes)17
4643 
+b(ma)o(y)f(b)q(e)h(arranged)g(hierarc)o(hically)l(,)0 2557
4644 
+y(forming)e(notions)g(of)g Fo(sup)n(er)n(classes)e Fp(and)j
4645 
+Fo(sub)n(classes)p Fp(,)d(and)i(p)q(ermitting)h Fo(inheritanc)n(e)e
4646 
+Fp(of)h(op)q(erations/metho)q(ds.)0 2614 y(A)g Fo(default)i(metho)n(d)f
4647 
+Fp(ma)o(y)e(also)h(b)q(e)h(asso)q(ciated)g(with)f(an)g(op)q(eration.")p
4648 
+eop
4649 
+%%Page: 26 26
4650 
+bop 0 -40 a Fp(T-26)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g
4651 
+(AND)f(\\OOP")71 105 y Fp(In)h Fo(c)n(ontr)n(ast)e Fp(to)h(OOP)l(,)h(it)g
4652 
+(should)g(b)q(e)g(clear)g(that)f(t)o(yp)q(es)h(are)f(not)g(ob)s(jects,)f(and)
4653 
+i(in)g(particular)g(there)g(is)g(no)0 162 y(notion)f(of)g(an)f(ob)s(ject's)g
4654 
+(or)h(t)o(yp)q(e's)f(in)o(ternal)i(m)o(utable)f(state.)k(An)c(adv)m(an)o
4655 
+(tage)g(o)o(v)o(er)f(OOP)h(is)h(that)e(metho)q(ds)h(in)0 218
4656 
+y(Hask)o(ell)i(are)f(completely)i(t)o(yp)q(e-safe:)k(an)o(y)17
4657 
+b(attempt)e(to)h(apply)h(a)f(metho)q(d)h(to)f(a)g(v)m(alue)h(whose)g(t)o(yp)q
4658 
+(e)f(is)h(not)f(in)0 274 y(the)f(required)h(class)f(will)h(b)q(e)f(detected)h
4659 
+(at)e(compile)i(time)f(instead)g(of)f(at)g(run)o(time.)21 b(In)15
4660 
+b(other)f(w)o(ords,)g(metho)q(ds)0 331 y(are)h(not)g(\\lo)q(ok)o(ed)g(up")g
4661 
+(at)g(run)o(time)h(but)f(are)g(simply)h(passed)g(as)f(higher-order)g
4662 
+(functions.)71 428 y(A)d(di\013eren)o(t)g(p)q(ersp)q(ectiv)o(e)h(can)f(b)q(e)
4663 
+h(gotten)e(b)o(y)h(considering)h(the)f(relationship)i(b)q(et)o(w)o(een)e
4664 
+(parametric)g(and)g(ad)0 485 y(ho)q(c)k(p)q(olymorphism.)21
4665 
+b(W)l(e)16 b(ha)o(v)o(e)f(sho)o(wn)g(ho)o(w)f(parametric)i(p)q(olymorphism)g
4666 
+(is)g(useful)h(in)f(de\014ning)h(families)f(of)0 541 y(t)o(yp)q(es)c(b)o(y)f
4667 
+(univ)o(ersally)j(quan)o(tifying)e(o)o(v)o(er)f Fo(al)r(l)h
4668 
+Fp(t)o(yp)q(es.)18 b(Sometimes,)13 b(ho)o(w)o(ev)o(er,)e(that)g(univ)o(ersal)
4669 
+i(quan)o(ti\014cation)f(is)0 597 y(to)q(o)h(broad|w)o(e)h(wish)h(to)e(quan)o
4670 
+(tify)h(o)o(v)o(er)f(some)h(smaller)g(set)g(of)f(t)o(yp)q(es,)h(suc)o(h)g(as)
4671 
+g(those)g(t)o(yp)q(es)f(whose)h(elemen)o(ts)0 654 y(can)j(b)q(e)h(compared)f
4672 
+(for)f(equalit)o(y)l(.)26 b(T)o(yp)q(e)17 b(classes)h(can)f(b)q(e)h(seen)f
4673 
+(as)g(pro)o(viding)h(a)e(structured)h(w)o(a)o(y)f(to)g(do)h(just)0
4674 
+710 y(this.)j(Indeed,)c(w)o(e)f(can)g(think)g(of)f(parametric)h(p)q
4675 
+(olymorphism)h(as)e(a)h(kind)h(of)e(o)o(v)o(erloading)h(to)q(o!)k(It's)14
4676 
+b(just)h(that)0 767 y(the)k(o)o(v)o(erloading)g(o)q(ccurs)g(implicitly)j(o)o
4677 
+(v)o(er)c(all)i(t)o(yp)q(es)e(instead)i(of)e(a)h(constrained)g(set)g(of)f(t)o
4678 
+(yp)q(es)h(\(i.e.)f(a)h(t)o(yp)q(e)0 823 y(class\).)71 920
4679 
+y(In)g(the)g(remainder)h(of)e(this)h(section)h(w)o(e)f(in)o(tro)q(duce)g(the)
4680 
+g(sev)o(eral)g(prede\014ned)i Fo(standar)n(d)e Fp(t)o(yp)q(e)g(classes)g(in)0
4681 
+977 y(Hask)o(ell.)0 1176 y Fg(5.1)56 b(Equalit)n(y)17 b(and)i(Ordered)f
4682 
+(Classes)0 1310 y Fp(Hask)o(ell's)c(standard)e(classes)i(form)e(the)h
4683 
+(somewhat)f(frigh)o(tening)i(inclusion)i(structure)d(sho)o(wn)f(in)i(Figure)g
4684 
+(2.)k(A)o(t)0 1367 y(the)e(top)f(of)g(the)g(\014gure,)h(w)o(e)f(see)h
4685 
+Fi(Eq)f Fp(with)h(its)g(sub)q(class)g Fi(Ord)f Fp(b)q(elo)o(w)h(it.)21
4686 
+b(These)16 b(w)o(ere)f(de\014ned)i(in)g(the)e(previous)0 1423
4687 
+y(section.)20 b(Con)o(tin)o(uing)c(do)o(wn,)f(w)o(e)g(encoun)o(ter)g(t)o(w)o
4688 
+(o)f(sub)q(classes)j(of)d Fi(Ord)p Fp(,)h Fi(Enum)f Fp(and)i
4689 
+Fi(Ix)o Fp(.)0 1623 y Fg(5.2)56 b(En)n(umeration)17 b(and)i(Index)f(Classes)0
4690 
+1757 y Fi(Enum)13 b Fp(has)g(a)h(set)f(of)g(op)q(erations)h(that)f(underlie)i
4691 
+(the)f(syn)o(tactic)f(sugar)g(of)h(arithmetic)g(sequences;)h(for)d(example,)0
4692 
+1813 y(the)j(arithmetic)g(sequence)h(expression)f Fi([1,3..])f
4693 
+Fp(stands)h(for)f Fi(enumFromThen)22 b(1)i(3)14 b Fp(\(see)h
4694 
+Fn(x)p Fp(3.9)f(for)g(the)g(formal)0 1870 y(translation\).)29
4695 
+b(Arithmetic)20 b(sequences)f(are)g(ordered,)g(so)f(naturally)l(,)h
4696 
+Fi(Enum)f Fp(is)h(a)f(sub)q(class)i(of)e Fi(Ord)p Fp(.)29 b(W)l(e)19
4697 
+b(can)0 1926 y(no)o(w)d(see)h(that)f(arithmetic)i(sequence)f(expressions)h
4698 
+(can)f(b)q(e)g(used)g(to)f(generate)h(lists)g(of)g(an)o(y)f(t)o(yp)q(e)h
4699 
+(that)f(is)h(an)0 1983 y(instance)f(of)g Fi(Enum)o Fp(.)21
4700 
+b(This)16 b(includes)i(not)e(only)g(most)f(n)o(umeric)h(t)o(yp)q(es,)f(but)h
4701 
+(also)g Fi(Char)o Fp(,)g(so)f(that,)g(for)g(instance,)0 2039
4702 
+y Fi(['a'..'z'])g Fp(denotes)h(the)g(list)h(of)f(lo)o(w)o(er-case)f(letters)i
4703 
+(in)g(alphab)q(etical)h(order.)k(F)l(urthermore,)15 b(user-de\014ned)0
4704 
+2096 y(en)o(umerated)g(t)o(yp)q(es)h(lik)o(e)g Fi(Color)e Fp(can)i(easily)g
4705 
+(b)q(e)g(giv)o(en)f Fi(Enum)g Fp(instance)h(declarations.)21
4706 
+b(If)15 b(so:)318 2221 y Fi([Red..Violet])72 b Fn(\))h Fi([Red,)24
4707 
+b(Green,)f(Blue,)g(Indigo,)g(Violet])0 2347 y Fp(Note)13 b(that)g(suc)o(h)h
4708 
+(a)g(sequence)h(is)f Fo(arithmetic)g Fp(in)h(the)f(sense)g(that)f(the)h
4709 
+(incremen)o(t)g(b)q(et)o(w)o(een)g(v)m(alues)h(is)f(constan)o(t,)0
4710 
+2404 y(ev)o(en)i(though)f(the)g(v)m(alues)h(are)f(not)g(n)o(um)o(b)q(ers.)71
4711 
+2501 y(The)j(other)h(immediate)g(standard)f(sub)q(class)i(of)e
4712 
+Fi(Ord)g Fp(is)h Fi(Ix)p Fp(,)g(whic)o(h)g(is)g(the)g(class)g(of)f(t)o(yp)q
4713 
+(es)h(that)f(can)g(b)q(e)0 2557 y(used)d(as)g(arra)o(y)e(indices.)22
4714 
+b(Again,)15 b(it)g(is)g(natural)f(that)g Fi(Ix)h Fp(should)g(b)q(e)h(a)e(sub)
4715 
+q(class)i(of)e Fi(Ord)p Fp(,)g(since)i(w)o(e)e(exp)q(ect)i(the)0
4716 
+2614 y(elemen)o(ts)g(of)f(an)g(arra)o(y)f(to)g(ha)o(v)o(e)h(an)g(index)i
4717 
+(order.)i(W)l(e)d(deal)g(with)f(class)h Fi(Ix)e Fp(in)j(Section)f(6.9.)p
4718 
+eop
4719 
+%%Page: 27 27
4720 
+bop 0 -40 a Fj(5.3)45 b(T)l(ext)15 b(and)g(Binary)h(Classes)1267
4721 
+b Fp(T-27)793 675 y Fa(#)751 708 y(#)741 717 y(#)943 525 y(#)901
4722 
+558 y(#)891 567 y(#)1074 375 y(#)1033 409 y(#)1022 417 y(#)1093
4723 
+675 y(#)1051 708 y(#)1041 717 y(#)1187 825 y(#)1145 858 y(#)1134
4724 
+867 y(#)816 534 y(S)841 567 y(S)816 234 y(S)847 275 y(S)878
4725 
+317 y(S)909 358 y(S)940 400 y(S)953 417 y(S)1022 833 y(S)1047
4726 
+867 y(S)1041 534 y(S)1066 567 y(S)1153 684 y(S)1178 717 y(S)909
4727 
+684 y(S)934 717 y(S)546 609 y(S)577 650 y(S)608 692 y(S)627
4728 
+717 y(S)631 384 y(\023)600 425 y(\023)569 467 y(\023)549 492
4729 
+y(\023)728 234 y(\023)703 267 y(\023)703 384 y(S)728 417 y(S)1022
4730 
+923 y Fi(RealFloat)591 773 y(Integral)389 b(Floating)-473 b(RealFrac)1022
4731 
+623 y(Fractional)516 548 y(Ix)816 623 y(Real)966 473 y(Num)-279
4732 
+b(Enum)628 323 y(Ord)759 173 y(Eq)1097 323 y(Text)185 b(Binary)468
4733 
+1071 y Fp(Figure)16 b(2:)j(Hask)o(ell's)d(Standard)f(T)o(yp)q(e)g(Class)h
4734 
+(Hierarc)o(h)o(y)0 1254 y Fg(5.3)56 b(T)-5 b(ext)18 b(and)h(Binary)f(Classes)
4735 
+0 1438 y Fc(5.3.1)52 b(T)l(ext)17 b(Class)0 1622 y Fp(The)h(instances)h(of)e
4736 
+(class)h Fi(Text)f Fp(are)h(those)f(t)o(yp)q(es)h(that)f(can)h(b)q(e)g(con)o
4737 
+(v)o(erted)g(to)f(c)o(haracter)g(strings)h(\(t)o(ypically)0
4738 
+1678 y(for)e(I/O\))h(and)g(bac)o(k;)f(th)o(us,)h(this)g(class)g(pro)o(vides)g
4739 
+(op)q(erations)g(for)f(parsing)h(c)o(haracter)f(strings)g(to)g(obtain)h(the)0
4740 
+1735 y(v)m(alues)j(they)f(ma)o(y)f(represen)o(t)h(and)g(for)f(pro)q(ducing)j
4741 
+(the)e(canonical)h(textual)f(represen)o(tation)g(of)f(a)h(prin)o(table)0
4742 
+1791 y(v)m(alue.)i(As)14 b(these)g(primitiv)o(e)i(op)q(erations)e(are)g
4743 
+(somewhat)g(esoteric,)g(let's)g(b)q(egin)i(with)e(one)h(of)e(the)i
4744 
+(higher-lev)o(el)0 1848 y(functions)h(that)e(is)i(de\014ned)h(in)f(terms)e
4745 
+(of)h(them:)71 1948 y Fi(show)476 b(::)24 b(\(Text)f(a\))h(=>)f(a)h(->)g
4746 
+(String)0 2057 y Fp(Naturally)16 b(enough,)f Fi(show)f Fp(tak)o(es)h(an)o(y)f
4747 
+(v)m(alue)j(of)d(an)h(appropriate)h(t)o(yp)q(e)f(and)g(returns)g(its)g
4748 
+(represen)o(tation)h(as)e(a)0 2113 y(c)o(haracter)i(string)g(\(list)h(of)f(c)
4749 
+o(haracters\),)f(as)h(in)h Fi(show)23 b(\(2+2\))o Fp(,)16 b(whic)o(h)i
4750 
+(results)e(in)h Fi("4")p Fp(.)23 b(This)17 b(is)g(\014ne)g(as)f(far)f(as)0
4751 
+2170 y(it)h(go)q(es,)e(but)i(w)o(e)f(t)o(ypically)i(need)f(to)f(pro)q(duce)h
4752 
+(more)f(complex)h(strings)f(that)g(ma)o(y)g(ha)o(v)o(e)g(the)g(represen)o
4753 
+(tations)0 2226 y(of)g(man)o(y)g(v)m(alues)h(in)g(them,)f(as)f(in)71
4754 
+2335 y Fi("The)23 b(sum)g(of)h(")g(++)f(show)h(x)f(++)h(")g(and)f(")h(++)f
4755 
+(show)h(y)f(++)h(")g(is)f(")h(++)g(show)f(\(x+y\))g(++)h(".")0
4756 
+2444 y Fp(and)18 b(after)f(a)g(while,)j(all)f(that)e(concatenation)h(gets)f
4757 
+(to)g(b)q(e)h(a)g(bit)g(ine\016cien)o(t.)29 b(Sp)q(eci\014call)q(y)l(,)21
4758 
+b(let's)d(consider)g(a)0 2501 y(function)h(to)f(represen)o(t)g(the)g(binary)h
4759 
+(trees)f(of)g(Section)h(2.3)e(as)h(a)f(string,)i(with)f(suitable)i(markings)e
4760 
+(to)g(sho)o(w)0 2557 y(the)d(nesting)h(of)e(subtrees)i(and)f(the)g
4761 
+(separation)g(of)f(left)i(and)f(righ)o(t)g(branc)o(hes)g(\(pro)o(vided)h(the)
4762 
+f(elemen)o(t)g(t)o(yp)q(e)g(is)0 2614 y(represen)o(table)h(as)f(a)g
4763 
+(string\):)p eop
4764 
+%%Page: 28 28
4765 
+bop 0 -40 a Fp(T-28)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g
4766 
+(AND)f(\\OOP")71 160 y Fi(showTree)380 b(::)24 b(\(Text)f(a\))h(=>)f(Tree)h
4767 
+(a)f(->)h(String)71 216 y(showTree)e(\(Leaf)i(x\))166 b(=)48
4768 
+b(show)23 b(x)71 272 y(showTree)f(\(Branch)h(l)h(r\))71 b(=)48
4769 
+b("<")23 b(++)h(showTree)f(l)g(++)h("|")f(++)h(showTree)f(r)h(++)f(">")0
4770 
+382 y Fp(Because)16 b Fi(\(++\))f Fp(has)g(time)h(complexit)o(y)g(linear)h
4771 
+(in)f(the)f(length)h(of)f(its)h(left)f(argumen)o(t,)g Fi(showTree)f
4772 
+Fp(is)i(quadratic)0 438 y(in)g(the)f(size)h(of)f(the)g(tree.)71
4773 
+531 y(T)l(o)f(restore)h(linear)h(complexit)o(y)l(,)g(the)g(function)g
4774 
+Fi(shows)e Fp(is)i(pro)o(vided:)71 640 y Fi(shows)452 b(::)24
4775 
+b(\(Text)f(a\))h(=>)f(a)h(->)g(String)f(->)g(String)0 749 y(shows)15
4776 
+b Fp(tak)o(es)g(a)h(prin)o(table)h(v)m(alue)g(and)f(a)f(string)h(and)g
4777 
+(returns)g(that)f(string)h(with)g(the)g(v)m(alue's)h(represen)o(tation)0
4778 
+805 y(concatenated)f(at)g(the)g(fron)o(t.)22 b(The)16 b(second)h(argumen)o(t)
4779 
+e(serv)o(es)h(as)g(a)g(sort)f(of)h(string)g Fo(ac)n(cumulator,)h
4780 
+Fp(and)g Fi(show)0 862 y Fp(can)e(no)o(w)g(b)q(e)h(de\014ned)g(as)f
4781 
+Fi(shows)g Fp(with)g(the)h(n)o(ull)g(accum)o(ulator:)71 962
4782 
+y Fi(show)23 b(x)429 b(=)48 b(shows)23 b(x)h("")0 1071 y Fp(W)l(e)16
4783 
+b(can)g(use)g Fi(shows)f Fp(to)g(de\014ne)i(a)e(more)g(e\016cien)o(t)i(v)o
4784 
+(ersion)f(of)f Fi(showTree)o Fp(,)h(whic)o(h)g(also)g(has)f(a)h(string)g
4785 
+(accum)o(u-)0 1128 y(lator)f(argumen)o(t:)71 1237 y Fi(showsTree)356
4786 
+b(::)24 b(\(Text)f(a\))h(=>)f(Tree)h(a)f(->)h(String)f(->)h(String)71
4787 
+1293 y(showsTree)e(\(Leaf)h(x\))h(s)95 b(=)48 b(shows)23 b(x)h(s)71
4788 
+1349 y(showsTree)e(\(Branch)h(l)h(r\))f(s=)48 b('<')23 b(:)h(showsTree)f(l)g
4789 
+(\('|')h(:)f(showsTree)g(r)h(\('>')f(:)h(s\)\))0 1461 y Fp(This)16
4790 
+b(solv)o(es)f(our)g(e\016ciency)i(problem)f(\()p Fi(showsTree)e
4791 
+Fp(has)h(linear)h(complexit)o(y\),)g(but)f(the)g(presen)o(tation)h(of)f(this)
4792 
+0 1518 y(function)h(\(and)f(others)g(lik)o(e)h(it\))f(can)h(b)q(e)g(impro)o
4793 
+(v)o(ed.)k(First,)14 b(let's)h(create)g(a)g(t)o(yp)q(e)g(synon)o(ym:)71
4794 
+1629 y Fi(type)23 b(ShowS)333 b(=)48 b(String)23 b(->)h(String)0
4795 
+1738 y Fp(This)d(is)f(the)g(t)o(yp)q(e)g(of)g(a)f(function)i(that)f(returns)f
4796 
+(a)h(string)g(represen)o(tation)g(of)g(something)g(follo)o(w)o(ed)g(b)o(y)g
4797 
+(an)0 1795 y(accum)o(ulator)15 b(string.)21 b(Second,)c(w)o(e)e(can)h(a)o(v)o
4798 
+(oid)f(carrying)h(accum)o(ulators)f(around,)g(and)h(also)g(a)o(v)o(oid)f
4799 
+(amassing)0 1851 y(paren)o(theses)g(at)g(the)g(righ)o(t)g(end)h(of)f(long)g
4800 
+(constructions,)g(b)o(y)g(using)h(functional)h(comp)q(osition:)71
4801 
+1960 y Fi(showsTree)356 b(::)24 b(\(Text)f(a\))h(=>)f(Tree)h(a)f(->)h(ShowS)
4802 
+71 2016 y(showsTree)e(\(Leaf)h(x\))143 b(=)48 b(shows)23 b(x)71
4803 
+2073 y(showsTree)f(\(Branch)h(l)h(r\))47 b(=)h(\('<':\))23
4804 
+b(.)h(showsTree)e(l)i(.)g(\('|':\))f(.)h(showsTree)e(r)i(.)g(\('>':\))0
4805 
+2182 y Fp(Something)16 b(more)g(imp)q(ortan)o(t)g(than)f(just)h(tidying)h(up)
4806 
+f(the)g(co)q(de)h(has)f(come)g(ab)q(out)f(b)o(y)h(this)h(transformation:)0
4807 
+2238 y(W)l(e)f(ha)o(v)o(e)f(raised)h(the)g(presen)o(tation)g(from)e(an)i
4808 
+Fo(obje)n(ct)g(level)f Fp(\(in)h(this)g(case,)g(strings\))f(to)g(a)g
4809 
+Fo(function)h(level.)21 b Fp(W)l(e)0 2295 y(can)16 b(think)h(of)e(the)h(t)o
4810 
+(yping)h(as)e(sa)o(ying)h(that)f Fi(showsTree)g Fp(maps)h(a)f(tree)h(in)o(to)
4811 
+g(a)g Fo(showing)g(function)p Fp(.)22 b(F)l(unctions)0 2351
4812 
+y(lik)o(e)16 b Fi(\('<')23 b(:\))14 b Fp(or)g Fi(\("a)23 b(string")g(++\))14
4813 
+b Fp(are)g(primitiv)o(e)i(sho)o(wing)e(functions,)h(and)g(w)o(e)f(build)i(up)
4814 
+f(more)f(complex)0 2408 y(functions)i(b)o(y)f(comp)q(osition.)71
4815 
+2501 y(No)o(w)i(that)g(w)o(e)h(can)g(turn)g(trees)g(in)o(to)g(strings,)g
4816 
+(let's)g(turn)g(to)g(the)g(in)o(v)o(erse)g(problem.)30 b(The)18
4817 
+b(basic)h(idea)f(is)0 2557 y(a)g Fo(p)n(arser)h Fp(for)f(a)g(t)o(yp)q(e)h
4818 
+Fi(a)p Fp(,)g(whic)o(h)g(is)h(a)e(function)h(that)f(tak)o(es)g(a)h(string)f
4819 
+(and)h(returns)f(a)h(list)g(of)g Fi(\(a,)k(String\))0 2614
4820 
+y Fp(pairs[7].)c(The)d(Standard)f(Prelude)h(pro)o(vides)g(a)f(t)o(yp)q(e)g
4821 
+(synon)o(ym)g(for)f(suc)o(h)i(functions:)p eop
4822 
+%%Page: 29 29
4823 
+bop 0 -40 a Fj(5.3)45 b(T)l(ext)15 b(and)g(Binary)h(Classes)1267
4824 
+b Fp(T-29)71 160 y Fi(type)23 b(ReadS)g(a)286 b(=)48 b(String)23
4825 
+b(->)h([\(a,String\)])0 269 y Fp(Normally)l(,)13 b(a)f(parser)f(returns)h(a)g
4826 
+(singleton)h(list,)g(con)o(taining)f(a)g(v)m(alue)h(of)f(t)o(yp)q(e)g
4827 
+Fi(a)f Fp(that)h(w)o(as)f(read)h(from)f(the)h(input)0 325 y(string)g(and)g
4828 
+(the)g(remaining)i(string)e(that)f(follo)o(ws)h(what)g(w)o(as)f(parsed.)19
4829 
+b(If)12 b(no)g(parse)g(w)o(as)f(p)q(ossible,)j(ho)o(w)o(ev)o(er,)e(the)0
4830 
+382 y(result)k(is)h(the)f(empt)o(y)f(list,)i(and)f(if)g(there)g(is)g(more)g
4831 
+(than)g(one)g(p)q(ossible)h(parse)f(\(an)f(am)o(biguit)o(y\),)h(the)g
4832 
+(resulting)0 438 y(list)e(con)o(tains)g(more)f(than)g(one)h(pair.)20
4833 
+b(The)14 b(standard)f(function)h Fi(reads)f Fp(is)h(a)f(parser)g(for)g(an)o
4834 
+(y)g(instance)i(of)e Fi(Text)o Fp(:)71 547 y Fi(reads)452 b(::)24
4835 
+b(\(Text)f(a\))h(=>)f(ReadS)g(a)0 656 y Fp(W)l(e)16 b(can)h(use)g(this)f
4836 
+(function)i(to)d(de\014ne)j(a)e(parsing)g(function)i(for)d(the)i(string)f
4837 
+(represen)o(tation)g(of)g(binary)h(trees)0 713 y(pro)q(duced)k(b)o(y)f
4838 
+Fi(showsTree)n Fp(.)34 b(List)21 b(comprehensions)g(giv)o(e)f(us)g(a)f(con)o
4839 
+(v)o(enien)o(t)h(idiom)h(for)f(constructing)g(suc)o(h)0 769
4840 
+y(parsers:)71 878 y Fi(readsTree)356 b(::)24 b(\(Text)f(a\))h(=>)f(ReadS)g
4841 
+(\(Tree)h(a\))71 934 y(readsTree)e(\('<':s\))166 b(=)48 b([\(Branch)23
4842 
+b(l)g(r,)h(u\))g(|)f(\(l,)h('|':t\))f(<-)g(readsTree)g(s,)1168
4843 
+991 y(\(r,)h('>':u\))f(<-)g(readsTree)g(t)h(])71 1047 y(readsTree)e(s)310
4844 
+b(=)48 b([\(Leaf)23 b(x,)h(t\))119 b(|)23 b(\(x,t\))143 b(<-)23
4845 
+b(reads)h(s])0 1156 y Fp(Let's)19 b(tak)o(e)f(a)g(momen)o(t)g(to)h(examine)g
4846 
+(this)h(function)f(de\014nition)i(in)f(detail.)31 b(There)20
4847 
+b(are)e(t)o(w)o(o)g(main)h(cases)g(to)0 1213 y(consider:)i(If)15
4848 
+b(the)g(\014rst)g(c)o(haracter)f(of)h(the)g(string)g(to)f(b)q(e)i(parsed)f
4849 
+(is)g Fi('<')p Fp(,)g(w)o(e)f(should)i(ha)o(v)o(e)f(the)g(represen)o(tation)0
4850 
+1269 y(of)e(a)g(branc)o(h;)g(otherwise,)h(w)o(e)f(ha)o(v)o(e)f(a)h(leaf.)20
4851 
+b(In)14 b(the)f(\014rst)g(case,)g(calling)i(the)e(rest)g(of)g(the)g(input)h
4852 
+(string)f(follo)o(wing)0 1326 y(the)j(op)q(ening)h(angle)f(brac)o(k)o(et)f
4853 
+Fi(s)p Fp(,)g(an)o(y)h(p)q(ossible)h(parse)f(m)o(ust)f(b)q(e)h(a)f(tree)h
4854 
+Fi(Branch)23 b(l)h(r)15 b Fp(with)h(remaining)h(string)0 1382
4855 
+y Fi(u)p Fp(,)e(sub)s(ject)g(to)f(the)i(follo)o(wing)f(conditions:)56
4856 
+1510 y(1.)22 b(The)15 b(tree)g Fi(l)g Fp(can)g(b)q(e)h(parsed)g(from)e(the)h
4857 
+(b)q(eginning)j(of)c(the)i(string)f Fi(s)p Fp(.)56 1611 y(2.)22
4858 
+b(The)14 b(string)f(remaining)i(\(follo)o(wing)f(the)g(represen)o(tation)g
4859 
+(of)f Fi(l)p Fp(\))g(b)q(egins)i(with)g Fi('|')o Fp(.)k(Call)c(the)f(tail)g
4860 
+(of)g(this)114 1668 y(string)h Fi(t)p Fp(.)56 1769 y(3.)22
4861 
+b(The)15 b(tree)g Fi(r)g Fp(can)g(b)q(e)h(parsed)g(from)e(the)h(b)q(eginning)
4862 
+j(of)c Fi(t)p Fp(.)56 1870 y(4.)22 b(The)15 b(string)g(remaining)h(from)f
4863 
+Fo(that)h Fp(parse)f(b)q(egins)h(with)g Fi('>')o Fp(,)f(and)h
4864 
+Fi(u)f Fp(is)g(the)h(tail.)0 1997 y(Notice)e(the)f(expressiv)o(e)h(p)q(o)o(w)
4865 
+o(er)f(w)o(e)g(get)g(from)g(the)g(com)o(bination)h(of)f(pattern)g(matc)o
4866 
+(hing)g(with)h(list)g(comprehen-)0 2054 y(sion:)22 b(The)16
4867 
+b(form)f(of)h(a)f(resulting)i(parse)f(is)g(giv)o(en)h(b)o(y)f(the)g(main)g
4868 
+(expression)h(of)e(the)h(list)h(comprehension,)g(the)0 2110
4869 
+y(\014rst)d(t)o(w)o(o)e(conditions)k(ab)q(o)o(v)o(e)d(are)h(expressed)h(b)o
4870 
+(y)f(the)g(\014rst)f(generator)h(\(\\)p Fi(\(l,)22 b('|':t\))14
4871 
+b Fp(is)g(dra)o(wn)g(from)f(the)h(list)0 2167 y(of)h(parses)g(of)g
4872 
+Fi(s)o Fp(."\),)f(and)i(the)f(remaining)h(conditions)h(are)d(expressed)i(b)o
4873 
+(y)f(the)h(second)f(generator.)71 2252 y(The)e(second)g(de\014ning)h
4874 
+(equation)f(ab)q(o)o(v)o(e)f(just)h(sa)o(ys)f(that)g(to)g(parse)g(the)h
4875 
+(represen)o(tation)g(of)f(a)g(leaf,)i(w)o(e)e(parse)0 2308
4876 
+y(a)k(represen)o(tation)g(of)f(the)i(elemen)o(t)f(t)o(yp)q(e)h(of)e(the)h
4877 
+(tree)g(and)h(apply)f(the)h(constructor)e Fi(Leaf)g Fp(to)h(the)g(v)m(alue)h
4878 
+(th)o(us)0 2365 y(obtained.)71 2450 y(W)l(e'll)f(accept)h(on)e(faith)h(for)g
4879 
+(the)g(momen)o(t)f(that)g(there)h(is)h(a)e Fi(Text)g Fp(instance)i(of)f
4880 
+Fi(Int)f Fp(\(among)g(man)o(y)g(other)0 2506 y(t)o(yp)q(es\),)g(pro)o(viding)
4881 
+h(a)f Fi(reads)f Fp(that)g(b)q(eha)o(v)o(es)i(as)f(one)g(w)o(ould)h(exp)q
4882 
+(ect,)f(e.g.:)115 2614 y Fi(\(reads)23 b("5)h(golden)f(rings"\))g(::)h
4883 
+([\(Int,String\)])71 b Fn(\))j Fi([\(5,)23 b(")h(golden)f(rings"\)])p
4884 
+eop
4885 
+%%Page: 30 30
4886 
+bop 0 -40 a Fp(T-30)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g
4887 
+(AND)f(\\OOP")0 105 y Fp(With)g(this)h(understanding,)g(the)f(reader)g
4888 
+(should)i(v)o(erify)e(the)g(follo)o(wing)h(ev)m(aluations:)21
4889 
+194 y Fi(readsTree)22 b("<1|<2|3>>")101 b Fn(\))i Fi([\(Branch)22
4890 
+b(\(Leaf)i(1\))f(\(Branch)g(\(Leaf)g(2\))h(\(Leaf)f(3\)\),)g(""\)])21
4891 
+251 y(readsTree)f("<1|2")221 b Fn(\))103 b Fi([])71 362 y Fp(Because)19
4892 
+b(the)g(textual)g(represen)o(tation)f(w)o(e)h(ha)o(v)o(e)f(c)o(hosen)h(for)f
4893 
+(trees)h(is)g(unam)o(biguous,)h Fi(readsTree)d Fp(will)0 418
4894 
+y(alw)o(a)o(ys)11 b(return)g(either)h(a)f(singleton)i(list)f(or)f(an)g(empt)o
4895 
+(y)g(list,)i(pro)o(vided)f(that)f(the)g(represen)o(tation)h(of)f(the)g
4896 
+(elemen)o(t)0 474 y(t)o(yp)q(e)k(is)g(also)f(unam)o(biguous.)21
4897 
+b(Supp)q(ose,)15 b(ho)o(w)o(ev)o(er,)f(that)f(w)o(e)i(w)o(ere)f(to)g(c)o
4898 
+(hange)h(our)f(textual)h(represen)o(tation)f(of)0 531 y(trees)h(to)g(omit)g
4899 
+(the)g(angle)h(brac)o(k)o(ets:)71 640 y Fi(readsTree)22 b(s)310
4900 
+b(=)48 b([\(Branch)23 b(l)g(r,)h(u\))g(|)f(\(l,)h('|':t\))f(<-)g(readsTree)g
4901 
+(s,)1168 696 y(\(r,)h(u\))119 b(<-)23 b(readsTree)g(t)h(])715
4902 
+753 y(++)715 809 y([\(Leaf)f(x,)h(t\))119 b(|)23 b(\(x,t\))143
4903 
+b(<-)23 b(reads)h(s])0 921 y Fp(\(The)16 b Fi(\(++\))g Fp(here)h(can)g(b)q(e)
4904 
+g(though)o(t)e(of)h(as)g(a)h(list)g(analogue)f(of)g(set)h(union;)g(that)f
4905 
+(is,)h(the)g(tree)f(parses)g(of)g Fi(s)g Fp(are)0 977 y(all)g(its)g(parses)f
4906 
+(as)f(a)h(branc)o(h)h(plus)g(all)g(its)f(parses)g(as)g(a)g(leaf.\))20
4907 
+b(No)o(w,)14 b(w)o(e)h(see)h(that:)51 1069 y Fi(readsTree)22
4908 
+b("1|2|3")102 b Fn(\))g Fi([\(Branch)23 b(\(Branch)g(\(Leaf)g(1\))h(\(Leaf)f
4909 
+(2\)\))g(\(Leaf)g(3\),)h(""\),)730 1125 y(\(Branch)f(\(Leaf)g(1\))h(\(Branch)
4910 
+f(\(Leaf)g(2\))g(\(Leaf)g(3\)\),)h(""\)])71 1236 y Fp(Returning)15
4911 
+b(to)f(our)g(unam)o(biguous)h(represen)o(tation,)f(there)h(are)f(a)g(couple)h
4912 
+(of)f(shortcomings)g(to)g(deal)h(with.)0 1293 y(One)g(is)g(that)e(the)h
4913 
+(parser)g(is)h(quite)g(rigid,)g(allo)o(wing)g(no)f(white)h(space)f(b)q(efore)
4914 
+h(or)e(b)q(et)o(w)o(een)i(the)f(elemen)o(ts)h(of)f(the)0 1349
4915 
+y(tree)i(represen)o(tation;)h(the)f(other)g(is)h(that)e(the)i(w)o(a)o(y)e(w)o
4916 
+(e)h(parse)g(our)g(punctuation)h(sym)o(b)q(ols)g(is)g(quite)g(di\013eren)o(t)
4917 
+0 1406 y(from)10 b(the)g(w)o(a)o(y)g(w)o(e)g(parse)h(leaf)g(v)m(alues)g(and)g
4918 
+(subtrees,)g(this)g(lac)o(k)g(of)f(uniformit)o(y)h(making)g(the)g(function)g
4919 
+(de\014nition)0 1462 y(harder)16 b(to)g(read.)23 b(W)l(e)17
4920 
+b(can)f(address)h(b)q(oth)f(of)g(these)h(problems)g(b)o(y)f(using)h(the)g
4921 
+(lexical)h(analyzer)f(pro)o(vided)g(b)o(y)0 1519 y(the)e(Standard)g(Prelude:)
4922 
+71 1619 y Fi(lex)500 b(::)24 b(ReadS)f(String)0 1728 y(lex)c
4923 
+Fp(normally)i(returns)f(a)f(singleton)i(list)g(con)o(taining)g(a)e(pair)i(of)
4924 
+e(strings:)30 b(the)20 b(\014rst)f(lexeme)i(in)g(the)f(input)0
4925 
+1784 y(string)d(and)g(the)g(remainder)g(of)g(the)g(input.)26
4926 
+b(The)17 b(lexical)i(rules)e(are)g(those)f(of)h(Hask)o(ell)g(programs,)f
4927 
+(including)0 1841 y(commen)o(ts,)h(whic)o(h)g Fi(lex)g Fp(skips,)h(along)f
4928 
+(with)g(whitespace.)26 b(If)18 b(the)f(input)h(string)f(is)g(empt)o(y)g(or)f
4929 
+(con)o(tains)h(only)0 1897 y(whitespace)e(and)f(commen)o(ts,)f
4930 
+Fi(lex)h Fp(returns)g Fi([\("",""\)])o Fp(;)g(if)g(the)g(input)h(is)g(not)e
4931 
+(empt)o(y)h(in)h(this)f(sense,)h(but)f(also)0 1954 y(do)q(es)i(not)e(b)q
4932 
+(egin)j(with)e(a)g(v)m(alid)i(lexeme)f(after)f(an)o(y)g(leading)h(whitespace)
4933 
+g(and)g(commen)o(ts,)e Fi(lex)h Fp(returns)g Fi([])o Fp(.)71
4934 
+2032 y(Using)g(the)h(lexical)h(analyzer,)e(our)g(tree)g(parser)g(no)o(w)g(lo)
4935 
+q(oks)g(lik)o(e)h(this:)71 2141 y Fi(readsTree)356 b(::)24
4936 
+b(\(Text)f(a\))h(=>)f(ReadS)g(\(Tree)h(a\))71 2197 y(readsTree)e(s)310
4937 
+b(=)48 b([\(Branch)23 b(l)g(r,)h(x\))g(|)f(\("<",)g(t\))h(<-)g(lex)f(s,)1168
4938 
+2254 y(\(l,)71 b(u\))24 b(<-)g(readsTree)e(t,)1168 2310 y(\("|",)h(v\))h(<-)g
4939 
+(lex)f(u,)1168 2367 y(\(r,)71 b(w\))24 b(<-)g(readsTree)e(v,)1168
4940 
+2423 y(\(">",)h(x\))h(<-)g(lex)f(w)215 b(])715 2480 y(++)715
4941 
+2536 y([\(Leaf)23 b(x,)h(t\))119 b(|)23 b(\(x,)71 b(t\))24
4942 
+b(<-)g(reads)f(s)167 b(])p eop
4943 
+%%Page: 31 31
4944 
+bop 0 -40 a Fj(5.4)45 b(Deriv)o(ed)15 b(Instances)1402 b Fp(T-31)71
4945 
+105 y(W)l(e)10 b(ma)o(y)g(no)o(w)h(wish)g(to)f(use)h Fi(readsTree)f
4946 
+Fp(and)h Fi(showsTree)e Fp(to)h(declare)i Fi(\(Text)23 b(a\))h(=>)g(Tree)f(a)
4947 
+10 b Fp(an)h(instance)0 162 y(of)18 b Fi(Text)o Fp(.)30 b(This)19
4948 
+b(w)o(ould)f(allo)o(w)h(us)f(to)g(use)h(the)f(generic)h(o)o(v)o(erloaded)g
4949 
+(functions)g(from)e(the)i(Prelude)g(to)f(parse)0 218 y(and)c(displa)o(y)g
4950 
+(trees.)19 b(Moreo)o(v)o(er,)12 b(w)o(e)i(w)o(ould)g(automatically)f(then)h
4951 
+(b)q(e)g(able)h(to)e(parse)g(and)h(displa)o(y)g(man)o(y)f(other)0
4952 
+274 y(t)o(yp)q(es)k(con)o(taining)g(trees)f(as)g(comp)q(onen)o(ts,)h(for)f
4953 
+(example,)h Fi([Tree)23 b(Int])p Fp(.)h(As)16 b(it)h(turns)f(out,)g
4954 
+Fi(readsTree)g Fp(and)0 331 y Fi(showsTree)c Fp(are)h(of)h(almost)f(the)g
4955 
+(righ)o(t)h(t)o(yp)q(es)f(to)g(b)q(e)h Fi(Text)f Fp(metho)q(ds,)h(needing)h
4956 
+(only)f(the)f(addition)i(of)e(an)h(extra)0 387 y(parameter)f(eac)o(h)g(that)g
4957 
+(has)g(do)h(do)f(with)h(paren)o(thesization)g(of)f(forms)g(with)h(in\014x)h
4958 
+(constructors.)j(W)l(e)c(refer)f(the)0 444 y(in)o(terested)j(reader)f(to)f
4959 
+Fn(x)q Fp(E.2)g(for)h(details.)71 527 y(W)l(e)i(can)g(test)f(suc)o(h)h(a)g
4960 
+Fi(Text)f Fp(instance)i(b)o(y)f(applying)h Fi(\(read)24 b(.)f(show\))16
4961 
+b Fp(\(whic)o(h)i(should)g(b)q(e)g(the)f(iden)o(tit)o(y\))0
4962 
+584 y(to)e(some)f(trees,)h(where)g Fi(read)g Fp(is)h(a)f(sp)q(ecialization)i
4963 
+(of)e Fi(reads)p Fp(:)71 693 y Fi(read)476 b(::)24 b(\(Text)f(a\))h(=>)f
4964 
+(String)g(->)h(a)0 802 y Fp(This)c(function)g(fails)h(if)f(there)f(is)h(not)f
4965 
+(a)g(unique)i(parse)f(or)f(if)h(the)f(input)i(con)o(tains)e(an)o(ything)h
4966 
+(more)f(than)g(a)0 858 y(represen)o(tation)c(of)g(one)g(v)m(alue)i(of)e(t)o
4967 
+(yp)q(e)g Fi(a)g Fp(\(and)g(p)q(ossibly)l(,)h(commen)o(ts)f(and)g
4968 
+(whitespace\).)0 1010 y Fc(5.3.2)52 b(Binary)17 b(Class)0 1123
4969 
+y Fp(The)e Fi(Binary)f Fp(class)i(is)f(similar)h(to)f Fi(Text)o
4970 
+Fp(,)g(but)g(uses)g(a)g(primitiv)o(e)h(abstract)e(t)o(yp)q(e)h
4971 
+Fi(Bin)g Fp(instead)g(of)g Fi(String)o Fp(,)g(the)0 1180 y(purp)q(ose)f(of)g
4972 
+(whic)o(h)g(is)h(e\016cien)o(t)f(transparen)o(t)f(I/O.)h(\(See)g
4973 
+Fn(x)p Fp(7.\))19 b(Generally)l(,)c(only)f(deriv)o(ed)h(instances)f(of)g
4974 
+Fi(Binary)0 1236 y Fp(are)22 b(used)g(\(see)g(b)q(elo)o(w\),)h(whic)o(h)g
4975 
+(generate)e(implemen)o(tation-de\014ned)k(op)q(erations)d Fi(readBin)f
4976 
+Fp(and)h Fi(showBin)0 1293 y Fp(\(analogous)15 b(to)f Fi(reads)h
4977 
+Fp(and)g Fi(shows)o Fp(\).)0 1446 y Fg(5.4)56 b(Deriv)n(ed)17
4978 
+b(Instances)0 1560 y Fp(Recall)12 b(the)f Fi(Eq)f Fp(instance)i(for)e(trees)g
4979 
+(w)o(e)h(presen)o(ted)g(in)g(Section)h(5;)f(suc)o(h)g(a)g(declaration)g(is)g
4980 
+(simple|and)i(b)q(oring|)0 1616 y(to)f(pro)q(duce:)20 b(W)l(e)12
4981 
+b(require)i(that)e(the)h(elemen)o(t)g(t)o(yp)q(e)g(in)h(the)e(lea)o(v)o(es)h
4982 
+(b)q(e)h(an)e(equalit)o(y)i(t)o(yp)q(e;)f(then,)g(t)o(w)o(o)e(lea)o(v)o(es)i
4983 
+(are)0 1673 y(equal)18 b(i\013)f(they)h(con)o(tain)f(equal)h(elemen)o(ts,)g
4984 
+(and)f(t)o(w)o(o)f(branc)o(hes)i(are)f(equal)h(i\013)f(their)h(left)f(and)h
4985 
+(righ)o(t)f(subtrees)0 1729 y(are)e(equal,)g(resp)q(ectiv)o(ely)l(.)22
4986 
+b(An)o(y)15 b(other)g(t)o(w)o(o)f(trees)h(are)g(unequal:)71
4987 
+1838 y Fi(instance)46 b(\(Eq)24 b(a\))f(=>)h(Eq)f(\(Tree)h(a\))47
4988 
+b(where)166 1895 y(\(Leaf)23 b(x\))119 b(==)24 b(\(Leaf)f(y\))191
4989 
+b(=)47 b(x)24 b(==)g(y)166 1951 y(\(Branch)f(l)h(r\))f(==)h(\(Branch)f(l')g
4990 
+(r'\))48 b(=)f(l)24 b(==)g(l')f(&&)h(r)f(==)h(r')166 2008 y(_)286
4991 
+b(==)24 b(_)358 b(=)47 b(False)71 2168 y Fp(F)l(ortunately)l(,)13
4992 
+b(w)o(e)g(don't)g(need)i(to)e(go)g(through)g(this)h(tedium)g(ev)o(ery)g(time)
4993 
+g(w)o(e)f(need)i(equalit)o(y)f(op)q(erators)f(for)0 2225 y(a)f(new)i(t)o(yp)q
4994 
+(e;)f(the)g Fi(Eq)f Fp(instance)i(can)f(b)q(e)g Fo(derive)n(d)h(automatic)n
4995 
+(al)r(ly)g Fp(from)e(the)h Fi(data)f Fp(declaration)i(if)f(w)o(e)g(so)f(sp)q
4996 
+(ecify:)71 2335 y Fi(data)47 b(Tree)23 b(a)286 b(=)48 b(Leaf)23
4997 
+b(a)h(|)g(Branch)f(\(Tree)g(a\))g(\(Tree)h(a\))47 b(deriving)23
4998 
+b(Eq)0 2444 y Fp(The)16 b Fi(deriving)e Fp(clause)i(implicitly)i(pro)q(duces)
4999 
+e(an)g Fi(Eq)f Fp(instance)h(declaration)g(just)f(lik)o(e)h(the)g(one)f(in)h
5000 
+(Section)h(5.)0 2501 y(Instances)d(of)f Fi(Ord)o Fp(,)h Fi(Enum)o
5001 
+Fp(,)g Fi(Ix)o Fp(,)g Fi(Text)o Fp(,)f(and)h Fi(Binary)e Fp(can)i(also)f(b)q
5002 
+(e)h(generated)g(b)o(y)f(the)h Fi(deriving)e Fp(clause.)20
5003 
+b([More)0 2557 y(than)d(one)g(class)h(name)f(can)h(b)q(e)g(sp)q(eci\014ed,)h
5004 
+(in)f(whic)o(h)g(case)f(the)h(list)g(of)f(names)g(m)o(ust)f(b)q(e)i(paren)o
5005 
+(thesized)h(and)0 2614 y(the)c(names,)g(separated)g(b)o(y)g(commas.])p
5006 
+eop
5007 
+%%Page: 32 32
5008 
+bop 0 -40 a Fp(T-32)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g
5009 
+(AND)f(\\OOP")71 105 y Fp(The)g(deriv)o(ed)h Fi(Ord)f Fp(instance)h(for)f
5010 
+Fi(Tree)f Fp(is)i(sligh)o(tly)g(more)f(complicated)h(than)g(the)f
5011 
+Fi(Eq)g Fp(instance:)71 215 y Fi(instance)46 b(\(Ord)24 b(a\))f(=>)h(Ord)f
5012 
+(\(Tree)g(a\))48 b(where)166 272 y(\(Leaf)23 b(_\))119 b(<=)24
5013 
+b(\(Branch)f(_\))143 b(=)47 b(True)166 328 y(\(Leaf)23 b(x\))119
5014 
+b(<=)24 b(\(Leaf)f(y\))191 b(=)47 b(x)24 b(<=)g(y)166 385 y(\(Branch)f(_\))71
5015 
+b(<=)24 b(\(Leaf)f(_\))191 b(=)47 b(False)166 441 y(\(Branch)23
5016 
+b(l)h(r\))f(<=)h(\(Branch)f(l')g(r'\))48 b(=)f(l)24 b(==)g(l')f(&&)h(r)f(<=)h
5017 
+(r')g(||)f(l)h(<=)g(l')0 550 y Fp(This)17 b(sp)q(eci\014es)i(a)d
5018 
+Fo(lexic)n(o)n(gr)n(aphic)g Fp(order:)23 b(Constructors)15
5019 
+b(are)i(ordered)g(b)o(y)f(the)h(order)f(of)h(their)g(app)q(earance)g(in)0
5020 
+607 y(the)f Fi(data)g Fp(declaration,)h(and)g(the)f(argumen)o(ts)g(of)g(a)g
5021 
+(constructor)f(are)i(compared)f(from)g(left)g(to)g(righ)o(t.)23
5022 
+b(Recall)0 663 y(that)16 b(the)g(built-in)j(list)e(t)o(yp)q(e)g(is)g(seman)o
5023 
+(tically)g(equiv)m(alen)o(t)h(to)e(an)g(ordinary)h(t)o(w)o(o-constructor)d(t)
5024 
+o(yp)q(e.)24 b(In)17 b(fact,)0 720 y(this)f(is)f(the)h(full)g(declaration:)71
5025 
+820 y Fi(data)23 b([a])190 b(=)24 b([])g(|)f(a)h(:)g([a])f(deriving)g(\(Eq,)g
5026 
+(Ord,)h(Binary\))118 b(--)24 b(pseudocode)0 931 y Fp(\(Lists)16
5027 
+b(also)f(ha)o(v)o(e)g(a)g Fi(Text)g Fp(instance,)h(whic)o(h)g(is)g(not)f
5028 
+(deriv)o(ed.\))21 b(The)15 b(deriv)o(ed)i Fi(Eq)e Fp(and)g
5029 
+Fi(Ord)g Fp(instances)h(for)f(lists)0 988 y(are)e(the)h(usual)h(ones;)f(in)g
5030 
+(particular,)h(c)o(haracter)e(strings,)h(as)f(lists)h(of)g(c)o(haracters,)f
5031 
+(are)g(ordered)h(as)g(determined)0 1044 y(b)o(y)20 b(the)g(underlying)j
5032 
+Fi(Char)c Fp(t)o(yp)q(e,)i(with)g(an)f(initial)i(substring)f(comparing)f
5033 
+(less)h(than)f(a)g(longer)g(string;)j(for)0 1101 y(example,)16
5034 
+b Fi("cat")23 b(<)h("catalog")n Fp(.)71 1194 y(In)11 b(practice,)h
5035 
+Fi(Eq)f Fp(and)g Fi(Ord)f Fp(instances)i(are)f(almost)f(alw)o(a)o(ys)g(deriv)
5036 
+o(ed,)j(rather)d(than)h(user-de\014ned.)20 b(In)11 b(fact,)g(w)o(e)0
5037 
+1250 y(should)16 b(pro)o(vide)f(our)f(o)o(wn)g(de\014nitions)i(of)e(equalit)o
5038 
+(y)i(and)e(ordering)h(predicates)g(only)g(with)g(some)g(trepidation,)0
5039 
+1307 y(b)q(eing)i(careful)g(to)e(main)o(tain)h(the)g(exp)q(ected)h(algebraic)
5040 
+g(prop)q(erties)f(of)f(equiv)m(alence)k(relations)d(and)g(partial)g(or)0
5041 
+1363 y(total)h(orders.)28 b(An)19 b(in)o(transitiv)o(e)f Fi(\(==\))g
5042 
+Fp(predicate,)h(for)e(example,)i(could)h(b)q(e)e(disastrous,)g(confusing)h
5043 
+(readers)0 1420 y(of)f(the)g(program)f(and)h(confounding)h(man)o(ual)g(or)e
5044 
+(automatic)h(program)f(transformations)g(that)g(rely)i(on)f(the)0
5045 
+1476 y Fi(\(==\))i Fp(predicate's)h(b)q(eing)h(an)f(appro)o(ximation)f(to)g
5046 
+(de\014nitional)j(equalit)o(y)l(.)37 b(Nev)o(ertheless,)23
5047 
+b(it)e(is)g(sometimes)0 1533 y(necessary)16 b(to)f(pro)o(vide)h
5048 
+Fi(Eq)f Fp(or)g Fi(Ord)h Fp(instances)g(di\013eren)o(t)g(from)f(those)g(that)
5049 
+g(w)o(ould)h(b)q(e)g(deriv)o(ed;)h(probably)f(the)0 1589 y(most)h(imp)q
5050 
+(ortan)o(t)h(example)h(is)f(that)g(of)f(an)h(abstract)f(data)h(t)o(yp)q(e)g
5051 
+(in)h(whic)o(h)g(di\013eren)o(t)f(concrete)g(v)m(alues)i(ma)o(y)0
5052 
+1645 y(represen)o(t)15 b(the)g(same)g(abstract)g(v)m(alue.)71
5053 
+1738 y(An)h(en)o(umerated)g(t)o(yp)q(e)g(can)g(ha)o(v)o(e)f(a)h(deriv)o(ed)h
5054 
+Fi(Enum)e Fp(instance,)i(and)f(here)g(again,)g(the)g(ordering)g(is)g(that)f
5055 
+(of)0 1795 y(the)g(constructors)g(in)h(the)f Fi(data)g Fp(declaration.)20
5056 
+b(F)l(or)15 b(example:)71 1904 y Fi(data)23 b(Day)g(=)h(Sunday)f(|)h(Monday)f
5057 
+(|)h(Tuesday)f(|)g(Wednesday)285 1960 y(|)h(Thursday)f(|)h(Friday)f(|)g
5058 
+(Saturday)214 b(deriving)23 b(\(Eq,)g(Ord,)g(Enum\))272 2099
5059 
+y([Wednesday..Friday])141 b Fn(\))72 b Fi([Wednesday,)22 b(Thursday,)h
5060 
+(Friday])272 2156 y([Monday,)g(Wednesday)f(..])72 b Fn(\))g
5061 
+Fi([Monday,)23 b(Wednesday,)f(Friday])71 2295 y Fp(An)17 b(en)o(umerated)g(t)
5062 
+o(yp)q(e)h(or)e(tuple)i(\(single-constructor\))g(t)o(yp)q(e)f(all)h(of)f
5063 
+(whose)g(comp)q(onen)o(t)g(t)o(yp)q(es)g(ha)o(v)o(e)g Fi(Ix)0
5064 
+2351 y Fp(instances)f(can)f(ha)o(v)o(e)g(a)g(deriv)o(ed)h Fi(Ix)f
5065 
+Fp(instance.)21 b(\(See)15 b(Section)h Fn(x)q Fp(6.9.\))71
5066 
+2444 y(Deriv)o(ed)j Fi(Text)f Fp(instances)i(are)e(p)q(ossible)i(for)f(en)o
5067 
+(umerated)g(t)o(yp)q(es)f(and)h(other)g(t)o(yp)q(es)f(all)i(of)e(whose)h
5068 
+(com-)0 2501 y(p)q(onen)o(t)g(t)o(yp)q(es)f(also)g(ha)o(v)o(e)g
5069 
+Fi(Text)g Fp(instances.)30 b(\()p Fi(Text)17 b Fp(instances)i(for)f(most)f
5070 
+(of)h(the)g(standard)g(t)o(yp)q(es,)h(but)f(not)0 2557 y(functions,)d(are)f
5071 
+(pro)o(vided)h(b)o(y)f(the)h(Standard)f(Prelude.\))21 b(The)14
5072 
+b(textual)h(represen)o(tation)f(de\014ned)i(b)o(y)e(a)g(deriv)o(ed)0
5073 
+2614 y Fi(Text)21 b Fp(instance)h(is)f(consisten)o(t)h(with)f(the)h(app)q
5074 
+(earance)f(of)g(constan)o(t)g(Hask)o(ell)h(expressions)g(of)f(the)g(t)o(yp)q
5075 
+(e)g(in)p eop
5076 
+%%Page: 33 33
5077 
+bop 0 -40 a Fj(5.5)45 b(Num)o(b)q(ers)1575 b Fp(T-33)0 105
5078 
+y(question.)20 b(F)l(or)15 b(example,)h(if)f(w)o(e)g(add)h
5079 
+Fi(Text)e Fp(to)h(the)g Fi(deriving)f Fp(clause)i(for)f(t)o(yp)q(e)g
5080 
+Fi(Day)p Fp(,)f(ab)q(o)o(v)o(e,)h(w)o(e)g(obtain)259 209 y
5081 
+Fi(show)23 b([Monday..Wednesday])71 b Fn(\))i Fi
5082 
+("[Monday,Tuesday,Wednesday]")0 361 y Fg(5.5)56 b(Num)n(b)r(ers)0
5083 
+474 y Fp(Hask)o(ell)21 b(pro)o(vides)f(a)g(ric)o(h)g(collection)i(of)d(n)o
5084 
+(umeric)i(t)o(yp)q(es,)f(based)h(on)e(those)h(of)f(Sc)o(heme[5],)i(whic)o(h)f
5085 
+(in)h(turn)0 530 y(are)15 b(based)h(on)f(Common)g(Lisp[6)q(].)20
5086 
+b(\(Those)15 b(languages,)g(ho)o(w)o(ev)o(er,)g(are)g(dynamically)i(t)o(yp)q
5087 
+(ed.\))k(The)15 b(standard)0 587 y(t)o(yp)q(es)j(include)j(\014xed-)e(and)f
5088 
+(arbitrary-precision)h(in)o(tegers,)g(ratios)f(\(rational)f(n)o(um)o(b)q
5089 
+(ers\))i(formed)e(from)h(eac)o(h)0 643 y(in)o(teger)c(t)o(yp)q(e,)g(and)g
5090 
+(single-)h(and)f(double-precision)j(real)d(and)g(complex)h(\015oating-p)q
5091 
+(oin)o(t.)20 b(W)l(e)14 b(outline)h(here)f(the)0 700 y(basic)i(c)o
5092 
+(haracteristics)f(of)g(the)g(n)o(umeric)i(t)o(yp)q(e)e(class)g(structure)g
5093 
+(and)h(refer)f(the)g(reader)g(to)g Fn(x)p Fp(6.8)f(for)h(details.)0
5094 
+850 y Fc(5.5.1)52 b(Numeric)17 b(Class)g(Structure)0 963 y
5095 
+Fp(Returning)f(to)f(Figure)g(2,)f(w)o(e)h(notice)g(that)g(the)g(n)o(umeric)h
5096 
+(t)o(yp)q(e)f(classes)g(\(class)g Fi(Num)g Fp(and)g(those)g(that)f(lie)i(b)q
5097 
+(elo)o(w)0 1019 y(it\))h(accoun)o(t)f(for)g(more)g(than)h(half)g(of)f(the)h
5098 
+(standard)f(classes.)24 b(W)l(e)17 b(also)g(note)f(that)g Fi(Num)g
5099 
+Fp(is)h(a)g(sub)q(class)g(of)g Fi(Eq)o Fp(,)0 1076 y(but)c(not)f(of)h
5100 
+Fi(Ord)o Fp(;)h(this)f(is)g(b)q(ecause)h(the)f(order)f(predicates)i(do)f(not)
5101 
+f(apply)i(to)e(complex)i(n)o(um)o(b)q(ers.)19 b(The)13 b(sub)q(class)0
5102 
+1132 y Fi(Real)i Fp(of)f Fi(Num)p Fp(,)h(ho)o(w)o(ev)o(er,)f(is)h(a)g(sub)q
5103 
+(class)i(of)d Fi(Ord)h Fp(as)g(w)o(ell.)71 1215 y(The)k Fi(Num)f
5104 
+Fp(class)i(pro)o(vides)f(sev)o(eral)g(basic)h(op)q(erations)f(common)g(to)f
5105 
+(all)i(n)o(umeric)g(t)o(yp)q(es;)h(these)e(include,)0 1271
5106 
+y(among)14 b(others,)h(addition,)h(subtraction,)f(negation,)g(m)o
5107 
+(ultiplication,)i(and)e(absolute)h(v)m(alue:)71 1380 y Fi(\(+\),)23
5108 
+b(\(-\),)g(\(*\))262 b(::)24 b(\(Num)f(a\))h(=>)f(a)h(->)g(a)f(->)h(a)71
5109 
+1437 y(negate,)e(abs)310 b(::)24 b(\(Num)f(a\))h(=>)f(a)h(->)g(a)0
5110 
+1548 y Fp([)p Fi(negate)10 b Fp(is)h(the)g(function)h(applied)h(b)o(y)e(Hask)
5111 
+o(ell's)g(only)h(pre\014x)f(op)q(erator,)g(min)o(us;)i(w)o(e)d(can't)h(call)h
5112 
+(it)f Fi(\(-\))p Fp(,)g(b)q(ecause)0 1605 y(that)j(is)h(the)g(subtraction)g
5113 
+(function,)g(so)g(this)g(name)g(is)g(pro)o(vided)h(instead.)k(F)l(or)14
5114 
+b(example,)i Fi(-x*y)e Fp(is)h(equiv)m(alen)o(t)0 1661 y(to)d
5115 
+Fi(negate)23 b(\(x*y\))o Fp(.)c(\(Pre\014x)12 b(min)o(us)h(has)f(the)g(same)g
5116 
+(syn)o(tactic)g(precedence)i(as)e(in\014x)h(min)o(us,)g(whic)o(h,)g(of)f
5117 
+(course,)0 1718 y(is)k(lo)o(w)o(er)f(than)g(that)f(of)h(m)o
5118 
+(ultiplication.\)])71 1801 y(Note)d(that)h Fi(Num)g Fp(do)q(es)g
5119 
+Fo(not)h Fp(pro)o(vide)f(a)g(division)j(op)q(erator;)c(t)o(w)o(o)g
5120 
+(di\013eren)o(t)i(kinds)g(of)f(division)i(op)q(erators)d(are)0
5121 
+1857 y(pro)o(vided)k(in)g(t)o(w)o(o)e(non-o)o(v)o(erlapping)i(sub)q(classes)g
5122 
+(of)f Fi(Num)p Fp(:)71 1940 y(The)i(class)h Fi(Integral)e Fp(pro)o(vides)i
5123 
+(whole-n)o(um)o(b)q(er)h(division)g(and)f(remainder)g(op)q(erations,)f(as)g
5124 
+(w)o(ell)i(as)e(the)0 1996 y Fi(even)e Fp(and)h Fi(odd)g Fp(predicates.)23
5125 
+b(The)16 b(standard)f(instances)i(of)e Fi(Integral)g Fp(are)h
5126 
+Fi(Integer)f Fp(\(un)o(b)q(ounded)i(or)e(math-)0 2053 y(ematical)20
5127 
+b(in)o(tegers,)f(also)g(kno)o(wn)g(as)g(\\bign)o(ums"\))f(and)i
5128 
+Fi(Int)e Fp(\(b)q(ounded,)j(mac)o(hine)f(in)o(tegers,)f(with)h(a)e(range)0
5129 
+2109 y(equiv)m(alen)o(t)i(to)f(at)f(least)h(29-bit)f(signed)i(binary\).)31
5130 
+b(A)19 b(particular)g(Hask)o(ell)h(implemen)o(tation)g(migh)o(t)e(pro)o(vide)
5131 
+0 2166 y(other)d(in)o(tegral)g(t)o(yp)q(es)g(in)g(addition)h(to)f(these.)20
5132 
+b(Note)14 b(that)g Fi(Integral)g Fp(is)h(a)g(sub)q(class)h(of)e
5133 
+Fi(Real)p Fp(,)g(rather)h(than)f(of)0 2222 y Fi(Num)h Fp(directly;)h(this)g
5134 
+(means)f(that)f(there)h(is)h(no)f(attempt)g(to)f(pro)o(vide)i(Gaussian)f(in)o
5135 
+(tegers.)71 2305 y(All)23 b(other)e(n)o(umeric)i(t)o(yp)q(es)e(fall)i(in)g
5136 
+(the)f(class)g Fi(Fractional)n Fp(,)h(whic)o(h)g(pro)o(vides)f(the)g
5137 
+(ordinary)g(division)0 2361 y(op)q(erator)13 b Fi(\(/\))p Fp(.)19
5138 
+b(The)c(further)e(sub)q(class)j Fi(Floating)d Fp(con)o(tains)h
5139 
+(trigonometric,)f(logarithmic,)i(and)f(exp)q(onen)o(tial)0
5140 
+2418 y(functions.)71 2501 y(The)j Fi(RealFrac)g Fp(sub)q(class)h(of)g
5141 
+Fi(Fractional)e Fp(and)i Fi(Real)f Fp(pro)o(vides)h(a)f(function)h
5142 
+Fi(properFraction)n Fp(,)g(whic)o(h)0 2557 y(decomp)q(oses)e(a)f(n)o(um)o(b)q
5143 
+(er)h(in)o(to)f(its)h(whole)g(and)g(fractional)f(parts,)g(and)g(a)g
5144 
+(collection)j(of)d(functions)h(that)f(round)0 2614 y(to)g(in)o(tegral)g(v)m
5145 
+(alues)h(b)o(y)g(di\013ering)g(rules:)p eop
5146 
+%%Page: 34 34
5147 
+bop 0 -40 a Fp(T-34)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g
5148 
+(AND)f(\\OOP")71 160 y Fi(properFraction)236 b(::)24 b(\(Fractional)e(a,)i
5149 
+(Integral)f(b\))g(=>)h(a)g(->)f(\(b,a\))71 216 y(truncate,)f(round,)71
5150 
+272 y(floor,)h(ceiling:)213 b(::)24 b(\(Fractional)e(a,)i(Integral)f(b\))g
5151 
+(=>)h(a)g(->)f(b)71 453 y Fp(The)d Fi(RealFloat)f Fp(sub)q(class)j(of)e
5152 
+Fi(Floating)f Fp(and)i Fi(RealFrac)e Fp(pro)o(vides)i(some)f(sp)q(ecialized)j
5153 
+(functions)f(for)0 509 y(e\016cien)o(t)c(access)g(to)f(the)h(comp)q(onen)o
5154 
+(ts)g(of)f(a)g(\015oating-p)q(oin)o(t)i(n)o(um)o(b)q(er,)f(the)g
5155 
+Fo(exp)n(onent)f Fp(and)g Fo(signi\014c)n(and)p Fp(.)26 b(The)0
5156 
+566 y(standard)15 b(t)o(yp)q(es)g Fi(Float)f Fp(and)i Fi(Double)e
5157 
+Fp(fall)i(in)g(class)g Fi(RealFloat)o Fp(.)0 782 y Fc(5.5.2)52
5158 
+b(Constructed)17 b(Num)o(b)q(ers)0 924 y Fp(Of)h(the)g(standard)f(n)o(umeric)
5159 
+i(t)o(yp)q(es,)f Fi(Int)p Fp(,)g Fi(Integer)o Fp(,)g Fi(Float)o
5160 
+Fp(,)g(and)g Fi(Double)f Fp(are)h(primitiv)o(e.)29 b(The)18
5161 
+b(others)f(are)0 981 y(made)e(from)g(these)g(b)o(y)g(t)o(yp)q(e)g
5162 
+(constructors:)71 1083 y Fi(Complex)e Fp(is)i(a)g(t)o(yp)q(e)f(constructor)g
5163 
+(that)g(mak)o(es)g(a)h(complex)g(t)o(yp)q(e)g(in)g(class)g
5164 
+Fi(Floating)f Fp(from)g(a)g Fi(RealFloat)0 1140 y Fp(t)o(yp)q(e:)71
5165 
+1249 y Fi(data)23 b(\(RealFloat)f(a\))i(=>)g(Complex)e(a)i(=)g(a)g(:+)f(a)48
5166 
+b(deriving)23 b(\(Eq,)g(Binary,)g(Text\))0 1358 y Fp(Notice)14
5167 
+b(the)f(con)o(text)g Fi(\(RealFloat)23 b(a\))g(=>)p Fp(,)13
5168 
+b(whic)o(h)i(restricts)e(the)g(argumen)o(t)g(t)o(yp)q(e;)g(th)o(us,)h(the)f
5169 
+(standard)g(com-)0 1414 y(plex)18 b(t)o(yp)q(es)g(are)f Fi(Complex)23
5170 
+b(Float)17 b Fp(and)g Fi(Complex)23 b(Double)o Fp(.)k(W)l(e)17
5171 
+b(can)h(also)f(see)h(from)f(the)g Fi(data)g Fp(declaration)0
5172 
+1471 y(that)12 b(a)g(complex)i(n)o(um)o(b)q(er)e(is)h(written)g
5173 
+Fo(x)18 b Fi(:+)12 b Fo(y)t Fp(;)i(the)e(argumen)o(ts)g(are)g(the)h
5174 
+(cartesian)f(real)h(and)g(imaginary)g(parts,)0 1527 y(resp)q(ectiv)o(ely)l(.)
5175 
+22 b(Since)16 b Fi(:+)f Fp(is)h(a)f(data)f(constructor,)g(w)o(e)h(can)h(use)f
5176 
+(it)h(in)g(pattern)e(matc)o(hing:)71 1636 y Fi(conjugate)356
5177 
+b(::)24 b(\(RealFloat)e(a\))i(=>)g(Complex)e(a)i(->)g(Complex)f(a)71
5178 
+1693 y(conjugate)f(\(x:+y\))190 b(=)48 b(x)24 b(:+)f(\(-y\))71
5179 
+1873 y Fp(Similarly)l(,)15 b(the)f(t)o(yp)q(e)g(constructor)f
5180 
+Fi(Ratio)f Fp(mak)o(es)h(a)h(rational)f(t)o(yp)q(e)h(in)g(class)g
5181 
+Fi(RealFrac)f Fp(from)g(an)g(instance)0 1929 y(of)k Fi(Integral)o
5182 
+Fp(.)26 b(\()p Fi(Rational)16 b Fp(is)i(a)f(t)o(yp)q(e)h(synon)o(ym)f(for)g
5183 
+Fi(Ratio)23 b(Integer)o Fp(.\))j Fi(Ratio)o Fp(,)18 b(ho)o(w)o(ev)o(er,)f(is)
5184 
+h(an)f(abstract)0 1986 y(t)o(yp)q(e)h(constructor,)g(b)q(eing)h(de\014ned)h
5185 
+(in)f(the)f(Prelude)h(mo)q(dule)h Fi(PreludeRatio)n Fp(,)e(from)g(whic)o(h)h
5186 
+(it)f(is)h(exp)q(orted)0 2042 y(without)d(its)g(data)f(constructor;)g(th)o
5187 
+(us,)h(ratios)f(cannot)h(b)q(e)g(pattern-matc)o(hed.)22 b(Instead,)16
5188 
+b(a)g(function)g(to)g(form)0 2099 y(a)f(ratio)g(from)f(t)o(w)o(o)g(in)o
5189 
+(tegers)h(is)h(pro)o(vided,)g(as)e(w)o(ell)j(as)d(comp)q(onen)o(t)i
5190 
+(extraction)f(functions:)71 2208 y Fi(\(\045\))500 b(::)24
5191 
+b(\(Integral)f(a\))g(=>)h(a)f(->)h(a)g(->)f(Ratio)h(a)71 2264
5192 
+y(numerator,)e(denominator)46 b(::)24 b(\(Integral)f(a\))g(=>)h(Ratio)f(a)h
5193 
+(->)f(a)71 2444 y Fp(Wh)o(y)17 b(the)g(di\013erence?)29 b(Complex)19
5194 
+b(n)o(um)o(b)q(ers)e(in)i(cartesian)e(form)g(are)h(unique|there)h(are)e(no)h
5195 
+(non)o(trivial)0 2501 y(iden)o(tities)g(in)o(v)o(olving)g Fi(:+)p
5196 
+Fp(.)23 b(On)17 b(the)f(other)h(hand,)f(ratios)g(are)g(not)g(unique,)i(but)f
5197 
+(ha)o(v)o(e)f(a)g(canonical)h(\(reduced\))0 2557 y(form)h(that)f(the)i
5198 
+(implemen)o(tation)h(of)e(the)g(abstract)g(data)g(t)o(yp)q(e)g(m)o(ust)g
5199 
+(main)o(tain;)i(it)f(is)g(not)f(necessarily)i(the)0 2614 y(case,)14
5200 
+b(for)h(instance,)g(that)f Fi(numerator)23 b(\(x\045y\))14
5201 
+b Fp(is)h(equal)g(to)f Fi(x)p Fp(,)h(although)g(the)g(real)g(part)f(of)g
5202 
+Fi(x:+y)g Fp(is)i(alw)o(a)o(ys)e Fi(x)o Fp(.)p eop
5203 
+%%Page: 35 35
5204 
+bop 0 -40 a Fj(5.5)45 b(Num)o(b)q(ers)1575 b Fp(T-35)0 105
5205 
+y Fc(5.5.3)52 b(Numeric)17 b(Co)q(ercions)h(and)g(Ov)o(erloaded)f(Literals)0
5206 
+269 y Fp(The)e(Standard)h(Prelude)g(pro)o(vides)g(sev)o(eral)f(o)o(v)o
5207 
+(erloaded)g(functions)h(that)f(serv)o(e)g(as)f(explicit)k(co)q(ercions:)71
5208 
+378 y Fi(fromInteger)308 b(::)24 b(\(Num)f(a\))h(=>)f(Integer)g(->)h(a)71
5209 
+435 y(fromRational)284 b(::)24 b(\(Fractional)e(a\))i(=>)f(Rational)g(->)h(a)
5210 
+71 491 y(toInteger)356 b(::)24 b(\(Integral)f(a\))g(=>)h(a)f(->)h(Integer)71
5211 
+548 y(toRational)332 b(::)24 b(\(RealFrac)f(a\))g(=>)h(a)f(->)h(Rational)71
5212 
+604 y(fromIntegral)284 b(::)24 b(\(Integral)f(a,)g(Num)h(b\))f(=>)h(a)f(->)h
5213 
+(b)71 661 y(fromRealFrac)284 b(::)24 b(\(RealFrac)f(a,)g(Fractional)g(b\))g
5214 
+(=>)h(a)g(->)f(b)71 740 y(fromIntegral)284 b(=)48 b(fromInteger)22
5215 
+b(.)i(toInteger)71 797 y(fromRealFrac)284 b(=)48 b(fromRational)22
5216 
+b(.)i(toRational)71 992 y Fp(Tw)o(o)18 b(of)h(these)g(are)g(implicitly)k
5217 
+(used)c(to)g(pro)o(vide)h(o)o(v)o(erloaded)f(n)o(umeric)h(literals:)29
5218 
+b(An)20 b(in)o(teger)g(n)o(umeral)0 1049 y(\(without)c(a)g(decimal)i(p)q(oin)
5219 
+o(t\))e(is)h(actually)g(equiv)m(alen)o(t)h(to)e(an)g(application)i(of)e
5220 
+Fi(fromInteger)f Fp(to)g(the)i(v)m(alue)g(of)0 1105 y(the)i(n)o(umeral)g(as)f
5221 
+(an)h Fi(Integer)o Fp(.)31 b(Similarly)l(,)21 b(a)e(\015oating)g(n)o(umeral)g
5222 
+(\(with)g(a)f(decimal)i(p)q(oin)o(t\))f(is)h(regarded)e(as)0
5223 
+1162 y(an)e(application)h(of)e Fi(fromRational)g Fp(to)g(the)h(v)m(alue)h(of)
5224 
+e(the)h(n)o(umeral)g(as)f(a)h Fi(Rational)o Fp(.)21 b(Th)o(us,)16
5225 
+b Fi(7)f Fp(has)h(the)g(t)o(yp)q(e)0 1218 y Fi(\(Num)23 b(a\))h(=>)f(a)p
5226 
+Fp(,)18 b(and)f Fi(7.3)g Fp(has)g(the)h(t)o(yp)q(e)f Fi(Fractional)23
5227 
+b(a)g(=>)h(a)p Fp(.)i(This)18 b(means)f(that)g(w)o(e)g(can)g(use)h(n)o
5228 
+(umeric)0 1274 y(literals)e(in)g(generic)h(n)o(umeric)f(functions,)f(for)g
5229 
+(example:)71 1383 y Fi(halve)452 b(::)24 b(\(Fractional)e(a\))i(=>)f(a)h(->)g
5230 
+(a)71 1440 y(halve)f(x)405 b(=)48 b(x)24 b(*)f(0.5)0 1549 y
5231 
+Fp(This)16 b(rather)e(indirect)i(w)o(a)o(y)e(of)h(o)o(v)o(erloading)g(n)o
5232 
+(umerals)g(has)g(the)g(additional)i(adv)m(an)o(tage)d(that)g(the)h(metho)q(d)
5233 
+g(of)0 1605 y(in)o(terpreting)f(a)g(n)o(umeral)g(as)f(a)g(n)o(um)o(b)q(er)h
5234 
+(of)f(a)g(giv)o(en)i(t)o(yp)q(e)e(can)h(b)q(e)g(sp)q(eci\014ed)i(in)e(an)g
5235 
+Fi(Integral)e Fp(or)h Fi(Fractional)0 1662 y Fp(instance)j(declaration)g
5236 
+(\(since)g Fi(fromInteger)d Fp(and)i Fi(fromRational)f Fp(are)g(op)q(erators)
5237 
+g(of)h(those)g(classes,)g(resp)q(ec-)0 1718 y(tiv)o(ely\).)20
5238 
+b(F)l(or)15 b(example,)h(the)f Fi(Num)g Fp(instance)h(of)e
5239 
+Fi(\(RealFloat)23 b(a\))g(=>)h(Complex)f(a)15 b Fp(con)o(tains)g(this)h
5240 
+(metho)q(d:)71 1830 y Fi(fromInteger)22 b(x)262 b(=)48 b(fromInteger)22
5241 
+b(x)i(:+)g(0)0 1939 y Fp(This)15 b(sa)o(ys)f(that)g(a)h Fi(Complex)f
5242 
+Fp(instance)h(of)g Fi(fromInteger)e Fp(is)i(de\014ned)h(to)e(pro)q(duce)i(a)e
5243 
+(complex)i(n)o(um)o(b)q(er)f(whose)0 1995 y(real)h(part)e(is)i(supplied)i(b)o
5244 
+(y)d(an)g(appropriate)g Fi(RealFloat)f Fp(instance)j(of)d Fi(fromInteger)o
5245 
+Fp(.)20 b(In)c(this)g(manner,)f(ev)o(en)0 2052 y(user-de\014ned)i(n)o(umeric)
5246 
+f(t)o(yp)q(es)f(\(sa)o(y)l(,)f(quaternions\))i(can)f(mak)o(e)g(use)g(of)g(o)o
5247 
+(v)o(erloaded)g(n)o(umerals.)71 2170 y(As)g(another)g(example,)g(recall)i
5248 
+(our)d(\014rst)h(de\014nition)i(of)e Fi(succ)g Fp(from)f(Section)i(2:)71
5249 
+2279 y Fi(succ)23 b(::)g(Int)h(->)g(Int)71 2335 y(succ)f(n)h(=)f(n+1)0
5250 
+2444 y Fp(Ignoring)15 b(the)g(t)o(yp)q(e)f(signature,)g(the)h(most)f(general)
5251 
+h(t)o(yp)q(e)f(of)g Fi(succ)g Fp(is)h Fi(\(Num)23 b(a\))h(=>)g(a->a)o
5252 
+Fp(.)c(The)14 b(explicit)j(t)o(yp)q(e)0 2501 y(signature)h(is)g(legal,)h(ho)o
5253 
+(w)o(ev)o(er,)e(since)i(it)f(is)g Fo(mor)n(e)g(sp)n(e)n(ci\014c)e
5254 
+Fp(than)i(the)g(principal)i(t)o(yp)q(e)d(\(a)g(more)h(general)g(t)o(yp)q(e)0
5255 
+2557 y(signature)e(w)o(ould)g(cause)g(a)f(static)g(error\).)20
5256 
+b(The)c(t)o(yp)q(e)g(signature)g(has)f(the)h(e\013ect)f(of)h(restricting)g
5257 
+Fi(succ)o Fp('s)f(t)o(yp)q(e,)0 2614 y(and)g(in)h(this)g(case)f(w)o(ould)h
5258 
+(cause)f(something)h(lik)o(e)g Fi(succ)23 b(\(1::Float\))14
5259 
+b Fp(to)h(b)q(e)h(ill-t)o(yp)q(ed.)p eop
5260 
+%%Page: 36 36
5261 
+bop 0 -40 a Fp(T-36)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g
5262 
+(AND)f(\\OOP")0 105 y Fc(5.5.4)52 b(Default)18 b(Numeric)g(T)o(yp)q(es)0
5263 
+216 y Fp(Consider)e(the)f(follo)o(wing)h(function)g(de\014nition:)71
5264 
+325 y Fi(rms)500 b(::)24 b(\(Floating)f(a\))g(=>)h(a)f(->)h(a)g(->)f(a)71
5265 
+381 y(rms)g(x)h(y)405 b(=)48 b(sqrt)23 b(\(\(x^2)g(+)h(y^2\))f(*)h(0.5\))0
5266 
+493 y Fp(The)c(exp)q(onen)o(tiation)g(function)g Fi(\(^\))f
5267 
+Fp(\(one)g(of)g(three)g(di\013eren)o(t)h(standard)f(exp)q(onen)o(tiation)h
5268 
+(op)q(erators)f(with)0 549 y(di\013eren)o(t)13 b(t)o(ypings,)g(see)g
5269 
+Fn(x)p Fp(6.8.5\))e(has)h(the)h(t)o(yp)q(e)g Fi(\(Num)23 b(a,)h(Integral)e
5270 
+(b\))i(=>)g(a)f(->)h(b)g(->)f(a)p Fp(,)13 b(and)g(since)h Fi(2)e
5271 
+Fp(has)0 606 y(the)k(t)o(yp)q(e)f Fi(\(Num)24 b(a\))f(=>)h(a)p
5272 
+Fp(,)15 b(the)h(t)o(yp)q(e)g(of)f Fi(x^2)g Fp(is)h Fi(\(Num)23
5273 
+b(a,)h(Integral)f(b\))g(=>)h(a)p Fp(.)d(This)16 b(is)g(a)g(problem;)g(there)0
5274 
+662 y(is)g(no)g(w)o(a)o(y)e(to)i(resolv)o(e)f(the)h(o)o(v)o(erloading)g(asso)
5275 
+q(ciated)g(with)g(the)g(t)o(yp)q(e)f(v)m(ariable)i Fi(b)p Fp(,)f(since)g(it)g
5276 
+(is)h(in)f(the)g(con)o(text,)0 719 y(but)j(has)f(otherwise)h(v)m(anished)i
5277 
+(from)d(the)g(t)o(yp)q(e)h(expression.)31 b(Essen)o(tially)l(,)21
5278 
+b(the)e(programmer)e(has)i(sp)q(eci\014ed)0 775 y(that)e Fi(x)h
5279 
+Fp(should)g(b)q(e)h(squared,)f(but)f(has)h(not)f(sp)q(eci\014ed)j(whether)e
5280 
+(it)g(should)h(b)q(e)f(squared)g(with)g(an)g Fi(Int)f Fp(or)g(an)0
5281 
+832 y Fi(Integer)d Fp(v)m(alue)j(of)d(t)o(w)o(o.)19 b(Of)c(course,)g(w)o(e)g
5282 
+(can)g(\014x)h(this:)71 942 y Fi(rms)23 b(x)h(y)405 b(=)48
5283 
+b(sqrt)23 b(\(\(x)h(^)f(\(2::Int\))g(+)h(y)g(^)f(\(2::Int\)\))g(*)h(0.5\))0
5284 
+1051 y Fp(It's)15 b(ob)o(vious)g(that)g(this)g(sort)g(of)f(thing)i(will)h(so)
5285 
+q(on)e(gro)o(w)f(tiresome,)h(ho)o(w)o(ev)o(er.)71 1132 y(In)g(fact,)g(this)g
5286 
+(kind)i(of)d(o)o(v)o(erloading)i(am)o(biguit)o(y)f(is)h(not)f(restricted)g
5287 
+(to)g(n)o(um)o(b)q(ers:)71 1241 y Fi(show)23 b(\(read)g("xyz"\))0
5288 
+1350 y Fp(As)d(what)f(t)o(yp)q(e)h(is)g(the)g(string)f(supp)q(osed)i(to)e(b)q
5289 
+(e)h(read?)35 b(This)20 b(is)g(more)f(serious)h(than)g(the)g(exp)q(onen)o
5290 
+(tiation)0 1407 y(am)o(biguit)o(y)l(,)14 b(b)q(ecause)h(there,)f(an)o(y)f
5291 
+Fi(Integral)g Fp(instance)i(will)g(do,)f(whereas)g(here,)g(v)o(ery)f
5292 
+(di\013eren)o(t)h(b)q(eha)o(vior)h(can)0 1463 y(b)q(e)h(exp)q(ected)g(dep)q
5293 
+(ending)i(on)d(what)f(instance)i(of)f Fi(Text)g Fp(is)h(used)f(to)g(resolv)o
5294 
+(e)g(the)h(am)o(biguit)o(y)l(.)71 1545 y(Because)h(of)f(the)g(di\013erence)i
5295 
+(b)q(et)o(w)o(een)f(the)f(n)o(umeric)i(and)e(general)h(cases)g(of)f(the)g(o)o
5296 
+(v)o(erloading)h(am)o(biguit)o(y)0 1601 y(problem,)24 b(Hask)o(ell)e(pro)o
5297 
+(vides)g(a)g(solution)g(that)f(is)h(restricted)g(to)f(n)o(um)o(b)q(ers:)33
5298 
+b(Eac)o(h)22 b(mo)q(dule)h(ma)o(y)e(con)o(tain)0 1658 y(a)h
5299 
+Fo(default)h(de)n(clar)n(ation,)g Fp(consisting)g(of)f(the)g(k)o(eyw)o(ord)g
5300 
+Fi(default)f Fp(follo)o(w)o(ed)i(b)o(y)f(a)g(paren)o(thesized,)i(comma-)0
5301 
+1714 y(separated)17 b(list)h(of)f(n)o(umeric)h(monot)o(yp)q(es)f(\(t)o(yp)q
5302 
+(es)h(with)f(no)h(v)m(ariables\).)27 b(When)18 b(an)f(am)o(bigous)g(t)o(yp)q
5303 
+(e)h(v)m(ariable)0 1770 y(is)h(disco)o(v)o(ered)f(\(suc)o(h)h(as)e
5304 
+Fi(b)p Fp(,)i(ab)q(o)o(v)o(e\),)f(if)g(at)g(least)g(one)g(of)g(its)h(classes)
5305 
+f(is)h(n)o(umeric)g(and)f(all)h(of)f(its)h(classes)f(are)0
5306 
+1827 y(standard,)d(the)g(default)h(list)h(is)f(consulted,)g(and)f(the)h
5307 
+(\014rst)f(t)o(yp)q(e)g(from)g(the)h(list)g(that)f(will)i(satisfy)e(the)h
5308 
+(con)o(text)0 1883 y(of)g(the)h(t)o(yp)q(e)g(v)m(ariable)h(is)f(used.)25
5309 
+b(F)l(or)16 b(example,)h(if)h(the)e(default)i(declaration)f
5310 
+Fi(default)23 b(\(Int,)g(Float\))16 b Fp(is)h(in)0 1940 y(e\013ect,)e(the)g
5311 
+(am)o(biguous)g(exp)q(onen)o(t)h(ab)q(o)o(v)o(e)f(will)h(b)q(e)g(resolv)o(ed)
5312 
+g(as)f(t)o(yp)q(e)g Fi(Int)p Fp(.)k(\(See)d Fn(x)p Fp(4.3.4)e(for)g(more)h
5313 
+(details.\))71 2021 y(The)f(\\default)h(default")g(is)g Fi(\(Int,)23
5314 
+b(Double\))o Fp(,)15 b(but)f Fi(\(Integer,)23 b(Rational,)g(Double\))13
5315 
+b Fp(ma)o(y)h(also)h(b)q(e)g(ap-)0 2078 y(propriate.)20 b(V)l(ery)15
5316 
+b(cautious)h(programmers)e(ma)o(y)g(prefer)i Fi(default)22
5317 
+b(\(\))p Fp(,)15 b(whic)o(h)h(pro)o(vides)g(no)f(defaults.)p
5318 
+eop
5319 
+%%Page: 37 37
5320 
+bop 1857 -40 a Fp(T-37)0 105 y Fq(6)69 b(Mo)r(dules)0 237 y
5321 
+Fp(A)o(t)14 b(the)h(top)f(lev)o(el,)i(a)f(Hask)o(ell)g(program)f(consists)h
5322 
+(of)f(a)h(collection)h(of)f Fo(mo)n(dules)p Fp(.)k(A)c(mo)q(dule)h(in)g(Hask)
5323 
+o(ell)f(serv)o(es)0 294 y(the)g(dual)h(purp)q(ose)g(of)f(con)o(trolling)h
5324 
+(name-spaces)g(and)f(creating)g(abstract)g(data)f(t)o(yp)q(es.)71
5325 
+379 y(The)19 b(top)f(lev)o(el)i(of)f(a)g(mo)q(dule)h(con)o(tains)f(an)o(y)f
5326 
+(of)h(the)g(v)m(arious)g(declarations)h(w)o(e)e(ha)o(v)o(e)h(discussed:)29
5327 
+b(\014xit)o(y)0 435 y(declarations,)15 b(data)f(and)h(t)o(yp)q(e)g
5328 
+(declarations,)g(class)g(and)f(instance)i(declarations,)f(t)o(yp)q(e)g
5329 
+(signatures,)f(function)0 492 y(de\014nitions,)k(and)e(pattern)f(bindings.)25
5330 
+b(Except)16 b(for)f(the)h(fact)g(that)f(\014xit)o(y)h(declarations)h(and)f
5331 
+(imp)q(ort)g(declara-)0 548 y(tions)i(\(to)f(b)q(e)i(describ)q(ed)h
5332 
+(shortly\))e(m)o(ust)f(app)q(ear)h(\014rst,)g(the)h(declarations)f(ma)o(y)g
5333 
+(app)q(ear)g(in)h(an)o(y)e(order)h(\(the)0 605 y(top-lev)o(el)e(scop)q(e)g
5334 
+(is)g(m)o(utually)g(recursiv)o(e\).)71 690 y(Hask)o(ell's)d(mo)q(dule)g
5335 
+(design)h(is)f(relativ)o(ely)g(conserv)m(ativ)o(e:)19 b(The)13
5336 
+b(namespace)g(of)f(mo)q(dules)i(is)f(completely)h(\015at,)0
5337 
+746 y(and)h(mo)q(dules)i(are)d(in)j(no)e(w)o(a)o(y)f(\\\014rst-class.")19
5338 
+b(Mo)q(dule)d(names)g(are)e(alphan)o(umeric)j(and)e(m)o(ust)g(b)q(egin)i
5339 
+(with)e(an)0 803 y(upp)q(ercase)g(letter.)20 b(There)14 b(is)h(no)f(formal)f
5340 
+(connection)i(b)q(et)o(w)o(een)g(a)e(Hask)o(ell)i(mo)q(dule)h(and)e(the)g
5341 
+(\014le)h(system)f(that)0 859 y(w)o(ould)i(\(t)o(ypically\))h(supp)q(ort)f
5342 
+(it.)22 b(In)17 b(particular,)f(there)g(is)h(no)f(connection)h(b)q(et)o(w)o
5343 
+(een)f(mo)q(dule)h(names)f(and)g(\014le)0 916 y(names,)g(and)g(more)g(than)g
5344 
+(one)g(mo)q(dule)h(could)g(conceiv)m(ably)i(reside)e(in)g(a)f(single)h
5345 
+(\014le)g(\(one)f(mo)q(dule)h(ma)o(y)f(ev)o(en)0 972 y(span)g(sev)o(eral)f
5346 
+(\014les\).)22 b(Of)15 b(course,)h(a)f(particular)h(implemen)o(tation)h(will)
5347 
+g(most)e(lik)o(ely)i(adopt)e(con)o(v)o(en)o(tions)h(that)0
5348 
+1029 y(mak)o(e)f(the)g(connection)h(b)q(et)o(w)o(een)g(mo)q(dules)g(and)f
5349 
+(\014les)i(more)d(stringen)o(t.)71 1114 y(T)l(ec)o(hnically)h(sp)q(eaking,)f
5350 
+(a)f(mo)q(dule)h(is)g(really)g(just)f(one)g(big)h(declaration)g(whic)o(h)g(b)
5351 
+q(egins)g(with)g(the)f(k)o(eyw)o(ord)0 1170 y Fi(module)o Fp(;)i(here's)g(an)
5352 
+g(example)h(for)f(a)g(mo)q(dule)h(whose)f(name)g(is)h Fi(Tree)p
5353 
+Fp(:)71 1279 y Fi(module)23 b(Tree)g(\()h(Tree\(Leaf,Branch\),)d(fringe)i(\))
5354 
+h(where)71 1359 y(data)f(Tree)g(a)382 b(=)24 b(Leaf)f(a)h(|)f(Branch)g
5355 
+(\(Tree)h(a\))f(\(Tree)g(a\))71 1439 y(fringe)g(::)g(Tree)h(a)f(->)h([a])71
5356 
+1495 y(fringe)f(\(Leaf)g(x\))286 b(=)24 b([x])71 1551 y(fringe)f(\(Branch)g
5357 
+(left)g(right\))g(=)h(fringe)f(left)g(++)h(fringe)f(right)0
5358 
+1661 y Fp(The)14 b(t)o(yp)q(e)g Fi(Tree)f Fp(and)h(the)g(function)h
5359 
+Fi(fringe)e Fp(should)i(b)q(e)g(familiar;)f(they)g(w)o(ere)g(giv)o(en)g(as)g
5360 
+(examples)g(in)h(Section)0 1717 y(2.3.)29 b([Because)19 b(of)f(the)h
5361 
+Fi(where)f Fp(k)o(eyw)o(ord,)g(la)o(y)o(out)g(is)h(activ)o(e)g(at)e(the)i
5362 
+(top)f(lev)o(el)i(of)e(a)h(mo)q(dule,)h(and)e(th)o(us)h(the)0
5363 
+1773 y(declarations)f(m)o(ust)e(all)i(line)g(up)f(in)h(the)f(same)f(column)i
5364 
+(\(t)o(ypically)g(the)f(\014rst\).)24 b(Also)17 b(note)g(that)f(the)h(mo)q
5365 
+(dule)0 1830 y(name)e(is)h(the)f(same)g(as)g(that)f(of)h(the)g(t)o(yp)q(e;)g
5366 
+(this)h(is)g(allo)o(w)o(ed.])71 1915 y(This)e(mo)q(dule)h(explicitly)i
5367 
+Fo(exp)n(orts)d Fi(Tree)o Fp(,)g Fi(Leaf)o Fp(,)g Fi(Branch)o
5368 
+Fp(,)g(and)g Fi(fringe)o Fp(.)20 b(If)14 b(the)g(exp)q(ort)g(list)g(follo)o
5369 
+(wing)h(the)0 1972 y Fi(module)10 b Fp(k)o(eyw)o(ord)g(is)h(omitted,)g
5370 
+Fo(al)r(l)g Fp(of)f(the)h(names)g(b)q(ound)h(at)e(the)h(top)f(lev)o(el)i(of)f
5371 
+(the)f(mo)q(dule)i(w)o(ould)g(b)q(e)f(exp)q(orted.)0 2028 y(\(In)h(the)h(ab)q
5372 
+(o)o(v)o(e)e(example)i(ev)o(erything)g(is)f(explicitly)j(exp)q(orted,)e(so)e
5373 
+(the)i(e\013ect)e(w)o(ould)i(b)q(e)g(the)f(same.\))18 b(Note)12
5374 
+b(that)0 2084 y(the)k(name)f(of)g(a)h(t)o(yp)q(e)f(and)h(its)g(constructors)f
5375 
+(m)o(ust)g(b)q(e)h(group)q(ed)g(together,)f(as)g(in)h Fi(Tree\(Leaf,Branch\))
5376 
+n Fp(.)21 b(As)0 2141 y(short-hand,)15 b(w)o(e)g(could)h(also)f(write)g
5377 
+Fi(Tree\(..\))f Fp(\(exp)q(orting)i(a)f(subset)g(of)g(the)g(constructors)f
5378 
+(is)i(not)f(allo)o(w)o(ed\).)71 2226 y(The)g Fi(Tree)g Fp(mo)q(dule)h(ma)o(y)
5379 
+e(no)o(w)h(b)q(e)h Fo(imp)n(orte)n(d)g Fp(in)o(to)f(some)g(other)f(mo)q
5380 
+(dule:)71 2335 y Fi(module)23 b(Main)g(\(main\))g(where)71
5381 
+2392 y(import)g(Tree)g(\()h(Tree\(Leaf,Branch\),)d(fringe)i(\))71
5382 
+2448 y(main)g(::)g(Dialogue)71 2504 y(main)g(=)h(print)f(\(fringe)g(\(Branch)
5383 
+g(\(Leaf)g(1\))g(\(Leaf)h(2\)\)\))0 2614 y Fp(The)16 b(v)m(arious)g(items)g
5384 
+(b)q(eing)g(imp)q(orted)g(in)o(to)g(and)g(exp)q(orted)g(out)f(of)g(a)g(mo)q
5385 
+(dule)i(are)e(called)i Fo(entities)p Fp(.)j(Note)15 b(the)p
5386 
+eop
5387 
+%%Page: 38 38
5388 
+bop 0 -40 a Fp(T-38)1557 b Fj(6)46 b(MODULES)0 105 y Fp(explicit)21
5389 
+b(imp)q(ort)d(list)h(in)h(the)e(imp)q(ort)h(declaration;)h(omitting)f(it)g(w)
5390 
+o(ould)g(cause)f(all)i(en)o(tities)f(exp)q(orted)g(from)0 162
5391 
+y Fi(Tree)c Fp(to)f(b)q(e)i(imp)q(orted.)71 244 y(The)c(en)o(tit)o(y)h
5392 
+Fi(main)e Fp(\(and)i(its)f(t)o(yping\))h(and)f(the)h(mo)q(dule)g(name)g
5393 
+Fi(Main)o Fp(,)g(in)g(the)g(ab)q(o)o(v)o(e)f(example,)h(ha)o(v)o(e)f(sp)q
5394 
+(ecial)0 300 y(signi\014cance,)17 b(as)e(sp)q(eci\014ed)i(in)f(the)f(Rep)q
5395 
+(ort:)71 383 y(\\A)d(Hask)o(ell)i Fo(pr)n(o)n(gr)n(am)g Fp(is)f(a)g
5396 
+(collection)i(of)d(mo)q(dules,)j(one)e(of)f(whic)o(h,)i(b)o(y)f(con)o(v)o(en)
5397 
+o(tion,)h(m)o(ust)e(b)q(e)i(called)h Fi(Main)0 439 y Fp(and)j(m)o(ust)f(exp)q
5398 
+(ort)g(the)h(v)m(alue)h Fi(main)o Fp(.)27 b(The)18 b Fo(value)g
5399 
+Fp(of)f(the)h(program)e(is)i(the)g(v)m(alue)h(of)e(the)h(iden)o(ti\014er)h
5400 
+Fi(main)e Fp(in)0 496 y(mo)q(dule)f Fi(Main)p Fp(,)f(and)g
5401 
+Fi(main)g Fp(m)o(ust)f(ha)o(v)o(e)h(t)o(yp)q(e)g Fi(Dialogue)o
5402 
+Fp(.")71 578 y(\(The)e(t)o(yp)q(e)g Fi(Dialogue)f Fp(relates)h(to)g(I/O,)g
5403 
+(and)h(is)f(discussed)i(in)f(Section)g(8.\))19 b(Th)o(us)13
5404 
+b(the)g(ab)q(o)o(v)o(e)g(t)o(w)o(o)f(mo)q(dules)0 634 y(together)i
5405 
+(constitute)i(a)f(v)m(alid)i(Hask)o(ell)f(program.)0 784 y
5406 
+Fg(6.1)56 b(Original)17 b(Names)h(and)h(Renaming)0 896 y Fp(Abstractly)d
5407 
+(asso)q(ciated)h(with)g(ev)o(ery)f(en)o(tit)o(y)g(is)h(its)g
5408 
+Fo(original)g(name)p Fp(|a)f(pair)h(consisting)g(of)f(the)g(name)h(of)f(the)0
5409 
+953 y(en)o(tit)o(y)d(and)h(the)f(name)g(of)g(the)h(mo)q(dule)g(in)h(whic)o(h)
5410 
+f(it)f(w)o(as)g(originally)i(de\014ned.)20 b(This)14 b(concept)g(is)g(useful)
5411 
+g(in)h(that)0 1009 y(it)f(allo)o(ws)g(an)f(en)o(tit)o(y)h(with)g(the)g(same)f
5412 
+(name)h(to)f(b)q(e)h(imp)q(orted)g(from)f(a)g(v)m(ariet)o(y)h(of)f
5413 
+(di\013eren)o(t)h(mo)q(dules,)h(without)0 1066 y(con\015ict,)h(as)f(long)g
5414 
+(as)g(the)g(original)h(name)g(is)f(the)h(same.)71 1148 y(En)o(tities)f(b)q
5415 
+(eing)i(imp)q(orted)f(can)f(also)g(b)q(e)h Fo(r)n(ename)n(d)p
5416 
+Fp(;)e(for)h(example:)71 1257 y Fi(import)23 b(Tree)g(\()h
5417 
+(Tree\(Leaf,Branch\),)d(fringe)i(\))238 1313 y(renaming)f(\(Leaf)i(to)f
5418 
+(Root,)g(Branch)g(to)h(Twig\))0 1541 y Fg(6.2)56 b(In)n(terfaces)18
5419 
+b(and)h(Impleme)o(n)n(tations)0 1653 y Fp(The)d(mo)q(dules)h
5420 
+Fi(Tree)e Fp(and)g Fi(Main)g Fp(sho)o(wn)h(ab)q(o)o(v)o(e)f(are)g(in)i
5421 
+(actualit)o(y)f(mo)q(dule)g Fo(implementations)p Fp(|they)g(con)o(tain)0
5422 
+1709 y(all)j(of)e(the)h(Hask)o(ell)g(co)q(de)g(to)g(completely)h(de\014ne)f
5423 
+(a)g(mo)q(dule.)28 b(The)18 b(information)g(passed)g(b)q(et)o(w)o(een)g(mo)q
5424 
+(dules)0 1766 y(during)f(exp)q(ort)e(and)h(imp)q(ort,)g(ho)o(w)o(ev)o(er,)f
5425 
+(is)h(more)f(abstract,)g(and)h(is)g(captured)g(formally)g(in)h(a)e(mo)q(dule)
5426 
+i Fo(inter-)0 1822 y(fac)n(e)p Fp(.)i(The)c(in)o(terface)g(for)f(a)g(mo)q
5427 
+(dule)i Fi(M)e Fp(con)o(tains)h(all)g(of)f(the)h(information)f(ab)q(out)h
5428 
+(the)f(en)o(tities)i(exp)q(orted)f(from)0 1879 y Fi(M)h Fp(that)f(is)i
5429 
+(needed)h(to)d(ensure)i(prop)q(er)f(t)o(yping)h(of)e(some)h(other)g(mo)q
5430 
+(dule)h Fi(N)f Fp(that)g(ma)o(y)f(imp)q(ort)i Fi(M)p Fp(.)22
5431 
+b(The)17 b(prop)q(er)0 1935 y(in)o(terfaces)e(for)g(the)g(mo)q(dules)i
5432 
+Fi(Tree)d Fp(and)i Fi(Main)e Fp(are:)71 2035 y Fi(interface)22
5433 
+b(Tree)i(\()f(Tree\(Leaf,Branch\),)f(fringe)h(\))g(where)71
5434 
+2092 y(data)g(Tree)g(a)h(=)g(Leaf)f(a)h(|)f(Branch)g(\(Tree)h(a\))f(\(Tree)g
5435 
+(a\))71 2148 y(fringe)g(::)g(Tree)h(a)f(->)h([a])71 2228 y(interface)e(Main)i
5436 
+(\(main\))f(where)71 2284 y(import)g(Tree)g(\()h(Tree\(Leaf,Branch\),)d
5437 
+(fringe)i(\))71 2341 y(main)g(::)g(Dialogue)71 2501 y Fp(Normally)12
5438 
+b(the)f(user)h(need)g(not)f(b)q(e)i(concerned)f(ab)q(out)g(mo)q(dule)g(in)o
5439 
+(terfaces,)g(since)h(they)f(are)f(usually)i(deriv)o(ed)0 2557
5440 
+y(automatically)k(from)f(the)h(mo)q(dule)h(implemen)o(tation.)27
5441 
+b(On)17 b(the)g(other)f(hand,)i(it)f(is)g(not)g(un)o(usual)h(to)e(w)o(an)o(t)
5442 
+g(to)0 2614 y(statically)f(debug)h(a)e(mo)q(dule)i(implemen)o(tation)g(that)e
5443 
+(imp)q(orts)h(some)f(other)g(mo)q(dule)i(whose)f(implemen)o(tation)p
5444 
+eop
5445 
+%%Page: 39 39
5446 
+bop 0 -40 a Fj(6.3)45 b(Abstract)14 b(Data)g(T)o(yp)q(es)1332
5447 
+b Fp(T-39)0 105 y(do)q(es)21 b(not)g(exist)g(y)o(et;)i(b)q(eing)f(able)g(to)e
5448 
+(explicitly)k(write)d(the)g(in)o(terface)g(for)g(this)g(imp)q(orted)g(mo)q
5449 
+(dule)i(w)o(ould)0 162 y(p)q(ermit)f(this.)41 b(Indeed,)24
5450 
+b(in)o(terfaces)e(supp)q(ort)g(top-do)o(wn,)h(successiv)o(e)g(re\014nemen)o
5451 
+(t,)g(soft)o(w)o(are)d(dev)o(elopmen)o(t)0 218 y(metho)q(dologies,)c(in)g
5452 
+(whic)o(h)g Fo(al)r(l)f Fp(in)o(terfaces)g(are)g(ideally)i(written)e
5453 
+Fo(\014rst)p Fp(.)0 493 y Fg(6.3)56 b(Abstract)19 b(Data)f(T)n(yp)r(es)0
5454 
+661 y Fp(Aside)j(from)f(con)o(trolling)h(namespaces,)g(mo)q(dules)g(pro)o
5455 
+(vide)g(the)f(only)h(w)o(a)o(y)e(to)g(build)j(abstract)d(data)h(t)o(yp)q(es)0
5456 
+717 y(\(ADTs\))c(in)i(Hask)o(ell.)27 b(F)l(or)17 b(example,)h(the)g(c)o
5457 
+(haracteristic)f(feature)g(of)g(an)g(ADT)g(is)h(that)f(the)g
5458 
+Fo(r)n(epr)n(esentation)0 774 y(typ)n(e)i Fp(is)h Fo(hidden)p
5459 
+Fp(;)h(all)f(op)q(erations)f(on)g(the)g(ADT)g(are)g(done)h(at)e(an)h
5460 
+(abstract)f(lev)o(el)j(whic)o(h)f(do)q(es)g(not)e(dep)q(end)0
5461 
+830 y(on)f(the)h(represen)o(tation.)26 b(F)l(or)16 b(example,)j(although)e
5462 
+(the)g Fi(Tree)g Fp(t)o(yp)q(e)g(is)h(simple)h(enough)f(that)e(w)o(e)h(migh)o
5463 
+(t)g(not)0 886 y(normally)e(mak)o(e)g(it)g(abstract,)e(a)h(suitable)i(ADT)f
5464 
+(for)f(it)h(migh)o(t)g(include)i(the)e(follo)o(wing)g(op)q(erations,)g(whic)o
5465 
+(h)g(w)o(e)0 943 y(sp)q(ecify)i(in)f(the)f(form)f(of)h(an)g(in)o(terface:)71
5466 
+1052 y Fi(interface)22 b(TreeADT)h(\(Tree,)g(leaf,)g(branch,)g(cell,)524
5467 
+1108 y(left,)g(right,)g(isLeaf,)g(isBranch\))g(where)71 1165
5468 
+y(data)g(Tree)g(a)71 1221 y(leaf)476 b(::)24 b(a)g(->)f(Tree)h(a)71
5469 
+1278 y(branch)428 b(::)24 b(Tree)f(a)h(->)g(Tree)f(a)h(->)f(Tree)g(a)71
5470 
+1334 y(cell)476 b(::)24 b(Tree)f(a)h(->)g(a)71 1391 y(left,)f(right)309
5471 
+b(::)24 b(Tree)f(a)h(->)g(Tree)f(a)71 1447 y(isLeaf)428 b(::)24
5472 
+b(Tree)f(a)h(->)g(Bool)0 1556 y Fp(A)15 b(mo)q(dule)i(implemen)o(tation)f
5473 
+(supp)q(orting)g(this)g(is:)71 1665 y Fi(module)23 b(TreeADT)g(\(Tree,)g
5474 
+(leaf,)g(branch,)g(cell,)452 1722 y(left,)h(right,)f(isLeaf\))g(where)71
5475 
+1801 y(data)g(Tree)g(a)310 b(=)24 b(Leaf)f(a)h(|)g(Branch)f(\(Tree)g(a\))h
5476 
+(\(Tree)f(a\))71 1881 y(leaf)476 b(=)24 b(Leaf)71 1937 y(branch)428
5477 
+b(=)24 b(Branch)71 1994 y(cell)47 b(\(Leaf)23 b(a\))238 b(=)24
5478 
+b(a)71 2050 y(left)47 b(\(Branch)23 b(l)g(r\))143 b(=)24 b(l)71
5479 
+2107 y(right)f(\(Branch)g(l)g(r\))143 b(=)24 b(r)71 2163 y(isLeaf)70
5480 
+b(\(Leaf)24 b(_\))166 b(=)24 b(True)71 2220 y(isLeaf)70 b(_)334
5481 
+b(=)24 b(False)0 2331 y Fp(Note)d(in)h(the)g(exp)q(ort)f(list)i(that)d(the)i
5482 
+(t)o(yp)q(e)f(name)h Fi(Tree)f Fp(app)q(ears)g(alone)h(\(i.e.)f(without)h
5483 
+(its)g(constructors\);)0 2388 y(similarly)l(,)e(in)f(the)e(in)o(terface)h
5484 
+(the)g Fi(data)f Fp(declaration)i(for)e Fi(Tree)g Fp(do)q(es)h(not)f(include)
5485 
+k(the)c(constructors.)27 b(Th)o(us)0 2444 y Fi(Leaf)17 b Fp(and)h
5486 
+Fi(Branch)f Fp(are)h(not)f(exp)q(orted,)h(and)g(the)g(only)h(w)o(a)o(y)d(to)h
5487 
+(build)j(or)e(tak)o(e)f(apart)g(trees)g(outside)i(of)e(the)0
5488 
+2501 y(mo)q(dule)f(is)f(b)o(y)g(using)h(the)f(v)m(arious)g(\(abstract\))e(op)
5489 
+q(erations.)20 b(Of)15 b(course,)g(the)g(adv)m(an)o(tage)f(of)h(this)g
5490 
+(information)0 2557 y(hiding)20 b(is)e(that)f(at)h(a)g(later)g(time)g(w)o(e)g
5491 
+(could)h Fo(change)e Fp(the)h(represen)o(tation)g(t)o(yp)q(e)g(without)g
5492 
+(a\013ecting)g(users)g(of)0 2614 y(the)d(t)o(yp)q(e.)p eop
5493 
+%%Page: 40 40
5494 
+bop 0 -40 a Fp(T-40)1368 b Fj(7)45 b(TYPING)15 b(PITF)-5 b(ALLS)0
5495 
+105 y Fg(6.4)56 b(Rules,)17 b(Rules,)g(and)j(More)e(Rules)0
5496 
+227 y Fp(Although)f(Hask)o(ell's)h(mo)q(dule)g(system)e(is)i(relativ)o(ely)g
5497 
+(conserv)m(ativ)o(e,)f(there)g(are)g(man)o(y)f(rules)i(concerning)g(the)0
5498 
+283 y(imp)q(ort)g(and)g(exp)q(ort)g(of)g(v)m(alues.)29 b(Most)17
5499 
+b(of)g(these)h(are)g(ob)o(vious|for)g(instance,)h(it)f(is)h(illegal)h(to)d
5500 
+(imp)q(ort)h(t)o(w)o(o)0 340 y(di\013eren)o(t)f(en)o(tities)h(ha)o(ving)f
5501 
+(the)f(same)h(name)f(in)o(to)h(the)g(same)f(scop)q(e.)25 b(Other)17
5502 
+b(rules)h(are)e(not)h(so)f(ob)o(vious|for)0 396 y(example,)f(an)e
5503 
+Fi(instance)g Fp(declaration)i(can)f(only)g(app)q(ear)g(in)h(the)f(mo)q(dule)
5504 
+g(in)h(whic)o(h)g(the)f(corresp)q(onding)h Fi(data)0 453 y
5505 
+Fp(or)g Fi(class)f Fp(declaration)i(app)q(ears.)k(The)c(reader)f(should)h
5506 
+(read)f(the)g(Rep)q(ort)h(for)e(details)j(\()p Fn(x)o Fp(5\).)0
5507 
+646 y Fq(7)69 b(T)n(yping)23 b(Pitfalls)0 783 y Fp(This)c(short)e(section)i
5508 
+(giv)o(e)f(an)g(in)o(tuitiv)o(e)i(description)f(of)f(a)g(few)g(common)g
5509 
+(problems)g(that)g(no)o(vices)h(run)f(in)o(to)0 840 y(using)e(Hask)o(ell's)g
5510 
+(t)o(yp)q(e)f(system.)0 1011 y Fg(7.1)56 b(Let-Bound)17 b(P)n(olymorphism)0
5511 
+1133 y Fp(An)o(y)i(language)h(using)g(the)f(Hindley-Milne)q(r)j(t)o(yp)q(e)d
5512 
+(system)g(has)g(what)f(is)i(called)h Fo(let-b)n(ound)f(p)n(olymorphism)p
5513 
+Fp(,)0 1189 y(b)q(ecause)g(iden)o(ti\014ers)g(not)e(b)q(ound)i(using)g(a)e
5514 
+Fi(let)g Fp(or)h Fi(where)f Fp(clause)h(\(or)f(at)g(the)h(top)g(lev)o(el)h
5515 
+(of)e(a)h(mo)q(dule\))g(are)0 1246 y(limited)14 b(with)e(resp)q(ect)h(to)e
5516 
+(their)h(p)q(olymorphism.)20 b(In)13 b(particular,)g(a)f Fo(lamb)n(da-b)n
5517 
+(ound)g Fp(function)h(\(i.e.,)f(one)g(passed)0 1302 y(as)k(argumen)o(t)g(to)f
5518 
+(another)h(function\))h(cannot)f(b)q(e)h(instan)o(tiated)g(in)g(t)o(w)o(o)e
5519 
+(di\013eren)o(t)i(w)o(a)o(ys.)22 b(F)l(or)15 b(example,)j(this)0
5520 
+1359 y(program)c(is)i(illegal:)71 1468 y Fi(let)23 b(f)h(g)47
5521 
+b(=)h(\(g)24 b([],)f(g)h('a'\))548 b(--)24 b(ill-typed)e(expression)71
5522 
+1524 y(in)h(f)h(\(\\x->x\))0 1633 y Fp(b)q(ecause)19 b Fi(g)p
5523 
+Fp(,)f(b)q(ound)h(to)e(a)h(lam)o(b)q(da)g(abstraction)g(whose)g(principal)i
5524 
+(t)o(yp)q(e)e(is)h Fi(a->a)o Fp(,)f(is)h(used)f(within)i Fi(f)d
5525 
+Fp(in)i(t)o(w)o(o)0 1690 y(di\013eren)o(t)c(w)o(a)o(ys:)k(once)d(with)f(t)o
5526 
+(yp)q(e)h Fi([a]->[a])n Fp(,)f(and)h(once)f(with)h(t)o(yp)q(e)f
5527 
+Fi(Char->Char)o Fp(.)0 1861 y Fg(7.2)56 b(Numeric)16 b(Ov)n(erloading)0
5528 
+1983 y Fp(It)f(is)g(easy)g(to)f(forget)g(at)g(times)h(that)g(n)o(umerals)g
5529 
+(are)f Fo(overlo)n(ade)n(d,)h Fp(and)g Fo(not)h(implicitly)g(c)n(o)n(er)n(c)n
5530 
+(e)n(d)d Fp(to)i(the)f(v)m(arious)0 2040 y(n)o(umeric)k(t)o(yp)q(es,)g(as)e
5531 
+(in)j(man)o(y)d(other)h(languages.)26 b(More)17 b(general)h(n)o(umeric)g
5532 
+(expressions)g(sometimes)f(cannot)0 2096 y(b)q(e)f(quite)g(so)f(generic.)20
5533 
+b(A)c(common)e(n)o(umeric)j(t)o(yping)e(error)f(is)i(something)g(lik)o(e)g
5534 
+(the)f(follo)o(wing:)71 2205 y Fi(average)22 b(xs)334 b(=)48
5535 
+b(sum)23 b(xs)h(/)g(length)f(xs)262 b(--)24 b(Wrong!)0 2314
5536 
+y(\(/\))c Fp(requires)h(fractional)f(argumen)o(ts,)g(but)h
5537 
+Fi(length)o Fp('s)f(result)g(is)h(an)f Fi(Int)p Fp(.)35 b(The)20
5538 
+b(t)o(yp)q(e)h(mismatc)o(h)f(m)o(ust)f(b)q(e)0 2371 y(corrected)c(with)h(an)f
5539 
+(explicit)i(co)q(ercion:)71 2480 y Fi(average)404 b(::)24 b(\(Fractional)e
5540 
+(a\))i(=>)f([a])h(->)f(a)71 2536 y(average)f(xs)334 b(=)48
5541 
+b(sum)23 b(xs)h(/)g(fromIntegral)e(\(length)h(xs\))p eop
5542 
+%%Page: 41 41
5543 
+bop 0 -40 a Fj(7.3)45 b(The)15 b(Monomorphism)g(Restriction)1118
5544 
+b Fp(T-41)0 105 y Fg(7.3)56 b(The)18 b(Monomorphism)e(Restriction)0
5545 
+213 y Fp(The)e(Hask)o(ell)h(t)o(yp)q(e)g(system)e(con)o(tains)i(a)f
5546 
+(restriction)g(related)h(to)e(t)o(yp)q(e)i(classes)f(that)g(is)h(not)e(found)
5547 
+i(in)g(ordinary)0 269 y(Hindley-Milne)q(r)23 b(t)o(yp)q(e)d(systems:)29
5548 
+b(the)20 b Fo(monomorphism)i(r)n(estriction)p Fp(.)34 b(The)21
5549 
+b(reason)f(for)f(this)i(restriction)f(is)0 326 y(related)c(to)e(a)h(subtle)h
5550 
+(t)o(yp)q(e)f(am)o(biguit)o(y)g(and)h(is)f(explained)j(in)d(full)i(detail)f
5551 
+(in)g(the)f(Rep)q(ort)h(\()p Fn(x)p Fp(4.5.4\).)i(A)d(simpler)0
5552 
+382 y(explanation)h(follo)o(ws:)71 461 y(The)g(monomorphism)f(restriction)i
5553 
+(sa)o(ys)e(that)g(an)o(y)g(iden)o(ti\014er)j(b)q(ound)e(b)o(y)g(a)g(pattern)f
5554 
+(binding)j(\(whic)o(h)e(in-)0 517 y(cludes)e(bindings)g(to)e(a)g(single)i
5555 
+(iden)o(ti\014er\),)g(and)e(ha)o(ving)h(no)f(explicit)j(t)o(yp)q(e)e
5556 
+(signature,)f(m)o(ust)g(b)q(e)h Fo(monomorphic)p Fp(.)0 574
5557 
+y(An)h(iden)o(ti\014er)h(is)f(monomorphic)g(if)f(is)h(either)h(not)e(o)o(v)o
5558 
+(erloaded,)g(or)g(is)h(o)o(v)o(erloaded)f(but)h(is)g(used)g(in)g(at)f(most)g
5559 
+(one)0 630 y(sp)q(eci\014c)k(o)o(v)o(erloading)e(and)h(is)f(not)g(exp)q
5560 
+(orted.)71 709 y(Violations)e(of)e(this)i(restriction)g(result)f(in)h(a)f
5561 
+(static)g(t)o(yp)q(e)h(error.)18 b(The)12 b(simplest)h(w)o(a)o(y)f(to)f(a)o
5562 
+(v)o(oid)h(the)g(problem)0 765 y(is)18 b(to)g(pro)o(vide)g(an)g(explicit)i(t)
5563 
+o(yp)q(e)e(signature.)28 b(Note)17 b(that)g Fo(any)h Fp(t)o(yp)q(e)g
5564 
+(signature)g(will)h(do)f(\(as)f(long)h(it)h(is)f(t)o(yp)q(e)0
5565 
+822 y(correct\).)71 900 y(A)12 b(common)h(violation)g(of)g(the)f(restriction)
5566 
+i(happ)q(ens)f(with)g(functions)h(de\014ned)g(in)f(a)g(higher-order)g
5567 
+(manner,)0 957 y(as)i(in)h(this)f(de\014nition)i(of)e Fi(sum)g
5568 
+Fp(from)f(the)i(Standard)f(Prelude:)71 1057 y Fi(sum)500 b(=)48
5569 
+b(foldl)23 b(\(+\))h(0)0 1166 y Fp(As)15 b(is,)h(this)f(w)o(ould)h(cause)f(a)
5570 
+g(static)g(t)o(yp)q(e)g(error.)k(W)l(e)d(can)f(\014x)h(the)f(problem)h(b)o(y)
5571 
+f(adding)h(the)f(t)o(yp)q(e)g(signature:)71 1275 y Fi(sum)500
5572 
+b(::)24 b(\(Num)f(a\))h(=>)f([a])h(->)f(a)0 1384 y Fp(Also)16
5573 
+b(note)f(that)f(this)i(problem)g(w)o(ould)f(not)g(ha)o(v)o(e)g(arisen)g(if)h
5574 
+(w)o(e)f(had)g(written:)71 1493 y Fi(sum)23 b(xs)429 b(=)48
5575 
+b(foldl)23 b(\(+\))h(0)f(xs)0 1602 y Fp(b)q(ecause)16 b(the)f(restriction)h
5576 
+(only)g(applies)h(to)d(pattern)h(bindings.)0 1766 y Fq(8)69
5577 
+b(Input/Output)0 1890 y Fp(The)17 b(I/O)h(system)e(in)i(Hask)o(ell)g(is)g
5578 
+(purely)g(functional,)g(y)o(et)f(has)g(all)h(the)f(expressiv)o(e)h(p)q(o)o(w)
5579 
+o(er)f(of)f(that)h(found)g(in)0 1946 y(con)o(v)o(en)o(tional)h(programming)f
5580 
+(languages.)27 b(T)l(o)18 b(ac)o(hiev)o(e)g(this,)g(Hask)o(ell)g(relies)h
5581 
+(critically)h(on)e(lazy)g(ev)m(aluation)0 2002 y(and)d(higher-order)h
5582 
+(functions,)g(the)f(k)o(ey)g(building)j(blo)q(c)o(ks)e(of)f(an)o(y)g
5583 
+(functional)h(program.)j(\()p Fn(x)p Fp(7\))71 2081 y(The)13
5584 
+b(Rep)q(ort)h(describ)q(es)i(t)o(w)o(o)c(equiv)m(alen)o(t)j(w)o(a)o(ys)e(to)g
5585 
+(do)h(I/O)g(in)g(Hask)o(ell:)20 b(the)14 b Fo(str)n(e)n(am-b)n(ase)n(d)e
5586 
+Fp(approac)o(h)i(and)0 2137 y(the)f Fo(c)n(ontinuation-b)n(ase)n(d)e
5587 
+Fp(approac)o(h.)19 b(The)13 b(former)f(is)h(probably)g(easier)g(to)f(explain)
5588 
+j(conceptually)l(,)f(and)f(indeed)0 2194 y(the)19 b(latter)f(is)h(de\014ned)h
5589 
+(in)f(terms)f(of)g(the)h(former)f(in)h(the)g(Rep)q(ort.)30
5590 
+b(Ho)o(w)o(ev)o(er,)18 b(for)g(practical)h(programming,)0 2250
5591 
+y(the)g(latter)f(\(con)o(tin)o(uation-based\))h(approac)o(h)g(is)g(the)g
5592 
+(preferred)g(metho)q(dology)l(,)g(and)g(that)f(is)i(what)e(w)o(e)g(will)0
5593 
+2307 y(concen)o(trate)d(on)g(in)h(this)g(section.)k(\()p Fn(x)p
5594 
+Fp(7.5\))0 2449 y Fg(8.1)56 b(In)n(tro)r(duction)18 b(to)g(Con)n(tin)n
5595 
+(uations)0 2557 y Fp(T)l(o)13 b(understand)g(this)h(metho)q(dology)l(,)f(it)g
5596 
+(is)g(helpful)i(to)e(ha)o(v)o(e)f(some)h(understanding)h(of)e(the)h(notion)h
5597 
+(of)e(a)h Fo(c)n(ontin-)0 2614 y(uation)p Fp(.)20 b(A)13 b(con)o(tin)o
5598 
+(uation)h(is)f(basically)i(a)e(\(p)q(ossibly)i(n)o(ullary\))f
5599 
+Fo(function)e Fp(that)h(maps)g(an)g(\\in)o(termediate)h(v)m(alue")p
5600 
+eop
5601 
+%%Page: 42 42
5602 
+bop 0 -40 a Fp(T-42)1417 b Fj(8)45 b(INPUT/OUTPUT)0 105 y Fp(\(p)q(ossibly)20
5603 
+b(empt)o(y\))e(to)g(\\the)g(rest)g(of)h(the)f(program.")29
5604 
+b(In)19 b(this)g(w)o(a)o(y)l(,)g(con)o(tin)o(uations)g(are)f(used)h(to)f
5605 
+(explicitly)0 162 y(manage)d(\\\015o)o(w)h(of)f(con)o(trol,")h(and)g(th)o(us)
5606 
+g(w)o(e)f(tend)i(to)e(de\014ne)i(functions)g(that,)e(instead)i(of)e
5607 
+(returning)i(with)f(an)0 218 y(answ)o(er,)g(will)j(apply)e(a)f(con)o(tin)o
5608 
+(uation)i(\(passed)e(in)i(as)e(an)h(argumen)o(t\))e(to)h(the)h(answ)o(er.)24
5609 
+b(Because)17 b(of)g(this,)g(the)0 274 y(resulting)f(programming)f(st)o(yle)g
5610 
+(is)h(often)f(called)i Fo(c)n(ontinuation)e(p)n(assing)g(style)p
5611 
+Fp(,)f(or)h(CPS)g(for)g(short.)71 359 y(T)l(o)e(giv)o(e)h(an)g(example)g(of)f
5612 
+(this)i(idea)f(without)g(reference)g(to)f(I/O,)h(let's)g(consider)g(the)g
5613 
+(use)g(of)g(con)o(tin)o(uations)0 416 y(to)i(manage)g(errors|i.e.,)g(to)f
5614 
+(create)i(the)f(e\013ect)g(of)g(a)g(non-lo)q(cal)i(exit,)f(or)f(call)h(to)f
5615 
+(an)g(error-handler.)24 b(A)17 b(con-)0 472 y(v)o(en)o(tional)f(w)o(a)o(y)e
5616 
+(of)h(handling)i(error)d(v)m(alues)i(in)g(Hask)o(ell)g(migh)o(t)g(b)q(e)f
5617 
+(the)h(follo)o(wing:)71 581 y Fi(data)23 b(Maybe)g(a)286 b(=)24
5618 
+b(Ok)g(a)f(|)h(Oops)f(String)71 638 y(f)548 b(::)24 b(Int)f(->)h(Maybe)f(Int)
5619 
+71 694 y(f)g(x)501 b(=)24 b(let)f(y)h(=)g(...)691 751 y(in)47
5620 
+b(if)24 b(y==0)47 b(then)g(Oops)24 b("divide)f(by)g(zero")786
5621 
+807 y(else)48 b(Ok)23 b(\(x/y\))0 916 y Fp(Here)c(the)g Fi(Maybe)f
5622 
+Fp(t)o(yp)q(e)h(is)g(used)g(to)f(enco)q(de)i(the)f(p)q(ossibilit)o(y)i(of)d
5623 
+(error)g(in)o(v)o(olving)i(a)f(particular)g(t)o(yp)q(e.)31
5624 
+b(No)o(w)0 973 y(supp)q(ose)14 b Fi(f)f Fp(is)h(used)g(in)g(con)o(text)e
5625 
+(somewhere;)i(for)f(example,)h(supp)q(ose)g(when)f(the)h(divide-b)o(y-zero)h
5626 
+(error)e(o)q(ccurs)0 1029 y(there)i(is)h(some)f(default)h(v)m(alue)g
5627 
+Fi(d)f Fp(that)g(is)g(appropriate)g(to)g(use)h(instead:)118
5628 
+1138 y Fi(case)24 b(f)f(z)h(of)166 1195 y(Ok)g(x)71 b(->)24
5629 
+b(x)166 1251 y(Oops)f(s)h(->)g(d)71 1414 y Fp(In)16 b(con)o(trast)f(to)h
5630 
+(this,)h(an)f(approac)o(h)g(to)f(handling)j(errors)e(based)g(on)h(explicit)h
5631 
+(con)o(tin)o(uations)f(migh)o(t)f(lo)q(ok)0 1470 y(something)f(lik)o(e)i
5632 
+(this:)71 1579 y Fi(f)548 b(::)24 b(Int)f(->)h(\(String)f(->)g(Int\))h(->)f
5633 
+(Int)71 1635 y(f)g(x)h(c)453 b(=)24 b(let)f(y)h(=)g(...)691
5634 
+1692 y(in)47 b(if)24 b(x==0)47 b(then)g(c)24 b("divide)f(by)h(zero")786
5635 
+1748 y(else)48 b(x/y)0 1864 y Fp(Note)17 b(that)f(an)h(error)f(con)o(tin)o
5636 
+(uation)i Fi(c)f Fp(is)g(explicitly)j(supplied)g(to)c Fi(f)h
5637 
+Fp(as)f(an)h(argumen)o(t.)1546 1847 y Fm(14)1608 1864 y Fp(No)o(w,)g(to)f
5638 
+(sim)o(ulate)0 1920 y(the)f(ab)q(o)o(v)o(e)g Fo(use)g Fp(of)g
5639 
+Fi(f)p Fp(,)g(w)o(e)f(w)o(ould)i(simply)g(write:)118 2029 y
5640 
+Fi(f)24 b(z)g(\(\\s)f(->)h(d\))71 2192 y Fp(The)12 b(trade-o\013s)f(b)q(et)o
5641 
+(w)o(een)h(con)o(v)o(en)o(tional)h(and)f(con)o(tin)o(uation-based)h(approac)o
5642 
+(hes)f(to)f(handling)j(suc)o(h)f(things)0 2248 y(as)i(errors)f(are)h(sub)s
5643 
+(jectiv)o(e.)20 b(The)c(passing)f(of)g(con)o(tin)o(uations)g(can)h(b)q(e)f
5644 
+(cum)o(b)q(ersome,)h(but)f(on)g(the)g(other)g(hand,)p 0 2295
5645 
+780 2 v 37 2322 a Fl(14)69 2338 y Fk(As)h(an)h(aside,)h(w)o(e)e(p)q(oin)o(t)h
5646 
+(out)g(that)g(an)f(ev)o(en)h(b)q(etter)g(solution)h(w)o(ould)g(exist)f(if)f
5647 
+(the)h(primitiv)o(e)h(arithmetic)g(functions)g(to)q(ok)0 2383
5648 
+y(con)o(tin)o(uation)e(argumen)o(ts)e(to)q(o!)j(If)12 b Ff(divide)f
5649 
+Fk(w)o(ere)h(suc)o(h)i(a)f(function)h(for)f Ff(/)g Fk(then)g(w)o(e)g(could)h
5650 
+(simply)h(write:)71 2472 y Ff(f)k(x)g(c)372 b(=)20 b(let)e(y)h(=)g(...)581
5651 
+2518 y(in)38 b(divide)17 b(x)j(y)f(c)p eop
5652 
+%%Page: 43 43
5653 
+bop 0 -40 a Fj(8.2)45 b(Con)o(tin)o(uation)15 b(Based)g(I/O)1271
5654 
+b Fp(T-43)0 105 y(the)12 b(enco)q(ding)g(of)f(error)g(in)o(to)h(sp)q(ecial)h
5655 
+(t)o(yp)q(es)e(is)h(also)g(cum)o(b)q(ersome.)18 b(The)12 b(programmer)e(m)o
5656 
+(ust)h(mak)o(e)g(a)g(judicious)0 162 y(c)o(hoice)16 b(based)g(on)f(her)g
5657 
+(particular)h(circumstances.)71 259 y(Before)e(mo)o(ving)g(on)g(to)f(I/O,)h
5658 
+(ho)o(w)o(ev)o(er,)f(w)o(e)h(p)q(oin)o(t)g(out)g(one)g(\014nal)h(adv)m(an)o
5659 
+(tage)f(of)f(con)o(tin)o(uations)i(b)o(y)f(noting)0 316 y(that)g(if)h
5660 
+Fi(f)g Fp(w)o(ere)f Fo(r)n(e)n(cursive)p Fp(,)g(the)h(error)f(v)m(alue)i(in)f
5661 
+(the)g(con)o(v)o(en)o(tional)g(approac)o(h)f(migh)o(t)h(ha)o(v)o(e)f(to)g(b)q
5662 
+(e)i(propagated)0 372 y(bac)o(k)c(through)f(ev)o(ery)h(lev)o(el)i(of)d
5663 
+(recursion,)i(whereas)f(in)h(the)f(con)o(tin)o(uation-based)h(approac)o(h,)e
5664 
+(the)i(con)o(tin)o(uation)0 429 y(is)f(called)h(directly)l(,)g(m)o(uc)o(h)f
5665 
+(lik)o(e)h(a)e(non-lo)q(cal)i(exit)f(to)e(an)i(error)f(handler!)19
5666 
+b(This)12 b(ma)o(y)f(ha)o(v)o(e)g(an)h(imp)q(ortan)o(t)f(impact)0
5667 
+485 y(on)k(e\016ciency)l(.)0 688 y Fg(8.2)56 b(Con)n(tin)n(uation)19
5668 
+b(Based)g(I/O)0 823 y Fp(Giv)o(en)12 b(this)f(bac)o(kground,)h(understanding)
5669 
+g(con)o(tin)o(uation-based)g(I/O)g(in)g(Hask)o(ell)g(should)g(b)q(e)f
5670 
+(straigh)o(tforw)o(ard;)0 879 y(there)k(are)g(only)h(t)o(w)o(o)e(small)i(t)o
5671 
+(wists.)71 977 y(First,)11 b(a)h(program)f(engaged)h(in)h(I/O)f(\\comm)o
5672 
+(unicates")g(to)f(the)h(outside)h(w)o(orld)f(\(nominally)l(,)i(the)e(op)q
5673 
+(erating)0 1033 y(system\))19 b(using)h(con)o(tin)o(uations.)32
5674 
+b(A)20 b(Hask)o(ell)g(program)e(engaged)i(in)g(I/O)g(is)g(required)g(to)f(ha)
5675 
+o(v)o(e)g(a)g(top-lev)o(el)0 1090 y(iden)o(ti\014er)j Fi(main)d
5676 
+Fp(whose)h(t)o(yp)q(e)g(is)h Fi(Dialogue)o Fp(;)h(this)e(is)h(the)f(t)o(yp)q
5677 
+(e)g(of)g(the)g(con)o(tin)o(uation)g(that)g(the)g(op)q(erating)0
5678 
+1146 y(system)15 b(is)g(exp)q(ecting.)71 1244 y(The)j(other)g(t)o(wist)f(is)i
5679 
+(that)f(not)f(only)i(is)g Fo(failur)n(e)f Fp(enco)q(ded)h(as)f(a)g(con)o(tin)
5680 
+o(uation,)h(but)g(so)e(is)i Fo(suc)n(c)n(ess)p Fp(,)e(since)0
5681 
+1301 y(w)o(e)d(need)i(to)e(con)o(trol)h(the)f(\015o)o(w)h(of)f(all)i(asp)q
5682 
+(ects)e(of)h(I/O.)g(Th)o(us)f(the)h(I/O)g(\\commands")f(in)i(Hask)o
5683 
+(ell|functions)0 1357 y(called)h Fo(tr)n(ansactions)p Fp(|tak)o(e)d
5684 
+Fo(two)h Fp(con)o(tin)o(uation)h(argumen)o(ts,)e(one)h(for)g(success)h(and)f
5685 
+(the)g(other)g(for)g(failure.)71 1455 y(The)d(simplest)h(thing)g(a)f(program)
5686 
+f(could)i(do)f(is)g Fo(halt)p Fp(.)19 b(T)l(o)12 b(do)g(that,)g(w)o(e)g(use)g
5687 
+(the)g(sp)q(ecial)i Fi(done)e Fp(con)o(tin)o(uation,)0 1512
5688 
+y(whose)j(t)o(yp)q(e)g(is)h Fi(Dialogue)o Fp(:)71 1622 y Fi(main)476
5689 
+b(=)48 b(done)71 1797 y Fp(F)l(or)18 b(a)g(little)i(more)f(sophistication,)h
5690 
+(supp)q(ose)f(w)o(e)g(wish)g(to)f(write)h(a)g(string)f Fi(s)h
5691 
+Fp(to)f(a)g(\014le)i(whose)f(name)f(is)0 1854 y Fi("ReadMe")o
5692 
+Fp(.)i(W)l(e)15 b(w)o(ould)h(do)f(this)g(in)h(Hask)o(ell)g(using)g(the)g
5693 
+Fi(writeFile)e Fp(transaction:)71 1963 y Fi(main)476 b(=)24
5694 
+b(writeFile)f("ReadMe")f(s)i(failCont)f(succCont)0 2072 y Fp(where)12
5695 
+b Fi(failCont)f Fp(and)h Fi(succCont)f Fp(are)h(failure)h(and)f(success)g
5696 
+(con)o(tin)o(uations,)h(resp)q(ectiv)o(ely)l(,)h(that)d(will)j(b)q(e)e(giv)o
5697 
+(en)0 2128 y(sp)q(eci\014c)17 b(v)m(alues)f(later.)k(The)c(t)o(yp)q(e)f(of)g
5698 
+Fi(writeFile)f Fp(is:)71 2237 y Fi(writeFile)356 b(::)24 b(Name)f(->)h
5699 
+(String)f(->)g(FailCont)g(->)h(SuccCont)f(->)g(Dialogue)71
5700 
+2294 y(type)g(Name)357 b(=)24 b(String)0 2403 y Fp(So)15 b(w)o(e)g(see)h
5701 
+(that)e(the)h(result)h(of)f(the)g(application)i(of)e Fi(writeFile)f
5702 
+Fp(has)h(the)g(appropriate)g(t)o(yp)q(e:)20 b Fi(Dialogue)o
5703 
+Fp(.)71 2501 y(But)g(what)f(exactly)h(are)g Fi(FailCont)e Fp(and)j
5704 
+Fi(SuccCont)n Fp(?)35 b(T)l(o)20 b(answ)o(er)f(that,)h(w)o(e)g(m)o(ust)f
5705 
+(understand)i(what)0 2557 y(kinds)16 b(of)e(\\in)o(termediate)h(v)m(alues")h
5706 
+(are)e(generated)h(b)o(y)f(the)h(v)m(arious)g(transactions.)k(F)l(or)14
5707 
+b(example,)i Fo(failur)n(e)e Fp(of)g(a)0 2614 y(transaction)h(ma)o(y)f
5708 
+(generate)h(an)o(y)g(of)g(the)g(follo)o(wing)h(kinds)g(of)f(errors:)p
5709 
+eop
5710 
+%%Page: 44 44
5711 
+bop 0 -40 a Fp(T-44)1417 b Fj(8)45 b(INPUT/OUTPUT)71 160 y
5712 
+Fi(data)23 b(IOError)285 b(=)24 b(WriteError)46 b(String)643
5713 
+216 y(|)24 b(ReadError)70 b(String)643 272 y(|)24 b(SearchError)e(String)643
5714 
+329 y(|)i(FormatError)e(String)643 385 y(|)i(OtherError)46
5715 
+b(String)0 494 y Fp(and)15 b(th)o(us)g Fi(FailCont)f Fp(is)i(de\014ned)h(as:)
5716 
+71 595 y Fi(type)23 b(FailCont)261 b(=)24 b(IOError)f(->)h(Dialogue)0
5717 
+704 y Fp(In)16 b(con)o(trast)e(to)g(failure,)i Fo(suc)n(c)n(ess)e
5718 
+Fp(of)g Fi(writeFile)g Fp(do)q(esn't)h(really)h(return)g Fo(anything)p
5719 
+Fp(,)e(so)h Fi(SuccCont)f Fp(is)i(simply:)71 813 y Fi(type)23
5720 
+b(SuccCont)261 b(=)24 b(Dialogue)0 922 y Fp(A)19 b(simple)h(failure)f(con)o
5721 
+(tin)o(uation)g(that)f(is)h(prede\014ned)h(in)f(Hask)o(ell)h(is)f(one)f(that)
5722 
+g(ignores)h(the)g(error)e(message)0 978 y(and)e(halts:)71 1078
5723 
+y Fi(abort)452 b(::)24 b(FailCont)71 1135 y(abort)f(err)357
5724 
+b(=)24 b(done)0 1244 y Fp(A)15 b(b)q(etter)g(one,)g(also)h(prede\014ned,)g
5725 
+(prin)o(ts)f(the)h(error)e(message)h(to)g Fi(stderror)f Fp(b)q(efore)h
5726 
+(halting:)71 1353 y Fi(exit)476 b(::)48 b(FailCont)71 1409
5727 
+y(exit)23 b(err)381 b(=)48 b(appendChan)22 b(stderr)h(msg)h(abort)f(done)715
5728 
+1466 y(where)g(msg)h(=)f(case)h(err)f(of)h(ReadError)70 b(s)24
5729 
+b(->)f(s)1288 1522 y(WriteError)46 b(s)24 b(->)f(s)1288 1579
5730 
+y(SearchError)f(s)i(->)f(s)1288 1635 y(FormatError)f(s)i(->)f(s)1288
5731 
+1692 y(OtherError)46 b(s)24 b(->)f(s)71 1850 y Fp(Returning)18
5732 
+b(no)o(w)g(to)f(the)g(previous)i(example,)g(if)f(what)f(w)o(e)g(w)o(an)o(ted)
5733 
+g(is)i(simply)g(to)e(halt)g(after)g(writing)i(to)0 1906 y(the)c(\014le,)h
5734 
+(and)g(prin)o(t)f(an)o(y)g(error)f(message)h(that)g(migh)o(t)g(arise,)g(w)o
5735 
+(e)g(w)o(ould)g(write:)71 2015 y Fi(main)476 b(=)24 b(writeFile)f("ReadMe")f
5736 
+(s)i(exit)f(done)71 2173 y Fp(The)15 b(transaction)g Fi(readFile)f
5737 
+Fp(returns)h(the)g(con)o(ten)o(ts)g(of)f(a)h(\014le,)h(and)g(th)o(us)f(its)g
5738 
+(t)o(yp)q(e)g(is)h(giv)o(en)g(b)o(y:)71 2282 y Fi(readFile)380
5739 
+b(::)24 b(Name)f(->)h(FailCont)f(->)g(StrCont)g(->)h(Dialogue)71
5740 
+2339 y(type)f(StrCont)285 b(=)24 b(String)f(->)h(Dialogue)0
5741 
+2448 y Fp(F)l(or)15 b(example,)g(w)o(e)g(could)h(use)g(it)f(to)g(read)g(the)g
5742 
+(\014le)i(previously)f(written:)71 2557 y Fi(main)476 b(=)24
5743 
+b(readFile)f("ReadMe")g(exit)g(\(\\s->...\))p eop
5744 
+%%Page: 45 45
5745 
+bop 0 -40 a Fj(8.2)45 b(Con)o(tin)o(uation)15 b(Based)g(I/O)1271
5746 
+b Fp(T-45)0 105 y(where)15 b(the)h Fi(...)e Fp(re\015ects)i(whatev)o(er)e(it)
5747 
+i(is)g(w)o(e)f(wish)g(to)g(do)g(with)h(what)e(w)o(e)h(ha)o(v)o(e)g(read.)71
5748 
+183 y(Pragmatically)l(,)f(it)h(ma)o(y)e(seem)i(that)e Fi(readFile)g
5749 
+Fp(m)o(ust)h(read)g(an)h(en)o(tire)f(\014le,)h(resulting)h(in)f(p)q(o)q(or)f
5750 
+(space)h(and)0 240 y(time)k(p)q(erformance)g(under)h(certain)g
5751 
+(circumstances.)32 b(Ho)o(w)o(ev)o(er,)18 b(this)i(is)f(not)g(the)g(case.)31
5752 
+b(The)19 b(k)o(ey)g(p)q(oin)o(t)g(is)0 296 y(that)c Fi(readFile)g
5753 
+Fp(returns)h(a)g(\\lazy")g(\(i.e.)23 b(non-strict\))16 b(list)h(of)f(c)o
5754 
+(haracters)f(\(recall)i(that)f(strings)g(are)f(just)h(lists)0
5755 
+353 y(of)e(c)o(haracters)g(in)i(Hask)o(ell\),)f(whose)g(elemen)o(ts)g(are)f
5756 
+(read)h(\\b)o(y)g(demand")g(just)f(lik)o(e)i(an)o(y)e(other)h(list.)20
5757 
+b(An)15 b(imple-)0 409 y(men)o(tation)f(can)g(b)q(e)h(exp)q(ected)h(to)e
5758 
+(implemen)o(t)h(this)g(demand-driv)o(en)h(b)q(eha)o(vior)f(b)o(y)f(reading)h
5759 
+(one)f(c)o(haracter)g(at)0 465 y(a)h(time)g(from)g(the)g(\014le.)71
5760 
+543 y(There)k(are)g(lots)h(of)f(other)g(transactions)g(a)o(v)m(ailable)i(in)f
5761 
+(the)g(Hask)o(ell)g(I/O)g(design,)h(whic)o(h)f(primarily)h(re-)0
5762 
+600 y(\015ects)d(the)g(desire)h(for)e(compatibilit)o(y)j(with)e(con)o(v)o(en)
5763 
+o(tional)g(op)q(erating)g(systems.)27 b(F)l(or)18 b(example,)h(there)f(is)g
5764 
+(an)0 656 y Fi(appendFile)e Fp(transaction)g(whic)o(h)i(writes)f(a)f(string)h
5765 
+(to)g(the)g(end)g(of)g(a)f(\014le.)26 b(There)18 b(are)e(also)h
5766 
+Fo(binary)g Fp(v)o(ersions)0 713 y(of)e Fi(readFile)o Fp(,)f
5767 
+Fi(writeFile)o Fp(,)h(and)g Fi(appendFile)f Fp(\()p Fn(x)p
5768 
+Fp(7\).)71 791 y(Also)h(included)j(among)c(the)h(standard)f(op)q(erations)i
5769 
+(are)e(those)h(whic)o(h)h(in)o(teract)f(with)g Fo(channels)p
5770 
+Fp(,)e(whic)o(h)j(in)0 847 y(Unix-land)k(includes)g(things)e(lik)o(e)h
5771 
+(standard-input,)g(standard-output,)f(etc.)27 b(The)19 b(t)o(w)o(o)d(most)h
5772 
+(imp)q(ortan)o(t)g(of)0 904 y(these)e(are:)71 1004 y Fi(readChan)380
5773 
+b(::)24 b(Name)f(->)262 b(FailCont)23 b(->)h(StrCont)47 b(->)23
5774 
+b(Dialogue)71 1060 y(appendChan)332 b(::)24 b(Name)f(->)h(String)f(->)g
5775 
+(FailCont)g(->)h(SuccCont)f(->)g(Dialogue)0 1169 y Fp(There)12
5776 
+b(is)g(no)g Fi(writeChan)f Fp(transaction,)h(since)h(the)f(output)f(is)i(alw)
5777 
+o(a)o(ys)e(app)q(ended)i(to)e(whatev)o(er)h(w)o(as)f(previously)0
5778 
+1226 y(written)k(\(th)o(us)g Fi(appendChan)f Fp(is)h(akin)h(to)f
5779 
+Fi(appendFile)n Fp(\).)71 1304 y(Note)g(that)h(c)o(hannel)h(names)f(are)g
5780 
+(just)f(strings)h(\(lik)o(e)h(\014le)g(names\).)23 b(There)16
5781 
+b(are)g(four)f(c)o(hannel)j(names)e(that)0 1360 y(are)f(alw)o(a)o(ys)f(supp)q
5782 
+(orted)i(b)o(y)f(a)g(prop)q(er)h(implemen)o(tation,)g(and)f(are)g(b)q(ound)h
5783 
+(to)f(the)g(follo)o(wing)h(iden)o(ti\014ers:)71 1469 y Fi(stdin)452
5784 
+b(=)48 b("stdin")71 1526 y(stdout)428 b(=)48 b("stdout")71
5785 
+1582 y(stderr)428 b(=)48 b("stderr")71 1639 y(stdecho)404 b(=)48
5786 
+b("stdecho")0 1750 y Fp(On)12 b(most)f(systems,)g Fi(stdout)p
5787 
+Fp(,)g Fi(stderr)p Fp(,)h(and)f Fi(stdecho)g Fp(all)h(represen)o(t)g(the)g
5788 
+(same)f(ph)o(ysical)i(c)o(hannel)g(\(nominally)l(,)0 1807 y(the)i(user's)g
5789 
+(terminal)h(displa)o(y\).)71 1885 y(Let's)k(no)o(w)g(consider)h(a)f(sligh)o
5790 
+(tly)i(bigger)f(program|one)f(that)f(writes)i(to)f(a)g(\014le,)i(reads)e(the)
5791 
+h(\014le)g(bac)o(k,)0 1941 y(compares)15 b(the)h(con)o(ten)o(ts)e(for)h
5792 
+(equalit)o(y)h(with)g(what)f(w)o(as)f(previously)j(written,)e(prin)o(ts)h(a)f
5793 
+(suitable)i(message)e(to)0 1998 y(standard)g(output,)f(and)i(halts:)71
5794 
+2107 y Fi(main)94 b(=)24 b(writeFile)f("ReadMe")g(s1)g(exit)h(\()309
5795 
+2163 y(readFile)47 b("ReadMe")94 b(exit)24 b(\(\\s2->)309 2220
5796 
+y(appendChan)f(stdout)g(\(if)g(s1==s2)g(then)h("contents)e(match")1001
5797 
+2276 y(else)i("something)e(intervened!"\))g(exit)309 2333 y(done\)\))0
5798 
+2444 y Fp(This)f(program)e(demonstrates)g(an)h(imp)q(ortan)o(t)f(asp)q(ect)i
5799 
+(of)e(Hask)o(ell)i(I/O|it)g(p)q(ermits)g Fo(nondeterminism)e
5800 
+Fp(in)0 2501 y(the)e(op)q(erating)g(system)f(\(if)h(it)g(didn't,)g(it)g(w)o
5801 
+(ould)g(hardly)h(b)q(e)f(practical!\),)g(y)o(et)f(in)o(ternally)j(programs)c
5802 
+(are)i(still)0 2557 y(referen)o(tially)d(transparen)o(t.)k(In)13
5803 
+b(this)g(example)h(there)f(is)g(the)f(p)q(ossibilit)o(y)j(\(alb)q(eit)f
5804 
+(small\))f(that)f(the)h(test)f Fi(s1==s2)0 2614 y Fp(will)17
5805 
+b(fail,)e(b)q(ecause)h(some)e(other)h(agen)o(t)f(ma)o(y)g(mo)q(dify)h(the)g
5806 
+(\014le)h(b)q(et)o(w)o(een)f(the)g(times)g(it)g(w)o(as)f(written)h(and)g
5807 
+(read.)p eop
5808 
+%%Page: 46 46
5809 
+bop 0 -40 a Fp(T-46)1417 b Fj(8)45 b(INPUT/OUTPUT)71 105 y
5810 
+Fp(Also)16 b(note)g(ho)o(w)g(this)g(program)f(is)i(formatted,)e(giving)i(it)f
5811 
+(an)g(\\imp)q(erativ)o(e)h(feel.")24 b(W)l(e)16 b(can)g(enhance)i(this)0
5812 
+162 y(st)o(yle)d(b)o(y)g(using)h(an)g(in\014x)g(apply)g(op)q(erator:)71
5813 
+271 y Fi(infixr)23 b(0)g($)71 327 y(f)g($)h(a)71 b(=)24 b(f)g(a)71
5814 
+407 y(main)94 b(=)24 b(writeFile)47 b("ReadMe")22 b(s1)i(exit)f($)309
5815 
+463 y(readFile)71 b("ReadMe")94 b(exit)23 b($)h(\\s2->)309
5816 
+520 y(appendChan)f(stdout)g(\(if)g(s1==s2)g(then)h("contents)e(match")1001
5817 
+576 y(else)i("somebody)e(intervened!"\))g(exit)i($)309 632
5818 
+y(done)0 742 y Fp(This)12 b(v)o(ersion)h(has)e(the)h(adv)m(an)o(tage)g(of)f
5819 
+(not)h(requiring)h(the)f(nesting)g(of)g(paren)o(theses,)g(whic)o(h)h(in)f
5820 
+(larger)g(programs)0 798 y(can)j(b)q(ecome)h(quite)g(anno)o(ying.)0
5821 
+1050 y Fg(8.3)56 b(T)-5 b(erminal)16 b(I/O)0 1208 y Fp(Sp)q(ecial)h(men)o
5822 
+(tion)d(should)i(b)q(e)f(made)g(of)f(reading)h(from)f(standard)g(input,)h(in)
5823 
+g(that)f(what)g(is)h(returned)g(is)g(a)f(lazy)0 1264 y(string,)f(just)g(as)g
5824 
+(for)g(a)g(\014le.)20 b(The)13 b(\014rst)g(issue)h(that)f(arises)g(is)h
5825 
+(whether)f(the)h(input)g(is)g(\\ec)o(ho)q(ed")f(on)g(the)h(terminal,)0
5826 
+1320 y(or)e(whether)h(the)g(user)f(is)h(required)h(to)e(do)h(so)f(explicitly)
5827 
+l(.)22 b(The)13 b(answ)o(er)f(is)h(that)f(w)o(e)g(ha)o(v)o(e)g(a)h(c)o
5828 
+(hoice!)20 b(The)12 b(default)0 1377 y(is)k(that)f(ec)o(hoing)i(is)f(\\on,")f
5829 
+(but)g(it)h(can)g(b)q(e)g(turned)h(o\013)d(\(or)h(on\))h(using)g(the)g
5830 
+Fi(echo)f Fp(transaction,)g(whic)o(h)h(tak)o(es)f(a)0 1433
5831 
+y(b)q(o)q(olean)h(argumen)o(t)f(along)g(with)g(the)h(\(ubiquitous\))g
5832 
+(failure)g(and)f(success)h(con)o(tin)o(uations:)71 1545 y Fi(echo)476
5833 
+b(::)24 b(Bool)f(->)h(FailCont)f(->)g(SuccCont)g(->)h(Dialogue)0
5834 
+1654 y Fp(T)l(urning)19 b(ec)o(hoing)f(o\013)f(w)o(ould)h(b)q(e)g(required)h
5835 
+(if,)f(for)f(example,)h(w)o(e)g(w)o(an)o(ted)f(to)g(write)g(a)h(screen-orien)
5836 
+o(ted)g(text)0 1710 y(editor.)71 1823 y(Since)13 b(the)f(result)g(of)f
5837 
+(reading)i(from)e Fi(stdin)g Fp(is)h(a)g(lazy)g(string,)g(that)f(means)h(it)g
5838 
+(only)g(has)g(to)f(b)q(e)h(done)h Fo(onc)n(e)e Fp(for)0 1880
5839 
+y(a)k(giv)o(en)h(program|indeed,)g(a)f(run-time)i(error)e(will)i(result)f(if)
5840 
+f(it)h(is)g(done)g(more)f(than)g(once.)21 b(But)16 b(this)g(raises)0
5841 
+1936 y(the)f(follo)o(wing)g(question:)20 b(if)c(ec)o(hoing)f(is)g(enabled,)h
5842 
+(the)f(input)h(stream)d(will)k(app)q(ear)e(on)f(the)h Fi(stdecho)f
5843 
+Fp(c)o(hannel)0 1993 y(\(whic)o(h)k(on)g(most)f(systems)h(is)g(synon)o(ymous)
5844 
+g(with)g Fi(stdout)o Fp(\);)h(but)f(then)g(ho)o(w)f(is)i(this)f(output)g
5845 
+(\\in)o(terlea)o(v)o(ed")0 2049 y(with)e(explicit)h(output)e(to)f(the)i(same)
5846 
+f(c)o(hannel?)71 2162 y(T)l(o)c(giv)o(e)h(a)g(formal)g(answ)o(er)f(to)h(this)
5847 
+g(question)h(requires)f(de\014ning)i(precisely)g(the)e(b)q(eha)o(vior)g(of)g
5848 
+(the)g(op)q(erating)0 2218 y(system;)j(that's)g(wh)o(y)g(in)i(the)e(App)q
5849 
+(endix)j(of)d(the)h(Rep)q(ort)g(a)g(sp)q(eci\014cation)h(of)e(the)h(op)q
5850 
+(erating)g(system)f(is)h(giv)o(en)0 2275 y(in)g(Hask)o(ell)g(co)q(de.)21
5851 
+b(Here,)15 b(w)o(e)g(simply)h(giv)o(e)f(an)h(op)q(erational)f(description)i
5852 
+(of)e(the)g(exp)q(ected)i(b)q(eha)o(vior.)71 2388 y(First,)e(w)o(e)h(m)o(ust)
5853 
+g(consider)h(whether)f(ec)o(hoing)h(is)g(enabled)g(or)f(disabled.)25
5854 
+b(With)16 b(ec)o(ho)g(enabled,)i(w)o(e)e(w)o(ould)0 2444 y(exp)q(ect)h(line)h
5855 
+(editing)f(functions)g(lik)o(e)g(\\rub)q(out")f(to)g(b)q(e)g(handled)i
5856 
+Fo(b)n(efor)n(e)e Fp(the)g(program)f(is)h(allo)o(w)o(ed)h(to)e(see)i(the)0
5857 
+2501 y(result,)i(and)f(indeed)i(that's)d(what)g(happ)q(ens)i(in)g(Hask)o
5858 
+(ell.)29 b(This)19 b(means)f(that)f(the)h(user)g(input)h(is)g(e\013ectiv)o
5859 
+(ely)0 2557 y(seen)e(\\line-at-a-time,")h(since)f(a)f(series)h(of)f(rub)q
5860 
+(outs)h(could)h(o)q(ccur)e(at)g(an)o(y)g(p)q(oin)o(t)h(in)h(the)e(line.)26
5861 
+b(Consider,)17 b(for)0 2614 y(example,)f(this)f(program:)p
5862 
+eop
5863 
+%%Page: 47 47
5864 
+bop 0 -40 a Fj(8.4)45 b(Finer)15 b(Lev)o(el)i(of)d(Con)o(trol)1311
5865 
+b Fp(T-47)71 160 y Fi(main)285 b(=)24 b(echo)f(flag)h(exit)262
5866 
+b($)500 216 y(readChan)23 b(stdin)g(exit)143 b($)23 b(\\s->)500
5867 
+272 y(appendChan)g(stdout)g(s)g(exit)h($)500 329 y(done)0 438
5868 
+y Fp(If)13 b Fi(flag)e Fp(is)i Fi(True)p Fp(,)f(ec)o(hoing)h(will)h(b)q(e)f
5869 
+(enabled,)h(and)e(the)h(user)f(will)i(b)q(e)f(able)g(to)f(t)o(yp)q(e)g(an)g
5870 
+(en)o(tire)h(line,)h(with)f(correc-)0 494 y(tions)k(b)q(eing)h(dutifully)h
5871 
+(pro)q(cessed.)25 b(When)17 b(a)f(new-line)j(c)o(haracter)d(is)h(t)o(yp)q
5872 
+(ed,)g(the)g Fi(appendChan)e Fp(transaction)0 551 y(will)20
5873 
+b(then)f(b)q(e)g(able)g(to)f(\\see")g(the)h(result,)g(and)g(will)h(th)o(us)e
5874 
+(displa)o(y)h(the)g(line)h(just)e(t)o(yp)q(ed,)h(with)g(corrections.)0
5875 
+607 y(This)d(pro)q(cess)f(will)i(then)f(rep)q(eat)f(for)g(subsequen)o(t)h
5876 
+(lines;)g(in)g(other)f(w)o(ords,)f(the)h(ec)o(hoing)h(and)g(explicit)h
5877 
+(output)0 664 y(are)f(in)o(terlea)o(v)o(ed)h(line-at-a-time.)26
5878 
+b(Note)16 b(that)g(this)h(program)e(is)i(essen)o(tially)h(in)f(an)g
5879 
+(in\014nite)h(lo)q(op,)f(unless)h(the)0 720 y(user)h(terminates)h(the)f
5880 
+(input)h(sequence)h(\(suc)o(h)e(as)g(via)h(Cn)o(trl-D)f(in)h(a)f(Unix)h(en)o
5881 
+(vironmen)o(t\),)g(in)g(whic)o(h)g(case)0 777 y Fi(appendChan)14
5882 
+b Fp(can)h(\014nish)i(its)e(task.)71 858 y(On)j(the)h(other)f(hand,)h(if)f
5883 
+Fi(flag)g Fp(is)h Fi(False)o Fp(,)g(ec)o(hoing)g(is)f(disabled,)j(and)d
5884 
+Fi(appendChan)f Fp(will)j(see)f(the)f(input)0 915 y(c)o(haracter-b)o(y-c)o
5885 
+(haracter.)g(Th)o(us)12 b(the)g(e\013ect)f(of)h Fi(appendChan)e
5886 
+Fp(will)k(b)q(e)f(to)e(do)h(c)o(haracter-b)o(y-c)o(haracter)f(ec)o(hoing!)71
5887 
+996 y(The)17 b(other)f(factor)g(in)i(determining)g(the)g(in)o(terlea)o(ving)g
5888 
+(b)q(eha)o(vior)f(is)h(the)f(degree)g(to)f(whic)o(h)i(the)f(program)0
5889 
+1052 y Fo(dep)n(ends)j Fp(on)h(the)g(input)h(stream.)36 b(F)l(or)20
5890 
+b(example,)j(a)e(program)f(that)g(prin)o(ts)h(one)g Fi("X")g
5891 
+Fp(for)f(ev)o(ery)h(10)f(input)0 1109 y(c)o(haracters)14 b(will)j(b)q(eha)o
5892 
+(v)o(e)f(as)f(exp)q(ected;)h(here)f(is)h(suc)o(h)f(a)g(program:)71
5893 
+1218 y Fi(main)94 b(=)24 b(readChan)f(stdin)g(exit)g($)h(\\s->)309
5894 
+1274 y(let)g(loop)f(n)48 b([])310 b(=)23 b(done)405 1331 y(loop)g(n)h
5895 
+(\(x:xs\))f(|)g(n==10)48 b(=)23 b(appendChan)g(stdout)g("X")g(exit)h($)1001
5896 
+1387 y(loop)95 b(1)48 b(xs)739 1444 y(|)23 b(True)72 b(=)23
5897 
+b(loop)h(\(n+1\))f(xs)309 1500 y(in)h(loop)f(1)h(s)0 1612 y
5898 
+Fp(This)19 b(program)e(also)h(demonstrates)g(ho)o(w)f(to)h(write)g(a)g(lo)q
5899 
+(op)h(\(i.e.)f(a)g(recursion\))g(using)h(con)o(tin)o(uations.)30
5900 
+b(\(See)0 1668 y Fn(x)p Fp(7.7)14 b(for)h(another)g(example)h(of)f(sync)o
5901 
+(hronizing)h(input)h(with)e(output.\))71 1750 y(There)g(are)g(sev)o(eral)g(v)
5902 
+o(ery)g(useful)h(prede\014ned)h(functions)f(in)g(Hask)o(ell)g(that)f(mak)o(e)
5903 
+f(in)o(teractions)i(with)f(stan-)0 1806 y(dard)20 b(input)h(and)f(output)g
5904 
+(relativ)o(ely)h(painless.)36 b(These)21 b(are)e Fi(print)p
5905 
+Fp(,)h Fi(prints)p Fp(,)g(and)h Fi(interact)o Fp(,)f(whic)o(h)h(are)0
5906 
+1862 y(describ)q(ed)c(in)f(Section)g Fn(x)p Fp(7.5)f(of)f(the)i(Rep)q(ort.)0
5907 
+2009 y Fg(8.4)56 b(Finer)18 b(Lev)n(el)f(of)i(Con)n(trol)0
5908 
+2120 y Fp(Sometimes)c(\(although)f(rarely\))g(the)h(user)f(will)i(need)g(a)e
5909 
+(\014ner)h(lev)o(el)h(of)e(con)o(trol)g(o)o(v)o(er)f(I/O)i(than)f(that)g(pro)
5910 
+o(vided)0 2176 y(b)o(y)g(the)f(standard)h(set)f(of)g(I/O)h(transactions)f
5911 
+(pro)o(vided)i(in)f(Hask)o(ell)h(\(for)e(example,)h(sometimes)g(it)g(is)g
5912 
+(necessary)0 2233 y(to)f(explicitly)k(op)q(en)e(and)f(close)h(\014les\).)20
5913 
+b(This)15 b(fact)e(is)i(recognized)g(in)g(App)q(endix)h Fn(x)p
5914 
+Fp(C,)e(where)g(an)g(alternativ)o(e)g(set)0 2289 y(of)h(I/O)g(op)q(erations)h
5915 
+(is)f(suggested)h(and)f(that)f(some)h(implemen)o(tations)i(ma)o(y)d(supp)q
5916 
+(ort.)p eop
5917 
+%%Page: 48 48
5918 
+bop 0 -40 a Fp(T-48)1597 b Fj(9)45 b(ARRA)l(YS)0 105 y Fq(9)69
5919 
+b(Arra)n(ys)0 236 y Fp(Ideally)l(,)13 b(arra)o(ys)d(in)i(a)f(functional)h
5920 
+(language)f(w)o(ould)g(b)q(e)h(regarded)f(simply)h(as)f(functions)h(from)e
5921 
+(indices)j(to)d(v)m(alues,)0 292 y(but)16 b(pragmatically)l(,)g(in)h(order)e
5922 
+(to)g(assure)h(e\016cien)o(t)g(access)g(to)f(arra)o(y)g(elemen)o(ts,)h(w)o(e)
5923 
+f(need)i(to)e(b)q(e)h(sure)g(w)o(e)g(can)0 349 y(tak)o(e)h(adv)m(an)o(tage)g
5924 
+(of)h(the)g(sp)q(ecial)h(prop)q(erties)g(of)e(the)h(domains)g(of)g(these)g
5925 
+(functions,)h(whic)o(h)f(are)g(isomorphic)0 405 y(to)h(\014nite)i(con)o
5926 
+(tiguous)f(subsets)g(of)f(the)h(in)o(tegers.)34 b(Hask)o(ell,)21
5927 
+b(therefore,)f(do)q(es)g(not)g(treat)f(arra)o(ys)f(as)h(general)0
5928 
+462 y(functions)d(with)f(an)h(application)g(op)q(eration,)g(but)f(as)g
5929 
+(abstract)f(data)g(t)o(yp)q(es)i(with)f(a)g(subscript)h(op)q(eration.)71
5930 
+546 y(Tw)o(o)11 b(main)h(approac)o(hes)g(to)f(functional)j(arra)o(ys)c(ma)o
5931 
+(y)i(b)q(e)g(discerned:)20 b Fo(incr)n(emental)11 b Fp(and)h
5932 
+Fo(monolithic)g Fp(de\014ni-)0 603 y(tion.)20 b(In)15 b(the)f(incremen)o(tal)
5933 
+h(case,)f(w)o(e)g(ha)o(v)o(e)g(a)g(function)h(that)e(pro)q(duces)i(an)g(empt)
5934 
+o(y)e(arra)o(y)g(of)h(a)g(giv)o(en)h(size)g(and)0 659 y(another)f(that)f(tak)
5935 
+o(es)g(an)h(arra)o(y)l(,)f(an)h(index,)h(and)f(a)g(v)m(alue,)h(pro)q(ducing)g
5936 
+(a)f(new)g(arra)o(y)f(that)g(di\013ers)h(from)f(the)h(old)0
5937 
+716 y(one)i(only)g(at)f(the)h(giv)o(en)h(index.)23 b(Ob)o(viously)l(,)17
5938 
+b(a)e(naiv)o(e)i(implemen)o(tation)g(of)e(suc)o(h)h(an)g(arra)o(y)f(seman)o
5939 
+(tics)h(w)o(ould)0 772 y(b)q(e)h(in)o(tolerably)g(ine\016cien)o(t,)g
5940 
+(requiring)g(a)e(new)h(cop)o(y)g(of)g(an)f(arra)o(y)g(for)g(eac)o(h)h
5941 
+(incremen)o(tal)h(rede\014nition;)h(th)o(us,)0 829 y(serious)13
5942 
+b(attempts)e(at)g(using)i(this)f(approac)o(h)g(emplo)o(y)h(sophisticated)g
5943 
+(static)f(analysis)g(and)h(clev)o(er)g(run-time)f(de-)0 885
5944 
+y(vices)j(to)f(a)o(v)o(oid)h(excessiv)o(e)g(cop)o(ying.)20
5945 
+b(The)15 b(monolithic)h(approac)o(h,)e(on)g(the)h(other)f(hand,)h(constructs)
5946 
+f(an)g(arra)o(y)0 941 y(all)k(at)f(once,)g(without)g(reference)h(to)f(in)o
5947 
+(termediate)g(arra)o(y)f(v)m(alues.)27 b(Although)18 b(Hask)o(ell)g(has)f(an)
5948 
+g(incremen)o(tal)0 998 y(arra)o(y)d(up)q(date)i(op)q(erator,)e(the)h(main)h
5949 
+(thrust)e(of)h(the)g(arra)o(y)f(facilit)o(y)j(is)e(monolithic.)0
5950 
+1155 y Fg(9.1)56 b(Index)18 b(t)n(yp)r(es)0 1270 y Fp(The)d(Standard)h
5951 
+(Prelude)g(de\014nes)g(a)f(t)o(yp)q(e)g(class)h(of)f(arra)o(y)f(indices:)71
5952 
+1379 y Fi(class)47 b(\(Ord)23 b(a\))h(=>)f(Ix)h(a)47 b(where)166
5953 
+1436 y(range)166 b(::)24 b(\(a,a\))f(->)h([a])166 1492 y(index)166
5954 
+b(::)24 b(\(a,a\))f(a)h(->)f(Int)166 1549 y(inRange)118 b(::)24
5955 
+b(\(a,a\))f(->)h(a)f(->)h(Bool)0 1658 y Fp(Instance)12 b(declarations)g(are)e
5956 
+(pro)o(vided)i(for)f Fi(Int)o Fp(,)h Fi(Integer)o Fp(,)f Fi(Char)p
5957 
+Fp(,)g Fi(Bool)p Fp(,)g(and)h(tuples)g(of)e Fi(Ix)h Fp(t)o(yp)q(es;)h(in)g
5958 
+(addition,)0 1714 y(instances)17 b(ma)o(y)e(b)q(e)i(automatically)f(deriv)o
5959 
+(ed)h(for)f(en)o(umerated)g(and)g(tuple)h(t)o(yp)q(es.)23 b(W)l(e)16
5960 
+b(regard)f(the)i(primitiv)o(e)0 1771 y(t)o(yp)q(es)j(as)f(v)o(ector)g
5961 
+(indices)i(and)f(tuples)h(as)e(indices)i(of)f(m)o(ultidimensional)i
5962 
+(rectangular)e(arra)o(ys.)31 b(Note)20 b(that)0 1827 y(the)c(\014rst)g
5963 
+(argumen)o(t)f(of)h(eac)o(h)g(of)f(the)h(op)q(erations)h(of)e(class)h
5964 
+Fi(Ix)g Fp(is)h(a)e(pair)i(of)e(indices;)j(these)f(are)e(t)o(ypically)j(the)0
5965 
+1883 y Fo(b)n(ounds)g Fp(\(\014rst)f(and)h(last)g(indices\))i(of)e(an)g(arra)
5966 
+o(y)l(.)28 b(F)l(or)17 b(example,)j(the)e(b)q(ounds)h(of)f(a)f(10-elemen)o
5967 
+(t,)i(zero-origin)0 1940 y(v)o(ector)13 b(with)h Fi(Int)f Fp(indices)j(w)o
5968 
+(ould)e(b)q(e)h Fi(\(0,9\))o Fp(,)f(while)h(a)e(100)g(b)o(y)h(100)f(1-origin)
5969 
+h(matrix)f(migh)o(t)h(ha)o(v)o(e)f(the)h(b)q(ounds)0 1996 y
5970 
+Fi(\(\(1,1\),\(100,100\)\))n Fp(.)38 b(\(In)22 b(man)o(y)e(other)h
5971 
+(languages,)i(suc)o(h)f(b)q(ounds)g(w)o(ould)g(b)q(e)g(written)f(in)h(a)f
5972 
+(form)g(lik)o(e)0 2053 y Fi(1:100,)i(1:100)o Fp(,)17 b(but)g(the)g(presen)o
5973 
+(t)f(form)g(\014ts)h(the)g(t)o(yp)q(e)g(system)f(b)q(etter,)h(since)g(eac)o
5974 
+(h)g(b)q(ound)h(is)f(of)f(the)h(same)0 2109 y(t)o(yp)q(e)e(as)g(a)g(general)h
5975 
+(index.\))71 2194 y(The)g Fi(range)g Fp(op)q(eration)g(tak)o(es)g(a)f(b)q
5976 
+(ounds)j(pair)e(and)h(pro)q(duces)g(the)f(list)h(of)f(indices)i(lying)g(b)q
5977 
+(et)o(w)o(een)e(those)0 2250 y(b)q(ounds,)g(in)g(index)g(order.)k(F)l(or)14
5978 
+b(example,)617 2357 y Fi(range)23 b(\(0,4\))72 b Fn(\))i Fi([0,1,2,3,4])151
5979 
+2468 y(range)23 b(\(\(0,0\),\(1,2\)\))72 b Fn(\))i Fi([\(0,0\),)22
5980 
+b(\(0,1\),)h(\(0,2\),)h(\(1,0\),)f(\(1,1\),)g(\(1,2\)])0 2557
5981 
+y Fp(The)17 b Fi(inRange)g Fp(predicate)h(determines)g(whether)f(an)g(index)i
5982 
+(lies)f(b)q(et)o(w)o(een)g(a)e(giv)o(en)i(pair)g(of)e(b)q(ounds.)27
5983 
+b(\(F)l(or)16 b(a)0 2614 y(tuple)d(t)o(yp)q(e,)f(this)g(test)f(is)h(p)q
5984 
+(erformed)g(comp)q(onen)o(t)o(wise.\))19 b(Finally)l(,)14 b(the)e
5985 
+Fi(index)f Fp(op)q(eration)h(is)g(what)f(is)i(needed)g(to)p
5986 
+eop
5987 
+%%Page: 49 49
5988 
+bop 0 -40 a Fj(9.2)45 b(Arra)o(y)14 b(Creation)1451 b Fp(T-49)0
5989 
+105 y(address)13 b(a)g(particular)h(elemen)o(t)g(of)f(an)g(arra)o(y:)k(Giv)o
5990 
+(en)d(a)f(b)q(ounds)h(pair)g(and)f(an)g(in-range)h(index,)g(the)g(op)q
5991 
+(eration)0 162 y(yields)j(the)e(zero-origin)h(ordinal)g(of)f(the)g(index)i
5992 
+(within)f(the)f(range;)g(for)g(example:)712 259 y Fi(index)23
5993 
+b(\(1,9\))g(2)73 b Fn(\))h Fi(1)569 357 y(index)23 b(\(\(0,0\),\(1,2\)\))f
5994 
+(\(1,1\))73 b Fn(\))g Fi(5)0 501 y Fg(9.2)56 b(Arra)n(y)19
5995 
+b(Creation)0 610 y Fp(Hask)o(ell's)h(monolithic)h(arra)o(y)d(creation)i
5996 
+(function)h(forms)d(an)i(arra)o(y)e(from)h(a)g(pair)h(of)f(b)q(ounds)i(and)f
5997 
+(a)f(list)h(of)0 666 y(index-v)m(alue)e(pairs)d(\(an)g Fo(asso)n(ciation)h
5998 
+(list)p Fp(\):)71 778 y Fi(array)452 b(::)24 b(\(Ix)f(a\))h(=>)g(\(a,a\))f
5999 
+(->)g([Assoc)g(a)h(b])g(->)f(Array)g(a)h(b)0 887 y Fp(Notice)15
6000 
+b(the)f(t)o(yp)q(e)h Fi(Assoc)o Fp(;)f(to)g(impro)o(v)o(e)g(the)h(readabilit)
6001 
+o(y)g(of)f(arra)o(y)f(expressions,)i(the)f(pairs)h(in)g(the)g(asso)q(ciation)
6002 
+0 944 y(list)h(are)f(not)g(of)f(the)i(ordinary)f(sort,)f(but)h(of)g(another)g
6003 
+(tuple)h(t)o(yp)q(e)f(with)h(the)f(data)g(constructor)f Fi(\(:=\))p
6004 
+Fp(:)71 1053 y Fi(data)47 b(Assoc)23 b(a)h(b)214 b(=)48 b(a)24
6005 
+b(:=)f(b)0 1162 y Fp(Here,)15 b(for)g(example,)g(is)h(a)f(de\014nition)i(of)e
6006 
+(an)g(arra)o(y)f(of)h(the)g(squares)g(of)g(n)o(um)o(b)q(ers)g(from)f(1)h(to)g
6007 
+(100:)71 1271 y Fi(squares)404 b(=)48 b(array)23 b(\(1,100\))g([i)h(:=)f(i)h
6008 
+(*)g(i)f(|)h(i)g(<-)f([1..100]])0 1380 y Fp(This)17 b(arra)o(y)e(expression)j
6009 
+(is)f(t)o(ypical)g(in)h(using)f(a)f(list)h(comprehension)h(for)e(the)h(asso)q
6010 
+(ciation)g(list;)g(in)h(fact,)e(this)0 1436 y(usage)e(results)h(in)g(arra)o
6011 
+(y)e(expressions)i(m)o(uc)o(h)f(lik)o(e)h(the)g Fo(arr)n(ay)g(c)n(ompr)n
6012 
+(ehensions)e Fp(of)h(the)g(language)h(Id[4].)k(Arra)o(y)0 1493
6013 
+y(subscripting)f(is)f(p)q(erformed)g(with)g(the)g(in\014x)g(op)q(erator)f
6014 
+Fi(!)p Fp(,)g(and)h(the)g(b)q(ounds)g(of)f(an)h(arra)o(y)e(can)i(b)q(e)g
6015 
+(extracted)0 1549 y(with)f(the)f(function)h Fi(bounds)o Fp(:)748
6016 
+1606 y Fi(squares!7)72 b Fn(\))h Fi(49)628 1687 y(bounds)24
6017 
+b(squares)72 b Fn(\))h Fi(\(1,100\))0 1768 y Fp(W)l(e)15 b(migh)o(t)f
6018 
+(generalize)j(this)e(example)g(b)o(y)g(parameterizing)h(the)e(b)q(ounds)i
6019 
+(and)f(the)g(function)g(to)g(b)q(e)g(applied)i(to)0 1824 y(eac)o(h)e(index:)
6020 
+71 1924 y Fi(mkArray)404 b(::)24 b(\(Ix)f(a\))h(=>)g(\(a)f(->)h(b\))f(->)h
6021 
+(\(a,a\))f(->)h(Array)f(a)h(b)71 1981 y(mkArray)e(f)i(bnds)238
6022 
+b(=)48 b(array)23 b(bnds)g([i)h(:=)g(f)f(i)h(|)g(i)f(<-)h(range)f(bnds])0
6023 
+2090 y Fp(Th)o(us,)15 b(w)o(e)g(could)h(de\014ne)g Fi(squares)e
6024 
+Fp(as)h Fi(mkArray)23 b(\(\\i)h(->)f(i)h(*)g(i\))f(\(1,100\))o
6025 
+Fp(.)71 2170 y(Man)o(y)12 b(arra)o(ys)g(are)h(de\014ned)i(recursiv)o(ely;)g
6026 
+(that)e(is,)g(with)h(the)g(v)m(alues)g(of)f(some)g(elemen)o(ts)h(dep)q
6027 
+(ending)i(on)d(the)0 2226 y(v)m(alues)j(of)f(others.)20 b(Here,)15
6028 
+b(for)f(example,)i(w)o(e)f(ha)o(v)o(e)g(a)f(function)i(returning)g(an)f(arra)
6029 
+o(y)f(of)h(Fib)q(onacci)i(n)o(um)o(b)q(ers:)71 2335 y Fi(fibs)94
6030 
+b(::)24 b(Int)g(->)f(Array)g(Int)h(Int)71 2392 y(fibs)f(n)47
6031 
+b(=)h(a)g(where)23 b(a)h(=)f(array)g(\(0,n\))h(\([0)f(:=)h(1,)f(1)h(:=)g(1])f
6032 
+(++)954 2448 y([i)g(:=)h(a!\(i-2\))f(+)g(a!\(i-1\))g(|)h(i)g(<-)f([2..n]]\))0
6033 
+2557 y Fp(Another)18 b(example)i(of)e(suc)o(h)h(a)f(recurrence)h(is)g(the)g
6034 
+Fo(n)i Fp(b)o(y)e Fo(n)i(wavefr)n(ont)d Fp(matrix,)h(in)g(whic)o(h)h(elemen)o
6035 
+(ts)f(of)f(the)0 2614 y(\014rst)f(ro)o(w)e(and)j(\014rst)e(column)i(all)g(ha)
6036 
+o(v)o(e)e(the)h(v)m(alue)h Fo(1)24 b Fp(and)17 b(other)f(elemen)o(ts)i(are)e
6037 
+(sums)h(of)g(their)g(neigh)o(b)q(ors)h(to)p eop
6038 
+%%Page: 50 50
6039 
+bop 0 -40 a Fp(T-50)1597 b Fj(9)45 b(ARRA)l(YS)0 105 y Fp(the)15
6040 
+b(w)o(est,)f(north)o(w)o(est,)g(and)h(north:)71 214 y Fi(wavefront)165
6041 
+b(::)24 b(Int)f(->)h(Array)f(\(Int,Int\))g(Int)71 271 y(wavefront)f(n)119
6042 
+b(=)48 b(a)g(where)524 327 y(a)24 b(=)f(array)h(\(\(1,1\),\(n,n\)\))643
6043 
+383 y(\([\(1,j\))f(:=)h(1)g(|)f(j)h(<-)g([1..n]])e(++)667 440
6044 
+y([\(i,1\))h(:=)h(1)g(|)f(i)h(<-)g([2..n]])e(++)667 496 y([\(i,j\))h(:=)h
6045 
+(a!\(i,j-1\))e(+)i(a!\(i-1,j-1\))f(+)g(a!\(i-1,j\))954 553
6046 
+y(|)g(i)h(<-)g([2..n],)e(j)i(<-)g([2..n]]\))0 662 y Fp(The)13
6047 
+b(w)o(a)o(v)o(efron)o(t)d(matrix)i(is)h(so)f(called)i(b)q(ecause)g(in)f(a)f
6048 
+(parallel)i(implemen)o(tation,)g(the)f(recurrence)g(dictates)g(that)0
6049 
+718 y(the)f(computation)h(can)f(b)q(egin)h(with)g(the)f(\014rst)g(ro)o(w)f
6050 
+(and)i(column)g(in)g(parallel)h(and)e(pro)q(ceed)h(as)f(a)g(w)o(edge-shap)q
6051 
+(ed)0 775 y(w)o(a)o(v)o(e,)17 b(tra)o(v)o(elling)i(from)e(north)o(w)o(est)g
6052 
+(to)g(southeast.)28 b(It)18 b(is)g(imp)q(ortan)o(t)g(to)f(note,)h(ho)o(w)o
6053 
+(ev)o(er,)g(that)f(no)h(order)f(of)0 831 y(computation)e(is)h(sp)q(eci\014ed)
6054 
+h(b)o(y)e(the)h(asso)q(ciation)f(list.)71 959 y(In)h(eac)o(h)h(of)e(our)h
6055 
+(examples)h(so)f(far,)f(w)o(e)h(ha)o(v)o(e)g(giv)o(en)h(a)f(unique)h(asso)q
6056 
+(ciation)g(for)e(eac)o(h)i(index)g(of)f(the)g(arra)o(y)0 1015
6057 
+y(and)j(only)f(for)g(the)h(indices)h(within)g(the)e(b)q(ounds)h(of)f(the)h
6058 
+(arra)o(y)l(,)e(and)i(indeed,)h(w)o(e)e(m)o(ust)g(do)g(this)h(in)g(general)0
6059 
+1072 y(for)14 b(an)h(arra)o(y)f(b)q(e)i(fully)h(de\014ned.)k(An)15
6060 
+b(asso)q(ciation)h(with)f(an)g(out-of-b)q(ounds)h(index)g(results)f(in)h(an)f
6061 
+(error;)f(if)i(an)0 1128 y(index)g(is)e(missing)i(or)d(app)q(ears)i(more)f
6062 
+(than)g(once,)g(ho)o(w)o(ev)o(er,)g(there)g(is)h(no)f(immediate)i(error,)d
6063 
+(but)h(the)h(v)m(alue)g(of)0 1185 y(the)g(arra)o(y)f(at)g(that)g(index)i(is)g
6064 
+(then)f(unde\014ned,)i(so)d(that)h(subscripting)h(the)f(arra)o(y)f(with)h
6065 
+(suc)o(h)g(an)g(index)h(yields)0 1241 y(an)f(error.)0 1542
6066 
+y Fg(9.3)56 b(Accum)n(ulation)0 1721 y Fp(W)l(e)14 b(can)g(relax)g(the)g
6067 
+(restriction)g(that)f(an)h(index)h(app)q(ear)f(at)g(most)f(once)h(in)g(the)g
6068 
+(asso)q(ciation)h(list)f(b)o(y)g(sp)q(ecifying)0 1777 y(ho)o(w)h(to)g(com)o
6069 
+(bine)h(m)o(ultiple)i(v)m(alues)f(asso)q(ciated)e(with)h(a)g(single)g(index;)
6070 
+h(the)f(result)g(is)g(called)h(an)f Fo(ac)n(cumulate)n(d)0
6071 
+1834 y(arr)n(ay)p Fp(:)71 1943 y Fi(accumArray)22 b(::)i(\(Ix)f(a\))h(->)f
6072 
+(\(b)h(->)f(c)h(->)g(b\))f(->)h(b)g(->)f(\(a,a\))g(->)h([Assoc)f(a)h(c])f(->)
6073 
+h(Array)f(a)h(b)0 2054 y Fp(The)15 b(\014rst)g(argumen)o(t)g(of)g
6074 
+Fi(accumArray)e Fp(is)j(the)g Fo(ac)n(cumulating)g(function)p
6075 
+Fp(,)e(the)i(second)f(is)h(an)f(initial)j(v)m(alue)e(\(the)0
6076 
+2111 y(same)g(for)f(eac)o(h)i(elemen)o(t)g(of)e(the)i(arra)o(y\),)d(and)i
6077 
+(the)h(remaining)g(argumen)o(ts)e(are)h(b)q(ounds)h(and)f(an)h(asso)q
6078 
+(ciation)0 2167 y(list,)e(as)f(with)h(the)g Fi(array)e Fp(function.)21
6079 
+b(T)o(ypically)l(,)16 b(the)f(accum)o(ulating)g(function)g(is)g
6080 
+Fi(\(+\))p Fp(,)f(and)h(the)f(initial)j(v)m(alue,)0 2224 y(zero;)f(for)g
6081 
+(example,)h(this)f(function)h(tak)o(es)f(a)f(pair)i(of)f(b)q(ounds)h(and)f(a)
6082 
+g(list)h(of)f(v)m(alues)h(\(of)e(an)h(index)i(t)o(yp)q(e\))e(and)0
6083 
+2280 y(yields)h(a)e(histogram;)f(that)g(is,)i(a)e(table)i(of)f(the)g(n)o(um)o
6084 
+(b)q(er)h(of)e(o)q(ccurrences)j(of)d(eac)o(h)i(v)m(alue)g(within)h(the)e(b)q
6085 
+(ounds:)71 2389 y Fi(hist)285 b(::)24 b(\(Ix)f(a,)h(Integral)f(b\))g(=>)h
6086 
+(\(a,a\))f(->)h([a])f(->)h(Array)f(a)h(b)71 2446 y(hist)f(bnds)g(is)95
6087 
+b(=)48 b(accumArray)22 b(\(+\))i(0)g(bnds)f([i)h(:=)f(1)h(|)g(i)f(<-)h(is,)f
6088 
+(inRange)g(bnds)h(i])0 2557 y Fp(Supp)q(ose)c(w)o(e)e(ha)o(v)o(e)h(a)f
6089 
+(collection)j(of)d(measuremen)o(ts)h(on)g(the)f(in)o(terv)m(al)i([)p
6090 
+Fo(a)s Fh(;)8 b Fo(b)s Fp(\))o(,)20 b(and)f(w)o(e)f(w)o(an)o(t)g(to)g(divide)
6091 
+j(the)0 2614 y(in)o(terv)m(al)16 b(in)o(to)f(decades)h(and)g(coun)o(t)f(the)g
6092 
+(n)o(um)o(b)q(er)h(of)e(measuremen)o(ts)h(within)i(eac)o(h:)p
6093 
+eop
6094 
+%%Page: 51 51
6095 
+bop 0 -40 a Fj(9.4)45 b(Incremen)o(tal)16 b(up)q(dates)1348
6096 
+b Fp(T-51)71 160 y Fi(decades)213 b(::)24 b(\(RealFrac)f(a\))g(=>)h(a)g(->)f
6097 
+(a)h(->)f([a])h(->)f(Array)h(Int)f(Int)71 216 y(decades)f(a)i(b)119
6098 
+b(=)48 b(hist)23 b(\(0,9\))g(.)h(map)g(decade)524 272 y(where)f(decade)g(x)h
6099 
+(=)g(floor)f(\(\(x)g(-)h(a\))g(*)f(s\))667 329 y(s)191 b(=)24
6100 
+b(10)f(/)h(\(b)g(-)f(a\))0 572 y Fg(9.4)56 b(Incremen)n(tal)16
6101 
+b(up)r(dates)0 691 y Fp(In)d(addition)g(to)e(the)i(monolithic)g(arra)o(y)e
6102 
+(creation)h(functions,)h(Hask)o(ell)g(also)f(has)g(an)g(incremen)o(tal)i
6103 
+(arra)o(y)c(up)q(date)0 747 y(function,)15 b(written)g(as)f(the)h(in\014x)g
6104 
+(op)q(erator)f Fi(//)p Fp(;)g(the)h(simplest)h(case,)e(an)h(arra)o(y)e
6105 
+Fi(a)h Fp(with)h(elemen)o(t)h Fi(i)e Fp(up)q(dated)i(to)0 804
6106 
+y Fi(v)p Fp(,)e(is)i(written)e Fi(a)24 b(//)g([i)f(:=)h(v])p
6107 
+Fp(.)19 b(The)c(reason)g(for)f(the)g(square)h(brac)o(k)o(ets)f(is)h(that)f
6108 
+(the)h(left)g(argumen)o(t)f(of)h Fi(\(//\))0 860 y Fp(is)h(an)f(asso)q
6109 
+(ciation)g(list,)h(usually)h(con)o(taining)f(a)e(prop)q(er)i(subset)f(of)g
6110 
+(the)g(indices)j(of)c(the)i(arra)o(y:)71 969 y Fi(\(//\))285
6111 
+b(::)24 b(\(Ix)f(a\))h(=>)g(Array)f(a)h(b)f(->)h([Assoc)f(a)h(b])f(->)h
6112 
+(Array)f(a)h(b)0 1078 y Fp(As)15 b(with)h(the)f Fi(array)g
6113 
+Fp(function,)h(the)f(indices)i(in)f(the)g(asso)q(ciation)g(list)g(m)o(ust)e
6114 
+(b)q(e)i(unique)h(for)e(the)g(v)m(alues)i(to)d(b)q(e)0 1135
6115 
+y(de\014ned.)21 b(F)l(or)15 b(example,)g(here)h(is)g(a)f(function)h(to)e(in)o
6116 
+(terc)o(hange)i(t)o(w)o(o)e(ro)o(ws)g(of)h(a)f(matrix:)71 1243
6117 
+y Fi(swapRows)22 b(::)i(\(Ix)f(a,)h(Ix)g(b,)f(Enum)g(b\))h(=>)g(a)f(->)h(a)g
6118 
+(->)f(Array)g(\(a,b\))h(c)f(->)h(Array)f(\(a,b\))g(c)71 1300
6119 
+y(swapRows)f(i)i(i')g(a)f(=)48 b(a)24 b(//)f(\([\(i,j\))47
6120 
+b(:=)24 b(a!\(i',j\))e(|)i(j)g(<-)f([jLo..jHi]])g(++)667 1356
6121 
+y([\(i',j\))g(:=)h(a!\(i,)f(j\))g(|)h(j)g(<-)f([jLo..jHi]]\))524
6122 
+1413 y(where)g(\(\(iLo,jLo\),\(iHi,jHi\)\))e(=)j(bounds)f(a)0
6123 
+1522 y Fp(The)15 b(concatenation)f(here)h(of)g(t)o(w)o(o)e(separate)h(list)h
6124 
+(comprehensions)h(o)o(v)o(er)d(the)i(same)f(list)i(of)e Fi(j)g
6125 
+Fp(indices)j(is,)d(ho)o(w-)0 1578 y(ev)o(er,)i(a)h(sligh)o(t)g
6126 
+(ine\016ciency;)i(it's)d(lik)o(e)i(writing)f(t)o(w)o(o)e(lo)q(ops)i(where)g
6127 
+(one)f(will)i(do)f(in)g(an)g(imp)q(erativ)o(e)g(language.)0
6128 
+1635 y(Nev)o(er)e(fear,)g(w)o(e)f(can)i(p)q(erform)f(the)g(equiv)m(alen)o(t)i
6129 
+(of)e(a)g(lo)q(op)g(fusion)h(optimization)g(in)g(Hask)o(ell:)71
6130 
+1744 y Fi(swapRows)22 b(i)i(i')g(a)f(=)48 b(a)24 b(//)f([assoc)g(|)h(j)g(<-)f
6131 
+([jLo..jHi],)858 1800 y(assoc)g(<-)h([\(i,)f(j\))h(:=)f(a!\(i',j\),)1097
6132 
+1857 y(\(i',j\))g(:=)g(a!\(i,)h(j\)])f(])524 1913 y(where)g
6133 
+(\(\(iLo,jLo\),\(iHi,jHi\)\))e(=)j(bounds)f(a)0 2156 y Fg(9.5)56
6134 
+b(An)19 b(example:)j(Matrix)c(Multiplication)0 2275 y Fp(W)l(e)13
6135 
+b(complete)h(our)f(in)o(tro)q(duction)h(to)e(Hask)o(ell)i(arra)o(ys)e(with)h
6136 
+(the)g(familiar)h(example)g(of)e(matrix)h(m)o(ultiplication,)0
6137 
+2331 y(taking)k(adv)m(an)o(tage)f(of)g(o)o(v)o(erloading)h(to)f(de\014ne)i(a)
6138 
+e(fairly)i(general)f(function.)25 b(Since)18 b(only)g(m)o(ultiplication)h
6139 
+(and)0 2388 y(addition)c(on)f(the)f(elemen)o(t)i(t)o(yp)q(e)f(of)f(the)h
6140 
+(matrices)g(is)g(in)o(v)o(olv)o(ed,)h(w)o(e)e(get)h(a)f(function)i(that)e(m)o
6141 
+(ultiplies)j(matrices)0 2444 y(of)h(an)o(y)g(n)o(umeric)h(t)o(yp)q(e)g
6142 
+(unless)h(w)o(e)e(try)g(hard)g(not)g(to.)26 b(Additionally)l(,)20
6143 
+b(if)e(w)o(e)f(are)g(careful)h(to)f(apply)h(only)g Fi(\(!\))0
6144 
+2501 y Fp(and)f(the)h(op)q(erations)f(of)g Fi(Ix)g Fp(to)g(indices,)i(w)o(e)e
6145 
+(get)g(genericit)o(y)h(o)o(v)o(er)e(index)j(t)o(yp)q(es,)e(and)h(in)g(fact,)f
6146 
+(the)g(four)g(ro)o(w)0 2557 y(and)e(column)h(index)f(t)o(yp)q(es)g(need)h
6147 
+(not)e(all)i(b)q(e)f(the)g(same.)k(F)l(or)14 b(simplicit)o(y)l(,)j(ho)o(w)o
6148 
+(ev)o(er,)d(w)o(e)g(require)i(that)e(the)h(left)0 2614 y(column)g(indices)g
6149 
+(and)f(righ)o(t)g(ro)o(w)e(indices)k(b)q(e)f(of)e(the)h(same)f(t)o(yp)q(e,)h
6150 
+(and)g(moreo)o(v)o(er,)e(that)h(the)h(b)q(ounds)g(b)q(e)h(equal:)p
6151 
+eop
6152 
+%%Page: 52 52
6153 
+bop 0 -40 a Fp(T-52)1597 b Fj(9)45 b(ARRA)l(YS)71 160 y Fi(matMult)213
6154 
+b(::)24 b(\(Ix)f(a,)h(Ix)g(b,)f(Ix)h(c,)f(Num)h(d\))f(=>)524
6155 
+216 y(Array)g(\(a,b\))g(d)h(->)g(Array)f(\(b,c\))g(d)h(->)f(Array)h(\(a,c\))f
6156 
+(d)71 272 y(matMult)f(x)i(y)119 b(=)48 b(array)23 b(resultBounds)667
6157 
+329 y([\(i,j\))g(:=)h(sum)f([x!\(i,k\))g(*)h(y!\(k,j\))f(|)g(k)h(<-)g(range)f
6158 
+(\(lj,uj\)])1025 385 y(|)h(i)g(<-)f(range)g(\(li,ui\),)1073
6159 
+442 y(j)h(<-)f(range)g(\(lj',uj'\))g(])261 498 y(where)h
6160 
+(\(\(li,lj\),\(ui,uj\)\))212 b(=)48 b(bounds)23 b(x)405 555
6161 
+y(\(\(li',lj'\),\(ui',uj'\)\))116 b(=)48 b(bounds)23 b(y)405
6162 
+611 y(resultBounds)452 668 y(|)h(\(lj,uj\)==\(li',ui'\))93
6163 
+b(=)48 b(\(\(li,lj'\),\(ui,uj'\)\))452 724 y(|)24 b(otherwise)309
6164 
+b(=)24 b(error)f("matMult:)g(incompatible)f(bounds")0 833 y
6165 
+Fp(As)16 b(an)h(aside,)g(w)o(e)f(can)g(also)h(de\014ne)g Fi(matMult)f
6166 
+Fp(using)h Fi(accumArray)n Fp(,)g(resulting)g(in)g(a)f(presen)o(tation)h
6167 
+(that)e(more)0 890 y(closely)h(resem)o(bles)g(the)g(usual)g(form)o(ulation)f
6168 
+(in)h(an)f(imp)q(erativ)o(e)h(language:)71 999 y Fi(matMult)22
6169 
+b(x)i(y)119 b(=)48 b(accumArray)22 b(\(+\))i(0)g(resultBounds)786
6170 
+1055 y([\(i,j\))g(:=)f(x!\(i,k\))g(*)h(y!\(k,j\))977 1112 y(|)g(i)g(<-)f
6171 
+(range)h(\(li,ui\),)1025 1168 y(j)g(<-)f(range)h(\(lj',uj'\))1025
6172 
+1224 y(k)g(<-)f(range)h(\(lj,uj\))46 b(])261 1281 y(where)24
6173 
+b(\(\(li,lj\),\(ui,uj\)\))212 b(=)48 b(bounds)23 b(x)405 1337
6174 
+y(\(\(li',lj'\),\(ui',uj'\)\))116 b(=)48 b(bounds)23 b(y)405
6175 
+1394 y(resultBounds)452 1450 y(|)h(\(lj,uj\)==\(li',ui'\))93
6176 
+b(=)48 b(\(\(li,lj'\),\(ui,uj'\)\))452 1507 y(|)24 b(otherwise)309
6177 
+b(=)24 b(error)f("matMult:)g(incompatible)f(bounds")71 1718
6178 
+y Fp(W)l(e)16 b(can)h(generalize)h(further)e(b)o(y)h(making)g(the)f(function)
6179 
+i(higher-order,)f(simply)h(replacing)g Fi(sum)e Fp(and)g Fi(\(*\))0
6180 
+1775 y Fp(b)o(y)f(functional)i(parameters:)71 1883 y Fi(genMatMult)141
6181 
+b(::)24 b(\(Ix)f(a,)h(Ix)g(b,)f(Ix)h(c\))f(=>)524 1940 y(\([f])g(->)h(g\))f
6182 
+(->)h(\(d)g(->)f(e)h(->)g(f\))f(->)524 1996 y(Array)g(\(a,b\))g(d)h(->)g
6183 
+(Array)f(\(b,c\))g(e)h(->)f(Array)h(\(a,c\))f(g)71 2053 y(genMatMult)f(f)i(g)
6184 
+g(x)f(y)48 b(=)f(array)24 b(resultBounds)643 2109 y([\(i,j\))f(:=)h(f)g
6185 
+([x!\(i,k\))e(`g`)i(y!\(k,j\))f(|)h(k)f(<-)h(range)f(\(lj,uj\)])858
6186 
+2166 y(|)h(i)g(<-)f(range)g(\(li,ui\),)906 2222 y(j)h(<-)f(range)g
6187 
+(\(lj',uj'\))g(])261 2279 y(where)h(\(\(li,lj\),\(ui,uj\)\))212
6188 
+b(=)48 b(bounds)23 b(x)405 2335 y(\(\(li',lj'\),\(ui',uj'\)\))116
6189 
+b(=)48 b(bounds)23 b(y)405 2392 y(resultBounds)452 2448 y(|)h
6190 
+(\(lj,uj\)==\(li',ui'\))93 b(=)48 b(\(\(li,lj'\),\(ui,uj'\)\))452
6191 
+2504 y(|)24 b(otherwise)309 b(=)24 b(error)f("matMult:)g(incompatible)f
6192 
+(bounds")0 2614 y Fp(APL)16 b(fans)f(will)h(recognize)g(the)g(usefulness)g
6193 
+(of)f(functions)h(lik)o(e)g(the)g(follo)o(wing:)p eop
6194 
+%%Page: 53 53
6195 
+bop 1857 -40 a Fp(T-53)71 160 y Fi(genMatMult)22 b(maximum)h(\(-\))71
6196 
+216 y(genMatMult)f(and)i(\(==\))0 328 y Fp(With)15 b(the)g(\014rst)f(of)g
6197 
+(these,)h(the)g(argumen)o(ts)f(are)g(n)o(umeric)i(matrices,)e(and)h(the)g(\()
6198 
+p Fo(i)5 b Fh(;)j Fo(j)f Fp(\))m(-th)15 b(elemen)o(t)g(of)g(the)g(result)0
6199 
+384 y(is)g(the)g(maxim)o(um)f(di\013erence)i(b)q(et)o(w)o(een)f(corresp)q
6200 
+(onding)h(elemen)o(ts)f(of)f(the)h Fo(i)5 b Fp(-th)14 b(ro)o(w)g(and)h
6201 
+Fo(j)6 b Fp(-th)15 b(column)h(of)e(the)0 441 y(inputs.)30 b(In)18
6202 
+b(the)h(second)f(case,)h(the)f(argumen)o(ts)f(are)h(matrices)g(of)g(an)o(y)g
6203 
+(equalit)o(y)h(t)o(yp)q(e,)f(and)h(the)f(result)h(is)f(a)0
6204 
+497 y(Bo)q(olean)d(matrix)f(in)h(whic)o(h)g(elemen)o(t)g(\()p
6205 
+Fo(i)5 b Fh(;)j Fo(j)f Fp(\))k(is)k Fi(True)f Fp(if)g(and)h(only)g(if)f(the)g
6206 
+Fo(i)5 b Fp(-th)14 b(ro)o(w)g(of)f(the)i(\014rst)e(argumen)o(t)h(and)0
6207 
+553 y Fo(j)7 b Fp(-th)15 b(column)h(of)f(the)g(second)h(are)e(equal)i(as)f(v)
6208 
+o(ectors.)71 629 y(Notice)k(that)f(the)h(elemen)o(t)g(t)o(yp)q(es)g(of)g
6209 
+Fi(genMatMult)e Fp(need)j(not)e(b)q(e)i(the)e(same,)i(but)e(merely)i
6210 
+(appropriate)0 685 y(for)c(the)i(function)f(parameter)g Fi(g)p
6211 
+Fp(.)25 b(W)l(e)17 b(could)h(generalize)h(still)f(further)f(b)o(y)g(dropping)
6212 
+h(the)f(requiremen)o(t)h(that)0 742 y(the)i(\014rst)f(column)i(index)f(and)g
6213 
+(second)g(ro)o(w)f(index)i(t)o(yp)q(es)f(b)q(e)g(the)g(same;)h(clearly)l(,)h
6214 
+(t)o(w)o(o)c(matrices)i(could)g(b)q(e)0 798 y(considered)14
6215 
+b(conformable)g(as)e(long)i(as)e(the)i(lengths)f(of)g(the)g(columns)h(of)e
6216 
+(the)i(\014rst)e(and)i(the)f(ro)o(ws)f(of)g(the)h(second)0
6217 
+855 y(are)k(equal.)28 b(The)18 b(reader)g(ma)o(y)f(wish)h(to)f(deriv)o(e)h
6218 
+(this)h(still)g(more)e(general)h(v)o(ersion.)27 b(\()p Fc(Hin)o(t:)e
6219 
+Fp(Use)18 b(the)g Fi(index)0 911 y Fp(op)q(eration)d(to)g(determine)h(the)f
6220 
+(lengths.\))0 1070 y Fq(10)69 b(Ac)n(kno)n(wledgemen)n(ts)0
6221 
+1190 y Fp(Thanks)20 b(to)g(P)o(atricia)h(F)l(asel)f(and)h(Mark)f(Mundt)g(at)g
6222 
+(Los)g(Alamos,)i(and)e(Nic)o(k)h(Carriero,)g(Charles)g(Consel,)0
6223 
+1247 y(Amir)f(Kishon,)h(Sandra)e(Lo)q(osemore,)h(Martin)f(Odersky)l(,)h(John)
6224 
+g(P)o(eterson,)g(and)f(Da)o(vid)h(Ro)q(c)o(h)o(b)q(erg)f(at)g(Y)l(ale)0
6225 
+1303 y(Univ)o(ersit)o(y)i(for)f(their)g(quic)o(k)i(readings)e(of)g(earlier)h
6226 
+(drafts)f(of)g(this)h(man)o(uscript.)35 b(Sp)q(ecial)23 b(thanks)d(to)f(John)
6227 
+0 1360 y(P)o(eterson)c(for)f(getting)h(the)h(bugs)f(out)g(of)f(our)h(Hask)o
6228 
+(ell)h(co)q(de.)0 1519 y Fq(References)0 1636 y Fp([1])22 b(R.)d(Bird)h(and)f
6229 
+(P)l(.)g(W)l(adler.)32 b Fo(Intr)n(o)n(duction)19 b(to)h(F)m(unctional)f(Pr)n
6230 
+(o)n(gr)n(amming)p Fp(.)31 b(Pren)o(tice)20 b(Hall,)g(New)g(Y)l(ork,)71
6231 
+1692 y(1988.)0 1780 y([2])i(P)l(.)14 b(Hudak.)20 b(Conception,)c(ev)o
6232 
+(olution,)f(and)g(application)i(of)e(functional)h(programming)e(languages.)20
6233 
+b Fo(A)o(CM)71 1836 y(Computing)c(Surveys)p Fp(,)e(21\(3\):359{411,)d(1989.)0
6234 
+1924 y([3])22 b(P)l(.)c(Hudak,)h(S.)f(P)o(eyton)f(Jones,)i(and)g(P)l(.)f(W)l
6235 
+(adler)g(\(editors\).)29 b(Rep)q(ort)18 b(on)g(the)h(Programming)e(Language)
6236 
+71 1981 y(Hask)o(ell,)23 b(A)e(Non-strict)g(Purely)h(Functional)g(Language)f
6237 
+(\(Version)g(1.2\).)36 b Fo(A)o(CM)20 b(SIGPLAN)g(Notic)n(es)p
6238 
+Fp(,)71 2037 y(27\(5\),)13 b(Ma)o(y)h(1992.)0 2125 y([4])22
6239 
+b(R.S.)c(Nikhil.)30 b(Id)18 b(\(v)o(ersion)g(90.0\))f(reference)h(man)o(ual.)
6240 
+29 b(T)l(ec)o(hnical)19 b(rep)q(ort,)f(Massac)o(h)o(usetts)f(Institute)h(of)
6241 
+71 2181 y(T)l(ec)o(hnology)l(,)d(Lab)q(oratory)f(for)h(Computer)g(Science,)i
6242 
+(Septem)o(b)q(er)e(1990.)0 2269 y([5])22 b(J.)15 b(Rees)h(and)g(W.)f(Clinger)
6243 
+h(\(eds.\).)k(The)c(revised)928 2252 y Fm(3)964 2269 y Fp(rep)q(ort)f(on)h
6244 
+(the)f(algorithmic)h(language)g(Sc)o(heme.)21 b Fo(SIG-)71
6245 
+2325 y(PLAN)15 b(Notic)n(es)p Fp(,)f(21\(12\):37{79)o(,)e(Decem)o(b)q(er)k
6246 
+(1986.)0 2413 y([6])22 b(G.L.)14 b(Steele)j(Jr.)i Fo(Common)e(Lisp:)j(The)c
6247 
+(L)n(anguage)p Fp(.)j(Digital)d(Press,)e(Burlington,)i(Mass.,)e(1984.)0
6248 
+2501 y([7])22 b(P)l(.)f(W)l(adler.)39 b(Ho)o(w)21 b(to)g(replace)i(failure)g
6249 
+(b)o(y)e(a)h(list)g(of)f(successes.)40 b(In)22 b Fo(Pr)n(o)n(c)n(e)n(e)n
6250 
+(dings)e(of)i(Confer)n(enc)n(e)e(on)71 2557 y(F)m(unctional)e(Pr)n(o)n(gr)n
6251 
+(amming)h(L)n(anguages)g(and)h(Computer)h(A)o(r)n(chite)n(ctur)n(e,)f(LNCS)e
6252 
+(V)m(ol.)h(201)p Fp(,)h(pages)f(113{)71 2614 y(128.)14 b(Springer)i(V)l
6253 
+(erlag,)f(1985.)p eop
6254 
+%%Trailer
6255 
+end
6256 
+userdict /end-hook known{end-hook}if
6257 
+%%EOF
doc/xinterface/xman.dvi
History View file @ 4e98702
0 6258 
new file mode 100644
1 6259 
Binary files /dev/null and b/doc/xinterface/xman.dvi differ
emacs-tools/README
History View file @ 4e98702
2 6260 
new file mode 100644
... ... 
@@ -0,0 +1,5 @@
1 
+This directory contains GNU Emacs support for editing Haskell files.
2 
+We don't yet have a fancy editing mode, but haskell.el contains stuff
3 
+for running Haskell as an inferior process from Emacs with key bindings
4 
+for evaluating code from buffers, etc.  Look at the comments in haskell.el
5 
+for more information.
emacs-tools/comint.el
History View file @ 4e98702
0 6 
new file mode 100644
... ... 
@@ -0,0 +1,1524 @@
1 
+;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff
2 
+;;; Copyright Olin Shivers (1988).
3 
+;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
4 
+;;; notice appearing here to the effect that you may use this code any
5 
+;;; way you like, as long as you don't charge money for it, remove this
6 
+;;; notice, or hold me liable for its results.
7 
+
8 
+;;; The changelog is at the end of this file.
9 
+
10 
+;;; Please send me bug reports, bug fixes, and extensions, so that I can
11 
+;;; merge them into the master source.
12 
+;;;     - Olin Shivers (shivers@cs.cmu.edu)
13 
+
14 
+;;; This hopefully generalises shell mode, lisp mode, tea mode, soar mode,...
15 
+;;; This file defines a general command-interpreter-in-a-buffer package
16 
+;;; (comint mode). The idea is that you can build specific process-in-a-buffer
17 
+;;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, ....
18 
+;;; This way, all these specific packages share a common base functionality,
19 
+;;; and a common set of bindings, which makes them easier to use (and
20 
+;;; saves code, implementation time, etc., etc.).
21 
+
22 
+;;; Several packages are already defined using comint mode:
23 
+;;; - cmushell.el defines a shell-in-a-buffer mode.
24 
+;;; - cmulisp.el defines a simple lisp-in-a-buffer mode.
25 
+;;; Cmushell and cmulisp mode are similar to, and intended to replace,
26 
+;;; their counterparts in the standard gnu emacs release (in shell.el).
27 
+;;; These replacements are more featureful, robust, and uniform than the
28 
+;;; released versions. The key bindings in lisp mode are also more compatible
29 
+;;; with the bindings of Hemlock and Zwei (the Lisp Machine emacs).
30 
+;;;
31 
+;;; - The file cmuscheme.el defines a scheme-in-a-buffer mode.
32 
+;;; - The file tea.el tunes scheme and inferior-scheme modes for T.
33 
+;;; - The file soar.el tunes lisp and inferior-lisp modes for Soar.
34 
+;;; - cmutex.el defines tex and latex modes that invoke tex, latex, bibtex,
35 
+;;;   previewers, and printers from within emacs.
36 
+;;; - background.el allows csh-like job control inside emacs.
37 
+;;; It is pretty easy to make new derived modes for other processes.
38 
+
39 
+;;; For documentation on the functionality provided by comint mode, and
40 
+;;; the hooks available for customising it, see the comments below.
41 
+;;; For further information on the standard derived modes (shell,
42 
+;;; inferior-lisp, inferior-scheme, ...), see the relevant source files.
43 
+
44 
+;;; For hints on converting existing process modes (e.g., tex-mode,
45 
+;;; background, dbx, gdb, kermit, prolog, telnet) to use comint-mode
46 
+;;; instead of shell-mode, see the notes at the end of this file.
47 
+
48 
+(provide 'comint)
49 
+(defconst comint-version "2.01")
50 
+
51 
+
52 
+
53 
+
54 
+
55 
+
56 
+
57 
+
58 
+
59 
+
60 
+
61 
+
62 
+
63 
+
64 
+
65 
+
66 
+
67 
+
68 
+
69 
+
70 
+
71 
+;;; Brief Command Documentation:
72 
+;;;============================================================================
73 
+;;; Comint Mode Commands: (common to all derived modes, like cmushell & cmulisp
74 
+;;; mode)
75 
+;;;
76 
+;;; m-p	    comint-previous-input    	    Cycle backwards in input history
77 
+;;; m-n	    comint-next-input  	    	    Cycle forwards
78 
+;;; m-s     comint-previous-similar-input   Previous similar input
79 
+;;; c-c r   comint-previous-input-matching  Search backwards in input history
80 
+;;; return  comint-send-input
81 
+;;; c-a     comint-bol                      Beginning of line; skip prompt.
82 
+;;; c-d	    comint-delchar-or-maybe-eof     Delete char unless at end of buff.
83 
+;;; c-c c-u comint-kill-input	    	    ^u
84 
+;;; c-c c-w backward-kill-word    	    ^w
85 
+;;; c-c c-c comint-interrupt-subjob 	    ^c
86 
+;;; c-c c-z comint-stop-subjob	    	    ^z
87 
+;;; c-c c-\ comint-quit-subjob	    	    ^\
88 
+;;; c-c c-o comint-kill-output		    Delete last batch of process output
89 
+;;; c-c c-r comint-show-output		    Show last batch of process output
90 
+;;;
91 
+;;; Not bound by default in comint-mode
92 
+;;; send-invisible			Read a line w/o echo, and send to proc
93 
+;;; (These are bound in shell-mode)
94 
+;;; comint-dynamic-complete		Complete filename at point.
95 
+;;; comint-dynamic-list-completions	List completions in help buffer.
96 
+;;; comint-replace-by-expanded-filename	Expand and complete filename at point;
97 
+;;;					replace with expanded/completed name.
98 
+;;; comint-kill-subjob			No mercy.
99 
+;;; comint-continue-subjob		Send CONT signal to buffer's process
100 
+;;;					group. Useful if you accidentally
101 
+;;;					suspend your process (with C-c C-z).
102 
+;;;
103 
+;;; Bound for RMS -- I prefer the input history stuff, but you might like 'em.
104 
+;;; m-P	   comint-msearch-input		Search backwards for prompt
105 
+;;; m-N    comint-psearch-input		Search forwards for prompt
106 
+;;; C-cR   comint-msearch-input-matching Search backwards for prompt & string
107 
+
108 
+;;; comint-mode-hook is the comint mode hook. Basically for your keybindings.
109 
+;;; comint-load-hook is run after loading in this package.
110 
+
111 
+
112 
+
113 
+
114 
+
115 
+;;; Buffer Local Variables:
116 
+;;;============================================================================
117 
+;;; Comint mode buffer local variables:
118 
+;;;     comint-prompt-regexp    - string       comint-bol uses to match prompt.
119 
+;;;     comint-last-input-end   - marker       For comint-kill-output command
120 
+;;;     input-ring-size         - integer      For the input history
121 
+;;;     input-ring              - ring             mechanism
122 
+;;;     input-ring-index        - marker           ...
123 
+;;;     comint-last-input-match - string           ...
124 
+;;;     comint-get-old-input    - function     Hooks for specific
125 
+;;;     comint-input-sentinel   - function         process-in-a-buffer
126 
+;;;     comint-input-filter     - function         modes.
127 
+;;;     comint-input-send	- function
128 
+;;;     comint-eol-on-send	- boolean
129 
+
130 
+(defvar comint-prompt-regexp "^"
131 
+  "Regexp to recognise prompts in the inferior process.
132 
+Defaults to \"^\", the null string at BOL.
133 
+
134 
+Good choices:
135 
+  Canonical Lisp: \"^[^> ]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp)
136 
+  Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\"
137 
+  franz: \"^\\(->\\|<[0-9]*>:\\) *\"
138 
+  kcl: \"^>+ *\"
139 
+  shell: \"^[^#$%>]*[#$%>] *\"
140 
+  T: \"^>+ *\"
141 
+
142 
+This is a good thing to set in mode hooks.")
143 
+
144 
+(defvar input-ring-size 30
145 
+  "Size of input history ring.")
146 
+
147 
+;;; Here are the per-interpreter hooks.
148 
+(defvar comint-get-old-input (function comint-get-old-input-default)
149 
+  "Function that submits old text in comint mode.
150 
+This function is called when return is typed while the point is in old text.
151 
+It returns the text to be submitted as process input.  The default is
152 
+comint-get-old-input-default, which grabs the current line, and strips off
153 
+leading text matching comint-prompt-regexp")
154 
+
155 
+(defvar comint-input-sentinel (function ignore)
156 
+  "Called on each input submitted to comint mode process by comint-send-input.
157 
+Thus it can, for instance, track cd/pushd/popd commands issued to the csh.")
158 
+
159 
+(defvar comint-input-filter
160 
+  (function (lambda (str) (not (string-match "\\`\\s *\\'" str))))
161 
+  "Predicate for filtering additions to input history.
162 
+Only inputs answering true to this function are saved on the input
163 
+history list. Default is to save anything that isn't all whitespace")
164 
+
165 
+(defvar comint-input-sender (function comint-simple-send)
166 
+  "Function to actually send to PROCESS the STRING submitted by user.
167 
+Usually this is just 'comint-simple-send, but if your mode needs to
168 
+massage the input string, this is your hook. This is called from
169 
+the user command comint-send-input. comint-simple-send just sends
170 
+the string plus a newline.")
171 
+
172 
+(defvar comint-eol-on-send 'T
173 
+  "If non-nil, then jump to the end of the line before sending input to process.
174 
+See COMINT-SEND-INPUT")
175 
+
176 
+(defvar comint-mode-hook '()
177 
+  "Called upon entry into comint-mode")
178 
+
179 
+(defvar comint-mode-map nil)
180 
+
181 
+(defun comint-mode ()
182 
+  "Major mode for interacting with an inferior interpreter.
183 
+Interpreter name is same as buffer name, sans the asterisks.
184 
+Return at end of buffer sends line as input.
185 
+Return not at end copies rest of line to end and sends it.
186 
+Setting mode variable comint-eol-on-send means jump to the end of the line
187 
+before submitting new input.
188 
+
189 
+This mode is typically customised to create inferior-lisp-mode,
190 
+shell-mode, etc.. This can be done by setting the hooks
191 
+comint-input-sentinel, comint-input-filter, comint-input-sender and
192 
+comint-get-old-input to appropriate functions, and the variable
193 
+comint-prompt-regexp to the appropriate regular expression.
194 
+
195 
+An input history is maintained of size input-ring-size, and
196 
+can be accessed with the commands comint-next-input [\\[comint-next-input]] and
197 
+comint-previous-input [\\[comint-previous-input]]. Commands not keybound by
198 
+default are send-invisible, comint-dynamic-complete, and
199 
+comint-list-dynamic-completions.
200 
+
201 
+If you accidentally suspend your process, use \\[comint-continue-subjob]
202 
+to continue it.
203 
+
204 
+\\{comint-mode-map}
205 
+
206 
+Entry to this mode runs the hooks on comint-mode-hook"
207 
+  (interactive)
208 
+  (let ((old-ring (and (assq 'input-ring (buffer-local-variables))
209 
+		       (boundp 'input-ring)
210 
+		       input-ring))
211 
+	(old-ptyp comint-ptyp)) ; preserve across local var kill. gross.
212 
+    (kill-all-local-variables)
213 
+    (setq major-mode 'comint-mode)
214 
+    (setq mode-name "Comint")
215 
+    (setq mode-line-process '(": %s"))
216 
+    (use-local-map comint-mode-map)
217 
+    (make-local-variable 'comint-last-input-end)
218 
+    (setq comint-last-input-end (make-marker))
219 
+    (make-local-variable 'comint-last-input-match)
220 
+    (setq comint-last-input-match "")
221 
+    (make-local-variable 'comint-prompt-regexp) ; Don't set; default
222 
+    (make-local-variable 'input-ring-size)      ; ...to global val.
223 
+    (make-local-variable 'input-ring)
224 
+    (make-local-variable 'input-ring-index)
225 
+    (setq input-ring-index 0)
226 
+    (make-local-variable 'comint-get-old-input)
227 
+    (make-local-variable 'comint-input-sentinel)
228 
+    (make-local-variable 'comint-input-filter)
229 
+    (make-local-variable 'comint-input-sender)
230 
+    (make-local-variable 'comint-eol-on-send)
231 
+    (make-local-variable 'comint-ptyp)
232 
+    (setq comint-ptyp old-ptyp)
233 
+    (run-hooks 'comint-mode-hook)
234 
+    ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook.
235 
+    ;The test is so we don't lose history if we run comint-mode twice in
236 
+    ;a buffer.
237 
+    (setq input-ring (if (ring-p old-ring) old-ring
238 
+			 (make-ring input-ring-size)))))
239 
+
240 
+;;; The old-ptyp stuff above is because we have to preserve the value of
241 
+;;; comint-ptyp across calls to comint-mode, in spite of the
242 
+;;; kill-all-local-variables that it does. Blech. Hopefully, this will all
243 
+;;; go away when a later release fixes the signalling bug.
244 
+
245 
+(if comint-mode-map
246 
+    nil
247 
+  (setq comint-mode-map (make-sparse-keymap))
248 
+  (define-key comint-mode-map "\ep" 'comint-previous-input)
249 
+  (define-key comint-mode-map "\en" 'comint-next-input)
250 
+  (define-key comint-mode-map "\es" 'comint-previous-similar-input)
251 
+  (define-key comint-mode-map "\C-m" 'comint-send-input)
252 
+  (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof)
253 
+  (define-key comint-mode-map "\C-a" 'comint-bol)
254 
+  (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input)
255 
+  (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word)
256 
+  (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob)
257 
+  (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob)
258 
+  (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob)
259 
+  (define-key comint-mode-map "\C-c\C-o" 'comint-kill-output)
260 
+  (define-key comint-mode-map "\C-cr"    'comint-previous-input-matching)
261 
+  (define-key comint-mode-map "\C-c\C-r" 'comint-show-output)
262 
+  ;;; Here's the prompt-search stuff I installed for RMS to try...
263 
+  (define-key comint-mode-map "\eP" 'comint-msearch-input)
264 
+  (define-key comint-mode-map "\eN" 'comint-psearch-input)
265 
+  (define-key comint-mode-map "\C-cR" 'comint-msearch-input-matching))
266 
+
267 
+
268 
+;;; This function is used to make a full copy of the comint mode map,
269 
+;;; so that client modes won't interfere with each other. This function
270 
+;;; isn't necessary in emacs 18.5x, but we keep it around for 18.4x versions.
271 
+(defun full-copy-sparse-keymap (km)
272 
+  "Recursively copy the sparse keymap KM"
273 
+  (cond ((consp km)
274 
+	 (cons (full-copy-sparse-keymap (car km))
275 
+	       (full-copy-sparse-keymap (cdr km))))
276 
+	(t km)))
277 
+
278 
+(defun comint-check-proc (buffer-name)
279 
+  "True if there is a process associated w/buffer BUFFER-NAME, and
280 
+it is alive (status RUN or STOP)."
281 
+  (let ((proc (get-buffer-process buffer-name)))
282 
+    (and proc (memq (process-status proc) '(run stop)))))
283 
+
284 
+;;; Note that this guy, unlike shell.el's make-shell, barfs if you pass it ()
285 
+;;; for the second argument (program).
286 
+(defun make-comint (name program &optional startfile &rest switches)
287 
+  (let* ((buffer (get-buffer-create (concat "*" name "*")))
288 
+	 (proc (get-buffer-process buffer)))
289 
+    ;; If no process, or nuked process, crank up a new one and put buffer in
290 
+    ;; comint mode. Otherwise, leave buffer and existing process alone.
291 
+    (cond ((or (not proc) (not (memq (process-status proc) '(run stop))))
292 
+	   (save-excursion
293 
+	     (set-buffer buffer)
294 
+	     (comint-mode)) ; Install local vars, mode, keymap, ...
295 
+	   (comint-exec buffer name program startfile switches)))
296 
+    buffer))
297 
+
298 
+(defvar comint-ptyp t
299 
+  "True if communications via pty; false if by pipe. Buffer local.
300 
+This is to work around a bug in emacs process signalling.")
301 
+
302 
+(defun comint-exec (buffer name command startfile switches)
303 
+  "Fires up a process in buffer for comint modes.
304 
+Blasts any old process running in the buffer. Doesn't set the buffer mode.
305 
+You can use this to cheaply run a series of processes in the same comint
306 
+buffer."
307 
+  (save-excursion
308 
+    (set-buffer buffer)
309 
+    (let ((proc (get-buffer-process buffer)))	; Blast any old process.
310 
+      (if proc (delete-process proc)))
311 
+    ;; Crank up a new process
312 
+    (let ((proc (comint-exec-1 name buffer command switches)))
313 
+      (make-local-variable 'comint-ptyp)
314 
+      (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe.
315 
+      ;; Jump to the end, and set the process mark.
316 
+      (goto-char (point-max))
317 
+      (set-marker (process-mark proc) (point)))
318 
+      ;; Feed it the startfile.
319 
+      (cond (startfile
320 
+	     ;;This is guaranteed to wait long enough
321 
+	     ;;but has bad results if the comint does not prompt at all
322 
+	     ;;	     (while (= size (buffer-size))
323 
+	     ;;	       (sleep-for 1))
324 
+	     ;;I hope 1 second is enough!
325 
+	     (sleep-for 1)
326 
+	     (goto-char (point-max))
327 
+	     (insert-file-contents startfile)
328 
+	     (setq startfile (buffer-substring (point) (point-max)))
329 
+	     (delete-region (point) (point-max))
330 
+	     (comint-send-string proc startfile)))
331 
+    buffer))
332 
+
333 
+;;; This auxiliary function cranks up the process for comint-exec in
334 
+;;; the appropriate environment. It is twice as long as it should be
335 
+;;; because emacs has two distinct mechanisms for manipulating the
336 
+;;; process environment, selected at compile time with the
337 
+;;; MAINTAIN-ENVIRONMENT #define. In one case, process-environment
338 
+;;; is bound; in the other it isn't.
339 
+
340 
+(defun comint-exec-1 (name buffer command switches)
341 
+  (if (boundp 'process-environment) ; Not a completely reliable test.
342 
+      (let ((process-environment
343 
+	     (comint-update-env process-environment
344 
+				(list (format "TERMCAP=emacs:co#%d:tc=unknown"
345 
+					      (screen-width))
346 
+				      "TERM=emacs"
347 
+				      "EMACS=t"))))
348 
+	(apply 'start-process name buffer command switches))
349 
+
350 
+      (let ((tcapv (getenv "TERMCAP"))
351 
+	    (termv (getenv "TERM"))
352 
+	    (emv   (getenv "EMACS")))
353 
+	(unwind-protect
354 
+	     (progn (setenv "TERMCAP" (format "emacs:co#%d:tc=unknown"
355 
+					      (screen-width)))
356 
+		    (setenv "TERM" "emacs")
357 
+		    (setenv "EMACS" "t")
358 
+		    (apply 'start-process name buffer command switches))
359 
+	  (setenv "TERMCAP" tcapv)
360 
+	  (setenv "TERM"    termv)
361 
+	  (setenv "EMACS"   emv)))))
362 
+
363 
+
364 
+
365 
+;; This is just (append new old-env) that compresses out shadowed entries.
366 
+;; It's also pretty ugly, mostly due to elisp's horrible iteration structures.
367 
+(defun comint-update-env (old-env new)
368 
+  (let ((ans (reverse new))
369 
+	(vars (mapcar (function (lambda (vv)
370 
+			(and (string-match "^[^=]*=" vv)
371 
+			     (substring vv 0 (match-end 0)))))
372 
+		      new)))
373 
+    (while old-env
374 
+      (let* ((vv (car old-env)) ; vv is var=value
375 
+	     (var (and (string-match "^[^=]*=" vv)
376 
+		       (substring vv 0 (match-end 0)))))
377 
+	(setq old-env (cdr old-env))
378 
+	(cond ((not (and var (comint-mem var vars)))
379 
+	       (if var (setq var (cons var vars)))
380 
+	       (setq ans (cons vv ans))))))
381 
+    (nreverse ans)))
382 
+
383 
+;;; This should be in emacs, but it isn't.
384 
+(defun comint-mem (item list &optional elt=)
385 
+  "Test to see if ITEM is equal to an item in LIST.
386 
+Option comparison function ELT= defaults to equal."
387 
+  (let ((elt= (or elt= (function equal)))
388 
+	(done nil))
389 
+    (while (and list (not done))
390 
+      (if (funcall elt= item (car list))
391 
+	  (setq done list)
392 
+	  (setq list (cdr list))))
393 
+    done))
394 
+
395 
+
396 
+
397 
+
398 
+
399 
+
400 
+
401 
+
402 
+
403 
+
404 
+
405 
+
406 
+
407 
+
408 
+
409 
+
410 
+
411 
+
412 
+
413 
+
414 
+
415 
+
416 
+
417 
+
418 
+
419 
+
420 
+
421 
+
422 
+
423 
+;;; Ring Code
424 
+;;;============================================================================
425 
+;;; This code defines a ring data structure. A ring is a
426 
+;;;     (hd-index tl-index . vector)
427 
+;;; list. You can insert to, remove from, and rotate a ring. When the ring
428 
+;;; fills up, insertions cause the oldest elts to be quietly dropped.
429 
+;;;
430 
+;;; HEAD = index of the newest item on the ring.
431 
+;;; TAIL = index of the oldest item on the ring.
432 
+;;;
433 
+;;; These functions are used by the input history mechanism, but they can
434 
+;;; be used for other purposes as well.
435 
+
436 
+(defun ring-p (x)
437 
+  "T if X is a ring; NIL otherwise."
438 
+  (and (consp x) (integerp (car x))
439 
+       (consp (cdr x)) (integerp (car (cdr x)))
440 
+       (vectorp (cdr (cdr x)))))
441 
+
442 
+(defun make-ring (size)
443 
+  "Make a ring that can contain SIZE elts"
444 
+  (cons 1 (cons 0 (make-vector (+ size 1) nil))))
445 
+
446 
+(defun ring-plus1 (index veclen)
447 
+  "INDEX+1, with wraparound"
448 
+  (let ((new-index (+ index 1)))
449 
+    (if (= new-index veclen) 0 new-index)))
450 
+
451 
+(defun ring-minus1 (index veclen)
452 
+  "INDEX-1, with wraparound"
453 
+  (- (if (= 0 index) veclen index) 1))
454 
+
455 
+(defun ring-length (ring)
456 
+  "Number of elts in the ring."
457 
+  (let ((hd (car ring)) (tl (car (cdr ring)))  (siz (length (cdr (cdr ring)))))
458 
+    (let ((len (if (<= hd tl) (+ 1 (- tl hd)) (+ 1 tl (- siz hd)))))
459 
+      (if (= len siz) 0 len))))
460 
+
461 
+(defun ring-empty-p (ring)
462 
+  (= 0 (ring-length ring)))
463 
+
464 
+(defun ring-insert (ring item)
465 
+  "Insert a new item onto the ring. If the ring is full, dump the oldest
466 
+item to make room."
467 
+  (let* ((vec (cdr (cdr ring)))  (len (length vec))
468 
+	 (new-hd (ring-minus1 (car ring) len)))
469 
+      (setcar ring new-hd)
470 
+      (aset vec new-hd item)
471 
+      (if (ring-empty-p ring) ;overflow -- dump one off the tail.
472 
+	  (setcar (cdr ring) (ring-minus1 (car (cdr ring)) len)))))
473 
+
474 
+(defun ring-remove (ring)
475 
+  "Remove the oldest item retained on the ring."
476 
+  (if (ring-empty-p ring) (error "Ring empty")
477 
+      (let ((tl (car (cdr ring)))  (vec (cdr (cdr ring))))
478 
+	(set-car (cdr ring) (ring-minus1 tl (length vec)))
479 
+	(aref vec tl))))
480 
+
481 
+;;; This isn't actually used in this package. I just threw it in in case
482 
+;;; someone else wanted it. If you want rotating-ring behavior on your history
483 
+;;; retrieval (analagous to kill ring behavior), this function is what you
484 
+;;; need. I should write the yank-input and yank-pop-input-or-kill to go with
485 
+;;; this, and not bind it to a key by default, so it would be available to
486 
+;;; people who want to bind it to a key. But who would want it? Blech.
487 
+(defun ring-rotate (ring n)
488 
+  (if (not (= n 0))
489 
+      (if (ring-empty-p ring) ;Is this the right error check?
490 
+	  (error "ring empty")
491 
+	  (let ((hd (car ring))  (tl (car (cdr ring)))  (vec (cdr (cdr ring))))
492 
+	    (let ((len (length vec)))
493 
+	      (while (> n 0)
494 
+		(setq tl (ring-plus1 tl len))
495 
+		(aset ring tl (aref ring hd))
496 
+		(setq hd (ring-plus1 hd len))
497 
+		(setq n (- n 1)))
498 
+	      (while (< n 0)
499 
+		(setq hd (ring-minus1 hd len))
500 
+		(aset vec hd (aref vec tl))
501 
+		(setq tl (ring-minus1 tl len))
502 
+		(setq n (- n 1))))
503 
+	    (set-car ring hd)
504 
+	    (set-car (cdr ring) tl)))))
505 
+
506 
+(defun comint-mod (n m)
507 
+  "Returns N mod M. M is positive. Answer is guaranteed to be non-negative,
508 
+and less than m."
509 
+  (let ((n (% n m)))
510 
+    (if (>= n 0) n
511 
+	(+ n
512 
+	   (if (>= m 0) m (- m)))))) ; (abs m)
513 
+
514 
+(defun ring-ref (ring index)
515 
+  (let ((numelts (ring-length ring)))
516 
+    (if (= numelts 0) (error "indexed empty ring")
517 
+	(let* ((hd (car ring))  (tl (car (cdr ring)))  (vec (cdr (cdr ring)))
518 
+	       (index (comint-mod index numelts))
519 
+	       (vec-index (comint-mod (+ index hd)
520 
+				      (length vec))))
521 
+	  (aref vec vec-index)))))
522 
+
523 
+
524 
+;;; Input history retrieval commands
525 
+;;; M-p -- previous input    M-n -- next input
526 
+;;; C-c r -- previous input matching
527 
+;;; ===========================================================================
528 
+
529 
+(defun comint-previous-input (arg)
530 
+  "Cycle backwards through input history."
531 
+  (interactive "*p")
532 
+  (let ((len (ring-length input-ring)))
533 
+    (cond ((<= len 0)
534 
+	   (message "Empty input ring")
535 
+	   (ding))
536 
+	  ((not (comint-after-pmark-p))
537 
+	   (message "Not after process mark")
538 
+	   (ding))
539 
+	  (t
540 
+	   (cond ((eq last-command 'comint-previous-input)
541 
+		  (delete-region (mark) (point)))
542 
+		 ((eq last-command 'comint-previous-similar-input)
543 
+		  (delete-region
544 
+		   (process-mark (get-buffer-process (current-buffer)))
545 
+		   (point)))
546 
+		 (t
547 
+		  (setq input-ring-index
548 
+			(if (> arg 0) -1
549 
+			    (if (< arg 0) 1 0)))
550 
+		  (push-mark (point))))
551 
+	   (setq input-ring-index (comint-mod (+ input-ring-index arg) len))
552 
+	   (message "%d" (1+ input-ring-index))
553 
+	   (insert (ring-ref input-ring input-ring-index))
554 
+	   (setq this-command 'comint-previous-input)))))
555 
+
556 
+(defun comint-next-input (arg)
557 
+  "Cycle forwards through input history."
558 
+  (interactive "*p")
559 
+  (comint-previous-input (- arg)))
560 
+
561 
+(defvar comint-last-input-match ""
562 
+  "Last string searched for by comint input history search, for defaulting.
563 
+Buffer local variable.")
564 
+
565 
+(defun comint-previous-input-matching (str)
566 
+  "Searches backwards through input history for substring match."
567 
+  (interactive (let* ((last-command last-command) ; preserve around r-f-m
568 
+		      (s (read-from-minibuffer
569 
+			 (format "Command substring (default %s): "
570 
+				 comint-last-input-match))))
571 
+		 (list (if (string= s "") comint-last-input-match s))))
572 
+; (interactive "sCommand substring: ")
573 
+  (setq comint-last-input-match str) ; update default
574 
+  (if (not (eq last-command 'comint-previous-input))
575 
+      (setq input-ring-index -1))
576 
+  (let ((str (regexp-quote str))
577 
+        (len (ring-length input-ring))
578 
+	(n (+ input-ring-index 1)))
579 
+    (while (and (< n len) (not (string-match str (ring-ref input-ring n))))
580 
+      (setq n (+ n 1)))
581 
+    (cond ((< n len)
582 
+	   (comint-previous-input (- n input-ring-index)))
583 
+	  (t (if (eq last-command 'comint-previous-input)
584 
+		 (setq this-command 'comint-previous-input))
585 
+	     (message "Not found.")
586 
+	     (ding)))))
587 
+
588 
+
589 
+;;; These next three commands are alternatives to the input history commands --
590 
+;;; comint-next-input, comint-previous-input and
591 
+;;; comint-previous-input-matching. They search through the process buffer
592 
+;;; text looking for occurrences of the prompt. RMS likes them better;
593 
+;;; I don't. Bound to M-P, M-N, and C-c R (uppercase P, N, and R) for
594 
+;;; now. Try'em out. Go with what you like...
595 
+
596 
+;;; comint-msearch-input-matching prompts for a string, not a regexp.
597 
+;;; This could be considered to be the wrong thing. I decided to keep it
598 
+;;; simple, and not make the user worry about regexps. This, of course,
599 
+;;; limits functionality.
600 
+
601 
+(defun comint-psearch-input ()
602 
+  "Search forwards for next occurrence of prompt and skip to end of line.
603 
+\(prompt is anything matching regexp comint-prompt-regexp)"
604 
+  (interactive)
605 
+  (if (re-search-forward comint-prompt-regexp (point-max) t)
606 
+      (end-of-line)
607 
+      (error "No occurrence of prompt found")))
608 
+
609 
+(defun comint-msearch-input ()
610 
+  "Search backwards for previous occurrence of prompt and skip to end of line.
611 
+Search starts from beginning of current line."
612 
+  (interactive)
613 
+  (let ((p (save-excursion
614 
+	     (beginning-of-line)
615 
+	     (cond ((re-search-backward comint-prompt-regexp (point-min) t)
616 
+		    (end-of-line)
617 
+		    (point))
618 
+		   (t nil)))))
619 
+    (if p (goto-char p)
620 
+	(error "No occurrence of prompt found"))))
621 
+
622 
+(defun comint-msearch-input-matching (str)
623 
+  "Search backwards for occurrence of prompt followed by STRING.
624 
+STRING is prompted for, and is NOT a regular expression."
625 
+  (interactive (let ((s (read-from-minibuffer
626 
+			 (format "Command (default %s): "
627 
+				 comint-last-input-match))))
628 
+		 (list (if (string= s "") comint-last-input-match s))))
629 
+; (interactive "sCommand: ")
630 
+  (setq comint-last-input-match str) ; update default
631 
+  (let* ((r (concat comint-prompt-regexp (regexp-quote str)))
632 
+	 (p (save-excursion
633 
+	      (beginning-of-line)
634 
+	      (cond ((re-search-backward r (point-min) t)
635 
+		     (end-of-line)
636 
+		     (point))
637 
+		    (t nil)))))
638 
+    (if p (goto-char p)
639 
+	(error "No match"))))
640 
+
641 
+;;;
642 
+;;; Similar input -- contributed by ccm and highly winning.
643 
+;;;
644 
+;;; Reenter input, removing back to the last insert point if it exists.
645 
+;;;
646 
+(defvar comint-last-similar-string ""
647 
+  "The string last used in a similar string search.")
648 
+(defun comint-previous-similar-input (arg)
649 
+  "Reenters the last input that matches the string typed so far.  If repeated
650 
+successively older inputs are reentered.  If arg is 1, it will go back
651 
+in the history, if -1 it will go forward."
652 
+  (interactive "p")
653 
+  (if (not (comint-after-pmark-p))
654 
+      (error "Not after process mark"))
655 
+  (if (not (eq last-command 'comint-previous-similar-input))
656 
+      (setq input-ring-index -1
657 
+	    comint-last-similar-string
658 
+	    (buffer-substring
659 
+	     (process-mark (get-buffer-process (current-buffer)))
660 
+	     (point))))
661 
+  (let* ((size (length comint-last-similar-string))
662 
+	 (len (ring-length input-ring))
663 
+	 (n (+ input-ring-index arg))
664 
+	 entry)
665 
+    (while (and (< n len)
666 
+		(or (< (length (setq entry (ring-ref input-ring n))) size)
667 
+		    (not (equal comint-last-similar-string
668 
+				(substring entry 0 size)))))
669 
+      (setq n (+ n arg)))
670 
+    (cond ((< n len)
671 
+	   (setq input-ring-index n)
672 
+	   (if (eq last-command 'comint-previous-similar-input)
673 
+	       (delete-region (mark) (point)) ; repeat
674 
+	       (push-mark (point)))	      ; 1st time
675 
+	   (insert (substring entry size)))
676 
+	  (t (message "Not found.") (ding) (sit-for 1)))
677 
+    (message "%d" (1+ input-ring-index))))
678 
+
679 
+
680 
+
681 
+
682 
+
683 
+
684 
+
685 
+
686 
+
687 
+(defun comint-send-input ()
688 
+  "Send input to process.  After the process output mark, sends all text
689 
+from the process mark to point as input to the process.  Before the
690 
+process output mark, calls value of variable comint-get-old-input to retrieve
691 
+old input, copies it to the end of the buffer, and sends it.  A terminal
692 
+newline is also inserted into the buffer and sent to the process.  In either
693 
+case, value of variable comint-input-sentinel is called on the input before
694 
+sending it.  The input is entered into the input history ring, if value of
695 
+variable comint-input-filter returns non-nil when called on the input.
696 
+
697 
+If variable comint-eol-on-send is non-nil, then point is moved to the end of
698 
+line before sending the input.
699 
+
700 
+comint-get-old-input, comint-input-sentinel, and comint-input-filter are chosen
701 
+according to the command interpreter running in the buffer. E.g.,
702 
+If the interpreter is the csh,
703 
+    comint-get-old-input is the default: take the current line, discard any
704 
+        initial string matching regexp comint-prompt-regexp.
705 
+    comint-input-sentinel monitors input for \"cd\", \"pushd\", and \"popd\"
706 
+        commands. When it sees one, it cd's the buffer.
707 
+    comint-input-filter is the default: returns T if the input isn't all white
708 
+	space.
709 
+
710 
+If the comint is Lucid Common Lisp,
711 
+    comint-get-old-input snarfs the sexp ending at point.
712 
+    comint-input-sentinel does nothing.
713 
+    comint-input-filter returns NIL if the input matches input-filter-regexp,
714 
+        which matches (1) all whitespace (2) :a, :c, etc.
715 
+
716 
+Similarly for Soar, Scheme, etc.."
717 
+  (interactive)
718 
+  ;; Note that the input string does not include its terminal newline.
719 
+  (let ((proc (get-buffer-process (current-buffer))))
720 
+    (if (not proc) (error "Current buffer has no process")
721 
+	(let* ((pmark (process-mark proc))
722 
+	       (pmark-val (marker-position pmark))
723 
+	       (input (if (>= (point) pmark-val)
724 
+			  (progn (if comint-eol-on-send (end-of-line))
725 
+				 (buffer-substring pmark (point)))
726 
+			  (let ((copy (funcall comint-get-old-input)))
727 
+			    (goto-char pmark)
728 
+			    (insert copy)
729 
+			    copy))))
730 
+	  (insert ?\n)
731 
+	  (if (funcall comint-input-filter input) (ring-insert input-ring input))
732 
+	  (funcall comint-input-sentinel input)
733 
+	  (funcall comint-input-sender proc input)
734 
+	  (set-marker (process-mark proc) (point))
735 
+	  (set-marker comint-last-input-end (point))))))
736 
+
737 
+(defun comint-get-old-input-default ()
738 
+  "Default for comint-get-old-input: take the current line, and discard
739 
+any initial text matching comint-prompt-regexp."
740 
+  (save-excursion
741 
+    (beginning-of-line)
742 
+    (comint-skip-prompt)
743 
+    (let ((beg (point)))
744 
+      (end-of-line)
745 
+      (buffer-substring beg (point)))))
746 
+
747 
+(defun comint-skip-prompt ()
748 
+  "Skip past the text matching regexp comint-prompt-regexp.
749 
+If this takes us past the end of the current line, don't skip at all."
750 
+  (let ((eol (save-excursion (end-of-line) (point))))
751 
+    (if (and (looking-at comint-prompt-regexp)
752 
+	     (<= (match-end 0) eol))
753 
+	(goto-char (match-end 0)))))
754 
+
755 
+
756 
+(defun comint-after-pmark-p ()
757 
+  "Is point after the process output marker?"
758 
+  ;; Since output could come into the buffer after we looked at the point
759 
+  ;; but before we looked at the process marker's value, we explicitly
760 
+  ;; serialise. This is just because I don't know whether or not emacs
761 
+  ;; services input during execution of lisp commands.
762 
+  (let ((proc-pos (marker-position
763 
+		   (process-mark (get-buffer-process (current-buffer))))))
764 
+    (<= proc-pos (point))))
765 
+
766 
+(defun comint-simple-send (proc string)
767 
+  "Default function for sending to PROC input STRING.
768 
+This just sends STRING plus a newline. To override this,
769 
+set the hook COMINT-INPUT-SENDER."
770 
+  (comint-send-string proc string)
771 
+  (comint-send-string proc "\n"))
772 
+
773 
+(defun comint-bol (arg)
774 
+  "Goes to the beginning of line, then skips past the prompt, if any.
775 
+If a prefix argument is given (\\[universal-argument]), then no prompt skip
776 
+-- go straight to column 0.
777 
+
778 
+The prompt skip is done by skipping text matching the regular expression
779 
+comint-prompt-regexp, a buffer local variable.
780 
+
781 
+If you don't like this command, reset c-a to beginning-of-line
782 
+in your hook, comint-mode-hook."
783 
+  (interactive "P")
784 
+  (beginning-of-line)
785 
+  (if (null arg) (comint-skip-prompt)))
786 
+
787 
+;;; These two functions are for entering text you don't want echoed or
788 
+;;; saved -- typically passwords to ftp, telnet, or somesuch.
789 
+;;; Just enter m-x send-invisible and type in your line.
790 
+
791 
+(defun comint-read-noecho (prompt)
792 
+  "Prompt the user with argument PROMPT. Read a single line of text
793 
+without echoing, and return it. Note that the keystrokes comprising
794 
+the text can still be recovered (temporarily) with \\[view-lossage]. This
795 
+may be a security bug for some applications."
796 
+  (let ((echo-keystrokes 0)
797 
+	(answ "")
798 
+	tem)
799 
+    (if (and (stringp prompt) (not (string= (message prompt) "")))
800 
+	(message prompt))
801 
+    (while (not(or  (= (setq tem (read-char)) ?\^m)
802 
+		    (= tem ?\n)))
803 
+      (setq answ (concat answ (char-to-string tem))))
804 
+    (message "")
805 
+    answ))
806 
+
807 
+(defun send-invisible (str)
808 
+  "Read a string without echoing, and send it to the process running
809 
+in the current buffer. A new-line is additionally sent. String is not
810 
+saved on comint input history list.
811 
+Security bug: your string can still be temporarily recovered with
812 
+\\[view-lossage]."
813 
+; (interactive (list (comint-read-noecho "Enter non-echoed text")))
814 
+  (interactive "P") ; Defeat snooping via C-x esc
815 
+  (let ((proc (get-buffer-process (current-buffer))))
816 
+    (if (not proc) (error "Current buffer has no process")
817 
+	(comint-send-string proc
818 
+			    (if (stringp str) str
819 
+				(comint-read-noecho "Enter non-echoed text")))
820 
+	(comint-send-string proc "\n"))))
821 
+
822 
+
823 
+
824 
+
825 
+
826 
+
827 
+
828 
+
829 
+
830 
+
831 
+
832 
+
833 
+
834 
+
835 
+
836 
+
837 
+
838 
+
839 
+
840 
+
841 
+
842 
+
843 
+
844 
+
845 
+
846 
+
847 
+
848 
+
849 
+
850 
+
851 
+
852 
+
853 
+
854 
+
855 
+
856 
+
857 
+
858 
+
859 
+
860 
+
861 
+
862 
+
863 
+;;; Low-level process communication
864 
+
865 
+(defvar comint-input-chunk-size 512
866 
+  "*Long inputs send to comint processes are broken up into chunks of this size.
867 
+If your process is choking on big inputs, try lowering the value.")
868 
+
869 
+(defun comint-send-string (proc str)
870 
+  "Send PROCESS the contents of STRING as input.
871 
+This is equivalent to process-send-string, except that long input strings
872 
+are broken up into chunks of size comint-input-chunk-size. Processes
873 
+are given a chance to output between chunks. This can help prevent processes
874 
+from hanging when you send them long inputs on some OS's."
875 
+  (let* ((len (length str))
876 
+	 (i (min len comint-input-chunk-size)))
877 
+    (process-send-string proc (substring str 0 i))
878 
+    (while (< i len)
879 
+      (let ((next-i (+ i comint-input-chunk-size)))
880 
+	(accept-process-output)
881 
+	(process-send-string proc (substring str i (min len next-i)))
882 
+	(setq i next-i)))))
883 
+
884 
+(defun comint-send-region (proc start end)
885 
+  "Sends to PROC the region delimited by START and END.
886 
+This is a replacement for process-send-region that tries to keep
887 
+your process from hanging on long inputs. See comint-send-string."
888 
+  (comint-send-string proc (buffer-substring start end)))
889 
+
890 
+
891 
+
892 
+
893 
+
894 
+
895 
+
896 
+
897 
+
898 
+
899 
+
900 
+
901 
+
902 
+
903 
+
904 
+
905 
+
906 
+
907 
+;;; Random input hackage
908 
+
909 
+(defun comint-kill-output ()
910 
+  "Kill all output from interpreter since last input."
911 
+  (interactive)
912 
+  (let ((pmark (process-mark (get-buffer-process (current-buffer)))))
913 
+    (kill-region comint-last-input-end pmark)
914 
+    (goto-char pmark)
915 
+    (insert "*** output flushed ***\n")
916 
+    (set-marker pmark (point))))
917 
+
918 
+(defun comint-show-output ()
919 
+  "Display start of this batch of interpreter output at top of window.
920 
+Also put cursor there."
921 
+  (interactive)
922 
+  (goto-char comint-last-input-end)
923 
+  (backward-char)
924 
+  (beginning-of-line)
925 
+  (set-window-start (selected-window) (point))
926 
+  (end-of-line))
927 
+
928 
+(defun comint-interrupt-subjob ()
929 
+  "Interrupt the current subjob."
930 
+  (interactive)
931 
+  (interrupt-process nil comint-ptyp))
932 
+
933 
+(defun comint-kill-subjob ()
934 
+  "Send kill signal to the current subjob."
935 
+  (interactive)
936 
+  (kill-process nil comint-ptyp))
937 
+
938 
+(defun comint-quit-subjob ()
939 
+  "Send quit signal to the current subjob."
940 
+  (interactive)
941 
+  (quit-process nil comint-ptyp))
942 
+
943 
+(defun comint-stop-subjob ()
944 
+  "Stop the current subjob.
945 
+WARNING: if there is no current subjob, you can end up suspending
946 
+the top-level process running in the buffer. If you accidentally do
947 
+this, use \\[comint-continue-subjob] to resume the process. (This
948 
+is not a problem with most shells, since they ignore this signal.)"
949 
+  (interactive)
950 
+  (stop-process nil comint-ptyp))
951 
+
952 
+(defun comint-continue-subjob ()
953 
+  "Send CONT signal to process buffer's process group.
954 
+Useful if you accidentally suspend the top-level process."
955 
+  (interactive)
956 
+  (continue-process nil comint-ptyp))
957 
+
958 
+(defun comint-kill-input ()
959 
+  "Kill all text from last stuff output by interpreter to point."
960 
+  (interactive)
961 
+  (let* ((pmark (process-mark (get-buffer-process (current-buffer))))
962 
+	 (p-pos (marker-position pmark)))
963 
+    (if (> (point) p-pos)
964 
+	(kill-region pmark (point)))))
965 
+
966 
+(defun comint-delchar-or-maybe-eof (arg)
967 
+  "Delete ARG characters forward, or send an EOF to process if at end of buffer."
968 
+  (interactive "p")
969 
+  (if (eobp)
970 
+      (process-send-eof)
971 
+      (delete-char arg)))
972 
+
973 
+
974 
+
975 
+
976 
+
977 
+
978 
+
979 
+
980 
+
981 
+
982 
+
983 
+
984 
+
985 
+
986 
+
987 
+
988 
+
989 
+
990 
+
991 
+
992 
+
993 
+
994 
+
995 
+;;; Support for source-file processing commands.
996 
+;;;============================================================================
997 
+;;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have
998 
+;;; commands that process files of source text (e.g. loading or compiling
999 
+;;; files). So the corresponding process-in-a-buffer modes have commands
1000 
+;;; for doing this (e.g., lisp-load-file). The functions below are useful
1001 
+;;; for defining these commands.
1002 
+;;;
1003 
+;;; Alas, these guys don't do exactly the right thing for Lisp, Scheme
1004 
+;;; and Soar, in that they don't know anything about file extensions.
1005 
+;;; So the compile/load interface gets the wrong default occasionally.
1006 
+;;; The load-file/compile-file default mechanism could be smarter -- it
1007 
+;;; doesn't know about the relationship between filename extensions and
1008 
+;;; whether the file is source or executable. If you compile foo.lisp
1009 
+;;; with compile-file, then the next load-file should use foo.bin for
1010 
+;;; the default, not foo.lisp. This is tricky to do right, particularly
1011 
+;;; because the extension for executable files varies so much (.o, .bin,
1012 
+;;; .lbin, .mo, .vo, .ao, ...).
1013 
+
1014 
+
1015 
+;;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing
1016 
+;;; commands.
1017 
+;;;
1018 
+;;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you
1019 
+;;; want to save the buffer before issuing any process requests to the command
1020 
+;;; interpreter.
1021 
+;;;
1022 
+;;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt
1023 
+;;; for the file to process.
1024 
+
1025 
+;;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes)
1026 
+;;;============================================================================
1027 
+;;; This function computes the defaults for the load-file and compile-file
1028 
+;;; commands for tea, soar, cmulisp, and cmuscheme modes.
1029 
+;;;
1030 
+;;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last
1031 
+;;; source-file processing command. NIL if there hasn't been one yet.
1032 
+;;; - SOURCE-MODES is a list used to determine what buffers contain source
1033 
+;;; files: if the major mode of the buffer is in SOURCE-MODES, it's source.
1034 
+;;; Typically, (lisp-mode) or (scheme-mode).
1035 
+;;;
1036 
+;;; If the command is given while the cursor is inside a string, *and*
1037 
+;;; the string is an existing filename, *and* the filename is not a directory,
1038 
+;;; then the string is taken as default. This allows you to just position
1039 
+;;; your cursor over a string that's a filename and have it taken as default.
1040 
+;;;
1041 
+;;; If the command is given in a file buffer whose major mode is in
1042 
+;;; SOURCE-MODES, then the the filename is the default file, and the
1043 
+;;; file's directory is the default directory.
1044 
+;;;
1045 
+;;; If the buffer isn't a source file buffer (e.g., it's the process buffer),
1046 
+;;; then the default directory & file are what was used in the last source-file
1047 
+;;; processing command (i.e., PREVIOUS-DIR/FILE).  If this is the first time
1048 
+;;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory
1049 
+;;; is the cwd, with no default file. (\"no default file\" = nil)
1050 
+;;;
1051 
+;;; SOURCE-REGEXP is typically going to be something like (tea-mode)
1052 
+;;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode)
1053 
+;;; for Soar programs, etc.
1054 
+;;;
1055 
+;;; The function returns a pair: (default-directory . default-file).
1056 
+
1057 
+(defun comint-source-default (previous-dir/file source-modes)
1058 
+  (cond ((and buffer-file-name (memq major-mode source-modes))
1059 
+	 (cons (file-name-directory    buffer-file-name)
1060 
+	       (file-name-nondirectory buffer-file-name)))
1061 
+	(previous-dir/file)
1062 
+	(t
1063 
+	 (cons default-directory nil))))
1064 
+
1065 
+
1066 
+;;; (COMINT-CHECK-SOURCE fname)
1067 
+;;;============================================================================
1068 
+;;; Prior to loading or compiling (or otherwise processing) a file (in the CMU
1069 
+;;; process-in-a-buffer modes), this function can be called on the filename.
1070 
+;;; If the file is loaded into a buffer, and the buffer is modified, the user
1071 
+;;; is queried to see if he wants to save the buffer before proceeding with
1072 
+;;; the load or compile.
1073 
+
1074 
+(defun comint-check-source (fname)
1075 
+  (let ((buff (get-file-buffer fname)))
1076 
+    (if (and buff
1077 
+	     (buffer-modified-p buff)
1078 
+	     (y-or-n-p (format "Save buffer %s first? "
1079 
+			       (buffer-name buff))))
1080 
+	;; save BUFF.
1081 
+	(let ((old-buffer (current-buffer)))
1082 
+	  (set-buffer buff)
1083 
+	  (save-buffer)
1084 
+	  (set-buffer old-buffer)))))
1085 
+
1086 
+
1087 
+;;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p)
1088 
+;;;============================================================================
1089 
+;;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter
1090 
+;;; commands that process source files (like loading or compiling a file).
1091 
+;;; It prompts for the filename, provides a default, if there is one,
1092 
+;;; and returns the result filename.
1093 
+;;;
1094 
+;;; See COMINT-SOURCE-DEFAULT for more on determining defaults.
1095 
+;;;
1096 
+;;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair
1097 
+;;; from the last source processing command.  SOURCE-MODES is a list of major
1098 
+;;; modes used to determine what file buffers contain source files.  (These
1099 
+;;; two arguments are used for determining defaults). If MUSTMATCH-P is true,
1100 
+;;; then the filename reader will only accept a file that exists.
1101 
+;;;
1102 
+;;; A typical use:
1103 
+;;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file
1104 
+;;;                                 '(lisp-mode) t))
1105 
+
1106 
+;;; This is pretty stupid about strings. It decides we're in a string
1107 
+;;; if there's a quote on both sides of point on the current line.
1108 
+(defun comint-extract-string ()
1109 
+  "Returns string around point that starts the current line or nil."
1110 
+  (save-excursion
1111 
+    (let* ((point (point))
1112 
+	   (bol (progn (beginning-of-line) (point)))
1113 
+	   (eol (progn (end-of-line) (point)))
1114 
+	   (start (progn (goto-char point)
1115 
+			 (and (search-backward "\"" bol t)
1116 
+			      (1+ (point)))))
1117 
+	   (end (progn (goto-char point)
1118 
+		       (and (search-forward "\"" eol t)
1119 
+			    (1- (point))))))
1120 
+      (and start end
1121 
+	   (buffer-substring start end)))))
1122 
+
1123 
+(defun comint-get-source (prompt prev-dir/file source-modes mustmatch-p)
1124 
+  (let* ((def (comint-source-default prev-dir/file source-modes))
1125 
+         (stringfile (comint-extract-string))
1126 
+	 (sfile-p (and stringfile
1127 
+		       (file-exists-p stringfile)
1128 
+		       (not (file-directory-p stringfile))))
1129 
+	 (defdir  (if sfile-p (file-name-directory stringfile)
1130 
+                      (car def)))
1131 
+	 (deffile (if sfile-p (file-name-nondirectory stringfile)
1132 
+                      (cdr def)))
1133 
+	 (ans (read-file-name (if deffile (format "%s(default %s) "
1134 
+						  prompt    deffile)
1135 
+				  prompt)
1136 
+			      defdir
1137 
+			      (concat defdir deffile)
1138 
+			      mustmatch-p)))
1139 
+    (list (expand-file-name (substitute-in-file-name ans)))))
1140 
+
1141 
+;;; I am somewhat divided on this string-default feature. It seems
1142 
+;;; to violate the principle-of-least-astonishment, in that it makes
1143 
+;;; the default harder to predict, so you actually have to look and see
1144 
+;;; what the default really is before choosing it. This can trip you up.
1145 
+;;; On the other hand, it can be useful, I guess. I would appreciate feedback
1146 
+;;; on this.
1147 
+;;;     -Olin
1148 
+
1149 
+
1150 
+
1151 
+
1152 
+
1153 
+
1154 
+
1155 
+
1156 
+
1157 
+
1158 
+
1159 
+
1160 
+
1161 
+
1162 
+
1163 
+
1164 
+
1165 
+
1166 
+
1167 
+
1168 
+
1169 
+
1170 
+
1171 
+;;; Simple process query facility.
1172 
+;;; ===========================================================================
1173 
+;;; This function is for commands that want to send a query to the process
1174 
+;;; and show the response to the user. For example, a command to get the
1175 
+;;; arglist for a Common Lisp function might send a "(arglist 'foo)" query
1176 
+;;; to an inferior Common Lisp process.
1177 
+;;;
1178 
+;;; This simple facility just sends strings to the inferior process and pops
1179 
+;;; up a window for the process buffer so you can see what the process
1180 
+;;; responds with.  We don't do anything fancy like try to intercept what the
1181 
+;;; process responds with and put it in a pop-up window or on the message
1182 
+;;; line. We just display the buffer. Low tech. Simple. Works good.
1183 
+
1184 
+;;; Send to the inferior process PROC the string STR. Pop-up but do not select
1185 
+;;; a window for the inferior process so that its response can be seen.
1186 
+(defun comint-proc-query (proc str)
1187 
+  (let* ((proc-buf (process-buffer proc))
1188 
+	 (proc-mark (process-mark proc)))
1189 
+    (display-buffer proc-buf)
1190 
+    (set-buffer proc-buf) ; but it's not the selected *window*
1191 
+    (let ((proc-win (get-buffer-window proc-buf))
1192 
+	  (proc-pt (marker-position proc-mark)))
1193 
+      (comint-send-string proc str) ; send the query
1194 
+      (accept-process-output proc)  ; wait for some output
1195 
+      ;; Try to position the proc window so you can see the answer.
1196 
+      ;; This is bogus code. If you delete the (sit-for 0), it breaks.
1197 
+      ;; I don't know why. Wizards invited to improve it.
1198 
+      (if (not (pos-visible-in-window-p proc-pt proc-win))
1199 
+	  (let ((opoint (window-point proc-win)))
1200 
+	    (set-window-point proc-win proc-mark) (sit-for 0)
1201 
+	    (if (not (pos-visible-in-window-p opoint proc-win))
1202 
+		(push-mark opoint)
1203 
+		(set-window-point proc-win opoint)))))))
1204 
+
1205 
+
1206 
+
1207 
+
1208 
+
1209 
+
1210 
+
1211 
+
1212 
+
1213 
+
1214 
+
1215 
+;;; Filename completion in a buffer
1216 
+;;; ===========================================================================
1217 
+;;; Useful completion functions, courtesy of the Ergo group.
1218 
+;;; M-<Tab> will complete the filename at the cursor as much as possible
1219 
+;;; M-? will display a list of completions in the help buffer.
1220 
+
1221 
+;;; Three commands:
1222 
+;;; comint-dynamic-complete		Complete filename at point.
1223 
+;;; comint-dynamic-list-completions	List completions in help buffer.
1224 
+;;; comint-replace-by-expanded-filename	Expand and complete filename at point;
1225 
+;;;					replace with expanded/completed name.
1226 
+
1227 
+;;; These are not installed in the comint-mode keymap. But they are
1228 
+;;; available for people who want them. Shell-mode installs them:
1229 
+;;; (define-key cmushell-mode-map "\M-\t" 'comint-dynamic-complete)
1230 
+;;; (define-key cmushell-mode-map "\M-?"  'comint-dynamic-list-completions)))
1231 
+;;;
1232 
+;;; Commands like this are fine things to put in load hooks if you
1233 
+;;; want them present in specific modes. Example:
1234 
+;;; (setq cmushell-load-hook
1235 
+;;;       '((lambda () (define-key lisp-mode-map "\M-\t"
1236 
+;;;				   'comint-replace-by-expanded-filename))))
1237 
+;;;
1238 
+
1239 
+
1240 
+(defun comint-match-partial-pathname ()
1241 
+  "Returns the string of an existing filename or causes an error."
1242 
+  (if (save-excursion (backward-char 1) (looking-at "\\s ")) ""
1243 
+      (save-excursion
1244 
+	(re-search-backward "[^~/A-Za-z0-9---_.$#,]+")
1245 
+	(re-search-forward "[~/A-Za-z0-9---_.$#,]+")
1246 
+	(substitute-in-file-name
1247 
+	  (buffer-substring (match-beginning 0) (match-end 0))))))
1248 
+
1249 
+
1250 
+(defun comint-replace-by-expanded-filename ()
1251 
+"Replace the filename at point with an expanded, canonicalised, and
1252 
+completed replacement.
1253 
+\"Expanded\" means environment variables (e.g., $HOME) and ~'s are
1254 
+replaced with the corresponding directories.  \"Canonicalised\" means ..
1255 
+and \. are removed, and the filename is made absolute instead of relative.
1256 
+See functions expand-file-name and substitute-in-file-name. See also
1257 
+comint-dynamic-complete."
1258 
+  (interactive)
1259 
+  (let* ((pathname (comint-match-partial-pathname))
1260 
+	 (pathdir (file-name-directory pathname))
1261 
+	 (pathnondir (file-name-nondirectory pathname))
1262 
+	 (completion (file-name-completion pathnondir
1263 
+					   (or pathdir default-directory))))
1264 
+    (cond ((null completion)
1265 
+	   (message "No completions of %s." pathname)
1266 
+	   (ding))
1267 
+	  ((eql completion t)
1268 
+	   (message "Unique completion."))
1269 
+	  (t				; this means a string was returned.
1270 
+	   (delete-region (match-beginning 0) (match-end 0))
1271 
+	   (insert (expand-file-name (concat pathdir completion)))))))
1272 
+
1273 
+
1274 
+(defun comint-dynamic-complete ()
1275 
+  "Dynamically complete the filename at point.
1276 
+This function is similar to comint-replace-by-expanded-filename, except
1277 
+that it won't change parts of the filename already entered in the buffer;
1278 
+it just adds completion characters to the end of the filename."
1279 
+  (interactive)
1280 
+  (let* ((pathname (comint-match-partial-pathname))
1281 
+	 (pathdir (file-name-directory pathname))
1282 
+	 (pathnondir (file-name-nondirectory pathname))
1283 
+	 (completion (file-name-completion  pathnondir
1284 
+					   (or pathdir default-directory))))
1285 
+    (cond ((null completion)
1286 
+	   (message "No completions of %s." pathname)
1287 
+	   (ding))
1288 
+	  ((eql completion t)
1289 
+	   (message "Unique completion."))
1290 
+	  (t				; this means a string was returned.
1291 
+	   (goto-char (match-end 0))
1292 
+	   (insert (substring completion (length pathnondir)))))))
1293 
+
1294 
+(defun comint-dynamic-list-completions ()
1295 
+  "List in help buffer all possible completions of the filename at point."
1296 
+  (interactive)
1297 
+  (let* ((pathname (comint-match-partial-pathname))
1298 
+	 (pathdir (file-name-directory pathname))
1299 
+	 (pathnondir (file-name-nondirectory pathname))
1300 
+	 (completions
1301 
+	  (file-name-all-completions pathnondir
1302 
+				     (or pathdir default-directory))))
1303 
+    (cond ((null completions)
1304 
+	   (message "No completions of %s." pathname)
1305 
+	   (ding))
1306 
+	  (t
1307 
+	   (let ((conf (current-window-configuration)))
1308 
+	     (with-output-to-temp-buffer "*Help*"
1309 
+	       (display-completion-list completions))
1310 
+	     (sit-for 0)
1311 
+	     (message "Hit space to flush.")
1312 
+	     (let ((ch (read-char)))
1313 
+	       (if (= ch ?\ )
1314 
+		   (set-window-configuration conf)
1315 
+		   (setq unread-command-char ch))))))))
1316 
+
1317 
+; Ergo bindings
1318 
+; (global-set-key "\M-\t" 'comint-replace-by-expanded-filename)
1319 
+; (global-set-key "\M-?" 'comint-dynamic-list-completions)
1320 
+; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete)
1321 
+
1322 
+
1323 
+
1324 
+
1325 
+
1326 
+
1327 
+
1328 
+
1329 
+
1330 
+
1331 
+
1332 
+
1333 
+
1334 
+
1335 
+
1336 
+
1337 
+
1338 
+
1339 
+
1340 
+
1341 
+
1342 
+
1343 
+
1344 
+
1345 
+
1346 
+
1347 
+;;; Converting process modes to use comint mode
1348 
+;;; ===========================================================================
1349 
+;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog,
1350 
+;;; telnet are some) use the shell package as clients. Most of them would
1351 
+;;; be better off using the comint package, but they predate it.
1352 
+;;;
1353 
+;;; Altering these packages to use comint mode should greatly
1354 
+;;; improve their functionality, and is fairly easy.
1355 
+;;;
1356 
+;;; Renaming variables
1357 
+;;; Most of the work is renaming variables and functions. These are the common
1358 
+;;; ones:
1359 
+;;; Local variables:
1360 
+;;; 	last-input-end		comint-last-input-end
1361 
+;;;	last-input-start	<unnecessary>
1362 
+;;;	shell-prompt-pattern	comint-prompt-regexp
1363 
+;;;     shell-set-directory-error-hook <no equivalent>
1364 
+;;; Miscellaneous:
1365 
+;;;	shell-set-directory	<unnecessary>
1366 
+;;; 	shell-mode-map		comint-mode-map
1367 
+;;; Commands:
1368 
+;;;	shell-send-input	comint-send-input
1369 
+;;;	shell-send-eof		comint-delchar-or-maybe-eof
1370 
+;;; 	kill-shell-input	comint-kill-input
1371 
+;;;	interrupt-shell-subjob	comint-interrupt-subjob
1372 
+;;;	stop-shell-subjob	comint-stop-subjob
1373 
+;;;	quit-shell-subjob	comint-quit-subjob
1374 
+;;;	kill-shell-subjob	comint-kill-subjob
1375 
+;;;	kill-output-from-shell	comint-kill-output
1376 
+;;;	show-output-from-shell	comint-show-output
1377 
+;;;	copy-last-shell-input	Use comint-previous-input/comint-next-input
1378 
+;;;
1379 
+;;; LAST-INPUT-START is no longer necessary because inputs are stored on the
1380 
+;;; input history ring. SHELL-SET-DIRECTORY is gone, its functionality taken
1381 
+;;; over by SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-sentinel.
1382 
+;;; Comint mode does not provide functionality equivalent to
1383 
+;;; shell-set-directory-error-hook; it is gone.
1384 
+;;;
1385 
+;;; If you are implementing some process-in-a-buffer mode, called foo-mode, do
1386 
+;;; *not* create the comint-mode local variables in your foo-mode function.
1387 
+;;; This is not modular.  Instead, call comint-mode, and let *it* create the
1388 
+;;; necessary comint-specific local variables. Then create the
1389 
+;;; foo-mode-specific local variables in foo-mode.  Set the buffer's keymap to
1390 
+;;; be foo-mode-map, and its mode to be foo-mode.  Set the comint-mode hooks
1391 
+;;; (comint-prompt-regexp, comint-input-filter, comint-input-sentinel,
1392 
+;;; comint-get-old-input) that need to be different from the defaults.  Call
1393 
+;;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself;
1394 
+;;; comint-mode will take care of it. The following example, from cmushell.el,
1395 
+;;; is typical:
1396 
+;;;
1397 
+;;; (defun shell-mode ()
1398 
+;;;   (interactive)
1399 
+;;;   (comint-mode)
1400 
+;;;   (setq comint-prompt-regexp shell-prompt-pattern)
1401 
+;;;   (setq major-mode 'shell-mode)
1402 
+;;;   (setq mode-name "Shell")
1403 
+;;;   (cond ((not shell-mode-map)
1404 
+;;; 	     (setq shell-mode-map (full-copy-sparse-keymap comint-mode-map))
1405 
+;;; 	     (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete)
1406 
+;;; 	     (define-key shell-mode-map "\M-?"
1407 
+;;;                      'comint-dynamic-list-completions)))
1408 
+;;;   (use-local-map shell-mode-map)
1409 
+;;;   (make-local-variable 'shell-directory-stack)
1410 
+;;;   (setq shell-directory-stack nil)
1411 
+;;;   (setq comint-input-sentinel 'shell-directory-tracker)
1412 
+;;;   (run-hooks 'shell-mode-hook))
1413 
+;;;
1414 
+;;;
1415 
+;;; Note that make-comint is different from make-shell in that it
1416 
+;;; doesn't have a default program argument. If you give make-shell
1417 
+;;; a program name of NIL, it cleverly chooses one of explicit-shell-name,
1418 
+;;; $ESHELL, $SHELL, or /bin/sh. If you give make-comint a program argument
1419 
+;;; of NIL, it barfs. Adjust your code accordingly...
1420 
+;;;
1421 
+
1422 
+
1423 
+
1424 
+
1425 
+
1426 
+
1427 
+
1428 
+
1429 
+
1430 
+
1431 
+
1432 
+
1433 
+
1434 
+
1435 
+;;; Do the user's customisation...
1436 
+
1437 
+(defvar comint-load-hook nil
1438 
+  "This hook is run when comint is loaded in.
1439 
+This is a good place to put keybindings.")
1440 
+
1441 
+(run-hooks 'comint-load-hook)
1442 
+
1443 
+;;; Change log:
1444 
+;;; 9/12/89
1445 
+;;;  - Souped up the filename expansion procedures.
1446 
+;;;    Doc strings are much clearer and more detailed.
1447 
+;;;    Fixed a bug where doing a filename completion when the point
1448 
+;;;    was in the middle of the filename instead of at the end would lose.
1449 
+;;;
1450 
+;;; 2/17/90
1451 
+;;;  - Souped up the command history stuff so that text inserted
1452 
+;;;    by comint-previous-input-matching is removed by following
1453 
+;;;    command history recalls. comint-next/previous-input-matching
1454 
+;;;    is now much more smoothly integrated w/the command history stuff.
1455 
+;;;  - Added comint-eol-on-send flag and comint-input-sender hook.
1456 
+;;;    Comint-input-sender based on code contributed by Jeff Peck
1457 
+;;;    (peck@sun.com).
1458 
+;;;
1459 
+;;; 3/13/90 ccm@cmu.cs.edu
1460 
+;;;  - Added comint-previous-similar-input for looking up similar inputs.
1461 
+;;;  - Added comint-send-and-get-output to allow snarfing input from
1462 
+;;;    buffer.
1463 
+;;;  - Added the ability to pick up a source file by positioning over
1464 
+;;;    a string in comint-get-source.
1465 
+;;;  - Added add-hook to make it a little easier for the user to use
1466 
+;;;    multiple hooks.
1467 
+;;;
1468 
+;;; 5/22/90 shivers
1469 
+;;; - Moved Chris' multiplexed ipc stuff to comint-ipc.el.
1470 
+;;; - Altered Chris' comint-get-source string feature. The string
1471 
+;;;   is only offered as a default if it names an existing file.
1472 
+;;; - Changed comint-exec to directly crank up the process, instead
1473 
+;;;   of calling the env program. This made background.el happy.
1474 
+;;; - Added new buffer-local var comint-ptyp. The problem is that
1475 
+;;;   the signalling functions don't work as advertised. If you are
1476 
+;;;   communicating via pipes, the CURRENT-GROUP arg is supposed to
1477 
+;;;   be ignored, but, unfortunately it seems to be the case that you
1478 
+;;;   must pass a NIL for this arg in the pipe case. COMINT-PTYP
1479 
+;;;   is a flag that tells whether the process is communicating
1480 
+;;;   via pipes or a pty. The comint signalling functions use it
1481 
+;;;   to determine the necessary CURRENT-GROUP arg value. The bug
1482 
+;;;   has been reported to the Gnu folks.
1483 
+;;; - comint-dynamic-complete flushes the help window if you hit space
1484 
+;;;   after you execute it.
1485 
+;;; - Added functions comint-send-string, comint-send-region and var
1486 
+;;;   comint-input-chunk-size.  comint-send-string tries to prevent processes
1487 
+;;;   from hanging when you send them long strings by breaking them into
1488 
+;;;   chunks and allowing process output between chunks. I got the idea from
1489 
+;;;   Eero Simoncelli's Common Lisp package. Note that using
1490 
+;;;   comint-send-string means that the process buffer's contents can change
1491 
+;;;   during a call!  If you depend on process output only happening between
1492 
+;;;   toplevel commands, this could be a problem. In such a case, use
1493 
+;;;   process-send-string instead. If this is a problem for people, I'd like
1494 
+;;;   to hear about it.
1495 
+;;; - Added comint-proc-query as a simple mechanism for commands that
1496 
+;;;   want to query an inferior process and display its response. For a
1497 
+;;;   typical use, see lisp-show-arglist in cmulisp.el.
1498 
+;;; - Added constant comint-version, which is now "2.01".
1499 
+;;;
1500 
+;;; 6/14/90 shivers
1501 
+;;; - Had comint-update-env defined twice. Removed extra copy. Also
1502 
+;;;   renamed mem to be comint-mem, for modularity. The duplication
1503 
+;;;   was reported by Michael Meissner.
1504 
+;;; 6/16/90 shivers
1505 
+;;; - Emacs has two different mechanisms for maintaining the process
1506 
+;;;   environment, determined at compile time by the MAINTAIN-ENVIRONMENT
1507 
+;;;   #define. One uses the process-environment global variable, and
1508 
+;;;   one uses a getenv/setenv interface. comint-exec assumed the
1509 
+;;;   process-environment interface; it has been generalised (with
1510 
+;;;   comint-exec-1) to handle both cases. Pretty bogus. We could,
1511 
+;;;   of course, skip all this and just use the etc/env program to
1512 
+;;;   handle the environment tweaking, but that obscures process
1513 
+;;;   queries that other modules (like background.el) depend on. etc/env
1514 
+;;;   is also fairly bogus. This bug, and some of the fix code was
1515 
+;;;   reported by Dan Pierson.
1516 
+;;;
1517 
+;;; 9/5/90 shivers
1518 
+;;; - Changed make-variable-buffer-local's to make-local-variable's.
1519 
+;;;   This leaves non-comint-mode buffers alone. Stephane Payrard
1520 
+;;;   reported the sloppy useage.
1521 
+;;; - You can now go from comint-previous-similar-input to
1522 
+;;;   comint-previous-input with no problem.
1523 
+
1524 
+
emacs-tools/comint.elc
History View file @ 4e98702
0 1525 
new file mode 100644
1 1526 
Binary files /dev/null and b/emacs-tools/comint.elc differ
emacs-tools/haskell.el
History View file @ 4e98702
2 1527 
new file mode 100644
... ... 
@@ -0,0 +1,2198 @@
1 
+;;; ==================================================================
2 
+;;; File: 		haskell.el     				   ;;;
3 
+;;;                                                                ;;;
4 
+;;;			Author: 	A. Satish Pai		   ;;;
5 
+;;;                                     Maria M. Gutierrez         ;;;
6 
+;;;                                     Dan Rabin (Jul-1991)       ;;;
7 
+;;; ==================================================================
8 
+
9 
+;;; Description: Haskell mode for GNU Emacs.
10 
+
11 
+;;; Related files:  comint.el
12 
+
13 
+;;; Contents:
14 
+
15 
+;;;  Update Log
16 
+
17 
+;;;  Known bugs / problems
18 
+;;;  - the haskell editing mode (indentation, etc) is still missing.
19 
+;;;  - the handling for errors from haskell needs to be rethought.
20 
+;;;  - general cleanup of code.
21 
+
22 
+
23 
+;;;  Errors generated
24 
+
25 
+;;; ==================================================================
26 
+;;; Haskell mode for editing files, and an Inferior Haskell mode to
27 
+;;; run a Haskell process. This file contains stuff snarfed and
28 
+;;; modified from tea.el, scheme.el, etc. This file may be freely
29 
+;;; modified; however, if you have any bug-corrections or useful
30 
+;;; improvements, I'd appreciate it if you sent me the mods so that
31 
+;;; I can merge them into the version I maintain.
32 
+;;;
33 
+;;; The inferior Haskell mode requires comint.el.
34 
+;;;
35 
+;;; You might want to add this to your .emacs to go automagically
36 
+;;; into Haskell mode while finding .hs files.
37 
+;;;
38 
+;;;   (setq auto-mode-alist
39 
+;;;         (cons '("\\.hs$" . haskell-mode)
40 
+;;;                auto-mode-alist)_)
41 
+;;;
42 
+;;; To use this file, set up your .emacs to autoload this file for
43 
+;;; haskell-mode. For example:
44 
+;;;
45 
+;;;    (autoload 'haskell-mode "$HASKELL/emacs-tools/haskell.elc"
46 
+;;;       "Load Haskell mode" t)
47 
+;;;
48 
+;;;    (autoload 'run-mode "$HASKELL/emacs-tools/haskell.elc"
49 
+;;;       "Load Haskell mode" t)
50 
+;;;
51 
+;;; [Note: The path name given above is Yale specific!! Modify as
52 
+;;; required.]
53 
+;;; ================================================================
54 
+
55 
+;;; Announce your existence to the world at large.
56 
+
57 
+(provide 'haskell)
58 
+
59 
+
60 
+;;; Load these other files.
61 
+
62 
+(require 'comint)        ; Olin Shivers' comint mode is the substratum
63 
+
64 
+
65 
+
66 
+
67 
+;;; ================================================================
68 
+;;; Declare a bunch of variables.
69 
+;;; ================================================================
70 
+
71 
+
72 
+;;; User settable (via M-x set-variable and M-x edit-options)
73 
+
74 
+(defvar haskell-program-name (getenv "HASKELLPROG")
75 
+  "*Program invoked by the haskell command")
76 
+
77 
+(defvar *haskell-buffer* "*haskell*"
78 
+  "*Name of the haskell process buffer")
79 
+
80 
+(defvar *haskell-show-error* 1
81 
+  "*If not nil move to the buffer where the error was found")
82 
+
83 
+
84 
+(defvar haskell-auto-create-process t
85 
+  "*If not nil, create a Haskell process automatically when required to evaluate or compile Haskell code")
86 
+
87 
+(defvar *haskell-debug-in-lisp* nil
88 
+  "*If not nil, enter Lisp debugger on error; otherwise, automagically return
89 
+to Haskell top-level.")
90 
+
91 
+
92 
+;;; Command interface related variables
93 
+
94 
+(defvar *emacs* nil
95 
+  "When not nil means haskell is in emacs mode")
96 
+
97 
+
98 
+;;; Pad/buffer Initialization variables
99 
+
100 
+(defvar haskell-main-pad "\*Main-pad\*"
101 
+  "Scratch pad associated with module Main")
102 
+
103 
+(defvar haskell-main-file "Main")
104 
+
105 
+(defvar haskell-main-module "Main")
106 
+
107 
+
108 
+(defvar *last-loaded* haskell-main-file
109 
+  "Last file loaded with a :load command - Defaults to Main")
110 
+
111 
+(defvar *last-loaded-modtime* nil
112 
+  "Modification time of last file loaded, used to determine whether it
113 
+needs to be reloaded.")
114 
+
115 
+(defvar *last-module* haskell-main-module
116 
+  "Last module set with a :module command - Defaults to Main")
117 
+
118 
+(defvar *last-pad* haskell-main-pad
119 
+  "Last pad saved with a :save command - Defaults to Main")
120 
+
121 
+
122 
+;;; These are used for haskell-tutorial mode.
123 
+
124 
+(defvar *ht-source-file* "$HASKELL/progs/tutorial/tutorial.hs")
125 
+(defvar *ht-temp-buffer* nil)
126 
+(defvar *ht-file-buffer* "Haskell-Tutorial-Master")
127 
+
128 
+
129 
+
130 
+;;; ================================================================
131 
+;;; Haskell editing mode stuff
132 
+;;; ================================================================
133 
+
134 
+;;; Leave this place alone...
135 
+;;; The definitions below have been pared down to the bare
136 
+;;; minimum; they will be restored later.
137 
+;;;
138 
+;;; -Satish 2/5.
139 
+
140 
+;;; Keymap for Haskell mode
141 
+(defvar haskell-mode-map nil
142 
+  "Keymap used for haskell-mode")
143 
+
144 
+(defun haskell-establish-key-bindings (keymap)
145 
+  (define-key keymap "\C-ce"    'haskell-eval)
146 
+  (define-key keymap "\C-cr"    'haskell-run)
147 
+  (define-key keymap "\C-cm"    'haskell-run-main)
148 
+  (define-key keymap "\C-c\C-r" 'haskell-run-file)
149 
+  (define-key keymap "\C-cp"    'haskell-get-pad)
150 
+  (define-key keymap "\C-c\C-o" 'haskell-optimizers)
151 
+  (define-key keymap "\C-c\C-p" 'haskell-printers)
152 
+  (define-key keymap "\C-cc"    'haskell-compile)
153 
+  (define-key keymap "\C-cl"    'haskell-load)
154 
+  (define-key keymap "\C-ch"    'haskell-switch)
155 
+  (define-key keymap "\C-c:"    'haskell-command)
156 
+  (define-key keymap "\C-cq"    'haskell-exit)
157 
+  (define-key keymap "\C-ci"    'haskell-interrupt)
158 
+  (define-key keymap "\C-cu"    'haskell-edit-unit)
159 
+  (define-key keymap "\C-cd"    'haskell-please-recover)
160 
+  (define-key keymap "\C-c("    'haskell-ensure-lisp-mode)
161 
+  (define-key keymap "\C-c)"    'haskell-resume-command-loop))
162 
+
163 
+
164 
+(if haskell-mode-map
165 
+    nil
166 
+    (progn
167 
+      (setq haskell-mode-map (make-sparse-keymap))
168 
+      ;; Compiler commands
169 
+      (haskell-establish-key-bindings haskell-mode-map)
170 
+      ))
171 
+
172 
+(defvar haskell-mode-syntax-table nil
173 
+  "Syntax table used for haskell-mode")
174 
+
175 
+(if haskell-mode-syntax-table
176 
+    nil
177 
+    (setq haskell-mode-syntax-table (standard-syntax-table)))
178 
+
179 
+;;; Command for invoking the Haskell mode
180 
+(defun haskell-mode nil
181 
+  "Major mode for editing Haskell code to run in Emacs
182 
+The following commands are available:
183 
+\\{haskell-mode-map}
184 
+
185 
+A Haskell process can be fired up with \"M-x haskell\".
186 
+
187 
+Customization: Entry to this mode runs the hooks that are the value of variable
188 
+haskell-mode-hook.
189 
+
190 
+Windows:
191 
+
192 
+There are 3 types of windows associated with Haskell mode.  They are:
193 
+   *haskell*:  which is the process window.
194 
+   Pad:        which are buffers available for each module.  It is here
195 
+               where you want to test things before preserving them in a
196 
+               file.  Pads are always associated with a module.
197 
+               When issuing a command:
198 
+                 The pad and its associated module are sent to the Haskell
199 
+                 process prior to the execution of the command.
200 
+   .hs:        These are the files where Haskell programs live.  They
201 
+               have .hs as extension.
202 
+               When issuing a command:
203 
+                 The file is sent to the Haskell process prior to the
204 
+                 execution of the command.
205 
+
206 
+Commands:
207 
+
208 
+Each command behaves differently according to the type of the window in which
209 
+the cursor is positioned when the command is issued .
210 
+
211 
+haskell-eval:   \\[haskell-eval]
212 
+  Always promts user for a Haskell expression to be evaluated.  If in a
213 
+  .hs file buffer, then the cursor tells which module is the current
214 
+  module and the pad for that module (if any) gets loaded as well.
215 
+
216 
+haskell-run:    \\[haskell-run]
217 
+  Always queries for a variable of type Dialogue to be evaluated.
218 
+
219 
+haskell-run-main:    \\[haskell-run-main]
220 
+  Run Dialogue named main.
221 
+
222 
+haskell-run-file:   \\[haskell-run-file]
223 
+  Runs a file.  Ideally the file has a set of variable of type Dialogue
224 
+  that get evaluated.
225 
+
226 
+haskell-mode:   \\[haskell-mode]
227 
+  Puts the current buffer in haskell mode.
228 
+
229 
+haskell-compile:   \\[haskell-compile]
230 
+  Compiles file in current buffer.
231 
+
232 
+haskell-load:   \\[haskell-load]
233 
+  Loads file in current buffer.
234 
+
235 
+haskell-pad:   \\[haskell-pad]
236 
+  Creates a scratch pad for the current module.
237 
+
238 
+haskell-optimizers:  \\[haskell-optimizers]
239 
+  Shows the list of available optimizers.  Commands for turning them on/off.
240 
+
241 
+haskell-printers:  \\[haskell-printers]
242 
+  Shows the list of available printers.  Commands for turning them on/off.
243 
+
244 
+haskell-command:   \\[haskell-command]
245 
+  Prompts for a command to be sent to the command interface.  You don't
246 
+  need to put the : before the command.
247 
+
248 
+haskell-quit:   \\[haskell-quit]
249 
+  Terminates the haskell process.
250 
+
251 
+switch-to-haskell:   \\[switch-to-haskell]
252 
+  Switchs to the inferior Haskell buffer (*haskell*) and positions the
253 
+  cursor at the end of the buffer.
254 
+
255 
+haskell-interrupt:   \\[haskell-interrupt]
256 
+  Interrupts haskell process and resets it.
257 
+
258 
+haskell-edit-unit:   \\[haskell-edit-unit]
259 
+  Edit the .hu file for the unit containing this file.
260 
+"
261 
+  (interactive)
262 
+  (kill-all-local-variables)
263 
+  (use-local-map haskell-mode-map)
264 
+  (setq major-mode 'haskell-mode)
265 
+  (setq mode-name "Haskell")
266 
+  (make-local-variable 'indent-line-function)
267 
+  (setq indent-line-function 'indent-relative-maybe)
268 
+  ;(setq local-abbrev-table haskell-mode-abbrev-table)
269 
+  (set-syntax-table haskell-mode-syntax-table)
270 
+  ;(setq tab-stop-list haskell-tab-stop-list) ;; save old list??
271 
+  (run-hooks 'haskell-mode-hook))
272 
+
273 
+
274 
+
275 
+;;;================================================================
276 
+;;; Inferior Haskell stuff
277 
+;;;================================================================
278 
+
279 
+
280 
+(defvar inferior-haskell-mode-map nil)
281 
+
282 
+(if inferior-haskell-mode-map
283 
+    nil
284 
+  (setq inferior-haskell-mode-map
285 
+	(full-copy-sparse-keymap comint-mode-map))
286 
+  ;;; Haskell commands
287 
+  (haskell-establish-key-bindings inferior-haskell-mode-map)
288 
+  (define-key inferior-haskell-mode-map "\C-m"     'haskell-send-input))
289 
+
290 
+(defvar haskell-source-modes '(haskell-mode)
291 
+  "*Used to determine if a buffer contains Haskell source code.
292 
+If it's loaded into a buffer that is in one of these major modes,
293 
+it's considered a Haskell source file.")
294 
+
295 
+(defvar haskell-prev-l/c-dir/file nil
296 
+  "Caches the (directory . file) pair used in the last invocation of
297 
+haskell-run-file.")
298 
+
299 
+(defvar haskell-prompt-pattern "^[A-Z]\\([A-Z]\\|[a-z]\\|[0-9]\\)*>\\s-*"
300 
+  "Regular expression capturing the Haskell system prompt.")
301 
+
302 
+(defvar haskell-prompt-ring ()
303 
+  "Keeps track of input to haskell process from the minibuffer")
304 
+
305 
+(defvar tea-prompt-pattern "^>+\\s-*"
306 
+   "Regular expression capturing the T system prompt.")
307 
+
308 
+(defvar haskell-version "Yale University Haskell Version 0.8, 1991"
309 
+  "Current Haskell system version")
310 
+
311 
+(defun inferior-haskell-mode-variables ()
312 
+  nil)
313 
+
314 
+
315 
+;;; INFERIOR-HASKELL-MODE (adapted from comint.el)
316 
+
317 
+(defun inferior-haskell-mode ()
318 
+  "Major mode for interacting with an inferior Haskell process.
319 
+
320 
+The following commands are available:
321 
+\\{inferior-haskell-mode-map}
322 
+
323 
+A Haskell process can be fired up with \"M-x haskell\".
324 
+
325 
+Customization: Entry to this mode runs the hooks on comint-mode-hook and
326 
+inferior-haskell-mode-hook (in that order).
327 
+
328 
+You can send text to the inferior Haskell process from other buffers containing
329 
+Haskell source.
330 
+
331 
+
332 
+Windows:
333 
+
334 
+There are 3 types of windows in the inferior-haskell-mode.  They are:
335 
+   *haskell*:  which is the process window.
336 
+   Pad:        which are buffers available for each module.  It is here
337 
+               where you want to test things before preserving them in a
338 
+               file.  Pads are always associated with a module.
339 
+               When issuing a command:
340 
+                 The pad and its associated module are sent to the Haskell
341 
+                 process prior to the execution of the command.
342 
+   .hs:        These are the files where Haskell programs live.  They
343 
+               have .hs as extension.
344 
+               When issuing a command:
345 
+                 The file is sent to the Haskell process prior to the
346 
+                 execution of the command.
347 
+
348 
+Commands:
349 
+
350 
+Each command behaves differently according to the type of the window in which
351 
+the cursor is positioned when the command is issued.
352 
+
353 
+haskell-eval:   \\[haskell-eval]
354 
+  Always promts user for a Haskell expression to be evaluated.  If in a
355 
+  .hs file, then the cursor tells which module is the current module and
356 
+  the pad for that module (if any) gets loaded as well.
357 
+
358 
+haskell-run:    \\[haskell-run]
359 
+  Always queries for a variable of type Dialogue to be evaluated.
360 
+
361 
+haskell-run-main:    \\[haskell-run-main]
362 
+  Run Dialogue named main.
363 
+
364 
+haskell-run-file:   \\[haskell-run-file]
365 
+  Runs a file.  Ideally the file has a set of variable of type Dialogue
366 
+  that get evaluated.
367 
+
368 
+haskell-mode:   \\[haskell-mode]
369 
+  Puts the current buffer in haskell mode.
370 
+
371 
+haskell-compile:   \\[haskell-compile]
372 
+  Compiles file in current buffer.
373 
+
374 
+haskell-load:   \\[haskell-load]
375 
+  Loads file in current buffer.
376 
+
377 
+haskell-pad:   \\[haskell-pad]
378 
+  Creates a scratch pad for the current module.
379 
+
380 
+haskell-optimizers:  \\[haskell-optimizers]
381 
+  Shows the list of available optimizers.  Commands for turning them on/off.
382 
+
383 
+haskell-printers:  \\[haskell-printers]
384 
+  Shows the list of available printers.  Commands for turning them on/off.
385 
+
386 
+haskell-command:   \\[haskell-command]
387 
+  Prompts for a command to be sent to the command interface.  You don't
388 
+  need to put the : before the command.
389 
+
390 
+haskell-quit:   \\[haskell-quit]
391 
+  Terminates the haskell process.
392 
+
393 
+switch-to-haskell:   \\[switch-to-haskell]
394 
+  Switchs to the inferior Haskell buffer (*haskell*) and positions the
395 
+  cursor at the end of the buffer.
396 
+
397 
+haskell-interrupt:   \\[haskell-interrupt]
398 
+  Interrupts haskell process and resets it.
399 
+
400 
+haskell-edit-unit:   \\[haskell-edit-unit]
401 
+  Edit the .hu file for the unit containing this file.
402 
+
403 
+The usual comint functions are also available. In particular, the
404 
+following are all available:
405 
+
406 
+comint-bol: Beginning of line, but skip prompt. Bound to C-a by default.
407 
+comint-delchar-or-maybe-eof: Delete char, unless at end of buffer, in
408 
+            which case send EOF to process. Bound to C-d by default.
409 
+
410 
+Note however, that the default keymap bindings provided shadow some of
411 
+the default comint mode bindings, so that you may want to bind them
412 
+to your choice of keys.
413 
+
414 
+Comint mode's dynamic completion of filenames in the buffer is available.
415 
+(Q.v. comint-dynamic-complete, comint-dynamic-list-completions.)
416 
+
417 
+If you accidentally suspend your process, use \\[comint-continue-subjob]
418 
+to continue it."
419 
+
420 
+  (interactive)
421 
+  (comint-mode)
422 
+  (setq comint-prompt-regexp haskell-prompt-pattern)
423 
+  ;; Customise in inferior-haskell-mode-hook
424 
+  (inferior-haskell-mode-variables)
425 
+  (setq major-mode 'inferior-haskell-mode)
426 
+  (setq mode-name "Inferior Haskell")
427 
+  (setq mode-line-process '(": %s : busy"))
428 
+  (use-local-map inferior-haskell-mode-map)
429 
+  (setq comint-input-filter 'haskell-input-filter)
430 
+  (setq comint-input-sentinel 'ignore)
431 
+  (setq comint-get-old-input 'haskell-get-old-input)
432 
+  (run-hooks 'inferior-haskell-mode-hook)
433 
+    ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook.
434 
+    ;The test is so we don't lose history if we run comint-mode twice in
435 
+    ;a buffer.
436 
+  (setq haskell-prompt-ring (make-ring input-ring-size)))
437 
+
438 
+
439 
+;;; Install the process communication commands in the
440 
+;;; inferior-haskell-mode keymap.
441 
+
442 
+(defvar inferior-haskell-mode-hook 'haskell-fresh-start
443 
+  "*Hook for customizing inferior-Haskell mode")
444 
+
445 
+(defun haskell-input-filter (str)
446 
+  "Don't save whitespace."
447 
+  (not (string-match "\\s *" str)))
448 
+
449 
+
450 
+
451 
+;;; ==================================================================
452 
+;;; Handle output from Haskell process
453 
+;;; ==================================================================
454 
+
455 
+
456 
+;;; This keeps track of the status of the haskell process.
457 
+;;; Values are:
458 
+;;; busy -- The process is busy.
459 
+;;; ready -- The process is ready for a command.
460 
+;;; input -- The process is waiting for input.
461 
+;;; dead -- The process is dead (exited or not started yet).
462 
+
463 
+
464 
+(defvar *haskell-status* 'dead
465 
+  "Status of the haskell process")
466 
+
467 
+(defun set-haskell-status (value)
468 
+  (setq *haskell-status* value)
469 
+  (update-mode-line))
470 
+
471 
+(defun get-haskell-status ()
472 
+  *haskell-status*)
473 
+
474 
+(defun update-mode-line ()
475 
+  (save-excursion
476 
+    (set-buffer *haskell-buffer*)
477 
+    (cond ((eq *haskell-status* 'ready)
478 
+	   (setq mode-line-process '(": %s: ready")))
479 
+	  ((eq *haskell-status* 'input)
480 
+	   (setq mode-line-process '(": %s: input")))
481 
+	  ((eq *haskell-status* 'busy)
482 
+	   (setq mode-line-process '(": %s: busy")))
483 
+	  ((eq *haskell-status* 'dead)
484 
+	   (setq mode-line-process '(": %s: dead")))
485 
+	  (t
486 
+	   (haskell-mode-error "Confused about status of haskell process!")))
487 
+    ;; Yes, this is the officially sanctioned technique for forcing
488 
+    ;; a redisplay of the mode line.
489 
+    (set-buffer-modified-p (buffer-modified-p))))
490 
+
491 
+
492 
+;;; Filter
493 
+;;; The haskell process produces output with embedded control codes.
494 
+;;; These control codes are used to keep track of what kind of input
495 
+;;; the haskell process is expecting.  Ordinary output is just displayed.
496 
+;;;
497 
+;;; This is kind of complicated because control sequences can be broken
498 
+;;; across multiple batches of text received from the haskell process.
499 
+;;; If the string ends in the middle of a control sequence, save it up
500 
+;;; for the next call.
501 
+
502 
+(defvar *haskell-saved-output* nil)
503 
+
504 
+(defun process-haskell-output (process str)
505 
+  "Filter for output from Yale Haskell command interface"
506 
+  (let ((idx     0)
507 
+	(lastidx 0)
508 
+	(data    (match-data)))
509 
+    (unwind-protect
510 
+	(progn
511 
+	  ;; If there was saved output from last time, glue it in front of the
512 
+	  ;; newly received input.
513 
+	  (if *haskell-saved-output*
514 
+	      (progn
515 
+		(setq str (concat *haskell-saved-output* str))
516 
+		(setq *haskell-saved-output* nil)))
517 
+	  ;; Loop, looking for complete command sequences.
518 
+	  ;; Set idx to point to the first one.
519 
+	  ;; lastidx points to next character to be processed.
520 
+	  (while (setq idx (ci-response-start str lastidx))
521 
+	    ;; Display any intervening ordinary text.
522 
+	    (if (not (eq idx lastidx))
523 
+		(haskell-display-output (substring str lastidx idx)))
524 
+	    ;; Now dispatch on the particular command sequence found.
525 
+	    ;; Handler functions are called with the string and start index
526 
+	    ;; as arguments, and should return the index of the "next"
527 
+	    ;; character -- usually (match-end 0).
528 
+	    (setq lastidx (funcall (ci-response-handler str idx) str idx)))
529 
+	  ;; Look to see whether the string ends with an incomplete
530 
+	  ;; command sequence.
531 
+	  ;; If so, save the tail of the string for next time.
532 
+	  (if (setq idx (ci-prefix-start str lastidx))
533 
+	      (setq *haskell-saved-output* (substring str idx))
534 
+	      (setq idx (length str)))
535 
+	  ;; Display any leftover ordinary text.
536 
+	  (if (not (eq idx lastidx))
537 
+	      (haskell-display-output (substring str lastidx idx))))
538 
+      (store-match-data data))))
539 
+
540 
+
541 
+
542 
+;;; Here is code for matching command sequences from haskell.
543 
+
544 
+;;; The first entry of each item is the full regexp; the second is a prefix
545 
+;;; regexp; the third is a handler function to call.
546 
+
547 
+(defvar *ci-responses*
548 
+  '(("\C-Ar"          "\C-A"            haskell-got-ready)
549 
+    ("\C-Ai"          "\C-A"            haskell-got-input-request)
550 
+    ("\C-Ae"          "\C-A"            haskell-got-error)
551 
+    ("\C-Ap.*\n"      "\C-A\\(p.*\\)?"  haskell-got-printers)
552 
+    ("\C-Ao.*\n"      "\C-A\\(o.*\\)?"  haskell-got-optimizers)
553 
+    ("\C-As.*\n"      "\C-A\\(s.*\\)?"  haskell-got-message)
554 
+    ;; This is the error string for T
555 
+;    ("^\\*\\* Error"
556 
+;     "^\\*\\(\\*\\( \\(E\\(r\\(r\\(or?\\)?\\)?\\)?\\)?\\)?\\)?"
557 
+;     haskell-got-lisp-error)
558 
+    ;; This is the prompt for Lucid's break loop
559 
+    ("\n-> "    "\n\\(-\\(> ?\\)?\\)?" haskell-got-lisp-error)
560 
+    ;; This is the prompt for CMU CL's break loop
561 
+    ("0\\] "    "0\\(\\] ?\\)?" haskell-got-lisp-error)
562 
+    ;; This is the prompt for AKCL's break loop
563 
+    ("USER>>" "U\\(S\\(E\\(R\\(>>?\\)?\\)?\\)?\\)?" haskell-got-lisp-error)
564 
+    ;; This is the prompt for Allegro CL
565 
+    ("USER(.*):" "U\\(S\\(E\\(R\\((.*)?\\)?\\)?\\)?\\)?" haskell-got-lisp-error)
566 
+    ;; This is the prompt for Harlequin Lispworks
567 
+    ("USER .* : .* >" "U\\(S\\(E\\(R\\( .*\\( \\(:\\( .*\\( >?\\)?\\)?\\)?\\)?\\)?\\)?\\)?\\)?" haskell-got-lisp-error)
568 
+    ))
569 
+
570 
+(defun command-match-regexp (x) (car x))
571 
+(defun command-prefix-regexp (x) (car (cdr x)))
572 
+(defun command-handler (x) (car (cdr (cdr x))))
573 
+
574 
+(defun glue-together (extractor)
575 
+  (let ((result (concat "\\(" (funcall extractor (car *ci-responses*)) "\\)"))
576 
+	(stuff  (cdr *ci-responses*)))
577 
+    (while stuff
578 
+      (setq result
579 
+	    (concat result "\\|\\(" (funcall extractor (car stuff)) "\\)"))
580 
+      (setq stuff (cdr stuff)))
581 
+    result))
582 
+
583 
+(defvar *ci-response-regexp* (glue-together 'command-match-regexp))
584 
+
585 
+(defvar *ci-prefix-regexp*
586 
+  (concat "\\(" (glue-together 'command-prefix-regexp) "\\)\\'"))
587 
+
588 
+(defun ci-response-start (str idx)
589 
+  (string-match *ci-response-regexp* str idx))
590 
+
591 
+(defun ci-prefix-start (str idx)
592 
+  (string-match *ci-prefix-regexp* str idx))
593 
+
594 
+(defun ci-response-handler (str idx)
595 
+  (let ((list    *ci-responses*)
596 
+	(result  nil))
597 
+    (while (and list (null result))
598 
+      (if (eq (string-match (command-match-regexp (car list)) str idx) idx)
599 
+	  (setq result (command-handler (car list)))
600 
+	  (setq list (cdr list))))
601 
+    (if (null result)
602 
+	(haskell-mode-error "Failed to find command handler!!!"))
603 
+    result))
604 
+
605 
+
606 
+;;; Here are the low-level handler functions.  Basically, these
607 
+;;; guys just parse the input for the command sequence and then call some
608 
+;;; other function to do the real work.
609 
+
610 
+(defun haskell-got-ready (str idx)
611 
+  (let ((result  (match-end 0)))
612 
+    (haskell-reset)
613 
+    result))
614 
+
615 
+(defun haskell-got-input-request (str idx)
616 
+  (let ((result  (match-end 0)))
617 
+    (get-user-input)
618 
+    result))
619 
+
620 
+(defun haskell-got-error (str idx)
621 
+  (let ((result  (match-end 0)))
622 
+    (haskell-error-handler)
623 
+    result))
624 
+
625 
+(defun haskell-got-printers (str idx)
626 
+  (let ((result  (match-end 0)))
627 
+    (update-printers-list (substring str (+ idx 2) (- result 1)))
628 
+    result))
629 
+
630 
+(defun haskell-got-optimizers (str idx)
631 
+  (let ((result  (match-end 0)))
632 
+    (update-optimizers-list (substring str (+ idx 2) (- result 1)))
633 
+    result))
634 
+
635 
+(defun haskell-got-message (str idx)
636 
+  (let ((result  (match-end 0)))
637 
+    (message (substring str (+ idx 2) (- result 1)))
638 
+    result))
639 
+
640 
+(defun haskell-got-lisp-error (str idx)
641 
+  (haskell-handle-lisp-error idx str)
642 
+  (length str))
643 
+
644 
+
645 
+;;; Something really bad happened and we got a Lisp error.
646 
+;;; Either let the user mess around in the Lisp debugger, or else
647 
+;;; just get out of it and go back into the Haskell command loop.
648 
+
649 
+(defun haskell-handle-lisp-error (location str)
650 
+  (haskell-display-output (substring str location))
651 
+  (if *emacs*
652 
+      ;; Don't ding if we were already in the break loop when the
653 
+      ;; error happened.
654 
+      (progn
655 
+	(ding)
656 
+	(if *haskell-debug-in-lisp*
657 
+	    (haskell-talk-to-lisp)
658 
+	    (haskell-flush-commands-and-reset)))))
659 
+
660 
+(defun loaded-tutorial-p ()
661 
+  (and *ht-temp-buffer*
662 
+       (get-buffer *ht-temp-buffer*)
663 
+       (equal *last-loaded* (buffer-file-name (get-buffer *ht-temp-buffer*)))))
664 
+
665 
+(defun haskell-flush-commands-and-reset ()
666 
+  (haskell-flush-command-queue)
667 
+  (save-excursion
668 
+    (switch-to-buffer *haskell-buffer*)
669 
+    (haskell-ensure-lisp-mode)
670 
+    (haskell-resume-command-loop)))
671 
+
672 
+(defun haskell-talk-to-lisp ()
673 
+  (pop-to-buffer *haskell-buffer*)
674 
+  (goto-char (point-max))
675 
+  (haskell-ensure-lisp-mode))
676 
+
677 
+
678 
+(defun haskell-resume-command-loop ()
679 
+  "Resumes Haskell command processing after debugging in Lisp.  \\[haskell-resume-command-loop]"
680 
+  (interactive)
681 
+  (if (not *emacs*)
682 
+      (progn
683 
+	(process-send-string "haskell" "(mumble-user::restart-haskell)\n")
684 
+	(haskell-ensure-emacs-mode))))
685 
+
686 
+
687 
+
688 
+;;; Displays output at end of given buffer.
689 
+;;; This function only ensures that the output is visible, without
690 
+;;; selecting the buffer in which it is displayed.
691 
+;;; Note that just using display-buffer instead of all this rigamarole
692 
+;;; won't work; you need to temporarily select the window containing
693 
+;;; the *haskell-buffer*, or else the display won't be scrolled to show
694 
+;;; the new output.
695 
+;;; *** This should really position the window in the buffer so that
696 
+;;; *** the point is on the last line of the window.
697 
+
698 
+(defun haskell-display-output (str)
699 
+  (if (eq (get-haskell-status) 'dead)
700 
+      (save-excursion
701 
+	(set-buffer *haskell-buffer*)
702 
+	(haskell-display-output-aux str))
703 
+      (let ((window  (selected-window)))
704 
+	(unwind-protect
705 
+	    (progn
706 
+	      (pop-to-buffer *haskell-buffer*)
707 
+	      (haskell-display-output-aux str))
708 
+	  (select-window window)))))
709 
+
710 
+(defun haskell-display-output-aux (str)
711 
+  (haskell-move-marker)
712 
+  (insert str)
713 
+  (haskell-move-marker))
714 
+
715 
+
716 
+
717 
+;;; The haskell process says it's expecting the user to type in some input.
718 
+;;; Switch to the *haskell-buffer* so the user can type things.
719 
+;;; Once we have received an input message, stay in input mode until
720 
+;;; we get a ready message back from haskell.  This permits multiple
721 
+;;; data messages to be sent to haskell from a single input request.
722 
+;;;
723 
+;;; This user interface isn't really ideal.  You can be typing
724 
+;;; away in some other buffer and all of a sudden have Haskell decide
725 
+;;; it wants some input, and bingo!  You're switched into the Haskell
726 
+;;; buffer behind your back.  There's also the problem that you're
727 
+;;; left in the Haskell buffer afterwards, instead of getting swapped
728 
+;;; back into the buffer that was current when the input request was
729 
+;;; received.
730 
+;;; Not sure how to fix this -- seems like a totally synchronous interface
731 
+;;; would be worse....
732 
+
733 
+(defun get-user-input ()
734 
+  (message "Haskell is waiting for input...")
735 
+  (pop-to-buffer *haskell-buffer*)
736 
+  (goto-char (point-max))
737 
+  (set-haskell-status 'input)
738 
+  (haskell-pop-data-queue))
739 
+
740 
+
741 
+;;; The haskell process says it encountered an error.
742 
+;;; Remember to flush the command queue before continuing.
743 
+
744 
+(defun haskell-error-handler ()
745 
+  (ding)
746 
+  (haskell-flush-command-queue)
747 
+  ;; *** See comments below for why this is disabled.
748 
+;  (if *haskell-show-error*
749 
+;    (haskell-show-error))
750 
+  (set-haskell-status 'ready)
751 
+  (haskell-end-interaction nil))
752 
+
753 
+
754 
+;;; Pop up a buffer containing the file with the error, and put the
755 
+;;; point on the line where the error was reported.
756 
+;;; *** This code does the wrong thing in some situations.  For example,
757 
+;;; *** if you type in garbage to C-c e, it thinks that it should
758 
+;;; *** show you the last pad sent to the haskell process, which is
759 
+;;; *** clearly bogus.
760 
+;;; *** I also think it would be better interaction style to have to
761 
+;;; *** request to be shown the error explicitly, instead of unexpectedly
762 
+;;; *** being thrown into some other buffer.
763 
+
764 
+;;; Error handling Variables
765 
+
766 
+(defvar *yh-error-def*  "Error occured in definition of\\s *")
767 
+(defvar *yh-error-line* "at line\\s *")
768 
+(defvar *yh-error-file* "of file\\s *")
769 
+(defvar *haskell-line* "\\([0-9]\\)*")
770 
+
771 
+(defun haskell-show-error ()
772 
+  "Point out error to user if possible"
773 
+  (set-buffer *haskell-buffer*)
774 
+  (save-excursion
775 
+    (let ((function-name nil)
776 
+	  (line-number   nil)
777 
+	  (filename      nil))
778 
+      (if (and (setq function-name (get-function-name))
779 
+	       (setq line-number (get-line-number))
780 
+	       (setq filename (get-filename)))
781 
+	  (point-error-to-user function-name line-number filename)))))
782 
+
783 
+(defvar *haskell-function-name*
784 
+  "\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\|\-\\)*")
785 
+
786 
+(defun get-function-name ()
787 
+  (if (and (re-search-backward *yh-error-def* (point-min) t)
788 
+	   (re-search-forward *yh-error-def* (point-max) t))
789 
+      (let ((beg (point)))
790 
+	(if (re-search-forward *haskell-function-name* (point-max) t)
791 
+	    (buffer-substring beg (point))
792 
+	    nil))
793 
+      nil))
794 
+
795 
+(defun get-line-number ()
796 
+  (if (re-search-forward  *yh-error-line* (point-max) t)
797 
+      (let ((beg  (point)))
798 
+	(if (re-search-forward *haskell-line* (point-max) t)
799 
+	    (string-to-int (buffer-substring beg (point)))
800 
+	    nil))
801 
+      nil))
802 
+
803 
+
804 
+(defun get-filename ()
805 
+  (if (re-search-forward  *yh-error-file* (point-max) t)
806 
+      (let ((beg  (point)))
807 
+	(if (re-search-forward "\\($\\| \\|\t\\)" (point-max) t)
808 
+	    (buffer-substring beg (point))
809 
+	    nil))
810 
+      nil))
811 
+
812 
+(defun point-error-to-user (function-name line-number filename)
813 
+  (if (equal filename "Interactive")
814 
+    (pop-to-buffer *last-pad*)
815 
+    (let ((fname (strip-fext filename)))
816 
+      (if (get-buffer fname)
817 
+	(pop-to-buffer fname)
818 
+	(find-file-other-window filename))))
819 
+  (goto-line line-number))
820 
+
821 
+
822 
+;;; The haskell process says it is ready to execute another command.
823 
+;;; Tell the user the last command has finished and execute the next
824 
+;;; command from the queue, if there is one.
825 
+
826 
+(defun haskell-reset ()
827 
+  (set-haskell-status 'ready)
828 
+  (haskell-pop-command-queue))
829 
+
830 
+
831 
+
832 
+
833 
+;;; ==================================================================
834 
+;;; Command queue utilities
835 
+;;; ==================================================================
836 
+
837 
+;;; Here's the stuff for managing the command queue.
838 
+;;; There are three kinds of things that show up in the queue:
839 
+;;; * Strings to be sent as commands to the haskell process.  These
840 
+;;;   are queued with haskell-send-command.
841 
+;;; * Other stuff to be sent to the haskell process (e.g., text to
842 
+;;;   be read as dialogue input).  These are queued with
843 
+;;;   haskell-send-data.
844 
+;;; * Messages indicating start of an interaction sequence.  These
845 
+;;;   are just shown to the user.  These are added to the queue with
846 
+;;;   haskell-begin-interaction.
847 
+;;; * Messages indicating end of an interaction sequence.  These are
848 
+;;;   queued with haskell-end-interaction.
849 
+;;;
850 
+;;; Representationally, the queue is just a list of conses.  The car of each
851 
+;;; entry is a symbol that identifies the kind of queue entry, and the cdr
852 
+;;; is associated data.  Only the functions in this section need to know
853 
+;;; about the internal format of the queue.
854 
+
855 
+
856 
+(defvar *command-interface-queue* nil
857 
+  "Contains the commands to be sent to the Haskell command interface")
858 
+
859 
+
860 
+;;; Here's a helper function.
861 
+
862 
+(defun haskell-queue-or-execute (fn request data)
863 
+  (cond (*command-interface-queue*
864 
+	 (setq *command-interface-queue*
865 
+	       (nconc *command-interface-queue* (list (cons request data)))))
866 
+	((eq (get-haskell-status) 'ready)
867 
+	 (funcall fn data))
868 
+	(t
869 
+	 (setq *command-interface-queue* (list (cons request data))))))
870 
+
871 
+
872 
+;;; Queue a command.
873 
+
874 
+(defun haskell-send-command (str)
875 
+  "Queues STRING for transmission to haskell process."
876 
+  (haskell-queue-or-execute 'haskell-send-command-aux 'command str))
877 
+
878 
+(defun haskell-send-command-aux (str)
879 
+  (process-send-string "haskell" str)
880 
+  (process-send-string "haskell" "\n")
881 
+  (if (not (eq (get-haskell-status) 'input))
882 
+      (set-haskell-status 'busy)))
883 
+
884 
+
885 
+;;; Queue a begin-interaction message.
886 
+
887 
+(defvar *begin-interaction-delimiter* nil ;; "-------------\n"
888 
+  "*Delimiter showing an interaction has begun")
889 
+
890 
+(defun haskell-begin-interaction (msg)
891 
+  (haskell-queue-or-execute 'haskell-begin-interaction-aux 'begin msg))
892 
+
893 
+(defun haskell-begin-interaction-aux (msg)
894 
+  (if *begin-interaction-delimiter*
895 
+      (haskell-display-output *begin-interaction-delimiter*))
896 
+  (if msg
897 
+      (haskell-display-output (concat "\n" msg "\n"))))
898 
+
899 
+
900 
+;;; Queue an end-interaction message.
901 
+
902 
+(defvar *end-interaction-delimiter* nil ;; "\n--- ready ---\n\n"
903 
+  "*Delimiter showing an interaction has ended")
904 
+
905 
+(defun haskell-end-interaction (msg)
906 
+  (haskell-queue-or-execute 'haskell-end-interaction-aux 'end msg))
907 
+
908 
+(defun haskell-end-interaction-aux (msg)
909 
+  (if *end-interaction-delimiter*
910 
+      (haskell-display-output *end-interaction-delimiter*))
911 
+  (if msg
912 
+      (message "%s" msg)))
913 
+
914 
+
915 
+;;; Queue data.  This is treated a little differently because we want
916 
+;;; text typed in as input to the program to be sent down the pipe to
917 
+;;; the process before processing end-interaction messages and additional
918 
+;;; commands in the queue.
919 
+
920 
+(defun haskell-send-data (str)
921 
+  (cond ((assoc 'data *command-interface-queue*)
922 
+	 (setq *command-interface-queue*
923 
+	       (merge-data-into-queue
924 
+		   (list (cons 'data str))
925 
+		   *command-interface-queue*
926 
+		   *command-interface-queue*
927 
+		   nil)))
928 
+	((or (eq (get-haskell-status) 'ready) (eq (get-haskell-status) 'input))
929 
+	 (haskell-send-command-aux str))
930 
+	(t
931 
+	 (setq *command-interface-queue* (list (cons 'data str))))))
932 
+
933 
+(defun merge-data-into-queue (new head tail lasttail)
934 
+  (cond ((null tail)
935 
+	 (rplacd lasttail new)
936 
+	 head)
937 
+	((eq (car (car tail)) 'data)
938 
+	 (merge-data-into-queue new head (cdr tail) tail))
939 
+	(lasttail
940 
+	 (rplacd lasttail new)
941 
+	 (rplacd new tail)
942 
+	 head)
943 
+	(t
944 
+	 (rplacd new tail)
945 
+	 new)))
946 
+
947 
+
948 
+;;; This function is called when the haskell process reports that it
949 
+;;; has finished processing a command.  It sends the next queued
950 
+;;; command (if there is one) down the pipe.
951 
+
952 
+(defun haskell-pop-command-queue ()
953 
+  (if *command-interface-queue*
954 
+    (let ((entry  (car *command-interface-queue*)))
955 
+      (setq *command-interface-queue* (cdr *command-interface-queue*))
956 
+      (cond ((eq (car entry) 'command)
957 
+	     (haskell-send-command-aux (cdr entry)))
958 
+	    ((eq (car entry) 'begin)
959 
+	     (haskell-begin-interaction-aux (cdr entry))
960 
+	     (haskell-pop-command-queue))
961 
+	    ((eq (car entry) 'end)
962 
+	     (haskell-end-interaction-aux (cdr entry))
963 
+	     (haskell-pop-command-queue))
964 
+	    ((eq (car entry) 'data)
965 
+	     (haskell-send-command-aux (cdr entry)))
966 
+	    (t
967 
+	     (haskell-mode-error "Invalid command in queue!!!"))
968 
+	    ))))
969 
+
970 
+
971 
+;;; This function is called when the haskell process reports that it
972 
+;;; wants to read some input.  If there's queued data, send it; but
973 
+;;; don't do commands or messages on the queue.
974 
+;;; Remember, we can send multiple pieces of input data for one input
975 
+;;; request from haskell.
976 
+
977 
+(defun haskell-pop-data-queue ()
978 
+  (if *command-interface-queue*
979 
+      (let ((entry  (car *command-interface-queue*)))
980 
+	(if (eq (car entry) 'data)
981 
+	    (progn
982 
+	      (setq *command-interface-queue* (cdr *command-interface-queue*))
983 
+	      (haskell-send-command-aux (cdr entry))
984 
+	      (haskell-pop-data-queue))))))
985 
+
986 
+
987 
+;;; This is called when there is an error.
988 
+
989 
+(defun haskell-flush-command-queue ()
990 
+  (setq *command-interface-queue* nil))
991 
+
992 
+
993 
+
994 
+;;; ==================================================================
995 
+;;; Interactive commands
996 
+;;; ==================================================================
997 
+
998 
+
999 
+;;; HASKELL and RUN HASKELL
1000 
+;;; ------------------------------------------------------------------
1001 
+
1002 
+;;; These are the two functions that start a Haskell process.
1003 
+;;; Rewritten to avoid doing anything if a Haskell process
1004 
+;;; already exists.  1991-Sep-09 Dan Rabin.
1005 
+
1006 
+;;; *** Dan says:
1007 
+;;; *** If the *haskell* buffer still exists, and the process has status
1008 
+;;; *** `dead', the usual evaluation commands don't create a new one, so no
1009 
+;;; *** evaluation happens.
1010 
+
1011 
+
1012 
+(defun haskell ()
1013 
+  "Run an inferior Haskell process with input and output via buffer *haskell*.
1014 
+Takes the program name from the variable haskell-program-name.
1015 
+Runs the hooks from inferior-haskell-mode-hook
1016 
+(after the comint-mode-hook is run).
1017 
+\(Type \\[describe-mode] in the process buffer for a list of commands.)"
1018 
+  (interactive)
1019 
+  (let ((haskell-buffer  (get-buffer *haskell-buffer*)))
1020 
+    (if (not (and haskell-buffer (comint-check-proc haskell-buffer)))
1021 
+	(progn
1022 
+	  (setq haskell-buffer
1023 
+		(apply 'make-comint
1024 
+		       "haskell"
1025 
+		       haskell-program-name
1026 
+		       nil
1027 
+                       nil))
1028 
+	  (save-excursion
1029 
+	    (set-buffer haskell-buffer)
1030 
+	    (inferior-haskell-mode))
1031 
+	  (display-buffer haskell-buffer)))))
1032 
+
1033 
+
1034 
+;;; Fresh start
1035 
+
1036 
+(defun haskell-fresh-start ()
1037 
+  (set-haskell-status 'busy)
1038 
+  (setq *command-interface-queue* nil)
1039 
+  (setq *last-loaded* haskell-main-file)
1040 
+  (setq *last-pad* haskell-main-pad)
1041 
+  (setq *emacs* nil)
1042 
+  (setq *haskell-saved-output* nil)
1043 
+  (haskell-ensure-emacs-mode))
1044 
+
1045 
+
1046 
+;;; Called from evaluation and compilation commands to start up a Haskell
1047 
+;;; process if none is already in progress.
1048 
+
1049 
+(defun haskell-maybe-create-process ()
1050 
+  (if haskell-auto-create-process
1051 
+      (haskell)))
1052 
+
1053 
+
1054 
+;;; This is called from HASKELL-FRESH-START to ensure that
1055 
+;;; there is a pad when starting up a Haskell interaction.
1056 
+
1057 
+(defun haskell-ensure-emacs-mode ()
1058 
+  (create-main-pad)
1059 
+  (setq *emacs* t)
1060 
+  (ci-emacs))
1061 
+
1062 
+
1063 
+;;; This is called when a Lisp error has been detected.
1064 
+
1065 
+(defun haskell-ensure-lisp-mode ()
1066 
+  "Switch to talking to Lisp.  \\[haskell-ensure-lisp-mode]"
1067 
+  (interactive)
1068 
+  (setq *emacs* nil))
1069 
+
1070 
+
1071 
+;;; HASKELL-GET-PAD
1072 
+;;; ------------------------------------------------------------------
1073 
+
1074 
+;;; This always puts the pad buffer in the "other" window.
1075 
+;;; Having it wipe out the .hs file window is clearly the wrong
1076 
+;;; behavior.
1077 
+
1078 
+(defun haskell-get-pad ()
1079 
+  "Creates a new scratch pad for the current module.
1080 
+Signals an error if the current buffer is not a .hs file."
1081 
+  (interactive)
1082 
+  (let ((fname (buffer-file-name)))
1083 
+    (if fname
1084 
+	(do-get-pad fname (current-buffer))
1085 
+        (haskell-mode-error "Not in a .hs buffer"))))
1086 
+
1087 
+
1088 
+(defun do-get-pad (fname buff)
1089 
+  (let* ((mname (or (get-modname buff)
1090 
+		    (read-no-blanks-input "Scratch pad for module? " nil)))
1091 
+	 (pname (lookup-pad mname fname))
1092 
+	 (pbuff nil))
1093 
+    ;; Generate the base name of the pad buffer, then create the
1094 
+    ;; buffer.  The actual name of the pad buffer may be something
1095 
+    ;; else because of name collisions.
1096 
+    (if (or (not pname) (not (setq pbuff (get-buffer pname))))
1097 
+	(progn
1098 
+	  (setq pname (get-padname mname))
1099 
+	  (setq pbuff (generate-new-buffer pname))
1100 
+	  (setq pname (buffer-name pbuff))
1101 
+	  (record-pad-mapping pname mname fname)
1102 
+	  ))
1103 
+    ;; Make sure the pad buffer is in haskell mode.
1104 
+    (pop-to-buffer pbuff)
1105 
+    (haskell-mode)))
1106 
+
1107 
+
1108 
+;;; HASKELL-SWITCH
1109 
+;;; ------------------------------------------------------------------
1110 
+
1111 
+(defun haskell-switch ()
1112 
+  "Switches to \*haskell\* buffer"
1113 
+  (interactive)
1114 
+  (haskell-maybe-create-process)
1115 
+  (switch-to-haskell t))
1116 
+
1117 
+
1118 
+(defun switch-to-haskell (eob-p)
1119 
+  "Really switch to the \*haskell\* buffer.
1120 
+With argument, positions cursor at end of buffer."
1121 
+  (interactive "P")
1122 
+  (pop-to-buffer *haskell-buffer*)
1123 
+  (cond (eob-p
1124 
+	 (push-mark)
1125 
+	 (goto-char (point-max)))))
1126 
+
1127 
+
1128 
+;;; HASKELL-COMMAND
1129 
+;;; ------------------------------------------------------------------
1130 
+
1131 
+(defun haskell-command (str)
1132 
+  "Format STRING as a haskell command and send it to haskell process.  \\[haskell-command]"
1133 
+  (interactive "sHaskell command: ")
1134 
+  (if (eq ?Q (capitalize (aref str 0)))
1135 
+      (ci-quit)
1136 
+      (progn
1137 
+	(haskell-begin-interaction
1138 
+	    (concat "Executing command: :" str))
1139 
+	(haskell-send-command (concat ":" str))
1140 
+	(haskell-end-interaction
1141 
+	    (concat "Executing command: :" str "  ...done.")))))
1142 
+
1143 
+
1144 
+;;; HASKELL-EVAL and HASKELL-RUN
1145 
+;;; ------------------------------------------------------------------
1146 
+
1147 
+(defun haskell-eval ()
1148 
+  "Evaluate expression in current module. \\[haskell-eval]"
1149 
+  (interactive)
1150 
+  (haskell-maybe-create-process)
1151 
+  (haskell-eval-aux (get-haskell-expression "Haskell expression: ")
1152 
+		    nil
1153 
+		    "Evaluating"))
1154 
+
1155 
+(defun haskell-run ()
1156 
+  "Run Haskell Dialogue in current module"
1157 
+  (interactive)
1158 
+  (haskell-maybe-create-process)
1159 
+  (haskell-eval-aux (get-haskell-expression "Haskell dialogue: ")
1160 
+		    t
1161 
+		    "Running"))
1162 
+
1163 
+(defun haskell-run-main ()
1164 
+  "Run Dialogue named main in current module"
1165 
+  (interactive)
1166 
+  (haskell-maybe-create-process)
1167 
+  (haskell-eval-aux "main" t "Running"))
1168 
+
1169 
+(defun haskell-eval-aux (exp dialogue-p what)
1170 
+  (cond ((equal *haskell-buffer* (buffer-name))
1171 
+	 (let* ((pname  *last-pad*)
1172 
+		(mname  *last-module*)
1173 
+		(fname  *last-loaded*)
1174 
+		(msg    (format "%s: %s" what exp)))
1175 
+	   (haskell-eval-aux-aux exp pname mname fname msg dialogue-p)))
1176 
+	((equal *ht-temp-buffer* (buffer-name))
1177 
+	 (let* ((fname  (buffer-file-name))
1178 
+		(mname  (get-modname (current-buffer)))
1179 
+		(pname  (lookup-pad mname fname))
1180 
+		(msg    (format "%s (in tutorial): %s" what exp)))
1181 
+	   (haskell-eval-aux-aux exp pname mname fname msg dialogue-p)))
1182 
+	((buffer-file-name)
1183 
+	 (let* ((fname  (buffer-file-name))
1184 
+		(mname  (get-modname (current-buffer)))
1185 
+		(pname  (lookup-pad mname fname))
1186 
+		(msg    (format "%s (in file %s): %s"
1187 
+				what (file-name-nondirectory fname) exp)))
1188 
+	   (haskell-eval-aux-aux exp pname mname fname msg dialogue-p)))
1189 
+	(t
1190 
+	 (let* ((pname  (buffer-name (current-buffer)))
1191 
+		(mname  (get-module-from-pad pname))
1192 
+		(fname  (get-file-from-pad pname))
1193 
+		(msg    (format "%s (in pad %s): %s" what pname exp)))
1194 
+	   (haskell-eval-aux-aux exp pname mname fname msg dialogue-p)))
1195 
+	))
1196 
+
1197 
+(defun haskell-eval-aux-aux (exp pname mname fname msg dialogue-p)
1198 
+  (haskell-begin-interaction msg)
1199 
+  (ci-kill)
1200 
+  (haskell-load-file-if-modified fname)
1201 
+  (ci-module mname)
1202 
+  (if pname (haskell-save-pad-if-modified pname))
1203 
+  (if dialogue-p
1204 
+      (ci-send-name exp)
1205 
+      (ci-print-exp exp))
1206 
+  (ci-eval)
1207 
+  (haskell-end-interaction (concat msg "  ...done.")))
1208 
+
1209 
+
1210 
+;;; Save pad only if modified.  Keep track of *last-pad* sent to process.
1211 
+
1212 
+(defun haskell-save-pad-if-modified (pad)
1213 
+  (save-excursion
1214 
+    (set-buffer pad)
1215 
+    (if (or (equal pad haskell-main-pad) (buffer-modified-p))
1216 
+	(progn
1217 
+	  (setq *last-pad* pad)
1218 
+	  (ci-clear)
1219 
+	  (ci-set-file pad)
1220 
+	  (ci-send-buffer pad)
1221 
+;	  (set-buffer-modified-p t)  ;***???
1222 
+	  (ci-save)))))
1223 
+
1224 
+
1225 
+
1226 
+;;; HASKELL-RUN-FILE
1227 
+;;; ------------------------------------------------------------------
1228 
+
1229 
+(defun haskell-run-file ()
1230 
+  "Run all Dialogues in current file"
1231 
+  (interactive)
1232 
+  (haskell-maybe-create-process)
1233 
+  (cond ((equal *haskell-buffer* (buffer-name))
1234 
+	 ;; When called from the haskell process buffer, prompt for
1235 
+	 ;; a file to run.
1236 
+	 (call-interactively 'haskell-run-file/process))
1237 
+	((buffer-file-name)
1238 
+	 ;; When called from a .hs file buffer, run that file.
1239 
+	 (haskell-run-file-aux (buffer-file-name)))
1240 
+	(t
1241 
+	 ;; When called from a pad, run the file that the module the
1242 
+	 ;; pad belongs to lives in.
1243 
+	 (haskell-run-file-aux
1244 
+	     (get-file-from-pad (buffer-name (current-buffer)))))
1245 
+	))
1246 
+
1247 
+(defun haskell-run-file/process (filename)
1248 
+  (interactive (comint-get-source "Haskell file to run:  "
1249 
+				  haskell-prev-l/c-dir/file
1250 
+				  haskell-source-modes t))
1251 
+  (comint-check-source filename)
1252 
+  (setq haskell-prev-l/c-dir/file
1253 
+	(cons (file-name-directory filename)
1254 
+	      (file-name-nondirectory filename)))
1255 
+  (haskell-run-file-aux filename))
1256 
+
1257 
+(defun haskell-run-file-aux (fname)
1258 
+  (let ((msg  (concat "Running file: " fname)))
1259 
+    (haskell-begin-interaction msg)
1260 
+    (ci-kill)
1261 
+    (save-modified-source-files buffer-file-name)
1262 
+    (ci-run (strip-fext fname))
1263 
+    (haskell-end-interaction (concat msg "  ...done."))))
1264 
+
1265 
+
1266 
+;;; HASKELL-LOAD
1267 
+;;; ------------------------------------------------------------------
1268 
+
1269 
+(defun haskell-load ()
1270 
+  "Load current file"
1271 
+  (interactive)
1272 
+  (haskell-maybe-create-process)
1273 
+  (let* ((fname  (buffer-file-name))
1274 
+	 (msg    (concat "Loading file: " fname)))
1275 
+    (cond (fname
1276 
+	   (haskell-begin-interaction msg)
1277 
+	   (haskell-load-file-if-modified fname)
1278 
+	   (haskell-end-interaction (concat msg "  ...done.")))
1279 
+	  (t
1280 
+	   (haskell-mode-error "Must be in a file to load")))))
1281 
+
1282 
+
1283 
+;;; Load file only if modified or not *last-loaded*.
1284 
+;;; For now, this just loads the file unconditionally.
1285 
+
1286 
+(defun haskell-load-file-if-modified (filename)
1287 
+  (save-modified-source-files buffer-file-name)
1288 
+  (cond ((string= filename haskell-main-file)
1289 
+	 (setq *last-loaded* haskell-main-file)
1290 
+	 (ci-load-main))
1291 
+	(t
1292 
+	 (setq *last-loaded* filename)
1293 
+	 (ci-load (strip-fext filename)))))
1294 
+
1295 
+
1296 
+;;; ***This isn't used any more.
1297 
+;(defun file-modification-time (file)
1298 
+;  "Get modification time for FILE from filesystem information."
1299 
+;  (car (cdr (car (nthcdr 5 (file-attributes file))))))
1300 
+
1301 
+
1302 
+;;; HASKELL-COMPILE
1303 
+;;; ------------------------------------------------------------------
1304 
+
1305 
+(defun haskell-compile ()
1306 
+  "Compile current file"
1307 
+  (interactive)
1308 
+  (haskell-maybe-create-process)
1309 
+  (let ((fname  (buffer-file-name)))
1310 
+    (cond (fname
1311 
+	   (haskell-begin-interaction (concat "Compiling: " fname))
1312 
+	   (haskell-compile-file-if-modified fname)
1313 
+	   (haskell-end-interaction
1314 
+	    (concat "Compiling: " fname "  ...done.")))
1315 
+	  (t
1316 
+	   (haskell-mode-error "Must be in a file to compile")))))
1317 
+
1318 
+(defun haskell-compile-file-if-modified (fname)
1319 
+  ;; *** For now it unconditionally compiles the file.
1320 
+  (save-modified-source-files buffer-file-name)
1321 
+  (ci-compile (strip-fext fname)))
1322 
+
1323 
+
1324 
+;;; HASKELL-EXIT
1325 
+;;; ------------------------------------------------------------------
1326 
+
1327 
+(defun haskell-exit ()
1328 
+  "Quit the haskell process"
1329 
+  (interactive)
1330 
+  (ci-quit)
1331 
+  ;; If we were running the tutorial, mark the temp buffer as unmodified
1332 
+  ;; so we don't get asked about saving it later.
1333 
+  (if (and *ht-temp-buffer*
1334 
+	   (get-buffer *ht-temp-buffer*))
1335 
+      (save-excursion
1336 
+	(set-buffer *ht-temp-buffer*)
1337 
+	(set-buffer-modified-p nil)))
1338 
+  ;; Try to remove the haskell output buffer from the screen.
1339 
+  (bury-buffer *haskell-buffer*)
1340 
+  (replace-buffer-in-windows *haskell-buffer*))
1341 
+
1342 
+
1343 
+;;; HASKELL-INTERRUPT
1344 
+;;; ------------------------------------------------------------------
1345 
+
1346 
+(defun haskell-interrupt ()
1347 
+  "Interrupt the haskell process"
1348 
+  (interactive)
1349 
+  ;; Do not queue the interrupt character; send it immediately.
1350 
+  (haskell-send-command-aux "\C-c")       ; interrupt Haskell
1351 
+  (haskell-end-interaction "done.")    ; send a reset to Lisp
1352 
+  )
1353 
+
1354 
+
1355 
+;;; HASKELL-EDIT-UNIT
1356 
+;;; ------------------------------------------------------------------
1357 
+
1358 
+(defun haskell-edit-unit ()
1359 
+  "Edit the .hu file."
1360 
+  (interactive)
1361 
+  (let ((fname       (buffer-file-name)))
1362 
+    (if fname
1363 
+	(let ((find-file-not-found-hooks  (list 'haskell-new-unit))
1364 
+	      (file-not-found             nil)
1365 
+	      (units-fname                (haskell-get-unit-file)))
1366 
+	  (find-file-other-window units-fname)
1367 
+	  (if file-not-found
1368 
+	      ;; *** this is broken.
1369 
+	      (units-add-source-file
1370 
+	         (if (string= (file-name-directory fname)
1371 
+			      (file-name-directory units-fname))
1372 
+		     (file-name-nondirectory fname)
1373 
+		     fname))))
1374 
+	(haskell-mode-error "Not in a .hs buffer"))))
1375 
+
1376 
+(defun haskell-new-unit ()
1377 
+  (setq file-not-found t))
1378 
+
1379 
+(defun units-add-source-file (file)
1380 
+  (save-excursion
1381 
+    (insert (strip-fext file) "\n")))
1382 
+
1383 
+
1384 
+;;; Look for a comment like "-- unit:" at top of file.
1385 
+;;; If not found, assume unit file has same name as the buffer but
1386 
+;;; a .hu extension.
1387 
+
1388 
+(defun haskell-get-unit-file ()
1389 
+  (let ((name  nil))
1390 
+    (save-excursion
1391 
+      (beginning-of-buffer)
1392 
+      (if (re-search-forward "-- unit:[ \t]*" (point-max) t)
1393 
+	  (let ((beg  (match-end 0)))
1394 
+	    (end-of-line)
1395 
+	    (setq name (buffer-substring beg (point))))
1396 
+	  (setq name (concat (strip-fext (buffer-file-name)) ".hu"))))
1397 
+    name))
1398 
+
1399 
+
1400 
+;;; HASKELL-PLEASE-RECOVER
1401 
+;;; ------------------------------------------------------------------
1402 
+
1403 
+(defun haskell-please-recover ()
1404 
+  (interactive)
1405 
+  (haskell-flush-commands-and-reset)
1406 
+  (haskell-end-interaction "done."))
1407 
+
1408 
+
1409 
+
1410 
+;;; ==================================================================
1411 
+;;; Support for printers/optimizers menus
1412 
+;;; ==================================================================
1413 
+
1414 
+;;; This code was adapted from the standard buff-menu.el code.
1415 
+
1416 
+(defvar haskell-menu-mode-map nil "")
1417 
+
1418 
+(if (not haskell-menu-mode-map)
1419 
+    (progn
1420 
+      (setq haskell-menu-mode-map (make-keymap))
1421 
+      (suppress-keymap haskell-menu-mode-map t)
1422 
+      (define-key haskell-menu-mode-map "m" 'haskell-menu-mark)
1423 
+      (define-key haskell-menu-mode-map "u" 'haskell-menu-unmark)
1424 
+      (define-key haskell-menu-mode-map "x" 'haskell-menu-exit)
1425 
+      (define-key haskell-menu-mode-map "q" 'haskell-menu-exit)
1426 
+      (define-key haskell-menu-mode-map " " 'next-line)
1427 
+      (define-key haskell-menu-mode-map "\177" 'haskell-menu-backup-unmark)
1428 
+      (define-key haskell-menu-mode-map "?" 'describe-mode)))
1429 
+
1430 
+;; Printers Menu mode is suitable only for specially formatted data.
1431 
+
1432 
+(put 'haskell-menu-mode 'mode-class 'special)
1433 
+
1434 
+(defun haskell-menu-mode ()
1435 
+  "Major mode for editing Haskell flags.
1436 
+Each line describes a flag.
1437 
+Letters do not insert themselves; instead, they are commands.
1438 
+m -- mark flag (turn it on)
1439 
+u -- unmark flag (turn it off)
1440 
+x -- exit; tell the Haskell process to update the flags, then leave menu.
1441 
+q -- exit; same as x.
1442 
+Precisely,\\{haskell-menu-mode-map}"
1443 
+  (kill-all-local-variables)
1444 
+  (use-local-map haskell-menu-mode-map)
1445 
+  (setq truncate-lines t)
1446 
+  (setq buffer-read-only t)
1447 
+  (setq major-mode 'haskell-menu-mode)
1448 
+  (setq mode-name "Haskell Flags Menu")
1449 
+  ;; These are all initialized elsewhere
1450 
+  (make-local-variable 'haskell-menu-current-flags)
1451 
+  (make-local-variable 'haskell-menu-request-fn)
1452 
+  (make-local-variable 'haskell-menu-update-fn)
1453 
+  (run-hooks 'haskell-menu-mode-hook))
1454 
+
1455 
+
1456 
+(defun haskell-menu (help-file buffer request-fn update-fn)
1457 
+  (haskell-maybe-create-process)
1458 
+  (if (get-buffer buffer)
1459 
+      (progn
1460 
+	(pop-to-buffer buffer)
1461 
+	(goto-char (point-min)))
1462 
+      (progn
1463 
+        (pop-to-buffer buffer)
1464 
+	(insert-file-contents help-file)
1465 
+	(haskell-menu-mode)
1466 
+	(setq haskell-menu-request-fn request-fn)
1467 
+	(setq haskell-menu-update-fn update-fn)
1468 
+	))
1469 
+  (haskell-menu-mark-current)
1470 
+  (message "m = mark; u = unmark; x = execute; q = quit; ? = more help."))
1471 
+
1472 
+
1473 
+
1474 
+;;; A line that starts with *haskell-menu-marked* is a menu item turned on.
1475 
+;;; A line that starts with *haskell-menu-unmarked* is turned off.
1476 
+;;; A line that starts with anything else is just random text and is
1477 
+;;; ignored by commands that deal with menu items.
1478 
+
1479 
+(defvar *haskell-menu-marked*   " on")
1480 
+(defvar *haskell-menu-unmarked* "   ")
1481 
+(defvar *haskell-menu-marked-regexp*   " on   \\w")
1482 
+(defvar *haskell-menu-unmarked-regexp* "      \\w")
1483 
+
1484 
+(defun haskell-menu-mark ()
1485 
+  "Mark flag to be turned on."
1486 
+  (interactive)
1487 
+  (beginning-of-line)
1488 
+  (cond ((looking-at *haskell-menu-marked-regexp*)
1489 
+	 (forward-line 1))
1490 
+	((looking-at *haskell-menu-unmarked-regexp*)
1491 
+	 (let ((buffer-read-only  nil))
1492 
+	   (delete-char (length *haskell-menu-unmarked*))
1493 
+	   (insert *haskell-menu-marked*)
1494 
+	   (forward-line 1)))
1495 
+	(t
1496 
+	 (forward-line 1))))
1497 
+
1498 
+(defun haskell-menu-unmark ()
1499 
+  "Unmark flag."
1500 
+  (interactive)
1501 
+  (beginning-of-line)
1502 
+  (cond ((looking-at *haskell-menu-unmarked-regexp*)
1503 
+	 (forward-line 1))
1504 
+	((looking-at *haskell-menu-marked-regexp*)
1505 
+	 (let ((buffer-read-only  nil))
1506 
+	   (delete-char (length *haskell-menu-marked*))
1507 
+	   (insert *haskell-menu-unmarked*)
1508 
+	   (forward-line 1)))
1509 
+	(t
1510 
+	 (forward-line 1))))
1511 
+
1512 
+(defun haskell-menu-backup-unmark ()
1513 
+  "Move up and unmark."
1514 
+  (interactive)
1515 
+  (forward-line -1)
1516 
+  (haskell-menu-unmark)
1517 
+  (forward-line -1))
1518 
+
1519 
+
1520 
+;;; Actually make the changes.
1521 
+
1522 
+(defun haskell-menu-exit ()
1523 
+  "Update flags, then leave menu."
1524 
+  (interactive)
1525 
+  (haskell-menu-execute)
1526 
+  (haskell-menu-quit))
1527 
+
1528 
+(defun haskell-menu-execute ()
1529 
+  "Tell haskell process to tweak flags."
1530 
+  (interactive)
1531 
+  (start-setting-flags)
1532 
+  (save-excursion
1533 
+    (goto-char (point-min))
1534 
+    (while (not (eq (point) (point-max)))
1535 
+      (cond ((looking-at *haskell-menu-unmarked-regexp*)
1536 
+	     (funcall haskell-menu-update-fn (haskell-menu-flag) nil))
1537 
+	    ((looking-at *haskell-menu-marked-regexp*)
1538 
+	     (funcall haskell-menu-update-fn (haskell-menu-flag) t))
1539 
+	    (t
1540 
+	     nil))
1541 
+      (forward-line 1)))
1542 
+  (finish-setting-flags))
1543 
+
1544 
+(defun haskell-menu-quit ()
1545 
+  (interactive)
1546 
+  "Make the menu go away."
1547 
+  (bury-buffer (current-buffer))
1548 
+  (replace-buffer-in-windows (current-buffer)))
1549 
+
1550 
+
1551 
+(defun haskell-menu-flag ()
1552 
+  (save-excursion
1553 
+    (beginning-of-line)
1554 
+    (forward-char 6)
1555 
+    (let ((beg  (point)))
1556 
+      ;; End of flag name marked by tab or two spaces.
1557 
+      (re-search-forward "\t\\|  ")
1558 
+      (buffer-substring beg (match-beginning 0)))))
1559 
+
1560 
+
1561 
+(defun start-setting-flags ()
1562 
+  nil)
1563 
+
1564 
+(defun finish-setting-flags ()
1565 
+  (haskell-end-interaction "Setting flags....done."))
1566 
+
1567 
+
1568 
+;;; Update the menu to mark only those items currently turned on.
1569 
+
1570 
+(defun haskell-menu-mark-current ()
1571 
+  (funcall haskell-menu-request-fn)
1572 
+  (save-excursion
1573 
+    (goto-char (point-min))
1574 
+    (while (not (eq (point) (point-max)))
1575 
+      (cond ((and (looking-at *haskell-menu-unmarked-regexp*)
1576 
+		  (menu-item-currently-on-p (haskell-menu-flag)))
1577 
+	     (haskell-menu-mark))
1578 
+	    ((and (looking-at *haskell-menu-marked-regexp*)
1579 
+		  (not (menu-item-currently-on-p (haskell-menu-flag))))
1580 
+	     (haskell-menu-unmark))
1581 
+	    (t
1582 
+	     (forward-line 1))))))
1583 
+
1584 
+
1585 
+;;; See if a menu item is turned on.
1586 
+
1587 
+(defun menu-item-currently-on-p (item)
1588 
+  (member-string= item haskell-menu-current-flags))
1589 
+
1590 
+(defun member-string= (item list)
1591 
+  (cond ((null list)
1592 
+	 nil)
1593 
+	((string= item (car list))
1594 
+	 list)
1595 
+	(t
1596 
+	 (member-string= item (cdr list)))))
1597 
+
1598 
+
1599 
+
1600 
+;;; Make the menu for printers.
1601 
+
1602 
+(defvar *haskell-printers-help*
1603 
+  (concat (getenv "HASKELL") "/emacs-tools/printer-help.txt")
1604 
+  "Help file for printers.")
1605 
+
1606 
+(defvar *haskell-printers-buffer* "*Haskell printers*")
1607 
+
1608 
+(defun haskell-printers ()
1609 
+  "Set printers interactively."
1610 
+  (interactive)
1611 
+  (haskell-menu
1612 
+    *haskell-printers-help*
1613 
+    *haskell-printers-buffer*
1614 
+    'get-current-printers
1615 
+    'set-current-printers))
1616 
+
1617 
+(defun get-current-printers ()
1618 
+  (setq haskell-menu-current-flags t)
1619 
+  (haskell-send-command ":p?")
1620 
+  (while (eq haskell-menu-current-flags t)
1621 
+    (sleep-for 1)))
1622 
+
1623 
+(defun update-printers-list (data)
1624 
+  (setq haskell-menu-current-flags (read data)))
1625 
+
1626 
+(defun set-current-printers (flag on)
1627 
+  (let ((was-on (menu-item-currently-on-p flag)))
1628 
+    (cond ((and on (not was-on))
1629 
+	   (haskell-send-command (format ":p+ %s" flag)))
1630 
+	  ((and (not on) was-on)
1631 
+	   (haskell-send-command (format ":p- %s" flag)))
1632 
+	  (t
1633 
+	   nil))))
1634 
+
1635 
+
1636 
+;;; Equivalent stuff for the optimizers menu
1637 
+
1638 
+(defvar *haskell-optimizers-help*
1639 
+  (concat (getenv "HASKELL") "/emacs-tools/optimizer-help.txt")
1640 
+  "Help file for optimizers.")
1641 
+
1642 
+(defvar *haskell-optimizers-buffer* "*Haskell optimizers*")
1643 
+
1644 
+(defun haskell-optimizers ()
1645 
+  "Set optimizers interactively."
1646 
+  (interactive)
1647 
+  (haskell-menu
1648 
+    *haskell-optimizers-help*
1649 
+    *haskell-optimizers-buffer*
1650 
+    'get-current-optimizers
1651 
+    'set-current-optimizers))
1652 
+
1653 
+(defun get-current-optimizers ()
1654 
+  (setq haskell-menu-current-flags t)
1655 
+  (haskell-send-command ":o?")
1656 
+  (while (eq haskell-menu-current-flags t)
1657 
+    (sleep-for 1)))
1658 
+
1659 
+(defun update-optimizers-list (data)
1660 
+  (setq haskell-menu-current-flags (read data)))
1661 
+
1662 
+(defun set-current-optimizers (flag on)
1663 
+  (let ((was-on (menu-item-currently-on-p flag)))
1664 
+    (cond ((and on (not was-on))
1665 
+	   (haskell-send-command (format ":o+ %s" flag)))
1666 
+	  ((and (not on) was-on)
1667 
+	   (haskell-send-command (format ":o- %s" flag)))
1668 
+	  (t
1669 
+	   nil))))
1670 
+
1671 
+
1672 
+
1673 
+
1674 
+;;; ==================================================================
1675 
+;;; Random utilities
1676 
+;;; ==================================================================
1677 
+
1678 
+
1679 
+;;; Keep track of the association between pads, modules, and files.
1680 
+;;; The global variable is a list of (pad-buffer-name module-name file-name)
1681 
+;;; lists.
1682 
+
1683 
+(defvar *pad-mappings* ()
1684 
+  "Associates pads with their corresponding module and file.")
1685 
+
1686 
+(defun record-pad-mapping (pname mname fname)
1687 
+  (setq *pad-mappings*
1688 
+	(cons (list pname mname fname) *pad-mappings*)))
1689 
+
1690 
+(defun get-module-from-pad (pname)
1691 
+  (car (cdr (assoc pname *pad-mappings*))))
1692 
+
1693 
+(defun get-file-from-pad (pname)
1694 
+  (car (cdr (cdr (assoc pname *pad-mappings*)))))
1695 
+
1696 
+(defun lookup-pad (mname fname)
1697 
+  (lookup-pad-aux mname fname *pad-mappings*))
1698 
+
1699 
+(defun lookup-pad-aux (mname fname list)
1700 
+  (cond ((null list)
1701 
+	 nil)
1702 
+	((and (equal mname (car (cdr (car list))))
1703 
+	      (equal fname (car (cdr (cdr (car list))))))
1704 
+	 (car (car list)))
1705 
+	(t
1706 
+	 (lookup-pad-aux mname fname (cdr list)))))
1707 
+
1708 
+
1709 
+
1710 
+;;; Save any modified .hs and .hu files.
1711 
+;;; Yes, the two set-buffer calls really seem to be necessary.  It seems
1712 
+;;; that y-or-n-p makes emacs forget we had temporarily selected some
1713 
+;;; other buffer, and if you just do save-buffer directly it will end
1714 
+;;; up trying to save the current buffer instead.  The built-in
1715 
+;;; save-some-buffers function has this problem....
1716 
+
1717 
+(defvar *ask-before-saving* t)
1718 
+
1719 
+(defun save-modified-source-files (filename)
1720 
+  (let ((buffers   (buffer-list))
1721 
+	(found-any nil))
1722 
+    (while buffers
1723 
+      (let ((buffer  (car buffers)))
1724 
+	(if (and (buffer-modified-p buffer)
1725 
+		 (save-excursion
1726 
+		   (set-buffer buffer)
1727 
+		   (and buffer-file-name
1728 
+			(source-file-p buffer-file-name)
1729 
+			(setq found-any t)
1730 
+			(or (null *ask-before-saving*)
1731 
+			    (string= buffer-file-name filename)
1732 
+			    (y-or-n-p
1733 
+			        (format "Save file %s? " buffer-file-name))))))
1734 
+	    (save-excursion
1735 
+	      (set-buffer buffer)
1736 
+	      (save-buffer))))
1737 
+      (setq buffers (cdr buffers)))
1738 
+    (if found-any
1739 
+	(message "")
1740 
+        (message "(No files need saving)"))))
1741 
+
1742 
+(defun source-file-p (filename)
1743 
+  (or (string-match "\\.hs$" filename)
1744 
+      (string-match "\\.lhs$" filename)
1745 
+      (string-match "\\.hu$" filename)
1746 
+      (string-match "\\.shu$" filename)
1747 
+      (string-match "\\.hsp$" filename)
1748 
+      (string-match "\\.prim$" filename)))
1749 
+
1750 
+
1751 
+;;; Buffer utilities
1752 
+
1753 
+(defun haskell-move-marker ()
1754 
+  "Moves the marker and point to the end of buffer"
1755 
+  (set-marker comint-last-input-end (point-max))
1756 
+  (set-marker (process-mark (get-process "haskell")) (point-max))
1757 
+  (goto-char (point-max)))
1758 
+
1759 
+
1760 
+;;; Pad utils
1761 
+
1762 
+(defun create-main-pad ()
1763 
+  (let ((buffer (get-buffer-create haskell-main-pad)))
1764 
+    (save-excursion
1765 
+      (set-buffer buffer)
1766 
+      (haskell-mode))
1767 
+    (record-pad-mapping haskell-main-pad haskell-main-module haskell-main-file)
1768 
+    buffer))
1769 
+
1770 
+
1771 
+;;; Extract the name of the module the point is in, from the given buffer.
1772 
+
1773 
+(defvar *re-module* "^module\\s *\\|^>\\s *module\\s *")
1774 
+(defvar *re-modname* "[A-Z]\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\)*")
1775 
+
1776 
+(defun get-modname (buff)
1777 
+  "Get module name in BUFFER that point is in."
1778 
+  (save-excursion
1779 
+    (set-buffer buff)
1780 
+    (if (or (looking-at *re-module*)
1781 
+	    (re-search-backward *re-module* (point-min) t)
1782 
+	    (re-search-forward *re-module* (point-max) t))
1783 
+	(progn
1784 
+	  (goto-char (match-end 0))
1785 
+	  (if (looking-at *re-modname*)
1786 
+	      (buffer-substring (match-beginning 0) (match-end 0))
1787 
+	      (haskell-mode-error "Module name not found!!")))
1788 
+	"Main")))
1789 
+
1790 
+
1791 
+;;; Build the base name for a pad buffer.
1792 
+
1793 
+(defun get-padname (m)
1794 
+  "Build padname from module name"
1795 
+  (concat "*" m "-pad*"))
1796 
+
1797 
+
1798 
+;;; Strip file extensions.
1799 
+;;; Only strip off extensions we know about; e.g.
1800 
+;;; "foo.hs" -> "foo" but "foo.bar" -> "foo.bar".
1801 
+
1802 
+(defvar *haskell-filename-regexp* "\\(.*\\)\\.\\(hs\\|lhs\\)$")
1803 
+
1804 
+(defun strip-fext (filename)
1805 
+  "Strip off the extension from a filename."
1806 
+  (if (string-match *haskell-filename-regexp* filename)
1807 
+      (substring filename (match-beginning 1) (match-end 1))
1808 
+      filename))
1809 
+
1810 
+
1811 
+;;; Haskell mode error
1812 
+
1813 
+(defun haskell-mode-error (msg)
1814 
+  "Show MSG in message line as an error from the haskell mode"
1815 
+  (error (concat "Haskell mode:  " msg)))
1816 
+
1817 
+
1818 
+
1819 
+
1820 
+;;; ==================================================================
1821 
+;;; Command generators
1822 
+;;; ==================================================================
1823 
+
1824 
+;;; Generate Haskell command interface commands.  These are very simple
1825 
+;;; routines building the string commands to be sent to the haskell
1826 
+;;; process.
1827 
+
1828 
+(defun ci-send-buffer (buff)
1829 
+  "Send BUFFER to haskell process."
1830 
+  (let ((str (buffer-string)))
1831 
+    (if (not (string-match "\\`\\s *\\'" str))  ; ignore if all whitespace
1832 
+	(save-excursion
1833 
+	  (set-buffer buff)
1834 
+	  (haskell-send-command str)))))
1835 
+
1836 
+(defun ci-kill ()
1837 
+  (haskell-send-command ":kill"))
1838 
+
1839 
+(defun ci-clear ()
1840 
+  (haskell-send-command ":clear"))
1841 
+
1842 
+(defun ci-set-file (file-name)
1843 
+  (haskell-send-command (concat ":file " file-name)))
1844 
+
1845 
+(defun ci-module (modname)
1846 
+  (setq *last-module* modname)
1847 
+  (haskell-send-command (concat ":module " modname)))
1848 
+
1849 
+
1850 
+;;; Keeps track of the last file loaded.
1851 
+;;; Change to do a :compile (temporary until new csys)
1852 
+;;;  2-Aug-91 Dan Rabin.
1853 
+
1854 
+(defun ci-load (filename)
1855 
+  (haskell-send-command (concat ":load " filename)))
1856 
+
1857 
+(defun ci-load-main ()
1858 
+  (haskell-send-command ":Main"))
1859 
+
1860 
+(defun ci-save ()
1861 
+  (haskell-send-command ":save"))
1862 
+
1863 
+(defun ci-compile (filename)
1864 
+  (haskell-send-command (concat ":compile " filename)))
1865 
+
1866 
+(defun ci-run (filename)
1867 
+  (haskell-send-command (concat ":run " filename)))
1868 
+
1869 
+(defun ci-print-exp (exp)
1870 
+  (ci-set-file "interactive-expression-buffer")
1871 
+  (haskell-send-command (concat "= " exp)))
1872 
+
1873 
+(defun ci-send-name (name)
1874 
+  (let ((temp  (make-temp-name "etemp")))
1875 
+    (ci-set-file "interactive-expression-buffer")
1876 
+    (haskell-send-command (concat temp " = " name))))
1877 
+
1878 
+(defun ci-eval ()
1879 
+  (haskell-send-command ":eval"))
1880 
+
1881 
+(defun ci-quit ()
1882 
+  (cond ((not (get-buffer-process *haskell-buffer*))
1883 
+	 (message "No process currently running."))
1884 
+	((y-or-n-p "Do you really want to quit Haskell? ")
1885 
+	 (process-send-string "haskell" ":quit\n")
1886 
+	 (set-haskell-status 'dead))
1887 
+	(t
1888 
+	 nil)))
1889 
+
1890 
+
1891 
+;;; When setting emacs mode (on/off)
1892 
+;;;     (a) Set process-filter
1893 
+;;;     (b) Send :Emacs command to Haskell process
1894 
+
1895 
+(defun ci-emacs ()
1896 
+  (haskell-reset)
1897 
+  (set-process-filter (get-process "haskell") 'process-haskell-output)
1898 
+  (haskell-send-command ":Emacs on"))
1899 
+
1900 
+
1901 
+
1902 
+
1903 
+
1904 
+
1905 
+;;; ==================================================================
1906 
+;;; Handle input in haskell process buffer; history commands.
1907 
+;;; ==================================================================
1908 
+
1909 
+(defun haskell-get-old-input ()
1910 
+  "Get old input text from Haskell process buffer."
1911 
+  (save-excursion
1912 
+    (if (re-search-forward haskell-prompt-pattern (point-max) 'move)
1913 
+	(goto-char (match-beginning 0)))
1914 
+    (cond ((re-search-backward haskell-prompt-pattern (point-min) t)
1915 
+	   (comint-skip-prompt)
1916 
+	   (let ((temp  (point)))
1917 
+	     (end-of-line)
1918 
+	     (buffer-substring temp (point)))))))
1919 
+
1920 
+
1921 
+;;; Modified for Haskell (taken from comint-send-input)
1922 
+
1923 
+(defun haskell-send-input ()
1924 
+  "Send input to Haskell while in the process buffer"
1925 
+  (interactive)
1926 
+  (if *emacs*
1927 
+      (haskell-send-input-aux)
1928 
+      (comint-send-input)))
1929 
+
1930 
+(defun haskell-send-input-aux ()
1931 
+  ;; Note that the input string does not include its terminal newline.
1932 
+  (let ((proc (get-buffer-process (current-buffer))))
1933 
+    (if (not proc)
1934 
+	(haskell-mode-error "Current buffer has no process")
1935 
+	(let* ((pmark (process-mark proc))
1936 
+	       (pmark-val (marker-position pmark))
1937 
+	       (input (if (>= (point) pmark-val)
1938 
+			  (buffer-substring pmark (point))
1939 
+			  (let ((copy (funcall comint-get-old-input)))
1940 
+			    (goto-char pmark)
1941 
+			    (insert copy)
1942 
+			    copy))))
1943 
+	  (insert ?\n)
1944 
+	  (if (funcall comint-input-filter input)
1945 
+	      (ring-insert input-ring input))
1946 
+	  (funcall comint-input-sentinel input)
1947 
+	  (set-marker (process-mark proc) (point))
1948 
+	  (set-marker comint-last-input-end (point))
1949 
+	  (haskell-send-data input)))))
1950 
+
1951 
+
1952 
+
1953 
+;;; ==================================================================
1954 
+;;; Minibuffer input stuff
1955 
+;;; ==================================================================
1956 
+
1957 
+;;; Haskell input history retrieval commands   (taken from comint.el)
1958 
+;;; M-p -- previous input    M-n -- next input
1959 
+
1960 
+(defvar haskell-minibuffer-local-map nil
1961 
+  "Local map for minibuffer when in Haskell")
1962 
+
1963 
+(if haskell-minibuffer-local-map
1964 
+    nil
1965 
+    (progn
1966 
+      (setq haskell-minibuffer-local-map
1967 
+	    (full-copy-sparse-keymap minibuffer-local-map))
1968 
+      ;; Haskell commands
1969 
+      (define-key haskell-minibuffer-local-map "\ep"   'haskell-previous-input)
1970 
+      (define-key haskell-minibuffer-local-map "\en"   'haskell-next-input)
1971 
+      ))
1972 
+
1973 
+(defun haskell-previous-input (arg)
1974 
+  "Cycle backwards through input history."
1975 
+  (interactive "*p")
1976 
+  (let ((len (ring-length haskell-prompt-ring)))
1977 
+    (cond ((<= len 0)
1978 
+	   (message "Empty input ring")
1979 
+	   (ding))
1980 
+	  (t
1981 
+	   (cond ((eq last-command 'haskell-previous-input)
1982 
+		  (delete-region (mark) (point))
1983 
+		  (set-mark (point)))
1984 
+		 (t
1985 
+		  (setq input-ring-index
1986 
+			(if (> arg 0) -1
1987 
+			    (if (< arg 0) 1 0)))
1988 
+		  (push-mark (point))))
1989 
+	   (setq input-ring-index (comint-mod (+ input-ring-index arg) len))
1990 
+	   (insert (ring-ref haskell-prompt-ring input-ring-index))
1991 
+	   (setq this-command 'haskell-previous-input))
1992 
+	  (t (ding)))))
1993 
+
1994 
+(defun haskell-next-input (arg)
1995 
+  "Cycle forwards through input history."
1996 
+  (interactive "*p")
1997 
+  (haskell-previous-input (- arg)))
1998 
+
1999 
+(defvar haskell-last-input-match ""
2000 
+  "Last string searched for by Haskell input history search, for defaulting.
2001 
+Buffer local variable.")
2002 
+
2003 
+(defun haskell-previous-input-matching (str)
2004 
+  "Searches backwards through input history for substring match"
2005 
+  (interactive (let ((s (read-from-minibuffer
2006 
+			 (format "Command substring (default %s): "
2007 
+				 haskell-last-input-match))))
2008 
+		 (list (if (string= s "") haskell-last-input-match s))))
2009 
+  (setq haskell-last-input-match str) ; update default
2010 
+  (let ((str (regexp-quote str))
2011 
+        (len (ring-length haskell-prompt-ring))
2012 
+	(n 0))
2013 
+    (while (and (<= n len)
2014 
+		(not (string-match str (ring-ref haskell-prompt-ring n))))
2015 
+      (setq n (+ n 1)))
2016 
+    (cond ((<= n len) (haskell-previous-input (+ n 1)))
2017 
+	  (t (haskell-mode-error "Not found.")))))
2018 
+
2019 
+
2020 
+;;; Actually read an expression from the minibuffer using the new keymap.
2021 
+
2022 
+(defun get-haskell-expression (prompt)
2023 
+  (let ((exp  (read-from-minibuffer prompt nil haskell-minibuffer-local-map)))
2024 
+    (ring-insert haskell-prompt-ring exp)
2025 
+    exp))
2026 
+
2027 
+
2028 
+
2029 
+
2030 
+;;; ==================================================================
2031 
+;;; User customization
2032 
+;;; ==================================================================
2033 
+
2034 
+(defvar haskell-load-hook nil
2035 
+  "This hook is run when haskell is loaded in.
2036 
+This is a good place to put key bindings."
2037 
+  )
2038 
+
2039 
+(run-hooks 'haskell-load-hook)
2040 
+
2041 
+
2042 
+
2043 
+
2044 
+;;;======================================================================
2045 
+;;; Tutorial mode setup
2046 
+;;;======================================================================
2047 
+
2048 
+;;; Set up additional key bindings for tutorial mode.
2049 
+
2050 
+(defvar ht-mode-map nil)
2051 
+
2052 
+(if ht-mode-map
2053 
+    nil
2054 
+    (progn
2055 
+      (setq ht-mode-map (make-sparse-keymap))
2056 
+      (haskell-establish-key-bindings ht-mode-map)
2057 
+      (define-key ht-mode-map "\C-c\C-f" 'ht-next-page)
2058 
+      (define-key ht-mode-map "\C-c\C-b" 'ht-prev-page)
2059 
+      (define-key ht-mode-map "\C-c\C-l" 'ht-restore-page)
2060 
+      (define-key ht-mode-map "\C-c?"    'describe-mode)))
2061 
+
2062 
+(defun haskell-tutorial-mode ()
2063 
+  "Major mode for running the Haskell tutorial.
2064 
+You can use these commands:
2065 
+\\{ht-mode-map}"
2066 
+  (interactive)
2067 
+  (kill-all-local-variables)
2068 
+  (use-local-map ht-mode-map)
2069 
+  (setq major-mode 'haskell-tutorial-mode)
2070 
+  (setq mode-name "Haskell Tutorial")
2071 
+  (set-syntax-table haskell-mode-syntax-table)
2072 
+  (run-hooks 'haskell-mode-hook))
2073 
+
2074 
+
2075 
+(defun haskell-tutorial ()
2076 
+  "Run the haskell tutorial."
2077 
+  (interactive)
2078 
+  (ht-load-tutorial)
2079 
+  (ht-make-buffer)
2080 
+  (ht-display-page))
2081 
+
2082 
+
2083 
+;;; Load the tutorial file into a read-only buffer.  Do not display this
2084 
+;;; buffer.
2085 
+
2086 
+(defun ht-load-tutorial ()
2087 
+  (let ((buffer  (get-buffer *ht-file-buffer*)))
2088 
+    (if buffer
2089 
+	(save-excursion
2090 
+	  (set-buffer buffer)
2091 
+	  (beginning-of-buffer))
2092 
+	(save-excursion
2093 
+	  (set-buffer (setq buffer (get-buffer-create *ht-file-buffer*)))
2094 
+	  (let ((fname (substitute-in-file-name *ht-source-file*)))
2095 
+	    (if (file-readable-p fname)
2096 
+		(ht-load-tutorial-aux fname)
2097 
+		(call-interactively 'ht-load-tutorial-aux)))))))
2098 
+
2099 
+(defun ht-load-tutorial-aux (filename)
2100 
+  (interactive "fTutorial file: ")
2101 
+  (insert-file filename)
2102 
+  (set-buffer-modified-p nil)
2103 
+  (setq buffer-read-only t)
2104 
+  (beginning-of-buffer))
2105 
+
2106 
+
2107 
+;;; Create a buffer to use for messing about with each page of the tutorial.
2108 
+;;; Put the buffer into haskell-tutorial-mode.
2109 
+
2110 
+(defun ht-make-buffer ()
2111 
+  (find-file (concat "/tmp/" (make-temp-name "ht") ".hs"))
2112 
+  (setq *ht-temp-buffer* (buffer-name))
2113 
+  (haskell-tutorial-mode))
2114 
+
2115 
+
2116 
+;;; Commands for loading text into the tutorial pad buffer
2117 
+
2118 
+(defun ht-next-page ()
2119 
+  "Go to the next tutorial page."
2120 
+  (interactive)
2121 
+  (if (ht-goto-next-page)
2122 
+      (ht-display-page)
2123 
+      (beep)))
2124 
+
2125 
+(defun ht-goto-next-page ()
2126 
+  (let ((buff  (current-buffer)))
2127 
+    (unwind-protect
2128 
+	(progn
2129 
+	  (set-buffer *ht-file-buffer*)
2130 
+	  (search-forward "\C-l" nil t))
2131 
+      (set-buffer buff))))
2132 
+
2133 
+(defun ht-prev-page ()
2134 
+  "Go to the previous tutorial page."
2135 
+  (interactive)
2136 
+  (if (ht-goto-prev-page)
2137 
+      (ht-display-page)
2138 
+      (beep)))
2139 
+
2140 
+(defun ht-goto-prev-page ()
2141 
+  (let ((buff  (current-buffer)))
2142 
+    (unwind-protect
2143 
+	(progn
2144 
+	  (set-buffer *ht-file-buffer*)
2145 
+	  (search-backward "\C-l" nil t))
2146 
+      (set-buffer buff))))
2147 
+
2148 
+(defun ht-goto-page (arg)
2149 
+  "Go to the tutorial page specified as the argument."
2150 
+  (interactive "sGo to page: ")
2151 
+  (if (ht-searchfor-page (format "-- Page %s " arg))
2152 
+      (ht-display-page)
2153 
+      (beep)))
2154 
+
2155 
+(defun ht-goto-section (arg)
2156 
+  "Go to the tutorial section specified as the argument."
2157 
+  (interactive "sGo to section: ")
2158 
+  (if (ht-searchfor-page (format "-- Section %s " arg))
2159 
+      (ht-display-page)
2160 
+      (beep)))
2161 
+
2162 
+(defun ht-searchfor-page (search-string)
2163 
+  (let ((buff           (current-buffer)))
2164 
+    (unwind-protect
2165 
+	(progn
2166 
+	  (set-buffer *ht-file-buffer*)
2167 
+	  (let ((point  (point)))
2168 
+	    (beginning-of-buffer)
2169 
+	    (if (search-forward search-string nil t)
2170 
+		t
2171 
+		(progn
2172 
+		  (goto-char point)
2173 
+		  nil))))
2174 
+      (set-buffer buff))))
2175 
+
2176 
+(defun ht-restore-page ()
2177 
+  (interactive)
2178 
+  (let ((old-point  (point)))
2179 
+    (ht-display-page)
2180 
+    (goto-char old-point)))
2181 
+
2182 
+(defun ht-display-page ()
2183 
+  (set-buffer *ht-file-buffer*)
2184 
+  (let* ((beg   (progn
2185 
+		 (if (search-backward "\C-l" nil t)
2186 
+		     (forward-line 1)
2187 
+		     (beginning-of-buffer))
2188 
+		 (point)))
2189 
+	 (end   (progn
2190 
+		  (if (search-forward "\C-l" nil t)
2191 
+		      (beginning-of-line)
2192 
+		      (end-of-buffer))
2193 
+		  (point)))
2194 
+	 (text  (buffer-substring beg end)))
2195 
+    (set-buffer *ht-temp-buffer*)
2196 
+    (erase-buffer)
2197 
+    (insert text)
2198 
+    (beginning-of-buffer)))
emacs-tools/haskell.elc
History View file @ 4e98702
0 2199 
new file mode 100644
... ... 
@@ -0,0 +1,788 @@
1 
+
2 
+(provide (quote haskell))
3 
+
4 
+(require (quote comint))
5 
+
6 
+(defvar haskell-program-name (getenv "HASKELLPROG") "\
7 
+*Program invoked by the haskell command")
8 
+
9 
+(defvar *haskell-buffer* "*haskell*" "\
10 
+*Name of the haskell process buffer")
11 
+
12 
+(defvar *haskell-show-error* 1 "\
13 
+*If not nil move to the buffer where the error was found")
14 
+
15 
+(defvar haskell-auto-create-process t "\
16 
+*If not nil, create a Haskell process automatically when required to evaluate or compile Haskell code")
17 
+
18 
+(defvar *haskell-debug-in-lisp* nil "\
19 
+*If not nil, enter Lisp debugger on error; otherwise, automagically return
20 
+to Haskell top-level.")
21 
+
22 
+(defvar *emacs* nil "\
23 
+When not nil means haskell is in emacs mode")
24 
+
25 
+(defvar haskell-main-pad "*Main-pad*" "\
26 
+Scratch pad associated with module Main")
27 
+
28 
+(defvar haskell-main-file "Main")
29 
+
30 
+(defvar haskell-main-module "Main")
31 
+
32 
+(defvar *last-loaded* haskell-main-file "\
33 
+Last file loaded with a :load command - Defaults to Main")
34 
+
35 
+(defvar *last-loaded-modtime* nil "\
36 
+Modification time of last file loaded, used to determine whether it
37 
+needs to be reloaded.")
38 
+
39 
+(defvar *last-module* haskell-main-module "\
40 
+Last module set with a :module command - Defaults to Main")
41 
+
42 
+(defvar *last-pad* haskell-main-pad "\
43 
+Last pad saved with a :save command - Defaults to Main")
44 
+
45 
+(defvar *ht-source-file* "$HASKELL/progs/tutorial/tutorial.hs")
46 
+
47 
+(defvar *ht-temp-buffer* nil)
48 
+
49 
+(defvar *ht-file-buffer* "Haskell-Tutorial-Master")
50 
+
51 
+(defvar haskell-mode-map nil "\
52 
+Keymap used for haskell-mode")
53 
+
54 
+(defun haskell-establish-key-bindings (keymap) (byte-code "���#����#����#����#����#����#����#����#����#����#����#����#����#����#����#����#����#�" [keymap define-key "e" haskell-eval "r" haskell-run "m" haskell-run-main "" haskell-run-file "p" haskell-get-pad "" haskell-optimizers "" haskell-printers "c" haskell-compile "l" haskell-load "h" haskell-switch ":" haskell-command "q" haskell-exit "i" haskell-interrupt "u" haskell-edit-unit "d" haskell-please-recover "(" haskell-ensure-lisp-mode ")" haskell-resume-command-loop] 20))
55 
+
56 
+(if haskell-mode-map nil (progn (setq haskell-mode-map (make-sparse-keymap)) (haskell-establish-key-bindings haskell-mode-map)))
57 
+
58 
+(defvar haskell-mode-syntax-table nil "\
59 
+Syntax table used for haskell-mode")
60 
+
61 
+(if haskell-mode-syntax-table nil (setq haskell-mode-syntax-table (standard-syntax-table)))
62 
+
63 
+(defun haskell-mode nil "\
64 
+Major mode for editing Haskell code to run in Emacs
65 
+The following commands are available:
66 
+\\{haskell-mode-map}
67 
+
68 
+A Haskell process can be fired up with \"M-x haskell\".
69 
+
70 
+Customization: Entry to this mode runs the hooks that are the value of variable
71 
+haskell-mode-hook.
72 
+
73 
+Windows:
74 
+
75 
+There are 3 types of windows associated with Haskell mode.  They are:
76 
+   *haskell*:  which is the process window.
77 
+   Pad:        which are buffers available for each module.  It is here
78 
+               where you want to test things before preserving them in a
79 
+               file.  Pads are always associated with a module.
80 
+               When issuing a command:
81 
+                 The pad and its associated module are sent to the Haskell
82 
+                 process prior to the execution of the command.
83 
+   .hs:        These are the files where Haskell programs live.  They
84 
+               have .hs as extension.
85 
+               When issuing a command:
86 
+                 The file is sent to the Haskell process prior to the
87 
+                 execution of the command.
88 
+
89 
+Commands:
90 
+
91 
+Each command behaves differently according to the type of the window in which
92 
+the cursor is positioned when the command is issued .
93 
+
94 
+haskell-eval:   \\[haskell-eval]
95 
+  Always promts user for a Haskell expression to be evaluated.  If in a
96 
+  .hs file buffer, then the cursor tells which module is the current
97 
+  module and the pad for that module (if any) gets loaded as well.
98 
+
99 
+haskell-run:    \\[haskell-run]
100 
+  Always queries for a variable of type Dialogue to be evaluated.
101 
+
102 
+haskell-run-main:    \\[haskell-run-main]
103 
+  Run Dialogue named main.
104 
+
105 
+haskell-run-file:   \\[haskell-run-file]
106 
+  Runs a file.  Ideally the file has a set of variable of type Dialogue
107 
+  that get evaluated.
108 
+
109 
+haskell-mode:   \\[haskell-mode]
110 
+  Puts the current buffer in haskell mode.
111 
+
112 
+haskell-compile:   \\[haskell-compile]
113 
+  Compiles file in current buffer.
114 
+
115 
+haskell-load:   \\[haskell-load]
116 
+  Loads file in current buffer.
117 
+
118 
+haskell-pad:   \\[haskell-pad]
119 
+  Creates a scratch pad for the current module.
120 
+
121 
+haskell-optimizers:  \\[haskell-optimizers]
122 
+  Shows the list of available optimizers.  Commands for turning them on/off.
123 
+
124 
+haskell-printers:  \\[haskell-printers]
125 
+  Shows the list of available printers.  Commands for turning them on/off.
126 
+
127 
+haskell-command:   \\[haskell-command]
128 
+  Prompts for a command to be sent to the command interface.  You don't
129 
+  need to put the : before the command.
130 
+
131 
+haskell-quit:   \\[haskell-quit]
132 
+  Terminates the haskell process.
133 
+
134 
+switch-to-haskell:   \\[switch-to-haskell]
135 
+  Switchs to the inferior Haskell buffer (*haskell*) and positions the
136 
+  cursor at the end of the buffer.
137 
+
138 
+haskell-interrupt:   \\[haskell-interrupt]
139 
+  Interrupts haskell process and resets it.
140 
+
141 
+haskell-edit-unit:   \\[haskell-edit-unit]
142 
+  Edit the .hu file for the unit containing this file.
143 
+" (interactive) (byte-code "ň� ��!�ȉ�ɉ���!�ˉ��!���!�" [haskell-mode-map major-mode mode-name indent-line-function haskell-mode-syntax-table nil kill-all-local-variables use-local-map haskell-mode "Haskell" make-local-variable indent-relative-maybe set-syntax-table run-hooks haskell-mode-hook] 6))
144 
+
145 
+(defvar inferior-haskell-mode-map nil)
146 
+
147 
+(if inferior-haskell-mode-map nil (setq inferior-haskell-mode-map (full-copy-sparse-keymap comint-mode-map)) (haskell-establish-key-bindings inferior-haskell-mode-map) (define-key inferior-haskell-mode-map "
" (quote haskell-send-input)))
148 
+
149 
+(defvar haskell-source-modes (quote (haskell-mode)) "\
150 
+*Used to determine if a buffer contains Haskell source code.
151 
+If it's loaded into a buffer that is in one of these major modes,
152 
+it's considered a Haskell source file.")
153 
+
154 
+(defvar haskell-prev-l/c-dir/file nil "\
155 
+Caches the (directory . file) pair used in the last invocation of
156 
+haskell-run-file.")
157 
+
158 
+(defvar haskell-prompt-pattern "^[A-Z]\\([A-Z]\\|[a-z]\\|[0-9]\\)*>\\s-*" "\
159 
+Regular expression capturing the Haskell system prompt.")
160 
+
161 
+(defvar haskell-prompt-ring nil "\
162 
+Keeps track of input to haskell process from the minibuffer")
163 
+
164 
+(defvar tea-prompt-pattern "^>+\\s-*" "\
165 
+Regular expression capturing the T system prompt.")
166 
+
167 
+(defvar haskell-version "Yale University Haskell Version 0.8, 1991" "\
168 
+Current Haskell system version")
169 
+
170 
+(defun inferior-haskell-mode-variables nil (byte-code "��" [nil] 1))
171 
+
172 
+(defun inferior-haskell-mode nil "\
173 
+Major mode for interacting with an inferior Haskell process.
174 
+
175 
+The following commands are available:
176 
+\\{inferior-haskell-mode-map}
177 
+
178 
+A Haskell process can be fired up with \"M-x haskell\".
179 
+
180 
+Customization: Entry to this mode runs the hooks on comint-mode-hook and
181 
+inferior-haskell-mode-hook (in that order).
182 
+
183 
+You can send text to the inferior Haskell process from other buffers containing
184 
+Haskell source.
185 
+
186 
+
187 
+Windows:
188 
+
189 
+There are 3 types of windows in the inferior-haskell-mode.  They are:
190 
+   *haskell*:  which is the process window.
191 
+   Pad:        which are buffers available for each module.  It is here
192 
+               where you want to test things before preserving them in a
193 
+               file.  Pads are always associated with a module.
194 
+               When issuing a command:
195 
+                 The pad and its associated module are sent to the Haskell
196 
+                 process prior to the execution of the command.
197 
+   .hs:        These are the files where Haskell programs live.  They
198 
+               have .hs as extension.
199 
+               When issuing a command:
200 
+                 The file is sent to the Haskell process prior to the
201 
+                 execution of the command.
202 
+
203 
+Commands:
204 
+
205 
+Each command behaves differently according to the type of the window in which
206 
+the cursor is positioned when the command is issued.
207 
+
208 
+haskell-eval:   \\[haskell-eval]
209 
+  Always promts user for a Haskell expression to be evaluated.  If in a
210 
+  .hs file, then the cursor tells which module is the current module and
211 
+  the pad for that module (if any) gets loaded as well.
212 
+
213 
+haskell-run:    \\[haskell-run]
214 
+  Always queries for a variable of type Dialogue to be evaluated.
215 
+
216 
+haskell-run-main:    \\[haskell-run-main]
217 
+  Run Dialogue named main.
218 
+
219 
+haskell-run-file:   \\[haskell-run-file]
220 
+  Runs a file.  Ideally the file has a set of variable of type Dialogue
221 
+  that get evaluated.
222 
+
223 
+haskell-mode:   \\[haskell-mode]
224 
+  Puts the current buffer in haskell mode.
225 
+
226 
+haskell-compile:   \\[haskell-compile]
227 
+  Compiles file in current buffer.
228 
+
229 
+haskell-load:   \\[haskell-load]
230 
+  Loads file in current buffer.
231 
+
232 
+haskell-pad:   \\[haskell-pad]
233 
+  Creates a scratch pad for the current module.
234 
+
235 
+haskell-optimizers:  \\[haskell-optimizers]
236 
+  Shows the list of available optimizers.  Commands for turning them on/off.
237 
+
238 
+haskell-printers:  \\[haskell-printers]
239 
+  Shows the list of available printers.  Commands for turning them on/off.
240 
+
241 
+haskell-command:   \\[haskell-command]
242 
+  Prompts for a command to be sent to the command interface.  You don't
243 
+  need to put the : before the command.
244 
+
245 
+haskell-quit:   \\[haskell-quit]
246 
+  Terminates the haskell process.
247 
+
248 
+switch-to-haskell:   \\[switch-to-haskell]
249 
+  Switchs to the inferior Haskell buffer (*haskell*) and positions the
250 
+  cursor at the end of the buffer.
251 
+
252 
+haskell-interrupt:   \\[haskell-interrupt]
253 
+  Interrupts haskell process and resets it.
254 
+
255 
+haskell-edit-unit:   \\[haskell-edit-unit]
256 
+  Edit the .hu file for the unit containing this file.
257 
+
258 
+The usual comint functions are also available. In particular, the
259 
+following are all available:
260 
+
261 
+comint-bol: Beginning of line, but skip prompt. Bound to C-a by default.
262 
+comint-delchar-or-maybe-eof: Delete char, unless at end of buffer, in
263 
+            which case send EOF to process. Bound to C-d by default.
264 
+
265 
+Note however, that the default keymap bindings provided shadow some of
266 
+the default comint mode bindings, so that you may want to bind them
267 
+to your choice of keys.
268 
+
269 
+Comint mode's dynamic completion of filenames in the buffer is available.
270 
+(Q.v. comint-dynamic-complete, comint-dynamic-list-completions.)
271 
+
272 
+If you accidentally suspend your process, use \\[comint-continue-subjob]
273 
+to continue it." (interactive) (byte-code "ˈ� �	��� �Ή�ω�Љ��
!�҉�Ӊ�ԉ���!��
274 
+!�	�" [comint-prompt-regexp haskell-prompt-pattern major-mode mode-name mode-line-process inferior-haskell-mode-map comint-input-filter comint-input-sentinel comint-get-old-input haskell-prompt-ring input-ring-size nil comint-mode inferior-haskell-mode-variables inferior-haskell-mode "Inferior Haskell" (": %s : busy") use-local-map haskell-input-filter ignore haskell-get-old-input run-hooks inferior-haskell-mode-hook make-ring] 7))
275 
+
276 
+(defvar inferior-haskell-mode-hook (quote haskell-fresh-start) "\
277 
+*Hook for customizing inferior-Haskell mode")
278 
+
279 
+(defun haskell-input-filter (str) "\
280 
+Don't save whitespace." (byte-code "��\"?�" [str string-match "\\s *"] 3))
281 
+
282 
+(defvar *haskell-status* (quote dead) "\
283 
+Status of the haskell process")
284 
+
285 
+(defun set-haskell-status (value) (byte-code "	��� �" [*haskell-status* value update-mode-line] 2))
286 
+
287 
+(defun get-haskell-status nil (byte-code "�" [*haskell-status*] 1))
288 
+
289 
+(defun update-mode-line nil (byte-code "�q�	�=�ʼn�7	�=�lj�7	�=�(ɉ�7	�=�4ˉ�7��!��� !)�" [*haskell-buffer* *haskell-status* mode-line-process t ready (": %s: ready") input (": %s: input") busy (": %s: busy") dead (": %s: dead") haskell-mode-error "Confused about status of haskell process!" set-buffer-modified-p buffer-modified-p] 4))
290 
+
291 
+(defvar *haskell-saved-output* nil)
292 
+
293 
+(defun process-haskell-output (process str) "\
294 
+Filter for output from Yale Haskell command interface" (byte-code "��� ÈŽ�P��ʼn��	\"��<	=?�-�	O!���\"#�����	\"��O�O��SG��	=?�a�	O!)+�" [idx lastidx data *haskell-saved-output* str nil 0 match-data ((byte-code "�!�" [data store-match-data] 2)) ci-response-start haskell-display-output funcall ci-response-handler ci-prefix-start] 10))
295 
+
296 
+(defvar *ci-responses* (quote (("r" "" haskell-got-ready) ("i" "" haskell-got-input-request) ("e" "" haskell-got-error) ("p.*
297 
+" "\\(p.*\\)?" haskell-got-printers) ("o.*
298 
+" "\\(o.*\\)?" haskell-got-optimizers) ("s.*
299 
+" "\\(s.*\\)?" haskell-got-message) ("
300 
+-> " "
301 
+\\(-\\(> ?\\)?\\)?" haskell-got-lisp-error) ("0\\] " "0\\(\\] ?\\)?" haskell-got-lisp-error) ("USER>>" "U\\(S\\(E\\(R\\(>>?\\)?\\)?\\)?\\)?" haskell-got-lisp-error) ("USER(.*):" "U\\(S\\(E\\(R\\((.*)?\\)?\\)?\\)?\\)?" haskell-got-lisp-error) ("USER .* : .* >" "U\\(S\\(E\\(R\\( .*\\( \\(:\\( .*\\( >?\\)?\\)?\\)?\\)?\\)?\\)?\\)?\\)?" haskell-got-lisp-error))))
302 
+
303 
+(defun command-match-regexp (x) (byte-code "@�" [x] 1))
304 
+
305 
+(defun command-prefix-regexp (x) (byte-code "A@�" [x] 1))
306 
+
307 
+(defun command-handler (x) (byte-code "AA@�" [x] 1))
308 
+
309 
+(defun glue-together (extractor) (byte-code "��
310 
+@\"�Q
311 
+A�$��	@\"�R��A����*�" [result extractor *ci-responses* stuff "\\(" funcall "\\)" "\\|\\("] 7))
312 
+
313 
+(defvar *ci-response-regexp* (glue-together (quote command-match-regexp)))
314 
+
315 
+(defvar *ci-prefix-regexp* (concat "\\(" (glue-together (quote command-prefix-regexp)) "\\)\\'"))
316 
+
317 
+(defun ci-response-start (str idx) (byte-code "�
318 
+#�" [*ci-response-regexp* str idx string-match] 4))
319 
+
320 
+(defun ci-prefix-start (str idx) (byte-code "�
321 
+#�" [*ci-prefix-regexp* str idx string-match] 4))
322 
+
323 
+(defun ci-response-handler (str idx) (byte-code "	��
324 
+
325 
+?�+��@!
#
=�#�@!��'A����
326 
+?�4��!�
327 
+*�" [list *ci-responses* result nil str idx string-match command-match-regexp command-handler haskell-mode-error "Failed to find command handler!!!"] 6))
328 
+
329 
+(defun haskell-got-ready (str idx) (byte-code "��!� �)�" [result match-end 0 haskell-reset] 3))
330 
+
331 
+(defun haskell-got-input-request (str idx) (byte-code "��!� �)�" [result match-end 0 get-user-input] 3))
332 
+
333 
+(defun haskell-got-error (str idx) (byte-code "��!� �)�" [result match-end 0 haskell-error-handler] 3))
334 
+
335 
+(defun haskell-got-printers (str idx) (byte-code "��!�
336 
+�\\�ZO!�)�" [result str idx match-end 0 update-printers-list 2 1] 6))
337 
+
338 
+(defun haskell-got-optimizers (str idx) (byte-code "��!�
339 
+�\\�ZO!�)�" [result str idx match-end 0 update-optimizers-list 2 1] 6))
340 
+
341 
+(defun haskell-got-message (str idx) (byte-code "��!�
342 
+�\\�ZO!�)�" [result str idx match-end 0 message 2 1] 6))
343 
+
344 
+(defun haskell-got-lisp-error (str idx) (byte-code "�	\"�	G�" [idx str haskell-handle-lisp-error] 3))
345 
+
346 
+(defun haskell-handle-lisp-error (location str) (byte-code "�	�O!�
347 
+�� ��� �� �" [str location *emacs* *haskell-debug-in-lisp* haskell-display-output nil ding haskell-talk-to-lisp haskell-flush-commands-and-reset] 5))
348 
+
349 
+(defun loaded-tutorial-p nil (byte-code "��!��	��!!\"�" [*ht-temp-buffer* *last-loaded* get-buffer equal buffer-file-name] 6))
350 
+
351 
+(defun haskell-flush-commands-and-reset nil (byte-code "� ���!�� �� )�" [*haskell-buffer* haskell-flush-command-queue switch-to-buffer haskell-ensure-lisp-mode haskell-resume-command-loop] 5))
352 
+
353 
+(defun haskell-talk-to-lisp nil (byte-code "�!�db�� �" [*haskell-buffer* pop-to-buffer haskell-ensure-lisp-mode] 3))
354 
+
355 
+(defun haskell-resume-command-loop nil "\
356 
+Resumes Haskell command processing after debugging in Lisp.  \\[haskell-resume-command-loop]" (interactive) (byte-code "��?����\"�� �" [*emacs* nil process-send-string "haskell" "(mumble-user::restart-haskell)
357 
+" haskell-ensure-emacs-mode] 3))
358 
+
359 
+(defun haskell-display-output (str) (byte-code "� �=��q��	!)� � ǎ�!��	!))�" [*haskell-buffer* str window get-haskell-status dead haskell-display-output-aux selected-window ((byte-code "�!�" [window select-window] 2)) pop-to-buffer] 6))
360 
+
361 
+(defun haskell-display-output-aux (str) (byte-code "� �c�� �" [str haskell-move-marker] 3))
362 
+
363 
+(defun get-user-input nil (byte-code "��!��!�db���!�� �" [*haskell-buffer* message "Haskell is waiting for input..." pop-to-buffer set-haskell-status input haskell-pop-data-queue] 5))
364 
+
365 
+(defun haskell-error-handler nil (byte-code "� �� ���!��!�" [nil ding haskell-flush-command-queue set-haskell-status ready haskell-end-interaction] 5))
366 
+
367 
+(defvar *yh-error-def* "Error occured in definition of\\s *")
368 
+
369 
+(defvar *yh-error-line* "at line\\s *")
370 
+
371 
+(defvar *yh-error-file* "of file\\s *")
372 
+
373 
+(defvar *haskell-line* "\\([0-9]\\)*")
374 
+
375 
+(defun haskell-show-error nil "\
376 
+Point out error to user if possible" (byte-code "q������ ��� ��� ��$�	#+)�" [*haskell-buffer* function-name nil line-number filename get-function-name get-line-number get-filename point-error-to-user] 7))
377 
+
378 
+(defvar *haskell-function-name* "\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\|-\\)*")
379 
+
380 
+(defun get-function-name nil (byte-code "�e�#�
�d�#�&`�d�#�!�
381 
+`\"�\"�)�'ć" [*yh-error-def* t beg *haskell-function-name* nil re-search-backward re-search-forward buffer-substring] 6))
382 
+
383 
+(defun get-line-number nil (byte-code "�d�#� `�d�#���
384 
+`\"!��)�!ć" [*yh-error-line* t beg *haskell-line* nil re-search-forward string-to-int buffer-substring] 6))
385 
+
386 
+(defun get-filename nil (byte-code "�d�#�`��d�#��
387 
+`\"��)�Ç" [*yh-error-file* t beg nil re-search-forward "\\($\\| \\|	\\)" buffer-substring] 5))
388 
+
389 
+(defun point-error-to-user (function-name line-number filename) (byte-code "��\"�
�	!�!�!�
390 
+!��
391 
+!� �!)��!�" [filename *last-pad* fname line-number equal "Interactive" pop-to-buffer strip-fext get-buffer find-file-other-window goto-line] 8))
392 
+
393 
+(defun haskell-reset nil (byte-code "��!�� �" [set-haskell-status ready haskell-pop-command-queue] 3))
394 
+
395 
+(defvar *command-interface-queue* nil "\
396 
+Contains the commands to be sent to the Haskell command interface")
397 
+
398 
+(defun haskell-queue-or-execute (fn request data) (byte-code "��
399 
+BC\"��$� �=��
400 
+\"�$
401 
+BC��" [*command-interface-queue* request data fn t nconc get-haskell-status ready funcall] 5))
402 
+
403 
+(defun haskell-send-command (str) "\
404 
+Queues STRING for transmission to haskell process." (byte-code "���#�" [str haskell-queue-or-execute haskell-send-command-aux command] 4))
405 
+
406 
+(defun haskell-send-command-aux (str) (byte-code "��\"����\"�� �=?���!�" [str process-send-string "haskell" "
407 
+" get-haskell-status input set-haskell-status busy] 5))
408 
+
409 
+(defvar *begin-interaction-delimiter* nil "\
410 
+*Delimiter showing an interaction has begun")
411 
+
412 
+(defun haskell-begin-interaction (msg) (byte-code "���#�" [msg haskell-queue-or-execute haskell-begin-interaction-aux begin] 4))
413 
+
414 
+(defun haskell-begin-interaction-aux (msg) (byte-code "��!�	���	�Q!�" [*begin-interaction-delimiter* msg haskell-display-output "
415 
+"] 5))
416 
+
417 
+(defvar *end-interaction-delimiter* nil "\
418 
+*Delimiter showing an interaction has ended")
419 
+
420 
+(defun haskell-end-interaction (msg) (byte-code "���#�" [msg haskell-queue-or-execute haskell-end-interaction-aux end] 4))
421 
+
422 
+(defun haskell-end-interaction-aux (msg) (byte-code "��!�	���	\"�" [*end-interaction-delimiter* msg haskell-display-output message "%s"] 4))
423 
+
424 
+(defun haskell-send-data (str) (byte-code "��\"���	BC�$��/� �=� � �=�)�	!�/�	BC��" [*command-interface-queue* str nil t assoc data merge-data-into-queue get-haskell-status ready input haskell-send-command-aux] 7))
425 
+
426 
+(defun merge-data-into-queue (new head tail lasttail) (byte-code "?��
427 
+\"��8@@�=� �
428 
+A$�8	�2�
429 
+\"��
430 
+\"��8�
431 
+\"�
432 
+�" [tail lasttail new head t rplacd data merge-data-into-queue] 7))
433 
+
434 
+(defun haskell-pop-command-queue nil (byte-code "�N@A��	@�=��	A!�M	@�=�+�	A!�� �M	@�=�<�	A!�� �M	@�=�J�	A!�M��!)�" [*command-interface-queue* entry t command haskell-send-command-aux begin haskell-begin-interaction-aux haskell-pop-command-queue end haskell-end-interaction-aux data haskell-mode-error "Invalid command in queue!!!"] 8))
435 
+
436 
+(defun haskell-pop-data-queue nil (byte-code "�@	@�=�A���	A!�� )�" [*command-interface-queue* entry data haskell-send-command-aux haskell-pop-data-queue] 3))
437 
+
438 
+(defun haskell-flush-command-queue nil (byte-code "���" [*command-interface-queue* nil] 2))
439 
+
440 
+(defun haskell nil "\
441 
+Run an inferior Haskell process with input and output via buffer *haskell*.
442 
+Takes the program name from the variable haskell-program-name.
443 
+Runs the hooks from inferior-haskell-mode-hook
444 
+(after the comint-mode-hook is run).
445 
+(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive) (byte-code "�	!�
�!?�&���
446 
+��%���q�� )��!)�" [haskell-buffer *haskell-buffer* haskell-program-name nil get-buffer comint-check-proc apply make-comint "haskell" inferior-haskell-mode display-buffer] 8))
447 
+
448 
+(defun haskell-fresh-start nil (byte-code "��!������
��������� �" [*command-interface-queue* nil *last-loaded* haskell-main-file *last-pad* haskell-main-pad *emacs* *haskell-saved-output* set-haskell-status busy haskell-ensure-emacs-mode] 3))
449 
+
450 
+(defun haskell-maybe-create-process nil (byte-code "�� �" [haskell-auto-create-process haskell] 2))
451 
+
452 
+(defun haskell-ensure-emacs-mode nil (byte-code "� ����� �" [*emacs* t create-main-pad ci-emacs] 3))
453 
+
454 
+(defun haskell-ensure-lisp-mode nil "\
455 
+Switch to talking to Lisp.  \\[haskell-ensure-lisp-mode]" (interactive) (byte-code "�����" [*emacs* nil] 2))
456 
+
457 
+(defun haskell-get-pad nil "\
458 
+Creates a new scratch pad for the current module.
459 
+Signals an error if the current buffer is not a .hs file." (interactive) (byte-code "��� ��p\"���!)�" [fname nil buffer-file-name do-get-pad haskell-mode-error "Not in a .hs buffer"] 4))
460 
+
461 
+(defun do-get-pad (fname buff) (byte-code "�	!�
462 
+���\"�\"�?��!�?�7�!���!���
!���#��
!�� +�" [mname buff nil pname fname pbuff get-modname read-no-blanks-input "Scratch pad for module? " lookup-pad get-buffer get-padname generate-new-buffer buffer-name record-pad-mapping pop-to-buffer haskell-mode] 11))
463 
+
464 
+(defun haskell-switch nil "\
465 
+Switches to *haskell* buffer" (interactive) (byte-code "��� ��!�" [t nil haskell-maybe-create-process switch-to-haskell] 3))
466 
+
467 
+(defun switch-to-haskell (eob-p) "\
468 
+Really switch to the *haskell* buffer.
469 
+With argument, positions cursor at end of buffer." (interactive "P") (byte-code "ˆ�!�	�� �db�" [*haskell-buffer* eob-p nil pop-to-buffer push-mark] 3))
470 
+
471 
+(defun haskell-command (str) "\
472 
+Format STRING as a haskell command and send it to haskell process.  \\[haskell-command]" (interactive "sHaskell command: ") (byte-code "�����H!=�� �#��P!���P!����Q!�" [str nil 81 capitalize 0 ci-quit haskell-begin-interaction "Executing command: :" haskell-send-command ":" haskell-end-interaction "  ...done."] 8))
473 
+
474 
+(defun haskell-eval nil "\
475 
+Evaluate expression in current module. \\[haskell-eval]" (interactive) (byte-code "��� ����!��#�" [nil haskell-maybe-create-process haskell-eval-aux get-haskell-expression "Haskell expression: " "Evaluating"] 6))
476 
+
477 
+(defun haskell-run nil "\
478 
+Run Haskell Dialogue in current module" (interactive) (byte-code "��� ����!��#�" [t nil haskell-maybe-create-process haskell-eval-aux get-haskell-expression "Haskell dialogue: " "Running"] 6))
479 
+
480 
+(defun haskell-run-main nil "\
481 
+Run Dialogue named main in current module" (interactive) (byte-code "��� ����#�" [t nil haskell-maybe-create-process haskell-eval-aux "main" "Running"] 5))
482 
+
483 
+(defun haskell-eval-aux (exp dialogue-p what) (byte-code "�� \"�(
484 
+��	#�		

485 
+&,���� \"�V� �p!�
\"��	#�		

486 
+&,��� ��� �p!�
\"���
!	$�		

487 
+&,���p!�	!�	!��		$�		

488 
+&,�" [*haskell-buffer* pname *last-pad* mname *last-module* fname *last-loaded* msg what exp dialogue-p *ht-temp-buffer* t equal buffer-name format "%s: %s" haskell-eval-aux-aux buffer-file-name get-modname lookup-pad "%s (in tutorial): %s" "%s (in file %s): %s" file-name-nondirectory get-module-from-pad get-file-from-pad "%s (in pad %s): %s"] 29))
489 
+
490 
+(defun haskell-eval-aux-aux (exp pname mname fname msg dialogue-p) (byte-code "�!�� ��	!��
491 
+!���!��!�
!�$�
!�� ���P!�" [msg fname mname pname dialogue-p exp haskell-begin-interaction ci-kill haskell-load-file-if-modified ci-module haskell-save-pad-if-modified ci-send-name ci-print-exp ci-eval haskell-end-interaction "  ...done."] 11))
492 
+
493 
+(defun haskell-save-pad-if-modified (pad) (byte-code "�q��	\"�
� �!��� ��!��!�� )�" [pad haskell-main-pad *last-pad* equal buffer-modified-p ci-clear ci-set-file ci-send-buffer ci-save] 7))
494 
+
495 
+(defun haskell-run-file nil "\
496 
+Run all Dialogues in current file" (interactive) (byte-code "ˆ� ��� \"���!�&� ��� !�&���p!!!�" [*haskell-buffer* t nil haskell-maybe-create-process equal buffer-name call-interactively haskell-run-file/process buffer-file-name haskell-run-file-aux get-file-from-pad] 11))
497 
+
498 
+(defun haskell-run-file/process (filename) (interactive (byte-code "��	�$�" [haskell-prev-l/c-dir/file haskell-source-modes t comint-get-source "Haskell file to run:  "] 5)) (byte-code "Ĉ�!��!�!B���!�" [haskell-prev-l/c-dir/file haskell-source-modes t filename nil comint-check-source file-name-directory file-name-nondirectory haskell-run-file-aux] 5))
499 
+
500 
+(defun haskell-run-file-aux (fname) (byte-code "�	P�!�� ��
501 
+!���	!!���P!)�" [msg fname buffer-file-name "Running file: " haskell-begin-interaction ci-kill save-modified-source-files ci-run strip-fext haskell-end-interaction "  ...done."] 8))
502 
+
503 
+(defun haskell-load nil "\
504 
+Load current file" (interactive) (byte-code "� �� �P� �	!��!��	�P!�#��!*�" [fname msg t nil haskell-maybe-create-process buffer-file-name "Loading file: " haskell-begin-interaction haskell-load-file-if-modified haskell-end-interaction "  ...done." haskell-mode-error "Must be in a file to load"] 7))
505 
+
506 
+(defun haskell-load-file-if-modified (filename) (byte-code "�!��
507 
+\"�
508 
+��� �	����	!!�" [buffer-file-name filename haskell-main-file *last-loaded* t save-modified-source-files string= ci-load-main ci-load strip-fext] 6))
509 
+
510 
+(defun haskell-compile nil "\
511 
+Compile current file" (interactive) (byte-code "ˆ� �� ���P!��!����Q!�\"��!)�" [fname t nil haskell-maybe-create-process buffer-file-name haskell-begin-interaction "Compiling: " haskell-compile-file-if-modified haskell-end-interaction "  ...done." haskell-mode-error "Must be in a file to compile"] 8))
512 
+
513 
+(defun haskell-compile-file-if-modified (fname) (byte-code "�!���	!!�" [buffer-file-name fname save-modified-source-files ci-compile strip-fext] 4))
514 
+
515 
+(defun haskell-exit nil "\
516 
+Quit the haskell process" (interactive) (byte-code "��� ���!��q��!)��
517 
+!��
518 
+!�" [*ht-temp-buffer* nil *haskell-buffer* ci-quit get-buffer set-buffer-modified-p bury-buffer replace-buffer-in-windows] 6))
519 
+
520 
+(defun haskell-interrupt nil "\
521 
+Interrupt the haskell process" (interactive) (byte-code "����!���!�" [nil haskell-send-command-aux "" haskell-end-interaction "done."] 3))
522 
+
523 
+(defun haskell-edit-unit nil "\
524 
+Edit the .hu file." (interactive) (byte-code "� �1�C�� �!�
525 
+�-���!�!\"�+�!�,!+�4��!)�" [fname find-file-not-found-hooks file-not-found nil units-fname buffer-file-name haskell-new-unit haskell-get-unit-file find-file-other-window units-add-source-file string= file-name-directory file-name-nondirectory haskell-mode-error "Not in a .hs buffer"] 10))
526 
+
527 
+(defun haskell-new-unit nil (byte-code "���" [file-not-found t] 2))
528 
+
529 
+(defun units-add-source-file (file) (byte-code "���!�\")�" [file insert strip-fext "
530 
+"] 4))
531 
+
532 
+(defun haskell-get-unit-file nil (byte-code "��� ���d�#���!� ��`\"�)�'�� !�P�)�)�" [name nil t beg beginning-of-buffer re-search-forward "-- unit:[ 	]*" match-end 0 end-of-line buffer-substring strip-fext buffer-file-name ".hu"] 9))
533 
+
534 
+(defun haskell-please-recover nil (interactive) (byte-code "��� ���!�" [nil haskell-flush-commands-and-reset haskell-end-interaction "done."] 3))
535 
+
536 
+(defvar haskell-menu-mode-map nil "\
537 
+")
538 
+
539 
+(if (not haskell-menu-mode-map) (progn (setq haskell-menu-mode-map (make-keymap)) (suppress-keymap haskell-menu-mode-map t) (define-key haskell-menu-mode-map "m" (quote haskell-menu-mark)) (define-key haskell-menu-mode-map "u" (quote haskell-menu-unmark)) (define-key haskell-menu-mode-map "x" (quote haskell-menu-exit)) (define-key haskell-menu-mode-map "q" (quote haskell-menu-exit)) (define-key haskell-menu-mode-map " " (quote next-line)) (define-key haskell-menu-mode-map "" (quote haskell-menu-backup-unmark)) (define-key haskell-menu-mode-map "?" (quote describe-mode))))
540 
+
541 
+(put (quote haskell-menu-mode) (quote mode-class) (quote special))
542 
+
543 
+(defun haskell-menu-mode nil "\
544 
+Major mode for editing Haskell flags.
545 
+Each line describes a flag.
546 
+Letters do not insert themselves; instead, they are commands.
547 
+m -- mark flag (turn it on)
548 
+u -- unmark flag (turn it off)
549 
+x -- exit; tell the Haskell process to update the flags, then leave menu.
550 
+q -- exit; same as x.
551 
+Precisely,\\{haskell-menu-mode-map}" (byte-code "� ��!�‰�‰�ȉ�ɉ���!���!���!���!�" [haskell-menu-mode-map truncate-lines t buffer-read-only major-mode mode-name kill-all-local-variables use-local-map haskell-menu-mode "Haskell Flags Menu" make-local-variable haskell-menu-current-flags haskell-menu-request-fn haskell-menu-update-fn run-hooks haskell-menu-mode-hook] 7))
552 
+
553 
+(defun haskell-menu (help-file buffer request-fn update-fn) (byte-code "� ��!��!�eb�$�!��	!�� ���
��� ���!�" [buffer help-file haskell-menu-request-fn request-fn haskell-menu-update-fn update-fn haskell-maybe-create-process get-buffer pop-to-buffer insert-file-contents haskell-menu-mode haskell-menu-mark-current message "m = mark; u = unmark; x = execute; q = quit; ? = more help."] 9))
554 
+
555 
+(defvar *haskell-menu-marked* " on")
556 
+
557 
+(defvar *haskell-menu-unmarked* "   ")
558 
+
559 
+(defvar *haskell-menu-marked-regexp* " on   \\w")
560 
+
561 
+(defvar *haskell-menu-unmarked-regexp* "      \\w")
562 
+
563 
+(defun haskell-menu-mark nil "\
564 
+Mark flag to be turned on." (interactive) (byte-code "� ��!���!�+�	!�(��G!�
c���!)�+��!�" [*haskell-menu-marked-regexp* *haskell-menu-unmarked-regexp* buffer-read-only nil *haskell-menu-unmarked* *haskell-menu-marked* t beginning-of-line looking-at forward-line 1 delete-char] 8))
565 
+
566 
+(defun haskell-menu-unmark nil "\
567 
+Unmark flag." (interactive) (byte-code "� ��!���!�+�	!�(��G!�
c���!)�+��!�" [*haskell-menu-unmarked-regexp* *haskell-menu-marked-regexp* buffer-read-only nil *haskell-menu-marked* *haskell-menu-unmarked* t beginning-of-line looking-at forward-line 1 delete-char] 8))
568 
+
569 
+(defun haskell-menu-backup-unmark nil "\
570 
+Move up and unmark." (interactive) (byte-code "����!�� ���!�" [nil forward-line -1 haskell-menu-unmark] 4))
571 
+
572 
+(defun haskell-menu-exit nil "\
573 
+Update flags, then leave menu." (interactive) (byte-code "��� �� �" [nil haskell-menu-execute haskell-menu-quit] 3))
574 
+
575 
+(defun haskell-menu-execute nil "\
576 
+Tell haskell process to tweak flags." (interactive) (byte-code "ˆ� ��eb�`d=?�7�!��	� �#�/�!�.�	� �#�/ˆ��!��	)�� �" [*haskell-menu-unmarked-regexp* haskell-menu-update-fn nil *haskell-menu-marked-regexp* t start-setting-flags looking-at funcall haskell-menu-flag forward-line 1 finish-setting-flags] 11))
577 
+
578 
+(defun haskell-menu-quit nil (interactive) (byte-code "�����p!��p!�" [nil "Make the menu go away." bury-buffer replace-buffer-in-windows] 3))
579 
+
580 
+(defun haskell-menu-flag nil (byte-code "�� ���!�`��!����!\"))�" [beg beginning-of-line forward-char 6 re-search-forward "	\\|  " buffer-substring match-beginning 0] 7))
581 
+
582 
+(defun start-setting-flags nil (byte-code "��" [nil] 1))
583 
+
584 
+(defun finish-setting-flags nil (byte-code "��!�" [haskell-end-interaction "Setting flags....done."] 2))
585 
+
586 
+(defun haskell-menu-mark-current nil (byte-code "�!��eb�`d=?�;�	!��� !�!� �7�
587 
+!�,�� !?�4� �7��!��)�" [haskell-menu-request-fn *haskell-menu-unmarked-regexp* *haskell-menu-marked-regexp* t funcall looking-at menu-item-currently-on-p haskell-menu-flag haskell-menu-mark haskell-menu-unmark forward-line 1] 12))
588 
+
589 
+(defun menu-item-currently-on-p (item) (byte-code "�	\"�" [item haskell-menu-current-flags member-string=] 3))
590 
+
591 
+(defun member-string= (item list) (byte-code "?�	���
592 
+@\"���
593 
+A\"�" [list nil item t string= member-string=] 4))
594 
+
595 
+(defvar *haskell-printers-help* (concat (getenv "HASKELL") "/emacs-tools/printer-help.txt") "\
596 
+Help file for printers.")
597 
+
598 
+(defvar *haskell-printers-buffer* "*Haskell printers*")
599 
+
600 
+(defun haskell-printers nil "\
601 
+Set printers interactively." (interactive) (byte-code "ˆ�	��$�" [*haskell-printers-help* *haskell-printers-buffer* nil haskell-menu get-current-printers set-current-printers] 5))
602 
+
603 
+(defun get-current-printers nil (byte-code "�����!��=���!���" [haskell-menu-current-flags t haskell-send-command ":p?" sleep-for 1] 4))
604 
+
605 
+(defun update-printers-list (data) (byte-code "�	!��" [haskell-menu-current-flags data read] 3))
606 
+
607 
+(defun set-current-printers (flag on) (byte-code "�	!
608 
+�
609 
+?����	\"!�)
610 
+?��(���	\"!�)�)�" [was-on flag on t nil menu-item-currently-on-p haskell-send-command format ":p+ %s" ":p- %s"] 7))
611 
+
612 
+(defvar *haskell-optimizers-help* (concat (getenv "HASKELL") "/emacs-tools/optimizer-help.txt") "\
613 
+Help file for optimizers.")
614 
+
615 
+(defvar *haskell-optimizers-buffer* "*Haskell optimizers*")
616 
+
617 
+(defun haskell-optimizers nil "\
618 
+Set optimizers interactively." (interactive) (byte-code "ˆ�	��$�" [*haskell-optimizers-help* *haskell-optimizers-buffer* nil haskell-menu get-current-optimizers set-current-optimizers] 5))
619 
+
620 
+(defun get-current-optimizers nil (byte-code "�����!��=���!���" [haskell-menu-current-flags t haskell-send-command ":o?" sleep-for 1] 4))
621 
+
622 
+(defun update-optimizers-list (data) (byte-code "�	!��" [haskell-menu-current-flags data read] 3))
623 
+
624 
+(defun set-current-optimizers (flag on) (byte-code "�	!
625 
+�
626 
+?����	\"!�)
627 
+?��(���	\"!�)�)�" [was-on flag on t nil menu-item-currently-on-p haskell-send-command format ":o+ %s" ":o- %s"] 7))
628 
+
629 
+(defvar *pad-mappings* nil "\
630 
+Associates pads with their corresponding module and file.")
631 
+
632 
+(defun record-pad-mapping (pname mname fname) (byte-code "
633 
+EB��" [*pad-mappings* pname mname fname] 3))
634 
+
635 
+(defun get-module-from-pad (pname) (byte-code "�	\"A@�" [pname *pad-mappings* assoc] 3))
636 
+
637 
+(defun get-file-from-pad (pname) (byte-code "�	\"AA@�" [pname *pad-mappings* assoc] 3))
638 
+
639 
+(defun lookup-pad (mname fname) (byte-code "�
640 
+#�" [mname fname *pad-mappings* lookup-pad-aux] 4))
641 
+
642 
+(defun lookup-pad-aux (mname fname list) (byte-code "?�	��*�
643 
+@A@\"��@AA@\"�$@@�*�
644 
+A#�" [list nil mname fname t equal lookup-pad-aux] 6))
645 
+
646 
+(defvar *ask-before-saving* t)
647 
+
648 
+(defun save-modified-source-files (filename) (byte-code "� ��O@�!�;�q��:�!�:ʼn�:?�:�\"�:���\"!)�E�q�� ))�A����	�Z��!�]��!*�" [buffers found-any nil buffer buffer-file-name t *ask-before-saving* filename buffer-list buffer-modified-p source-file-p string= y-or-n-p format "Save file %s? " save-buffer message "" "(No files need saving)"] 10))
649 
+
650 
+(defun source-file-p (filename) (byte-code "��\"�'��\"�'��\"�'��\"�'��\"�'��\"�" [filename string-match "\\.hs$" "\\.lhs$" "\\.hu$" "\\.shu$" "\\.hsp$" "\\.prim$"] 8))
651 
+
652 
+(defun haskell-move-marker nil "\
653 
+Moves the marker and point to the end of buffer" (byte-code "�d\"�����!!d\"�db�" [comint-last-input-end set-marker process-mark get-process "haskell"] 6))
654 
+
655 
+(defun create-main-pad nil (byte-code "�	!�q�� )��
656 
+#�)�" [buffer haskell-main-pad haskell-main-module haskell-main-file get-buffer-create haskell-mode record-pad-mapping] 6))
657 
+
658 
+(defvar *re-module* "^module\\s *\\|^>\\s *module\\s *")
659 
+
660 
+(defvar *re-modname* "[A-Z]\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\)*")
661 
+
662 
+(defun get-modname (buff) "\
663 
+Get module name in BUFFER that point is in." (byte-code "�q��	!��	e�#��	d�#�6��!b��!�0���!��!\"�3��!�7�)�" [buff *re-module* t *re-modname* looking-at re-search-backward re-search-forward match-end 0 buffer-substring match-beginning haskell-mode-error "Module name not found!!" "Main"] 10))
664 
+
665 
+(defun get-padname (m) "\
666 
+Build padname from module name" (byte-code "��Q�" [m "*" "-pad*"] 3))
667 
+
668 
+(defvar *haskell-filename-regexp* "\\(.*\\)\\.\\(hs\\|lhs\\)$")
669 
+
670 
+(defun strip-fext (filename) "\
671 
+Strip off the extension from a filename." (byte-code "�	\"�	��!��!O�	�" [*haskell-filename-regexp* filename string-match match-beginning 1 match-end] 6))
672 
+
673 
+(defun haskell-mode-error (msg) "\
674 
+Show MSG in message line as an error from the haskell mode" (byte-code "��P!�" [msg error "Haskell mode:  "] 3))
675 
+
676 
+(defun ci-send-buffer (buff) "\
677 
+Send BUFFER to haskell process." (byte-code "� ��\"?��	q��!))�" [str buff buffer-string string-match "\\`\\s *\\'" haskell-send-command] 4))
678 
+
679 
+(defun ci-kill nil (byte-code "��!�" [haskell-send-command ":kill"] 2))
680 
+
681 
+(defun ci-clear nil (byte-code "��!�" [haskell-send-command ":clear"] 2))
682 
+
683 
+(defun ci-set-file (file-name) (byte-code "��P!�" [file-name haskell-send-command ":file "] 3))
684 
+
685 
+(defun ci-module (modname) (byte-code "	����	P!�" [*last-module* modname haskell-send-command ":module "] 3))
686 
+
687 
+(defun ci-load (filename) (byte-code "��P!�" [filename haskell-send-command ":load "] 3))
688 
+
689 
+(defun ci-load-main nil (byte-code "��!�" [haskell-send-command ":Main"] 2))
690 
+
691 
+(defun ci-save nil (byte-code "��!�" [haskell-send-command ":save"] 2))
692 
+
693 
+(defun ci-compile (filename) (byte-code "��P!�" [filename haskell-send-command ":compile "] 3))
694 
+
695 
+(defun ci-run (filename) (byte-code "��P!�" [filename haskell-send-command ":run "] 3))
696 
+
697 
+(defun ci-print-exp (exp) (byte-code "��!���P!�" [exp ci-set-file "interactive-expression-buffer" haskell-send-command "= "] 4))
698 
+
699 
+(defun ci-send-name (name) (byte-code "��!��!���	Q!)�" [temp name make-temp-name "etemp" ci-set-file "interactive-expression-buffer" haskell-send-command " = "] 6))
700 
+
701 
+(defun ci-eval nil (byte-code "��!�" [haskell-send-command ":eval"] 2))
702 
+
703 
+(defun ci-quit nil (byte-code "�!?�
��!���!����\"���!�‡" [*haskell-buffer* t nil get-buffer-process message "No process currently running." y-or-n-p "Do you really want to quit Haskell? " process-send-string "haskell" ":quit
704 
+" set-haskell-status dead] 6))
705 
+
706 
+(defun ci-emacs nil (byte-code "� ����!�\"���!�" [haskell-reset set-process-filter get-process "haskell" process-haskell-output haskell-send-command ":Emacs on"] 5))
707 
+
708 
+(defun haskell-get-old-input nil "\
709 
+Get old input text from Haskell process buffer." (byte-code "��d�#�
��!b��e�#�#� �`� ��
710 
+`\"))�" [haskell-prompt-pattern t temp re-search-forward move match-beginning 0 re-search-backward comint-skip-prompt end-of-line buffer-substring] 8))
711 
+
712 
+(defun haskell-send-input nil "\
713 
+Send input to Haskell while in the process buffer" (interactive) (byte-code "���� �
� �" [*emacs* nil haskell-send-input-aux comint-send-input] 3))
714 
+
715 
+(defun haskell-send-input-aux nil (byte-code "�p!?���!�Y�!�	!`
716 
+Y�$�	`\"�0�
!	b�c�)�c��\"�A�\"��\"���!`\"��	`\"��!+)�" [proc pmark pmark-val input copy comint-get-old-input comint-input-filter input-ring comint-input-sentinel comint-last-input-end get-buffer-process haskell-mode-error "Current buffer has no process" process-mark marker-position buffer-substring funcall 10 ring-insert set-marker haskell-send-data] 14))
717 
+
718 
+(defvar haskell-minibuffer-local-map nil "\
719 
+Local map for minibuffer when in Haskell")
720 
+
721 
+(if haskell-minibuffer-local-map nil (progn (setq haskell-minibuffer-local-map (full-copy-sparse-keymap minibuffer-local-map)) (define-key haskell-minibuffer-local-map "p" (quote haskell-previous-input)) (define-key haskell-minibuffer-local-map "n" (quote haskell-next-input))))
722 
+
723 
+(defun haskell-previous-input (arg) "\
724 
+Cycle backwards through input history." (interactive "*p") (byte-code "Lj�	!�X���!�� �V�=�'�� `\"��`!�B
�V�1т<
�W�;҂<ɉ��`!��
\\\"���	\"c�͉)�" [len haskell-prompt-ring t last-command input-ring-index arg this-command nil ring-length 0 message "Empty input ring" ding haskell-previous-input delete-region mark set-mark -1 1 push-mark comint-mod ring-ref] 11))
725 
+
726 
+(defun haskell-next-input (arg) "\
727 
+Cycle forwards through input history." (interactive "*p") (byte-code "���[!�" [arg nil haskell-previous-input] 2))
728 
+
729 
+(defvar haskell-last-input-match "" "\
730 
+Last string searched for by Haskell input history search, for defaulting.
731 
+Buffer local variable.")
732 
+
733 
+(defun haskell-previous-input-matching (str) "\
734 
+Searches backwards through input history for substring match" (interactive (byte-code "���	\"!��\"�	�C)�" [s haskell-last-input-match read-from-minibuffer format "Command substring (default %s): " string= ""] 5)) (byte-code "Lj
735 
+���
736 
+!�!�
X��
737 
+�
\"\"?�*
�\\����
X�9�
�\\!�<��!+�" [s haskell-last-input-match str len haskell-prompt-ring n t nil regexp-quote ring-length 0 string-match ring-ref 1 haskell-previous-input haskell-mode-error "Not found."] 7))
738 
+
739 
+(defun get-haskell-expression (prompt) (byte-code "�	�#�\"�)�" [exp prompt nil haskell-minibuffer-local-map haskell-prompt-ring read-from-minibuffer ring-insert] 4))
740 
+
741 
+(defvar haskell-load-hook nil "\
742 
+This hook is run when haskell is loaded in.
743 
+This is a good place to put key bindings.")
744 
+
745 
+(run-hooks (quote haskell-load-hook))
746 
+
747 
+(defvar ht-mode-map nil)
748 
+
749 
+(if ht-mode-map nil (progn (setq ht-mode-map (make-sparse-keymap)) (haskell-establish-key-bindings ht-mode-map) (define-key ht-mode-map "" (quote ht-next-page)) (define-key ht-mode-map "" (quote ht-prev-page)) (define-key ht-mode-map "" (quote ht-restore-page)) (define-key ht-mode-map "?" (quote describe-mode))))
750 
+
751 
+(defun haskell-tutorial-mode nil "\
752 
+Major mode for running the Haskell tutorial.
753 
+You can use these commands:
754 
+\\{ht-mode-map}" (interactive) (byte-code "Ĉ� ��!�lj�ȉ��!���!�" [ht-mode-map major-mode mode-name haskell-mode-syntax-table nil kill-all-local-variables use-local-map haskell-tutorial-mode "Haskell Tutorial" set-syntax-table run-hooks haskell-mode-hook] 5))
755 
+
756 
+(defun haskell-tutorial nil "\
757 
+Run the haskell tutorial." (interactive) (byte-code "��� �� �� �" [nil ht-load-tutorial ht-make-buffer ht-display-page] 4))
758 
+
759 
+(defun ht-load-tutorial nil (byte-code "�	!��q�� )�/��	!�q��!�
760 
+!�*�
761 
+!�-��!)))�" [buffer *ht-file-buffer* fname *ht-source-file* get-buffer beginning-of-buffer get-buffer-create substitute-in-file-name file-readable-p ht-load-tutorial-aux call-interactively] 8))
762 
+
763 
+(defun ht-load-tutorial-aux (filename) (interactive "fTutorial file: ") (byte-code "���!��!��� �" [filename nil buffer-read-only t insert-file set-buffer-modified-p beginning-of-buffer] 4))
764 
+
765 
+(defun ht-make-buffer nil (byte-code "����!�Q!�� ��� �" [*ht-temp-buffer* find-file "/tmp/" make-temp-name "ht" ".hs" buffer-name haskell-tutorial-mode] 5))
766 
+
767 
+(defun ht-next-page nil "\
768 
+Go to the next tutorial page." (interactive) (byte-code "��� �� �� �" [nil ht-goto-next-page ht-display-page beep] 4))
769 
+
770 
+(defun ht-goto-next-page nil (byte-code "pĎ	q�����#))�" [buff *ht-file-buffer* nil t ((byte-code "q�" [buff] 1)) search-forward ""] 4))
771 
+
772 
+(defun ht-prev-page nil "\
773 
+Go to the previous tutorial page." (interactive) (byte-code "��� �� �� �" [nil ht-goto-prev-page ht-display-page beep] 4))
774 
+
775 
+(defun ht-goto-prev-page nil (byte-code "pĎ	q�����#))�" [buff *ht-file-buffer* nil t ((byte-code "q�" [buff] 1)) search-backward ""] 4))
776 
+
777 
+(defun ht-goto-page (arg) "\
778 
+Go to the tutorial page specified as the argument." (interactive "sGo to page: ") (byte-code "�����\"!�� �� �" [arg nil ht-searchfor-page format "-- Page %s " ht-display-page beep] 5))
779 
+
780 
+(defun ht-goto-section (arg) "\
781 
+Go to the tutorial section specified as the argument." (interactive "sGo to section: ") (byte-code "�����\"!�� �� �" [arg nil ht-searchfor-page format "-- Section %s " ht-display-page beep] 5))
782 
+
783 
+(defun ht-searchfor-page (search-string) (byte-code "pƎ	q�`� ����#�ł
784 
+b��)))�" [buff *ht-file-buffer* point search-string nil t ((byte-code "q�" [buff] 1)) beginning-of-buffer search-forward] 5))
785 
+
786 
+(defun ht-restore-page nil (interactive) (byte-code "��`� �b)�" [old-point nil ht-display-page] 2))
787 
+
788 
+(defun ht-display-page nil (byte-code "q�����#���!�� �`����#�#� �%� �`�	\"q�� �
c�� +�" [*ht-file-buffer* beg nil t end text *ht-temp-buffer* search-backward "" forward-line 1 beginning-of-buffer search-forward beginning-of-line end-of-buffer buffer-substring erase-buffer] 10))
emacs-tools/optimizer-help.txt
History View file @ 4e98702
0 789 
new file mode 100644
... ... 
@@ -0,0 +1,5 @@
1 
+Optimizer switches
2 
+      inline         Aggressively inline functions
3 
+      constant       Hoist constant expressions to top-level
4 
+      foldr          Perform foldr/build deforestation
5 
+      lisp           Tell the Lisp compiler to work hard to produce best code
emacs-tools/printer-help.txt
History View file @ 4e98702
0 6 
new file mode 100644
... ... 
@@ -0,0 +1,24 @@
1 
+General messages
2 
+      compiling       Printed when the compilation system starts a compilation
3 
+      loading         Printed when a previously compiled unit is loaded
4 
+      reading         Prints the name of the file being parsed
5 
+      extension       Enables printing withinn extensions
6 
+Timings
7 
+      time            Prints the time that it takes to execute a computation
8 
+      phase-time      Prints the time of each phase of compilation
9 
+Compiler passes
10 
+      parse           Prints the program recreated from ast
11 
+      import          Lists all symbols imported and exported for each module
12 
+      scope           Print the program after scoping and precedence parsing
13 
+      depend          Prints entire program in nested let's
14 
+      type            Prints signatures during inference
15 
+      cfn             Prints entire program after context free normalization
16 
+      depend2         Like depend
17 
+      flic            Prints entire program as flic code
18 
+      optimize        Prints entire program as optimized flic code
19 
+      optimize-extra  Prints extra verbose information during optimization
20 
+      strictness      Print strictness of all functions and variables
21 
+      codegen         Prints generated Lisp code
22 
+      codegen-flic    Prints generated Lisp code and associated flic code
23 
+      dumper          Prints the code in the interface
24 
+      dump-stat       Prints statistics for the interface file
flic/README
History View file @ 4e98702
0 25 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+This directory contains code to define FLIC structures and associated
2 
+pretty-printers, and the traversal to convert AST to FLIC structures.
flic/ast-to-flic.scm
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,277 @@
1 
+;;; ast-to-flic.scm -- convert AST to flic structures.
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  3 Apr 1992
5 
+;;;
6 
+;;;
7 
+
8 
+
9 
+;;; ====================================================================
10 
+;;; Support
11 
+;;; ====================================================================
12 
+
13 
+
14 
+(define-walker ast-to-flic ast-td-ast-to-flic-walker)
15 
+
16 
+(define-local-syntax (define-ast-to-flic ast-type lambda-list . body)
17 
+  `(define-walker-method ast-to-flic ,ast-type ,lambda-list ,@body))
18 
+
19 
+(define (ast-to-flic big-let)
20 
+  (ast-to-flic-let-aux (let-decls big-let) (make-flic-void) '#t))
21 
+
22 
+(define (ast-to-flic-1 ast-node)
23 
+  (call-walker ast-to-flic ast-node))
24 
+
25 
+(define (ast-to-flic/list l)
26 
+  (map (function ast-to-flic-1) l))
27 
+
28 
+(define (init-flic-var var value toplevel?)
29 
+  (setf (var-value var) value)
30 
+  (setf (var-toplevel? var) toplevel?)
31 
+  (setf (var-simple? var)
32 
+	(and value
33 
+	     (or (is-type? 'flic-const value)
34 
+		 (is-type? 'flic-pack value))))
35 
+  (setf (var-strict? var) '#f)
36 
+  ;; Remember the strictness annotation.
37 
+  (let ((strictness-ann (lookup-annotation var '|Strictness|)))
38 
+    (setf (var-strictness var)
39 
+	  (if strictness-ann
40 
+	      (adjust-annotated-strictness var
41 
+		(parse-strictness (car (annotation-value-args strictness-ann))))
42 
+	      '#f)))
43 
+  ;; If the variable has an inline annotation, rewrite its value
44 
+  ;; from var = value
45 
+  ;; to   var = let temp = value in temp
46 
+  ;; (Necessary for inlining recursive definitions.)
47 
+  (let ((inline-ann (lookup-annotation var '|Inline|)))
48 
+    (when inline-ann
49 
+      (setf (var-force-inline? var) '#t)
50 
+      (setf (var-value var) (wrap-with-let var value))))
51 
+  var)
52 
+
53 
+(define (wrap-with-let var value)
54 
+  (let ((temp  (copy-temp-var (def-name var))))
55 
+    (init-flic-var temp (copy-flic value (list (cons var temp))) '#f)
56 
+    (make-flic-let (list temp) (make-flic-ref temp) '#t)))
57 
+
58 
+
59 
+;;; ====================================================================
60 
+;;; ast expression structs
61 
+;;; ====================================================================
62 
+
63 
+
64 
+(define-ast-to-flic lambda (object)
65 
+  (make-flic-lambda
66 
+    (map (lambda (pat)
67 
+	   (init-flic-var
68 
+	     (cond ((var-pat? pat)
69 
+		    (var-ref-var (var-pat-var pat)))
70 
+		   (else
71 
+		    (error "Bad lambda pattern: ~s." pat)))
72 
+	     '#f
73 
+	     '#f))
74 
+	 (lambda-pats object))
75 
+    (ast-to-flic-1 (lambda-body object))))
76 
+
77 
+
78 
+;;; For LET, the CFN has turned all of the definitions into
79 
+;;; simple assignments to a variable.  The dependency analyzer
80 
+;;; adds recursive-decl-groups for things which need to be bound
81 
+;;; with LETREC.
82 
+
83 
+(define-ast-to-flic let (object)
84 
+  (ast-to-flic-let-aux
85 
+    (let-decls object)
86 
+    (ast-to-flic-1 (let-body object))
87 
+    '#f))
88 
+
89 
+(define (ast-to-flic-let-aux decls body toplevel?)
90 
+  (multiple-value-bind (bindings newbody)
91 
+      (ast-to-flic-bindings decls body toplevel?)
92 
+    (if (null? bindings)
93 
+	newbody
94 
+	(make-flic-let bindings newbody toplevel?))))
95 
+
96 
+(define (ast-to-flic-bindings decls body toplevel?)
97 
+  (if (null? decls)
98 
+      (values '() body)
99 
+      (multiple-value-bind (bindings newbody)
100 
+	  (ast-to-flic-bindings (cdr decls) body toplevel?)
101 
+	(cond ((is-type? 'valdef (car decls))
102 
+	       ;; Continue collecting bindings.
103 
+	       (let* ((decl  (car decls))
104 
+		      (pat   (valdef-lhs decl))
105 
+		      (exp   (single-definition-rhs decl)))
106 
+		 (values
107 
+		  (cond ((var-pat? pat)
108 
+			 (cons
109 
+			   (init-flic-var
110 
+			    (var-ref-var (var-pat-var pat))
111 
+			    (ast-to-flic-1 exp)
112 
+			    toplevel?)
113 
+			   bindings))
114 
+			(else
115 
+			 (error "Definition has invalid pattern: ~s." decl)))
116 
+		  newbody)))
117 
+	      ((not (is-type? 'recursive-decl-group (car decls)))
118 
+	       (error "Decl has weird value: ~s." (car decls)))
119 
+	      (toplevel?
120 
+	       ;; We don't do any of this mess with top level bindings.
121 
+	       ;; Turn it into one big letrec.
122 
+	       (multiple-value-bind (more-bindings newerbody)
123 
+		   (ast-to-flic-bindings
124 
+		     (recursive-decl-group-decls (car decls))
125 
+		     newbody
126 
+		     toplevel?)
127 
+		 (values (nconc more-bindings bindings)
128 
+			 newerbody)))
129 
+	      (else
130 
+	       ;; Otherwise, turn remaining bindings into a nested
131 
+	       ;; let or letrec, and put that in the body of a new
132 
+	       ;; letrec.
133 
+	       (multiple-value-bind (more-bindings newerbody)
134 
+		   (ast-to-flic-bindings
135 
+		     (recursive-decl-group-decls (car decls))
136 
+		     (if (null? bindings)
137 
+			 newbody
138 
+			 (make-flic-let bindings newbody '#f))
139 
+		     toplevel?)
140 
+		 (values
141 
+		   '()
142 
+		   (if (null? more-bindings)
143 
+		       newerbody
144 
+		       (make-flic-let more-bindings newerbody '#t)))))
145 
+	      ))))
146 
+
147 
+
148 
+(define (single-definition-rhs decl)
149 
+  (let* ((def-list  (valdef-definitions decl))
150 
+	 (def       (car def-list))
151 
+	 (rhs-list  (single-fun-def-rhs-list def))
152 
+	 (rhs       (car rhs-list)))
153 
+    ;; All of this error checking could be omitted for efficiency, since
154 
+    ;; none of these conditions are supposed to happen anyway.
155 
+    (cond ((not (null? (cdr def-list)))
156 
+	   (error "Decl has multiple definitions: ~s." decl))
157 
+	  ((not (null? (single-fun-def-where-decls def)))
158 
+	   (error "Definition has non-null where-decls list: ~s." decl))
159 
+	  ((not (null? (cdr rhs-list)))
160 
+	   (error "Definition has multiple right-hand-sides: ~s." decl))
161 
+	  ((not (is-type? 'omitted-guard (guarded-rhs-guard rhs)))
162 
+	   (error "Definition has a guard: ~s." decl)))
163 
+    (guarded-rhs-rhs rhs)))
164 
+
165 
+
166 
+
167 
+;;; These are all straightforward translations.
168 
+
169 
+(define-ast-to-flic if (object)
170 
+  (make-flic-if
171 
+    (ast-to-flic-1 (if-test-exp object))
172 
+    (ast-to-flic-1 (if-then-exp object))
173 
+    (ast-to-flic-1 (if-else-exp object))))
174 
+
175 
+(define-ast-to-flic case-block (object)
176 
+  (make-flic-case-block
177 
+    (case-block-block-name object)
178 
+    (ast-to-flic/list (case-block-exps object))))
179 
+
180 
+(define-ast-to-flic return-from (object)
181 
+  (make-flic-return-from
182 
+    (return-from-block-name object)
183 
+    (ast-to-flic-1 (return-from-exp object))))
184 
+
185 
+(define-ast-to-flic and-exp (object)
186 
+  (make-flic-and (ast-to-flic/list (and-exp-exps object))))
187 
+
188 
+
189 
+;;; Applications.  Uncurry here.  It's more convenient to do the
190 
+;;; optimizer on fully uncurried applications.  After the optimizer
191 
+;;; has run, all applications are adjusted based on observed arity
192 
+;;; of the functions and the saturated? flag is set correctly.
193 
+
194 
+(define-ast-to-flic app (object)
195 
+  (ast-to-flic-app-aux object '()))
196 
+
197 
+(define (ast-to-flic-app-aux object args)
198 
+  (if (is-type? 'app object)
199 
+      (ast-to-flic-app-aux
200 
+        (app-fn object)
201 
+	(cons (ast-to-flic-1 (app-arg object)) args))
202 
+      (make-flic-app (ast-to-flic-1 object) args '#f)))
203 
+
204 
+
205 
+;;; References
206 
+
207 
+(define-ast-to-flic var-ref (object)
208 
+  (make-flic-ref (var-ref-var object)))
209 
+
210 
+(define-ast-to-flic con-ref (object)
211 
+  (make-flic-pack (con-ref-con object)))
212 
+
213 
+
214 
+;;; Constants
215 
+
216 
+(define-ast-to-flic integer-const (object)
217 
+  (make-flic-const (integer-const-value object)))
218 
+
219 
+
220 
+;;; We should probably add a type field to flic-const but at the moment
221 
+;;; I'll force the value to be a list of numerator, denominator.
222 
+
223 
+(define-ast-to-flic float-const (object)
224 
+  (let ((e (float-const-exponent object))
225 
+	(n (float-const-numerator object))
226 
+	(d (float-const-denominator object)))
227 
+    (make-flic-const
228 
+     (if (> e 0)
229 
+	 (list (* n (expt 10 e)) d)
230 
+	 (list n (* d (expt 10 (- e))))))))
231 
+
232 
+(define-ast-to-flic char-const (object)
233 
+  (make-flic-const (char-const-value object)))
234 
+
235 
+
236 
+(define-ast-to-flic string-const (object)
237 
+  (let ((value  (string-const-value object)))
238 
+    (if (equal? value "")
239 
+	(make-flic-pack (core-symbol "Nil"))
240 
+	(make-flic-const value))))
241 
+
242 
+
243 
+
244 
+;;; Random stuff
245 
+
246 
+(define-ast-to-flic con-number (object)
247 
+  (make-flic-con-number
248 
+    (con-number-type object)
249 
+    (ast-to-flic-1 (con-number-value object))))
250 
+
251 
+(define-ast-to-flic sel (object)
252 
+  (make-flic-sel
253 
+    (sel-constructor object)
254 
+    (sel-slot object)
255 
+    (ast-to-flic-1 (sel-value object))))
256 
+
257 
+(define-ast-to-flic is-constructor (object)
258 
+  (make-flic-is-constructor
259 
+    (is-constructor-constructor object)
260 
+    (ast-to-flic-1 (is-constructor-value object))))
261 
+
262 
+(define-ast-to-flic void (object)
263 
+  (declare (ignore object))
264 
+  (make-flic-void))
265 
+
266 
+
267 
+;;; This hack make strictness annotations work.  It adds #t's which correspond
268 
+;;; to the strictness of the dict params.
269 
+
270 
+(define (adjust-annotated-strictness v s)
271 
+  (let* ((ty (var-type v))
272 
+	 (c (gtype-context ty)))
273 
+    (dolist (c1 c)
274 
+      (dolist (c2 c1)
275 
+        (declare (ignorable c2))
276 
+        (push '#t s)))
277 
+    s))
flic/copy-flic.scm
History View file @ 4e98702
0 278 
new file mode 100644
... ... 
@@ -0,0 +1,146 @@
1 
+;;; copy-flic.scm -- general copy functions for flic structures
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  23 Feb 1993
5 
+;;;
6 
+;;;
7 
+
8 
+
9 
+;;; The var-renamings argument is an a-list.  It's used to map local vars
10 
+;;; in the input expression to new, gensymed vars.
11 
+
12 
+(define-flic-walker copy-flic (object var-renamings))
13 
+
14 
+(define (copy-flic-list objects var-renamings)
15 
+  (let ((result  '()))
16 
+    (dolist (o objects)
17 
+      (push (copy-flic o var-renamings) result))
18 
+    (nreverse result)))
19 
+
20 
+
21 
+(define (copy-flic-top object)
22 
+  (copy-flic object '()))
23 
+
24 
+
25 
+(define-copy-flic flic-lambda (object var-renamings)
26 
+  (let ((new-vars  (map (lambda (v)
27 
+			  (let ((new  (copy-temp-var (def-name v))))
28 
+			    (push (cons v new) var-renamings)
29 
+			    (when (var-force-strict? v)
30 
+			      (setf (var-force-strict? new) '#t))
31 
+			    (init-flic-var new '#f '#f)))
32 
+			(flic-lambda-vars object))))
33 
+    (make-flic-lambda
34 
+      new-vars
35 
+      (copy-flic (flic-lambda-body object) var-renamings))))
36 
+
37 
+
38 
+;;; Hack to avoid concatenating multiple gensym suffixes.
39 
+
40 
+(define (copy-temp-var sym)
41 
+  (if (gensym? sym)
42 
+      (let* ((string  (symbol->string sym))
43 
+	     (n       (string-length string))
44 
+	     (root    (find-string-prefix string 0 n)))
45 
+	(create-temp-var root))
46 
+      (create-temp-var sym)))
47 
+
48 
+(define (find-string-prefix string i n)
49 
+  (declare (type string string) (type fixnum i n))
50 
+  (cond ((eqv? i n)
51 
+	 string)
52 
+	((char-numeric? (string-ref string i))
53 
+	 (substring string 0 i))
54 
+	(else
55 
+	 (find-string-prefix string (+ i 1) n))))
56 
+
57 
+
58 
+(define-copy-flic flic-let (object var-renamings)
59 
+  (let ((new-vars  (map (lambda (v)
60 
+			  (let ((new  (copy-temp-var (def-name v))))
61 
+			    (when (var-force-inline? v)
62 
+			      (setf (var-force-inline? new) '#t))
63 
+			    (push (cons v new) var-renamings)
64 
+			    new))
65 
+			(flic-let-bindings object))))
66 
+    (for-each
67 
+      (lambda (new old)
68 
+	(init-flic-var new (copy-flic (var-value old) var-renamings) '#f))
69 
+      new-vars
70 
+      (flic-let-bindings object))
71 
+    (make-flic-let
72 
+      new-vars
73 
+      (copy-flic (flic-let-body object) var-renamings)
74 
+      (flic-let-recursive? object))))
75 
+
76 
+(define-copy-flic flic-app (object var-renamings)
77 
+  (make-flic-app
78 
+    (copy-flic (flic-app-fn object) var-renamings)
79 
+    (copy-flic-list (flic-app-args object) var-renamings)
80 
+    (flic-app-saturated? object)))
81 
+
82 
+(define-copy-flic flic-ref (object var-renamings)
83 
+  (let* ((var   (flic-ref-var object))
84 
+	 (entry (assq var var-renamings)))
85 
+    (if entry
86 
+	(make-flic-ref (cdr entry))
87 
+	(make-flic-ref var))))   ; don't share structure
88 
+
89 
+
90 
+(define-copy-flic flic-const (object var-renamings)
91 
+  (declare (ignore var-renamings))
92 
+  (make-flic-const (flic-const-value object)))  ; don't share structure
93 
+
94 
+(define-copy-flic flic-pack (object var-renamings)
95 
+  (declare (ignore var-renamings))
96 
+  (make-flic-pack (flic-pack-con object)))      ; don't share structure
97 
+
98 
+
99 
+;;; Don't have to gensym new block names; these constructs always
100 
+;;; happen in pairs.
101 
+
102 
+(define-copy-flic flic-case-block (object var-renamings)
103 
+  (make-flic-case-block
104 
+    (flic-case-block-block-name object)
105 
+    (copy-flic-list (flic-case-block-exps object) var-renamings)))
106 
+
107 
+(define-copy-flic flic-return-from (object var-renamings)
108 
+  (make-flic-return-from
109 
+    (flic-return-from-block-name object)
110 
+    (copy-flic (flic-return-from-exp object) var-renamings)))
111 
+
112 
+(define-copy-flic flic-and (object var-renamings)
113 
+  (make-flic-and
114 
+    (copy-flic-list (flic-and-exps object) var-renamings)))
115 
+
116 
+(define-copy-flic flic-if (object var-renamings)
117 
+  (make-flic-if
118 
+    (copy-flic (flic-if-test-exp object) var-renamings)
119 
+    (copy-flic (flic-if-then-exp object) var-renamings)
120 
+    (copy-flic (flic-if-else-exp object) var-renamings)))
121 
+
122 
+(define-copy-flic flic-sel (object var-renamings)
123 
+  (make-flic-sel
124 
+    (flic-sel-con object)
125 
+    (flic-sel-i object)
126 
+    (copy-flic (flic-sel-exp object) var-renamings)))
127 
+
128 
+(define-copy-flic flic-is-constructor (object var-renamings)
129 
+  (make-flic-is-constructor
130 
+    (flic-is-constructor-con object)
131 
+    (copy-flic (flic-is-constructor-exp object) var-renamings)))
132 
+
133 
+(define-copy-flic flic-con-number (object var-renamings)
134 
+  (make-flic-con-number
135 
+    (flic-con-number-type object)
136 
+    (copy-flic (flic-con-number-exp object) var-renamings)))
137 
+
138 
+(define-copy-flic flic-void (object var-renamings)
139 
+  (declare (ignore object var-renamings))
140 
+  (make-flic-void))   ; don't share structure
141 
+
142 
+
143 
+
144 
+
145 
+
146 
+
flic/flic-structs.scm
History View file @ 4e98702
0 147 
new file mode 100644
... ... 
@@ -0,0 +1,89 @@
1 
+;;; flic-structs.scm -- structures to define FLIC intermediate language
2 
+;;;
3 
+;;; author : Sandra Loosemore
4 
+;;; date   : 24 Mar 1992
5 
+
6 
+
7 
+
8 
+(define-struct flic-exp
9 
+  (type-template flic-td)
10 
+  (slots
11 
+   (unboxed?  (type bool) (default '#f) (bit #t))
12 
+   (cheap?    (type bool) (default '#f) (bit #t))))
13 
+
14 
+
15 
+;;; Use a macro to define each subtype and a BOA constructor.
16 
+;;; Maybe eventually the constructors will need to do additional
17 
+;;; initialization and have to be defined by hand.
18 
+
19 
+(define-local-syntax (define-flic name . slots)
20 
+  (let* ((maker  (symbol-append 'make- name))
21 
+	 (pred   (symbol-append name '?))
22 
+	 (args   (map (function car) slots))
23 
+	 (inits  (map (lambda (x) (list x x)) args)))
24 
+    `(begin
25 
+       (define-struct ,name
26 
+         (include flic-exp)
27 
+	 (predicate ,pred)
28 
+	 (slots ,@slots))
29 
+       (define (,maker ,@args) (make ,name ,@inits))
30 
+       ',name)))
31 
+
32 
+(define-flic flic-lambda
33 
+  (vars (type  (list var)))
34 
+  (body (type flic-exp)))
35 
+
36 
+(define-flic flic-let
37 
+  ;; value exp is stored in var-value slot
38 
+  (bindings (type (list var)))
39 
+  (body (type flic-exp))
40 
+  (recursive? (type bool) (bit #t)))
41 
+
42 
+(define-flic flic-app
43 
+  (fn (type flic-exp))
44 
+  (args (type (list flic-exp)))
45 
+  ;; true if number of args exactly matches arity of fn
46 
+  (saturated? (type bool) (bit #t)))
47 
+
48 
+(define-flic flic-ref
49 
+  (var (type var)))
50 
+
51 
+(define-flic flic-const
52 
+  (value (type t)))
53 
+
54 
+(define-flic flic-pack
55 
+  (con (type con)))
56 
+
57 
+(define-flic flic-case-block
58 
+  (block-name (type symbol))
59 
+  (exps       (type (list flic-exp))))
60 
+
61 
+(define-flic flic-return-from
62 
+  (block-name (type symbol))
63 
+  (exp        (type flic-exp)))
64 
+
65 
+(define-flic flic-and
66 
+  (exps       (type (list flic-exp))))
67 
+
68 
+(define-flic flic-if
69 
+  (test-exp   (type flic-exp))
70 
+  (then-exp   (type flic-exp))
71 
+  (else-exp   (type flic-exp)))
72 
+
73 
+(define-flic flic-sel
74 
+  (con (type con))
75 
+  (i (type int))
76 
+  (exp (type flic-exp)))
77 
+
78 
+(define-flic flic-is-constructor
79 
+  (con (type con))
80 
+  (exp (type flic-exp)))
81 
+
82 
+(define-flic flic-con-number
83 
+  (type (type algdata))
84 
+  (exp (type flic-exp)))
85 
+
86 
+(define-flic flic-void
87 
+  )
88 
+
89 
+
flic/flic-td.scm
History View file @ 4e98702
0 90 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+;;; flic-td.scm -- define type descriptor for flic structs
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  6 Oct 1992
5 
+;;;
6 
+
7 
+(define-struct flic-td
8 
+  (include type-descriptor)
9 
+  (slots
10 
+    (codegen-walker (type (maybe procedure)) (default '#f))
11 
+    (optimize-walker (type (maybe procedure)) (default '#f))
12 
+    (postoptimize-walker (type (maybe procedure)) (default '#f))
13 
+    (fun-strictness-walk-walker (type (maybe procedure)) (default '#f))
14 
+    (var-strictness-walk-walker (type (maybe procedure)) (default '#f))
15 
+    (compute-strictness-walk-walker (type (maybe procedure)) (default '#f))
16 
+    (print-strictness-walker (type (maybe procedure)) (default '#f))
17 
+    (box-analysis-walker (type (maybe procedure)) (default '#f))
18 
+    (copy-flic-walker (type (maybe procedure)) (default '#f))
19 
+    (dump-flic-walker (type (maybe procedure)) (default '#f))
20 
+    (flic-invariant?-walker (type (maybe procedure)) (default '#f))
21 
+    ))
flic/flic-walker.scm
History View file @ 4e98702
0 22 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+;;; flic-walker.scm -- macros for defining code walkers for flic
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  7 May 1992
5 
+;;;
6 
+
7 
+
8 
+;;; (define-flic-walker foo (object))
9 
+;;; creates a macro (define-foo type (object) . body)
10 
+;;; and a function (foo object) that dispatches on the type of object.
11 
+
12 
+(define-syntax (define-flic-walker name args)
13 
+  (let ((accessor-name (symbol-append 'flic-td- name '-walker))
14 
+	(definer-name  (symbol-append 'define- name)))
15 
+    `(begin
16 
+       (define-walker ,name ,accessor-name)
17 
+       (define-local-syntax (,definer-name type args . body)
18 
+	 `(define-walker-method ,',name ,type ,args ,@body))
19 
+       (define (,name ,@args)
20 
+	 (call-walker ,name ,@args)))))
21 
+
flic/flic.scm
History View file @ 4e98702
0 22 
new file mode 100644
... ... 
@@ -0,0 +1,29 @@
1 
+;;; flic.scm -- compilation unit for flic stuff
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  7 Apr 1992
5 
+;;;
6 
+
7 
+
8 
+(define-compilation-unit flic
9 
+  (source-filename "$Y2/flic/")
10 
+  (unit flic-td
11 
+	(source-filename "flic-td.scm"))
12 
+  (unit flic-structs
13 
+	(source-filename "flic-structs.scm")
14 
+	(require flic-td))
15 
+  (unit print-flic
16 
+	(source-filename "print-flic.scm")
17 
+	(require flic-structs printer-support))
18 
+  (unit ast-to-flic
19 
+	(source-filename "ast-to-flic.scm")
20 
+	(require flic-structs ast haskell-utils))
21 
+  (unit flic-walker
22 
+	(source-filename "flic-walker.scm"))
23 
+  (unit copy-flic
24 
+	(source-filename "copy-flic.scm")
25 
+	(require flic-walker flic-structs))
26 
+  (unit invariant
27 
+	(source-filename "invariant.scm")
28 
+	(require flic-walker flic-structs))
29 
+  )
flic/invariant.scm
History View file @ 4e98702
0 30 
new file mode 100644
... ... 
@@ -0,0 +1,88 @@
1 
+;;; invariant.scm -- look for invariant expressions
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  12 Mar 1993
5 
+;;;
6 
+;;;
7 
+;;; The function flic-invariant? returns true if the expression is
8 
+;;; invariant with respect to a set of local variable bindings.
9 
+
10 
+(define-flic-walker flic-invariant? (object local-bindings))
11 
+
12 
+(define (flic-invariant-list? objects local-bindings)
13 
+  (if (null objects)
14 
+      '#t
15 
+      (and (flic-invariant? (car objects) local-bindings)
16 
+	   (flic-invariant-list? (cdr objects) local-bindings))))
17 
+
18 
+(define-flic-invariant? flic-lambda (object local-bindings)
19 
+  (flic-invariant? (flic-lambda-body object)
20 
+		   (cons (flic-lambda-vars object) local-bindings)))
21 
+
22 
+(define-flic-invariant? flic-let (object local-bindings)
23 
+  (let* ((bindings      (flic-let-bindings object))
24 
+	 (body          (flic-let-body object))
25 
+	 (recursive?    (flic-let-recursive? object))
26 
+	 (inner-stuff   (cons bindings local-bindings)))
27 
+    (and (flic-invariant-list? (map (function var-value) bindings)
28 
+			       (if recursive? inner-stuff local-bindings))
29 
+	 (flic-invariant? body inner-stuff))))
30 
+
31 
+(define-flic-invariant? flic-app (object local-bindings)
32 
+  (and (flic-invariant? (flic-app-fn object) local-bindings)
33 
+       (flic-invariant-list? (flic-app-args object) local-bindings)))
34 
+
35 
+(define-flic-invariant? flic-ref (object local-bindings)
36 
+  (let ((var  (flic-ref-var object)))
37 
+    (or (var-toplevel? var)
38 
+	(flic-local-var? var local-bindings))))
39 
+
40 
+(define (flic-local-var? var local-bindings)
41 
+  (cond ((null? local-bindings)
42 
+	 '#f)
43 
+	((memq var (car local-bindings))
44 
+	 '#t)
45 
+	(else
46 
+	 (flic-local-var? var (cdr local-bindings)))))
47 
+
48 
+(define-flic-invariant? flic-const (object local-bindings)
49 
+  (declare (ignore object local-bindings))
50 
+  '#t)
51 
+
52 
+(define-flic-invariant? flic-pack (object local-bindings)
53 
+  (declare (ignore object local-bindings))
54 
+  '#t)
55 
+
56 
+(define-flic-invariant? flic-case-block (object local-bindings)
57 
+  (flic-invariant-list? (flic-case-block-exps object) local-bindings))
58 
+
59 
+(define-flic-invariant? flic-return-from (object local-bindings)
60 
+  (flic-invariant? (flic-return-from-exp object) local-bindings))
61 
+
62 
+(define-flic-invariant? flic-and (object local-bindings)
63 
+  (flic-invariant-list? (flic-and-exps object) local-bindings))
64 
+
65 
+(define-flic-invariant? flic-if (object local-bindings)
66 
+  (and (flic-invariant? (flic-if-test-exp object) local-bindings)
67 
+       (flic-invariant? (flic-if-then-exp object) local-bindings)
68 
+       (flic-invariant? (flic-if-else-exp object) local-bindings)))
69 
+
70 
+(define-flic-invariant? flic-sel (object local-bindings)
71 
+  (flic-invariant? (flic-sel-exp object) local-bindings))
72 
+
73 
+(define-flic-invariant? flic-is-constructor (object local-bindings)
74 
+  (flic-invariant? (flic-is-constructor-exp object) local-bindings))
75 
+
76 
+(define-flic-invariant? flic-con-number (object local-bindings)
77 
+  (flic-invariant? (flic-con-number-exp object) local-bindings))
78 
+
79 
+(define-flic-invariant? flic-void (object local-bindings)
80 
+  (declare (ignore object local-bindings))
81 
+  '#t)
82 
+
83 
+
84 
+
85 
+
86 
+
87 
+
88 
+
flic/print-flic.scm
History View file @ 4e98702
0 89 
new file mode 100644
... ... 
@@ -0,0 +1,130 @@
1 
+;;; print-flic.scm -- printers for FLIC structures
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  30 Mar 1992
5 
+;;;
6 
+;;;
7 
+
8 
+
9 
+;;; For now, printing of FLIC structures is controlled by the same
10 
+;;; *print-ast-syntax* variable as for AST structures.
11 
+;;; Maybe eventually this should use its own variable.
12 
+
13 
+(define-syntax (define-flic-printer type lambda-list . body)
14 
+  `(define-ast-printer ,type ,lambda-list ,@body))
15 
+
16 
+(define-flic-printer flic-lambda (object xp)
17 
+  (with-ast-block (xp)
18 
+    (write-string "\\ " xp)
19 
+    (write-ordinary-list (flic-lambda-vars object) xp)
20 
+    (write-string " ->" xp)
21 
+    (write-whitespace xp)
22 
+    (write (flic-lambda-body object) xp)))
23 
+
24 
+(define-flic-printer flic-let (object xp)
25 
+  (pprint-logical-block (xp '() "" "")  ; no extra indentation
26 
+    (write-string "let " xp)
27 
+    (write-layout-rule (flic-let-bindings object) xp
28 
+		       (lambda (v xp)
29 
+		         (with-ast-block (xp)
30 
+		           (write v xp)
31 
+			   (write-string " =" xp)
32 
+			   (write-whitespace xp)
33 
+			   (write (var-value v) xp))))
34 
+    (write-whitespace xp)
35 
+    (write-string "in " xp)
36 
+    (write (flic-let-body object) xp)))
37 
+
38 
+(define-flic-printer flic-app (object xp)
39 
+  (with-ast-block (xp)
40 
+    (maybe-paren-flic-object (flic-app-fn object) xp)
41 
+    (write-whitespace xp)
42 
+    (write-flic-list (flic-app-args object) xp)))
43 
+
44 
+(define (maybe-paren-flic-object object xp)
45 
+  (cond ((or (flic-ref? object)
46 
+	     (flic-const? object)
47 
+	     (flic-pack? object))
48 
+	 (write object xp))
49 
+	(else
50 
+	 (write-char #\( xp)
51 
+	 (write object xp)
52 
+	 (write-char #\) xp))))
53 
+
54 
+(define (write-flic-list objects xp)
55 
+  (write-delimited-list objects xp (function maybe-paren-flic-object) "" "" ""))
56 
+
57 
+(define-flic-printer flic-ref (object xp)
58 
+  (write (flic-ref-var object) xp))
59 
+
60 
+(define-flic-printer flic-const (object xp)
61 
+  (write (flic-const-value object) xp))
62 
+
63 
+(define-flic-printer flic-pack (object xp)
64 
+  (write-string "pack/" xp)
65 
+  (write (flic-pack-con object) xp))
66 
+
67 
+(define-flic-printer flic-case-block (object xp)
68 
+  (with-ast-block (xp)
69 
+    (write-string "case-block " xp)
70 
+    (write (flic-case-block-block-name object) xp)
71 
+    (write-whitespace xp)
72 
+    (write-layout-rule (flic-case-block-exps object) xp (function write))))
73 
+
74 
+(define-flic-printer flic-return-from (object xp)
75 
+  (with-ast-block (xp)
76 
+    (write-string "return-from " xp)
77 
+    (write (flic-return-from-block-name object) xp)
78 
+    (write-whitespace xp)
79 
+    (write (flic-return-from-exp object) xp)))
80 
+
81 
+(define-flic-printer flic-and (object xp)
82 
+  (with-ast-block (xp)
83 
+    (write-string "and " xp)
84 
+    (write-layout-rule (flic-and-exps object) xp (function write))))
85 
+
86 
+(define-flic-printer flic-if (object xp)
87 
+  (with-ast-block (xp)
88 
+    (write-string "if " xp)
89 
+    (write (flic-if-test-exp object) xp)
90 
+    (write-whitespace xp)
91 
+    (with-ast-block (xp)
92 
+      (write-string "then" xp)
93 
+      (write-whitespace xp)
94 
+      (write (flic-if-then-exp object) xp))
95 
+    (write-whitespace xp)
96 
+    (with-ast-block (xp)
97 
+      (write-string "else" xp)
98 
+      (write-whitespace xp)
99 
+      (write (flic-if-else-exp object) xp))
100 
+    ))
101 
+
102 
+
103 
+(define-flic-printer flic-sel (object xp)
104 
+  (with-ast-block (xp)
105 
+    (write-string "sel/" xp)
106 
+    (write (flic-sel-con object) xp)
107 
+    (write-char #\/ xp)
108 
+    (write (flic-sel-i object) xp)
109 
+    (write-whitespace xp)
110 
+    (write (flic-sel-exp object) xp)))
111 
+
112 
+(define-flic-printer flic-is-constructor (object xp)
113 
+  (with-ast-block (xp)
114 
+    (write-string "is-constructor/" xp)
115 
+    (write (flic-is-constructor-con object) xp)
116 
+    (write-whitespace xp)
117 
+    (write (flic-is-constructor-exp object) xp)))
118 
+
119 
+(define-flic-printer flic-con-number (object xp)
120 
+  (with-ast-block (xp)
121 
+    (write-string "con/" xp)
122 
+    (write (flic-con-number-type object) xp)
123 
+    (write-whitespace xp)
124 
+    (write (flic-con-number-exp object) xp)))
125 
+
126 
+(define-flic-printer flic-void (object xp)
127 
+  (declare (ignore object))
128 
+  (write-string "Void" xp))
129 
+
130 
+
0 131 
\ No newline at end of file
haskell-development
History View file @ 4e98702
1 132 
new file mode 100755
... ... 
@@ -0,0 +1,69 @@
1 
+#!/bin/csh
2 
+#
3 
+# Set up for Yale Haskell 2.x development
4 
+#
5 
+
6 
+source $HASKELL/haskell-setup
7 
+
8 
+
9 
+# You need to set this environment variable to point to the root
10 
+# directory where you have installed the Yale Haskell sources.
11 
+
12 
+setenv Y2 $HASKELL
13 
+
14 
+
15 
+# Define some aliases for getting the right RCS options.
16 
+# These aliases are only for use at Yale.
17 
+
18 
+alias rco 'co -l'
19 
+alias rci 'ci -u'
20 
+
21 
+
22 
+# Find the "right" lisp executable.
23 
+# You really only need to set up for the particular lisp implementation(s)
24 
+# you are going to build the system under (you can comment out the rest).
25 
+
26 
+# The Lucid CL executable we've been using is the one without fancy
27 
+# stuff like CLOS loaded.
28 
+
29 
+setenv LUCID /cs/licensed/sclisp-4.0/lisp-4-0-base
30 
+
31 
+
32 
+# Setup for CMUCL.  We have this aliased to a script that will select
33 
+# the right core file for the machine you are running on.
34 
+
35 
+setenv CMUCL $Y2/bin/run-cmucl
36 
+setenv CMUCLBIN $Y2/bin/cmucl
37 
+setenv CMUCLLIB $Y2/bin
38 
+
39 
+
40 
+# This is AKCL, not ordinary KCL (which is too brain-damaged).
41 
+
42 
+setenv AKCL /net/nebula/homes/systems/hcompile/akcl/xbin/kcl
43 
+
44 
+
45 
+# Set up for Franz Allegro.
46 
+# This is a hack; we run Allegro on both sparc and next boxes, and
47 
+# we need to be able to tell which kind of machine we're running on so
48 
+# the binaries don't get jumbled up together.
49 
+
50 
+if (-e /vmunix) then
51 
+  setenv ALLEGRODIR allegro
52 
+  setenv ALLEGRO /usr/licensed/allegro/cl
53 
+else if (-e /mach) then
54 
+  setenv ALLEGRODIR allegro-next
55 
+  setenv ALLEGRO /usr/local/bin/lisp
56 
+else
57 
+  echo "Can't figure out what kind of machine you're on!"
58 
+endif
59 
+
60 
+
61 
+# Set up for Harlequin Lispworks.
62 
+
63 
+setenv LISPWORKS /usr/licensed/bin/lispworks
64 
+
65 
+
66 
+# Set up for WCL
67 
+# This is not supported!
68 
+# setenv WCL /net/nebula/homes/systems/hcompile/wcl-2.14/bin/wcl
69 
+# setenv LD_LIBRARY_PATH /net/nebula/homes/systems/hcompile/wcl-2.14/lib
haskell-setup
History View file @ 4e98702
0 70 
new file mode 100755
... ... 
@@ -0,0 +1,27 @@
1 
+#!/bin/csh
2 
+#
3 
+# Set up for Yale Haskell 2.x users.
4 
+#
5 
+
6 
+setenv PRELUDE $HASKELL/progs/prelude
7 
+setenv HASKELL_LIBRARY $HASKELL/progs/lib
8 
+
9 
+# You may need to change this to point at the appropriate subdirectory,
10 
+# depending on which Lisp is being used.
11 
+setenv PRELUDEBIN $PRELUDE/lucid
12 
+#setenv PRELUDEBIN $PRELUDE/cmu
13 
+
14 
+# You may need to change this to point at the appropriate subdirectory,
15 
+# depending on which Lisp is being used.
16 
+setenv LIBRARYBIN $HASKELL_LIBRARY/bin/lucid
17 
+#setenv LIBRARYBIN $HASKELL_LIBRARY/bin/cmu
18 
+
19 
+# You may need to change this to point at the appropriate executable,
20 
+# depending on which Lisp is being used.
21 
+setenv HASKELLPROG $HASKELL/bin/haskell
22 
+#setenv HASKELLPROG $HASKELL/bin/cmu-haskell
23 
+
24 
+# You only need this next definition if you are using the CMU CL version
25 
+# of haskell and you have /tmp mounted on a tmpfs file system (it won't
26 
+# be able to initialize itself otherwise).
27 
+setenv CMUCL_EMPTYFILE /var/tmp/empty
import-export/README
History View file @ 4e98702
0 28 
new file mode 100644
... ... 
@@ -0,0 +1,15 @@
1 
+This is the import / export phase.  This process is accomplished as follows:
2 
+
3 
+a) Local definitions are created in each module.  These are entered into the
4 
+   local symbol table.
5 
+b) Imports to non-local modules are completely resolved.
6 
+c) Local import/export is performed via a fixpoint:
7 
+    1) Export: definitions added in the previous round are filtered by the
8 
+       export list and placed in a fresh export list.
9 
+    2) Each module imports from the fresh export list of the other modules.
10 
+       Any import not already present is placed on a new fresh export list.
11 
+   When no fresh exports are generated, the iteration is complete.
12 
+d) Missing exports and imports are checked for.
13 
+
14 
+
15 
+
import-export/ie-errors.scm
History View file @ 4e98702
0 16 
new file mode 100644
... ... 
@@ -0,0 +1,154 @@
1 
+;;; Error checks & calls for the import-export code
2 
+
3 
+;;; this is called at the end of import-export to look for
4 
+;;;  a) exported entities that were never found
5 
+;;;  b) imported entities that were never found
6 
+;;;  c) renamed entities that were never found
7 
+;;;  d) hidden entities that were never found
8 
+
9 
+(define (check-missing-names)
10 
+  (dolist (export (module-exports *module*))
11 
+    (remember-context export
12 
+      (signal-missing-export export)))
13 
+  (dolist (import-decl (module-imports *module*))
14 
+    (remember-context import-decl
15 
+      (with-slots import-decl (mode specs renamings) import-decl
16 
+        ;; *** I'm confused.  Aren't these errors already detected
17 
+	;; *** by import-all-entities and import-named-entities?
18 
+	;; jcp: no - a final check is needed after all symbols have moved.
19 
+        (cond ((eq? mode 'all)
20 
+	       (dolist (entity specs)
21 
+		 (signal-unused-hiding
22 
+		   (entity-name entity)
23 
+		   (import-decl-module-name import-decl))))
24 
+	      (else
25 
+	       (dolist (entity specs)
26 
+		 (signal-entity-not-found
27 
+		   (entity-name entity)
28 
+		   (import-decl-module-name import-decl)))))
29 
+	(find-unused-renamings renamings import-decl)))))
30 
+
31 
+(define (find-unused-renamings renamings import-decl)
32 
+  (dolist (r renamings)
33 
+    (when (not (renaming-referenced? r))
34 
+      (remember-context r
35 
+	(signal-unused-renaming (renaming-from r)
36 
+				(import-decl-module-name import-decl))))))
37 
+
38 
+(define (check-duplicates l entity)
39 
+  (when (not (null? (find-duplicates l)))
40 
+    (signal-duplicate-names-in-entity entity)))
41 
+
42 
+;;; There are a ton of possible errors in import-export.  All error
43 
+;;; calls are found here:
44 
+
45 
+(define (signal-missing-export export)
46 
+  (recoverable-error 'missing-export
47 
+    "Module ~A exports ~A, but provides no definition for it."
48 
+    *module-name* export))
49 
+
50 
+(define (signal-unused-renaming name module-name)
51 
+  (recoverable-error 'unused-renaming
52 
+    "The name ~a is included in the renaming list of an import declaration,~%~
53 
+     but is not among the entities being imported from module ~a."
54 
+    name module-name))
55 
+
56 
+(define (signal-unused-hiding name module-name)
57 
+  (recoverable-error 'unused-hiding
58 
+    "The name ~a is included in the hiding list of an import declaration,~%~
59 
+     but is not among the entities exported from module ~a."
60 
+    name module-name))
61 
+
62 
+(define (signal-multiple-name-conflict name old-local-name def)
63 
+  (recoverable-error 'multiple-name-conflict
64 
+    "In module ~A, the symbol ~A from module ~A is known as both ~A and ~A."
65 
+    *module-name* (def-name def) (def-module def) name old-local-name))
66 
+
67 
+
68 
+(define (signal-undefined-module-import name)
69 
+  (fatal-error 'undefined-module-import
70 
+	       "Cannot find module ~A, imported by module ~A."
71 
+	       name *module-name*))
72 
+
73 
+
74 
+(define (signal-undefined-module-export name)
75 
+  (fatal-error 'undefined-module-export
76 
+	       "Cannot find module ~A, exported by module ~A."
77 
+	       name *module-name*))
78 
+
79 
+
80 
+(define (signal-self-import name)
81 
+  (fatal-error 'self-import
82 
+	       "Module ~A cannot import itself."
83 
+	       name))
84 
+
85 
+(define (signal-missing-prelude)
86 
+  (fatal-error 'missing-prelude "Can't find module Prelude."))
87 
+
88 
+(define (signal-missing-prelude-core)
89 
+  (fatal-error 'missing-prelude "Can't find module PreludeCore."))
90 
+
91 
+(define (signal-export-not-imported name)
92 
+  (recoverable-error 'export-not-imported
93 
+    "Module ~A is exported from ~A,~%~
94 
+     but is not also imported into that module."
95 
+    name *module-name*))
96 
+
97 
+(define (signal-entity-not-found name module-name)
98 
+  (fatal-error 'entity-not-found
99 
+    "The entity ~a is not exported from module ~a." name module-name))
100 
+
101 
+(define (signal-synonym-needs-dots name module-name)
102 
+  (declare (ignore module-name))
103 
+  (fatal-error 'synonym-needs-dots
104 
+    "The entity ~a is a type synonym; to name it in an import or export~%~
105 
+     list, you must use `~a(..)' as the entity."
106 
+    name name))
107 
+
108 
+(define (signal-wrong-definition expected name module-name)
109 
+  (fatal-error 'wrong-definition
110 
+    "The entity ~a does not name a ~a in module ~a."
111 
+    name expected module-name))
112 
+
113 
+(define (signal-abstract-type name module-name)
114 
+  (fatal-error 'abstract-type
115 
+    "The entity ~a names an abstract type in module ~a;~%~
116 
+     you cannot import or export its constructors."
117 
+    name module-name))
118 
+
119 
+(define (signal-extra-constituent entity name what)
120 
+  (fatal-error 'extra-constituent
121 
+    "The entity specification ~a includes the ~a name ~a,~%~
122 
+     which is not present in its definition."
123 
+    entity what name))
124 
+
125 
+(define (signal-missing-constituent entity name what)
126 
+  (fatal-error 'missing-constituent
127 
+    "The entity specification ~a does not include the ~a name ~a,~%~
128 
+     which is part of its definition."
129 
+    entity what name))
130 
+
131 
+(define (signal-duplicate-names-in-entity entity)
132 
+  (fatal-error 'duplicate-names-in-entity
133 
+    "The entity specification ~a includes duplicate names."
134 
+    entity))
135 
+
136 
+(define (signal-export-method-var name)
137 
+  (fatal-error 'export-method-var
138 
+    "You can't export the method ~a like an ordinary variable."
139 
+    name))
140 
+
141 
+(define (signal-prelude-renaming def name)
142 
+  (recoverable-error 'cant-rename-core
143 
+     "Names in PreludeCore cannot be renamed: ~a was renamed to ~a"
144 
+     (def-name def) name))
145 
+
146 
+(define (signal-non-local-fixity op)
147 
+  (recoverable-error 'fixity-must-be-local
148 
+     "The fixity for ~A will be ignored since it is not defined in this module"
149 
+     op))
150 
+
151 
+(define (signal-fixity-not-var/con op)
152 
+  (recoverable-error 'fixity-requires-var-or-con
153 
+     "The fixity for ~A will be ignored since it is not a value or constructor"
154 
+     op))
import-export/ie-utils.scm
History View file @ 4e98702
0 155 
new file mode 100644
... ... 
@@ -0,0 +1,121 @@
1 
+
2 
+;;; This file contains utilities, globals, and macros used by the
3 
+;;; import-export system.
4 
+
5 
+(define *new-exports-found?* '#f)  ; used by the fixpoint iteration
6 
+
7 
+;;; A group is a collection of related symbols.  It is represented
8 
+;;; by a list of (name,def) pairs.  The first element is the head
9 
+;;; of the group; the group is entered in the export table under the
10 
+;;; name of the head only.  Groups for vars and synonyms have only the
11 
+;;; head.  Data types and classes have the constructors or methods in
12 
+;;; the tail of the group.
13 
+
14 
+(define (group-name x)  ; name of the head
15 
+  (tuple-2-1 (car x)))
16 
+
17 
+(define (group-definition x) ; definition of the head
18 
+  (tuple-2-2 (car x)))
19 
+
20 
+;;; The name & entry are the head of the group.  Others is a list of
21 
+;;; name - definition pairs.
22 
+(define (make-group name entry . others)
23 
+  (if (null? others)
24 
+      (list (cons name entry))
25 
+      (cons (cons name entry) (car others))))
26 
+
27 
+(define (hidden-constructors? group)
28 
+  (null? (cdr group)))
29 
+
30 
+(define (strip-constructors group)
31 
+  (list (car group)))
32 
+
33 
+;;; rename-group applies the current renaming  to every
34 
+;;;  name in a group.  When uses, a renaming is marked to allow unused
35 
+;;;  renamings to be detected.
36 
+
37 
+(define (rename-group g renamings)
38 
+  (if (null? renamings)
39 
+      g
40 
+      (map (lambda (n-d)
41 
+	     (let* ((def (tuple-2-2 n-d))
42 
+		    (keep-name? (or (con? def) (var? def)))
43 
+		    (n (tuple-2-1 n-d))
44 
+		    (name (if keep-name? n (add-con-prefix/symbol n)))
45 
+		    (renaming (locate-renaming name renamings)))
46 
+	       (cond (renaming
47 
+		      (let ((new-name
48 
+			     (if keep-name?
49 
+				 (renaming-to renaming)
50 
+				 (remove-con-prefix/symbol
51 
+				   (renaming-to renaming)))))
52 
+			(when (and (def-prelude? def)
53 
+				   (not (eq? (def-name def) new-name)))
54 
+			    (signal-prelude-renaming def new-name)
55 
+			    (setf new-name (def-name def)))
56 
+			(setf (renaming-referenced? renaming) '#t)
57 
+			(tuple new-name def)))
58 
+		     (else n-d))))
59 
+	   g)))
60 
+
61 
+(define (locate-renaming name renamings)
62 
+  (if (null? renamings)
63 
+      '#f
64 
+      (if (eq? name (renaming-from (car renamings)))
65 
+	  (car renamings)
66 
+	  (locate-renaming name (cdr renamings)))))
67 
+
68 
+(define (gather-algdata-group name def)
69 
+  (cons (tuple name def)
70 
+	(gather-group (algdata-constrs def))))
71 
+
72 
+(define (gather-class-group name def)
73 
+  (cons (tuple name def)
74 
+	(gather-group (class-method-vars def))))
75 
+
76 
+(define (gather-group defs)
77 
+  (if (null? defs)
78 
+      '()
79 
+      (let ((local-name (local-name (car defs))))
80 
+	(if (eq? local-name '#f)
81 
+	    '()
82 
+	    (cons (tuple local-name (car defs))
83 
+		  (gather-group (cdr defs)))))))
84 
+
85 
+;;; These deal with `hiding' lists.
86 
+
87 
+;;; Note: as per the new report, no need to worry about anything but the
88 
+;;; group head and the entity name since only var, Class(..),Alg(..) allowed
89 
+
90 
+(define (in-hiding-list? group hiding)
91 
+  (cond ((null? hiding)
92 
+	 '#f)
93 
+	((eq? (entity-name (car hiding)) (group-name group))
94 
+	 '#t)
95 
+	(else (in-hiding-list? group (cdr hiding)))))
96 
+
97 
+(define (remove-entity group hiding)
98 
+  (cond ((eq? (entity-name (car hiding)) (group-name group))
99 
+	 (cdr hiding))
100 
+	(else (cons (car hiding) (remove-entity group (cdr hiding))))))
101 
+
102 
+;;; This moves fixity information to the local symbols.  This must be
103 
+;;; called after local symbols are installed but before imported
104 
+;;; symbols arrive.
105 
+
106 
+(define (attach-fixities)
107 
+  (dolist (fixity-decl (module-fixities *module*))
108 
+    (let ((fixity (fixity-decl-fixity fixity-decl)))
109 
+      (dolist (op (fixity-decl-names fixity-decl))
110 
+        (let ((def (resolve-toplevel-name op)))
111 
+	  (cond ((or (eq? def '#f) (not (eq? *module-name* (def-module def))))
112 
+		 ;;; ***This is WRONG!  Inner fixities may be found.
113 
+		 (signal-non-local-fixity op))
114 
+		((var? def)
115 
+		 (setf (var-fixity def) fixity)
116 
+		 (setf (table-entry *fixity-table* op) fixity))
117 
+		((con? def)
118 
+		 (setf (con-fixity def) fixity)
119 
+		 (setf (table-entry *fixity-table* op) fixity))
120 
+		(else (signal-fixity-not-var/con op))))))))
121 
+
import-export/ie.scm
History View file @ 4e98702
0 122 
new file mode 100644
... ... 
@@ -0,0 +1,16 @@
1 
+(define-compilation-unit ie
2 
+  (source-filename "$Y2/import-export/")
3 
+  (require global)
4 
+  (unit ie-utils
5 
+    (source-filename "ie-utils"))
6 
+  (unit import-export
7 
+    (source-filename "import-export"))
8 
+  (unit init-modules
9 
+    (source-filename "init-modules"))
10 
+  (unit top-definitions
11 
+    (source-filename "top-definitions"))
12 
+  (unit locate-entity
13 
+    (source-filename "locate-entity"))
14 
+  (unit ie-errors
15 
+    (source-filename "ie-errors")))
16 
+
import-export/import-export.scm
History View file @ 4e98702
0 17 
new file mode 100644
... ... 
@@ -0,0 +1,209 @@
1 
+;;; This is the main driver for the import / export routine
2 
+
3 
+(define (import-export modules)
4 
+  (walk-modules modules
5 
+        (lambda () (add-module-to-symbol-table *module*)))
6 
+  (walk-modules modules
7 
+      (lambda () (init-module-structure)))
8 
+  (import-export/fixpoint modules '#t)
9 
+  (walk-modules modules (lambda () (check-missing-names)))
10 
+  (when (memq 'import (dynamic *printers*))
11 
+    (show-export-tables modules))
12 
+ modules)
13 
+
14 
+(define (import-export/interface modules)
15 
+  (walk-modules modules
16 
+        (lambda () (add-module-to-symbol-table *module*)))
17 
+  (walk-modules modules
18 
+      (lambda () (init-module-structure)))
19 
+  (walk-modules modules
20 
+      (lambda () (create-top-definitions)
21 
+	         (attach-fixities))))
22 
+
23 
+(define (import-export/fixpoint modules initial-cycle?)
24 
+  (setf *new-exports-found?* '#f)
25 
+  (walk-modules modules
26 
+   (lambda ()
27 
+     (setf (module-fresh-exports *module*) '())
28 
+     (when initial-cycle?
29 
+       (create-top-definitions)
30 
+       (attach-fixities)
31 
+       (import-non-local))
32 
+     (locally-import)
33 
+     (locally-export)))
34 
+  (when *new-exports-found?*
35 
+      (import-export/fixpoint modules '#f)))
36 
+
37 
+;;; This does the non-local importing from previously defined modules
38 
+
39 
+(define (import-non-local)
40 
+  (setf (module-imports *module*)
41 
+	(process-non-local-imports (module-imports *module*))))
42 
+
43 
+(define (process-non-local-imports imports)
44 
+  (if (null? imports)
45 
+      '()
46 
+      (let* ((import (car imports)))
47 
+        (with-slots import-decl (module mode specs renamings) import
48 
+	  (cond ((eq? *unit* (module-unit module))
49 
+		 (cons import (process-non-local-imports (cdr imports))))
50 
+		((eq? mode 'all)
51 
+		 (import-all-entities module specs renamings import)
52 
+		 (process-non-local-imports (cdr imports)))
53 
+		(else
54 
+		 (import-named-entities module specs renamings import)
55 
+		 (process-non-local-imports (cdr imports))))))))
56 
+
57 
+(define (import-all-entities module hiding renamings import-decl)
58 
+  (table-for-each
59 
+   (lambda (name group)
60 
+     (declare (ignore name))
61 
+     (cond ((in-hiding-list? group hiding)
62 
+	    (setf hiding (remove-entity group hiding)))
63 
+	   (else
64 
+	    (import-group (rename-group group renamings) module))))
65 
+   (module-export-table module))
66 
+  (when (not (null? hiding))
67 
+    (remember-context import-decl
68 
+      (dolist (h hiding)
69 
+	(signal-unused-hiding (entity-name h) (module-name module)))))
70 
+  (find-unused-renamings renamings import-decl))
71 
+
72 
+(define (import-named-entities mod specs renamings import-decl)
73 
+  (dolist (entity specs)
74 
+    (let ((group (locate-entity/export-table entity mod '#t)))
75 
+      (when (not (eq? group 'error))
76 
+	(setf group (rename-group group renamings))
77 
+	(import-group group mod))))
78 
+  (find-unused-renamings renamings import-decl))
79 
+
80 
+;;; This takes a module and processes the import declarations, moving as
81 
+;;; many entities from the freshly exported components of other modules into
82 
+;;; the current module.
83 
+
84 
+(define (locally-import)
85 
+  (dolist (import (module-imports *module*))
86 
+    (with-slots import-decl (module mode specs renamings) import
87 
+      (if (eq? mode 'all)
88 
+	  (import-fresh-entities import module specs renamings)
89 
+	  (setf (import-decl-specs import)
90 
+		(import-entities specs module renamings))))))
91 
+
92 
+(define (import-fresh-entities import module hiding renamings)
93 
+  (dolist (group (module-fresh-exports module))
94 
+    (cond ((in-hiding-list? group hiding)
95 
+	    (setf hiding (remove-entity group hiding)))
96 
+	   (else
97 
+	    (import-group (rename-group group renamings) module))))
98 
+  (setf (import-decl-specs import) hiding))
99 
+
100 
+(define (import-entities entities module renamings)
101 
+  (if (null? entities)
102 
+      '()
103 
+      (let ((group (locate-entity/export-table (car entities) module '#f)))
104 
+	(cond ((eq? group 'not-found)
105 
+	       (cons (car entities)
106 
+		     (import-entities (cdr entities) module renamings)))
107 
+	      ((eq? group 'error)
108 
+	       (import-entities (cdr entities) module renamings))
109 
+	      (else
110 
+	       (setf group (rename-group group renamings))
111 
+	       (import-group group module)
112 
+	       (import-entities (cdr entities) module renamings))))))
113 
+
114 
+;;; This imports a group into *module*.  module is the place the group is
115 
+;;; taken from.
116 
+
117 
+(define (import-group group module)
118 
+  (when (memq module (module-exported-modules *module*))
119 
+    (export-group group))
120 
+  (dolist (n-d group)
121 
+    (insert-top-definition (tuple-2-1 n-d) (tuple-2-2 n-d))))
122 
+
123 
+;;; This takes as yet unresolved exports and moves them to the export table.
124 
+
125 
+(define (locally-export)
126 
+  (setf (module-exports *module*)
127 
+	(export-entities (module-exports *module*))))
128 
+
129 
+(define (export-entities entities)
130 
+  (if (null? entities)
131 
+      '()
132 
+      (let* ((entity (car entities))
133 
+	     (group (locate-entity entity)))
134 
+	(cond ((eq? group 'error)
135 
+	       (export-entities (cdr entities)))
136 
+	      ((eq? group 'not-found)
137 
+	       (cons entity (export-entities (cdr entities))))
138 
+	      (else
139 
+	       (export-group group)
140 
+	       (export-entities (cdr entities)))))))
141 
+
142 
+
143 
+;;; This moves a group into the export table.  If this export is new,
144 
+;;; a flag is set.
145 
+
146 
+(define (export-group group)
147 
+  (let* ((export-table (module-export-table *module*))
148 
+	 (old-group (table-entry export-table (group-name group))))
149 
+    (when (or (eq? old-group '#f)
150 
+	      (and (hidden-constructors? old-group)
151 
+		   (not (hidden-constructors? group))))
152 
+      (setf (table-entry export-table (group-name group)) group)
153 
+      (dolist (n-d group)
154 
+        (setf (def-exported? (tuple-2-2 n-d)) '#t))
155 
+      (push group (module-fresh-exports *module*))
156 
+      (setf *new-exports-found?* '#t))))
157 
+
158 
+(define (show-export-tables modules)
159 
+  (walk-modules modules
160 
+    (lambda ()
161 
+      (format '#t "~%Exports from module ~A~%" *module-name*)
162 
+      (let ((exports '()))
163 
+	(table-for-each (lambda (key val)
164 
+			  (push (cons key val) exports))
165 
+			(module-export-table *module*))
166 
+	(setf exports (sort-list exports
167 
+				 (lambda (x y)
168 
+				   (string-ci<? (symbol->string (car x))
169 
+						(symbol->string (car y))))))
170 
+	(dolist (e exports)
171 
+          (print-exported-group (car e) (group-definition (cdr e))
172 
+				(cdr (cdr e))))))))
173 
+
174 
+(define (print-exported-group name def extras)
175 
+  (if (eq? (def-module def) *module-name*)
176 
+      (format '#t " ")
177 
+      (format '#t "*"))
178 
+  (cond ((synonym? def)
179 
+	 (format '#t "type  "))
180 
+	((algdata? def)
181 
+	 (format '#t "data  "))
182 
+	((class? def)
183 
+	 (format '#t "class "))
184 
+	(else
185 
+	 (format '#t "      ")))
186 
+  (format '#t "~A" name)
187 
+  (when (not (eq? name (def-name def)))
188 
+     (format '#t "[~A]" (def-name def)))
189 
+  (when extras
190 
+     (format '#t " (")
191 
+     (print-exported-group-1 extras (algdata? def)))
192 
+  (format '#t "~%"))
193 
+
194 
+(define (print-exported-group-1 extras alg?)
195 
+  (let* ((name (tuple-2-1 (car extras)))
196 
+	 (ns (symbol->string name))
197 
+	 (def (tuple-2-2 (car extras))))
198 
+    (format '#t "~A" (if alg? (remove-con-prefix ns) ns))
199 
+    (when (not (eq? name (def-name def)))
200 
+      (let ((name1 (symbol->string (def-name def))))
201 
+	  (format '#t "[~A]" (if alg? (remove-con-prefix name1) name1))))
202 
+    (if (null? (cdr extras))
203 
+	(format '#t ")")
204 
+	(begin
205 
+	  (format '#t ",")
206 
+	  (print-exported-group-1 (cdr extras) alg?)))))
207 
+
208 
+
209 
+
import-export/init-modules.scm
History View file @ 4e98702
0 210 
new file mode 100644
... ... 
@@ -0,0 +1,142 @@
1 
+;;; This initializes the module ast structures.
2 
+
3 
+;;; This requires that the module table be created and updated with new
4 
+;;; modules first.  *unit* must also be defined.
5 
+
6 
+;;; Things initialized there:
7 
+;;;  all tables in the module structure
8 
+;;;  the module slot of all import declarations and entity-modules
9 
+;;;  The import Prelude is added when necessary
10 
+;;;  Empty export lists are explicated
11 
+
12 
+(define (init-module-structure)
13 
+  (when (not (eq? (module-type *module*) 'extension))
14 
+    ;; If this is an extension, the incremental compiler has already
15 
+    ;; filled in the compilation unit.
16 
+    (setf (module-unit *module*) *unit*))
17 
+  ;;; This processes the annotations.  Annotations used at the top
18 
+  ;;; level of the module:
19 
+  ;;;   {-#PRELUDE#-} : this contains definitions in the Haskell prelude
20 
+  (setf (module-prelude? *module*) '#f)
21 
+  (setf (module-interface-codefile *module*) '())
22 
+  (dolist (a (module-annotations *module*))
23 
+    (when (annotation-value? a)
24 
+      (let ((name (annotation-value-name a)))
25 
+	(cond ((eq? name '|Prelude|)
26 
+	       (setf (module-prelude? *module*) '#t))))))
27 
+  (cond ((eq? (module-type *module*) 'interface)
28 
+	 (setf (module-exported-modules *module*) (list *module*))
29 
+	 (process-interface-imports *module*))
30 
+	((eq? (module-type *module*) 'standard)
31 
+	 (init-standard-module))))
32 
+
33 
+(define (init-standard-module)
34 
+   (let ((seen-prelude? '#f))
35 
+    (dolist (import (module-imports *module*))
36 
+      (let* ((name (import-decl-module-name import))
37 
+	     (imported-mod (locate-module name)))
38 
+	(when (eq? name '|Prelude|)
39 
+	   (setf seen-prelude? '#t))
40 
+	(if (eq? imported-mod '#f)
41 
+	    (signal-undefined-module-import name)
42 
+	    (setf (import-decl-module import) imported-mod))
43 
+	(when (eq? name *module-name*)
44 
+	  (signal-self-import name))))
45 
+    (when (null? (module-exports *module*))
46 
+	(setf (module-exports *module*)
47 
+	      (list (make entity-module (name *module-name*)
48 
+			                (module *module*)))))
49 
+    (when (not seen-prelude?)
50 
+      (let ((prelude (locate-module '|Prelude|)))
51 
+	(cond ((eq? prelude '#f)
52 
+	       (signal-missing-prelude))
53 
+	      ((module-prelude? *module*)
54 
+	       (setf (module-uses-standard-prelude? *module*) '#f)
55 
+	       (add-imported-module prelude))
56 
+	      (else
57 
+	       (setf (module-uses-standard-prelude? *module*) '#t)
58 
+	       (let ((fix-table (module-fixity-table *module*)))
59 
+		 (table-for-each (lambda (k v)
60 
+				   (setf (table-entry fix-table k) v))
61 
+				 *prelude-fixity-table*))))))
62 
+    (let ((prelude-core (locate-module '|PreludeCore|)))
63 
+       (if (eq? prelude-core '#f)
64 
+	   (signal-missing-prelude-core)
65 
+	   (when (module-prelude? *module*)
66 
+		 (add-imported-module prelude-core))))
67 
+    (setf (module-exports *module*)
68 
+	  (filter-complete-module-exports (module-exports *module*))))
69 
+    )
70 
+
71 
+
72 
+(define (add-imported-module module)
73 
+  (setf (module-imports *module*)
74 
+	(cons (make import-decl
75 
+		    (module-name (module-name module))
76 
+		    (module module)
77 
+		    (mode 'all)
78 
+		    (specs '())
79 
+		    (renamings '()))
80 
+	      (module-imports *module*))))
81 
+
82 
+(define (filter-complete-module-exports exports)
83 
+  (if (null? exports)
84 
+      '()
85 
+      (let ((export (car exports))
86 
+	    (others (filter-complete-module-exports (cdr exports))))
87 
+	(if (is-type? 'entity-module export)
88 
+	    (let* ((name (entity-name export))
89 
+		   (exported-mod (locate-module name)))
90 
+	      (when (eq? exported-mod '#f)
91 
+		(signal-undefined-module-export name))
92 
+	      (push exported-mod (module-exported-modules *module*))
93 
+	      (when (not (memq name
94 
+			   (cons *module-name*
95 
+				 (map
96 
+				   (lambda (import)
97 
+				     (import-decl-module-name import))
98 
+				   (module-imports *module*)))))
99 
+		(signal-export-not-imported name))
100 
+	      others)
101 
+	    (cons export others)))))
102 
+
103 
+(define (process-interface-imports module)
104 
+  (let ((imports '()))
105 
+    (dolist (i (module-imports module))
106 
+      (let ((module (import-decl-module-name i))
107 
+	    (renamings (import-decl-renamings i)))
108 
+	(dolist (s (import-decl-specs i))
109 
+          (let* ((n (entity-name s))
110 
+		 (n1 (do-interface-rename n renamings)))
111 
+	    (when (assq n1 imports)
112 
+               (signal-multiple-imports n1))
113 
+	    (push (tuple n1 (tuple module n)) imports)
114 
+	    (cond ((entity-class? s)
115 
+		   (dolist (m (entity-class-methods s))
116 
+                     (let ((m1 (do-interface-rename m renamings)))
117 
+		       (when (assq m1 imports)
118 
+                          (signal-multiple-imports m1))
119 
+		       (push (tuple m1 (tuple module m)) imports))))
120 
+		  ((entity-datatype? s)
121 
+		   (dolist (m (entity-datatype-constructors s))
122 
+                     (let ((m1 (do-interface-rename m renamings)))
123 
+		       (when (assq m1 imports)
124 
+                          (signal-multiple-imports m1))
125 
+		       (push (tuple m1 (tuple module m)) imports)))))))))
126 
+    (setf (module-interface-imports module) imports)))
127 
+
128 
+(define (signal-multiple-imports name)
129 
+  (phase-error 'multuple-interface-import
130 
+    "Interface file has more than one definition of ~A~%" name))
131 
+
132 
+(define (do-interface-rename name renamings)
133 
+  (if (has-con-prefix? (symbol->string name))
134 
+      (let* ((n1 (remove-con-prefix/symbol name))
135 
+	     (res (locate-renaming n1 renamings)))
136 
+	(if (eq? res '#f)
137 
+	    name
138 
+	    (add-con-prefix/symbol (renaming-to res))))
139 
+      (let ((res (locate-renaming name renamings)))
140 
+	(if (eq? res '#f)
141 
+	    name
142 
+	    (renaming-to res)))))
import-export/locate-entity.scm
History View file @ 4e98702
0 143 
new file mode 100644
... ... 
@@ -0,0 +1,126 @@
1 
+;;; This file deals with entities in import / export lists
2 
+
3 
+;;; This resolves an entity with the export table of a
4 
+;;; module.  It returns either a group, the symbol 'error, or the symbol
5 
+;;; 'not-found.  When force-error? is true, signal an error when
6 
+;;; the module is not found & return 'error.
7 
+
8 
+(define (locate-entity/export-table entity mod force-error?)
9 
+  (let* ((name (entity-name entity))
10 
+	 (group (table-entry (module-export-table mod) name)))
11 
+    (if (eq? group '#f)
12 
+	(if (not force-error?)
13 
+	    'not-found
14 
+	    (signal-entity-not-found name (module-name mod)))
15 
+	(let ((def (group-definition group)))
16 
+	  (cond ((is-type? 'entity-var entity)
17 
+		 group)
18 
+		((is-type? 'entity-con entity)
19 
+		 (cond ((algdata? def)
20 
+			(strip-constructors group))
21 
+		       ((synonym? def)
22 
+			(signal-synonym-needs-dots name (module-name mod)))
23 
+		       (else
24 
+			(signal-wrong-definition
25 
+			  "type constructor" name (module-name mod)))))
26 
+		((is-type? 'entity-abbreviated entity)
27 
+		 (cond ((algdata? def)
28 
+			(cond ((hidden-constructors? group)
29 
+			       (if force-error?
30 
+				   (signal-abstract-type
31 
+				     name (module-name mod))
32 
+				   'not-found))
33 
+			      (else
34 
+			       group)))
35 
+		       ((or (class? def) (synonym? def))
36 
+			group)
37 
+		       (else
38 
+			(signal-wrong-definition
39 
+			  "class or datatype" name (module-name mod)))))
40 
+		((is-type? 'entity-class entity)
41 
+		 (if (class? def)
42 
+		     (match-constituents group (entity-class-methods entity)
43 
+					 entity "method")
44 
+		     (signal-wrong-definition "class" name (module-name mod))))
45 
+		((is-type? 'entity-datatype entity)
46 
+		 (if (algdata? def)
47 
+		     (match-constituents group
48 
+					 (entity-datatype-constructors entity)
49 
+					 entity "constructor")
50 
+		     (signal-wrong-definition
51 
+		       "data type" name (module-name mod))))
52 
+		(else
53 
+		 (error "Bad entity ~s." entity))
54 
+		)))))
55 
+
56 
+(define (match-constituents group names entity what)
57 
+  (check-duplicates names entity)
58 
+  (dolist (n-d (cdr group))
59 
+    (when (not (memq (tuple-2-1 n-d) names))
60 
+      (signal-extra-constituent entity (tuple-2-1 n-d) what)))
61 
+  (dolist (name names)
62 
+    (when (not (assq name (cdr group)))
63 
+      (signal-missing-constituent entity name what)))
64 
+  group)
65 
+
66 
+
67 
+;;; The following routine locates an entity in the current module.
68 
+;;; It may return 'error, 'not-found, or a group.
69 
+
70 
+(define (locate-entity entity)
71 
+  (let* ((name (entity-name entity))
72 
+	 (def (resolve-toplevel-name name)))
73 
+    (cond ((eq? def '#f)
74 
+	   'not-found)
75 
+	  ((is-type? 'entity-var entity)
76 
+	   (if (method-var? def)
77 
+	       (signal-export-method-var name)
78 
+	       (make-group name def)))
79 
+	  ((is-type? 'entity-con entity)
80 
+	   (cond ((algdata? def)
81 
+		  (make-group name def))
82 
+		 ((synonym? def)
83 
+		  (signal-synonym-needs-dots name *module-name*))
84 
+		 (else
85 
+		  (signal-wrong-definition
86 
+		    "type constructor" name *module-name*))))
87 
+	  ((is-type? 'entity-abbreviated entity)
88 
+	   (cond ((algdata? def)
89 
+		  (require-complete-algdata
90 
+		   (gather-algdata-group name def)))
91 
+		 ((synonym? def)
92 
+		  (make-group name def))
93 
+		 ((class? def)
94 
+		  (gather-class-group name def))
95 
+		 (else
96 
+		  (signal-wrong-definition
97 
+		    "type constructor or class" name *module-name*))))
98 
+	  ((is-type? 'entity-class entity)
99 
+	   (if (class? def)
100 
+	       (match-group-names
101 
+		 (gather-class-group name def)
102 
+		 (entity-class-methods entity)
103 
+		 entity
104 
+		 "method")
105 
+	       (signal-wrong-definition "class" name *module-name*)))
106 
+	  ((is-type? 'entity-datatype entity)
107 
+	   (if (algdata? def)
108 
+	       (match-group-names
109 
+		 (require-complete-algdata (gather-algdata-group name def))
110 
+		 (entity-datatype-constructors entity)
111 
+		 entity "constructor")
112 
+	       (signal-wrong-definition "data type" name *module-name*)))
113 
+	  (else
114 
+	   (error "Bad entity ~s." entity)))))
115 
+
116 
+(define (require-complete-algdata group)
117 
+  (if (hidden-constructors? group)
118 
+      'not-found
119 
+      group))
120 
+
121 
+(define (match-group-names group names entity what)
122 
+  (when (not (eq? group 'not-found))
123 
+    (match-constituents group names entity what))
124 
+  group)
125 
+
126 
+
import-export/top-definitions.scm
History View file @ 4e98702
0 127 
new file mode 100644
... ... 
@@ -0,0 +1,98 @@
1 
+;;; File: top-definitions.scm
2 
+
3 
+;;; Description: This creates definitions for all top level (exportable)
4 
+;;;  object in a module.
5 
+
6 
+(define (create-top-definitions)
7 
+  (dolist (decl (module-decls *module*))
8 
+    (if (eq? (module-type *module*) 'interface)
9 
+	(when (signdecl? decl)
10 
+	   (create-var-definitions decl (signdecl-vars decl)))
11 
+	(when (valdef? decl)
12 
+	   (create-var-definitions
13 
+	    decl (collect-pattern-vars (valdef-lhs decl))))))
14 
+  (dolist (algdata (module-algdatas *module*))
15 
+    (create-alg-definitions algdata))
16 
+  (dolist (synonym (module-synonyms *module*))
17 
+    (create-syn-definitions synonym))
18 
+  (dolist (class (module-classes *module*))
19 
+    (create-class-definitions class)))
20 
+
21 
+;;; ------------------------------------------------------------------------
22 
+;;; creation of definitions
23 
+;;; ------------------------------------------------------------------------
24 
+
25 
+(define (create-var-definitions decl vars)
26 
+  (remember-context decl
27 
+    (dolist (v vars)
28 
+     (let* ((var-name (var-ref-name v))
29 
+	    (def (create-top-definition var-name 'var)))
30 
+       (setf (var-ref-var v) def)
31 
+       (push def (module-vars *module*))
32 
+       (add-new-group var-name def)))))
33 
+
34 
+;;; This also creates definitions for the constructors
35 
+
36 
+(define (create-alg-definitions algdata)
37 
+  (remember-context algdata
38 
+    (with-slots data-decl (simple constrs) algdata
39 
+      (let* ((alg-name (tycon-name simple))
40 
+	     (def (create-top-definition alg-name 'algdata)))
41 
+	(setf (tycon-def simple) def)
42 
+	(let ((constr-group
43 
+	       (map (lambda (constr)
44 
+		     (let* ((con-ref (constr-constructor constr))
45 
+			    (con-name (con-ref-name con-ref))
46 
+			    (con-def (create-top-definition con-name 'con)))
47 
+		        (setf (con-ref-con con-ref) con-def)
48 
+			(tuple con-name con-def)))
49 
+		    constrs)))
50 
+	  (setf (algdata-constrs def) (map (function tuple-2-2) constr-group))
51 
+	  (setf (tycon-def-arity def) (length (tycon-args simple)))
52 
+	  (add-new-group alg-name def constr-group))))))
53 
+
54 
+(define (create-class-definitions class-decl)
55 
+  (remember-context class-decl
56 
+    (with-slots class-decl (class decls) class-decl
57 
+      (let* ((class-name (class-ref-name class))
58 
+	     (class-def (create-top-definition class-name 'class)))
59 
+	(setf (class-ref-class class) class-def)
60 
+	(let ((method-group
61 
+	       (concat
62 
+		(map
63 
+		 (lambda (decl)
64 
+		  (if (is-type? 'signdecl decl)
65 
+		      (remember-context decl
66 
+		       (map (lambda (method-var)
67 
+			      (let* ((var-name (var-ref-name method-var))
68 
+				     (def (create-top-definition
69 
+					      var-name 'method-var)))
70 
+				(setf (method-var-class def) class-def)
71 
+				(setf (method-var-default def) '#f)
72 
+				(setf (var-ref-var method-var) def)
73 
+				(tuple var-name def)))
74 
+			    (signdecl-vars decl)))
75 
+		      '()))
76 
+		decls))))
77 
+	  (setf (class-method-vars class-def)
78 
+		(map (function tuple-2-2) method-group))
79 
+	  (add-new-group class-name class-def method-group))))))
80 
+
81 
+(define (create-syn-definitions synonym-decl)
82 
+  (remember-context synonym-decl
83 
+    (let* ((simple (synonym-decl-simple synonym-decl))
84 
+	   (syn-name (tycon-name simple))
85 
+	   (def (create-top-definition syn-name 'synonym)))
86 
+      (setf (tycon-def simple) def)
87 
+      (setf (tycon-def-arity def) (length (tycon-args simple)))
88 
+      (add-new-group syn-name def))))
89 
+
90 
+(define (add-new-group name def . others)
91 
+  (when (memq *module* (module-exported-modules *module*))
92 
+      (export-group (cons (tuple name def)
93 
+			  (if (null? others)
94 
+			      '()
95 
+			      (car others))))))
96 
+
97 
+
98 
+
parser/README
History View file @ 4e98702
0 99 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+This directory contains the lexer and parser.
parser/annotation-parser.scm
History View file @ 4e98702
0 2 
new file mode 100644
... ... 
@@ -0,0 +1,184 @@
1 
+
2 
+(define *annotation-escape* '())
3 
+
4 
+(define (parse-annotations)
5 
+ (let ((save-layout (dynamic *layout-stack*)))
6 
+  (setf (dynamic *layout-stack*) '())
7 
+  (advance-token)
8 
+  (let/cc annotation-escape
9 
+   (setf *annotation-escape* (lambda ()
10 
+			       (setf (dynamic *layout-stack*) save-layout)
11 
+			       (advance-to-annotation-end)
12 
+			       (funcall annotation-escape '())))
13 
+   (let ((res (start-layout (function parse-annotation-list-1))))
14 
+    (setf (dynamic *layout-stack*) save-layout)
15 
+    (token-case
16 
+     (end-annotation res)
17 
+     (else (signal-annotation-error)))))))
18 
+
19 
+(define (parse-annotation-list-1 in-layout?)
20 
+  (let ((kind (get-annotation-kind)))
21 
+    (cond ((eq? kind 'decl)
22 
+	   (let ((d (parse-annotation-decl)))
23 
+	     (token-case
24 
+	      (\; (cons d (parse-annotation-list-1 in-layout?)))
25 
+	      (else (close-layout in-layout?)
26 
+		    (list d)))))
27 
+	  ((eq? kind 'value)
28 
+	   (let ((d (parse-annotation-value)))
29 
+	     (token-case
30 
+	      (\; (cons d (parse-annotation-list-1 in-layout?)))
31 
+	      (else (close-layout in-layout?)
32 
+		    (list d)))))
33 
+	  (else
34 
+	   (close-layout in-layout?)
35 
+	   '()))))
36 
+
37 
+(define (get-annotation-kind)
38 
+  (token-case
39 
+   ((no-advance end-annotation) 'end)
40 
+   ((no-advance \() 'decl)
41 
+   ((var con)
42 
+    (let ((next (peek-1-type)))
43 
+      (cond ((eq? next '|,|)
44 
+	     'decl)
45 
+	    ((eq? next '|::|)
46 
+	     'decl)
47 
+	    (else
48 
+	     'value))))
49 
+   (else 'error)))
50 
+
51 
+(define (parse-annotation-decl)
52 
+  (let* ((names (parse-aname-list))
53 
+	 (decls (parse-aval-list)))
54 
+    (make annotation-decl (names names) (annotations decls))))
55 
+
56 
+(define (parse-aname-list)
57 
+ (let ((name 'foo))
58 
+  (token-case
59 
+   (var
60 
+    (setf name (var->symbol)))
61 
+   (con
62 
+    (setf name (con->symbol)))
63 
+   (else (signal-annotation-error)))
64 
+  (token-case (\, (cons name (parse-aname-list)))
65 
+	      (|::| (list name))
66 
+	      (else (signal-annotation-error)))))
67 
+
68 
+
69 
+(define (parse-aval-list)
70 
+  (let ((ann (parse-annotation-value)))
71 
+    (token-case (\, (cons ann (parse-aval-list)))
72 
+		(else (list ann)))))
73 
+
74 
+(define (parse-annotation-value)
75 
+  (token-case
76 
+   (name (let* ((name (token->symbol))
77 
+		(args (parse-annotation-args name)))
78 
+	   (make annotation-value (name name) (args args))))))
79 
+
80 
+(define (parse-annotation-args name)
81 
+  (token-case
82 
+   (\( (parse-annotation-args-1 name 0))
83 
+   (else '())))
84 
+
85 
+;;; This routine can invoke special parsers for the arguments
86 
+
87 
+(define (parse-annotation-args-1 name i)
88 
+  (let* ((argtype (get-annotation-arg-description name i))
89 
+	 (arg (parse-annotation-arg argtype)))
90 
+    (token-case
91 
+     (\) (list arg))
92 
+     (\, (cons arg (parse-annotation-args-1 name (1+ i))))
93 
+     (else (signal-annotation-error)))))
94 
+
95 
+(define (parse-annotation-arg type)
96 
+  (cond ((eq? type 'string)
97 
+	 (token-case
98 
+	  ((string no-advance)
99 
+	   (let ((res (car *token-args*)))
100 
+	     (advance-token)
101 
+	     res))
102 
+	  (else (signal-annotation-error))))
103 
+	;; The following is for a datatype import/export.  It is
104 
+	;; Type(Con1(strs),Con2(strs),...)
105 
+	((eq? type 'integer)
106 
+	 (token-case
107 
+	  ((integer no-advance) (token->integer))
108 
+	  (else (signal-annotation-error))))
109 
+	((eq? type 'constr-list)
110 
+	 (parse-annotation-constr-list))
111 
+	(else
112 
+	 (signal-annotation-error))))
113 
+
114 
+(define (signal-annotation-error)
115 
+  (parser-error/recoverable 'annotation-error "Error in annotation syntax")
116 
+  (funcall *annotation-escape*))
117 
+
118 
+(define (parse-annotation-constr-list)
119 
+  (token-case
120 
+   (tycon (let ((type-name (token->symbol)))
121 
+	    (token-case (\( (let* ((args (parse-acl1))
122 
+				   (res (tuple type-name args)))
123 
+			      (token-case  ; leave the ) to end the args
124 
+			       ((no-advance \)) (list res))
125 
+			       (\, (cons res (parse-annotation-constr-list)))
126 
+			       (else (signal-annotation-error)))))
127 
+			(else (signal-annotation-error)))))
128 
+   (else (signal-annotation-error))))
129 
+
130 
+(define (parse-acl1)
131 
+  (token-case
132 
+   (con (let ((con-name (con->symbol)))
133 
+	  (token-case (\( (let ((str-args (parse-string-list)))
134 
+			    (token-case
135 
+			     (\, (cons (tuple con-name str-args)
136 
+				       (parse-acl1)))
137 
+			     (\) (list (tuple con-name str-args)))
138 
+			     (else (signal-annotation-error)))))
139 
+		      (else (signal-annotation-error)))))
140 
+   (else (signal-annotation-error))))
141 
+
142 
+(define (parse-string-list)
143 
+  (token-case
144 
+   ((string no-advance)
145 
+    (let ((res (read-lisp-object (car *token-args*))))
146 
+      (advance-token)
147 
+      (token-case
148 
+       (\) (list res))
149 
+       (\, (cons res (parse-string-list)))
150 
+       (else (signal-annotation-error)))))
151 
+   (else (signal-annotation-error))))
152 
+
153 
+(define (advance-to-annotation-end)
154 
+  (token-case
155 
+   (eof '())
156 
+   (end-annotation
157 
+     (advance-token))
158 
+   (else
159 
+    (advance-token)
160 
+    (advance-to-annotation-end))))
161 
+
162 
+(define *known-annotations* '(
163 
+  (|LispName| string)
164 
+  (|Prelude|)
165 
+  (|Strictness| string)
166 
+  (|Strict|)
167 
+  (|NoConversion|)
168 
+  (|Inline|)
169 
+  (|STRICT|)
170 
+  (|ImportLispType| constr-list)
171 
+  (|ExportLispType| constr-list)
172 
+  (|Complexity| integer)
173 
+  ))
174 
+
175 
+(define (get-annotation-arg-description annotation i)
176 
+  (let ((s (assq annotation *known-annotations*)))
177 
+    (cond ((eq? s '#f)
178 
+	   (parser-error/recoverable 'unknown-annotation
179 
+             "Annotation ~A is not defined in this system - ignored."
180 
+	     annotation)
181 
+	   'unknown)
182 
+	  ((>= i (length s))
183 
+	   'error)
184 
+	  (else (list-ref s (1+ i))))))
parser/decl-parser.scm
History View file @ 4e98702
0 185 
new file mode 100644
... ... 
@@ -0,0 +1,175 @@
1 
+;;; File: decl-parser           Author: John
2 
+
3 
+(define (parse-decl)
4 
+  (let ((decl-type (find-decl-type)))
5 
+    (cond ((eq? decl-type 'signdecl)
6 
+	   (parse-signdecl))
7 
+	  ((eq? decl-type 'pat-or-op)
8 
+	   (parse-pat-or-op))
9 
+	  ((eq? decl-type 'fundef)
10 
+	   (parse-fundef))
11 
+	  ((eq? decl-type 'plus-def)
12 
+	   (parse-plus-def))
13 
+	  ((eq? decl-type 'annotation)
14 
+	   (make annotation-decls (annotations (parse-annotations)))))))
15 
+
16 
+;;; This looks at the first tokens in a definition to determine it's type.
17 
+;;;   var (:: | ,)      - signdecl
18 
+;;;   var apat-start    - function definition
19 
+;;;   (var | _) +       - definition of infix +
20 
+;;;   anything alse     - pattern binding or infix definition
21 
+
22 
+(define (find-decl-type)
23 
+  (let* ((saved-excursion (save-scanner-state))
24 
+	 (decl-type
25 
+	  (token-case
26 
+	   (var (scan-var)
27 
+		(token-case
28 
+		 ((\, \:\:) 'signdecl)
29 
+		 (apat-start 'fundef)
30 
+		 (+ 'plus-def)
31 
+		 (else 'pat-or-op)))
32 
+	   (_ (token-case
33 
+	       (+ 'plus-def)
34 
+	       (else 'pat-or-op)))
35 
+	   (begin-annotation 'annotation)
36 
+	   (else 'pat-or-op))))
37 
+    (restore-excursion saved-excursion)
38 
+    decl-type))
39 
+
40 
+;;; These are the different flavors of decl parsers
41 
+
42 
+(define (parse-signdecl)
43 
+ (save-parser-context
44 
+  (trace-parser signdecl
45 
+    (let ((vars (parse-signdecl-vars)))
46 
+      (require-token \:\:
47 
+		     (signal-missing-token "`::'" "signature declaration"))
48 
+      (let ((signature (parse-signature)))
49 
+	(make signdecl (vars vars) (signature signature)))))))
50 
+
51 
+(define (parse-signdecl-vars)
52 
+  (token-case
53 
+   (var (let ((var (var->ast)))
54 
+	  (token-case (\, (cons var (parse-signdecl-vars)))
55 
+		      (else (list var)))))
56 
+   (else (signal-missing-token "<var>" "signature declaration"))))
57 
+
58 
+(define (parse-pat-or-op)
59 
+  (trace-parser patdef
60 
+    (let* ((line-number (capture-current-line))
61 
+	   (pat (parse-pat)))
62 
+      (token-case
63 
+       (varop (parse-infix-def pat line-number))
64 
+       (else (add-rhs pat '() '#f line-number))))))
65 
+
66 
+(define (parse-infix-def pat1 line-number)
67 
+  (let* ((op (make var-pat (var (varop->ast))))
68 
+	 (pat2 (parse-pat)))
69 
+	(add-rhs op (list pat1 pat2) '#t line-number)))
70 
+
71 
+(define (parse-fundef)
72 
+ (trace-parser fundef
73 
+  (let* ((start-line (capture-current-line))
74 
+	 (fn (parse-apat))  ; must be a single variable
75 
+	 (args (parse-apat-list)))
76 
+    (add-rhs fn args '#f start-line))))
77 
+
78 
+(define (parse-plus-def)
79 
+  (trace-parser plus-def
80 
+    (let* ((start-line (capture-current-line))
81 
+	   (var (parse-apat)))
82 
+      (parse-infix-def var start-line))))
83 
+
84 
+(define (add-rhs pat args infix? start-line)
85 
+  (let* ((rhs (parse-rhs))
86 
+	 (decls (parse-where-decls))
87 
+	 (single (make single-fun-def
88 
+		       (args args)
89 
+		       (rhs-list rhs)
90 
+		       (where-decls decls)
91 
+		       (infix? infix?)))
92 
+	 (valdef (make valdef (lhs pat) (definitions (list single)))))
93 
+    (setf (ast-node-line-number single) start-line)
94 
+    (setf (ast-node-line-number valdef) start-line)
95 
+    valdef))
96 
+
97 
+(define (parse-rhs)
98 
+  (token-case
99 
+   (= (let ((rhs (parse-exp)))
100 
+	(list (make guarded-rhs (guard (make omitted-guard)) (rhs rhs)))))
101 
+   (\| (parse-guarded-rhs))
102 
+   (else
103 
+    (signal-missing-token "`=' or `|'" "rhs of valdef"))))
104 
+
105 
+(define (parse-guarded-rhs) ; assume just past |
106 
+ (trace-parser guard
107 
+  (let ((guard (parse-exp-i)))  ; 1.2 change
108 
+    (require-token = (signal-missing-token "`='" "guarded rhs"))
109 
+    (let* ((exp (parse-exp))
110 
+	   (res (make guarded-rhs (guard guard) (rhs exp))))
111 
+      (token-case
112 
+       (\| (cons res (parse-guarded-rhs)))
113 
+       (else (list res)))))))
114 
+
115 
+(define (parse-where-decls)
116 
+  (token-case
117 
+   (|where|
118 
+    (parse-decl-list))
119 
+   (else '())))
120 
+
121 
+(define (parse-decl-list)
122 
+  (start-layout (function parse-decl-list-1)))
123 
+
124 
+(define (parse-decl-list-1 in-layout?)
125 
+  (token-case
126 
+   ((apat-start begin-annotation)
127 
+    (let ((decl (parse-decl)))
128 
+      (token-case
129 
+       (\; (decl-cons decl (parse-decl-list-1 in-layout?)))
130 
+       (else (close-layout in-layout?)
131 
+	     (list decl)))))
132 
+   (else
133 
+    (close-layout in-layout?)
134 
+    '())))
135 
+
136 
+;;; This adds a new decl to a decl list.  Successive decls for the same fn
137 
+;;; are combined.
138 
+
139 
+(define (decl-cons decl decl-list)
140 
+  (cond ((null? decl-list)
141 
+	 (list decl))
142 
+	(else (nconc (combine-decls decl (car decl-list)) (cdr decl-list)))))
143 
+
144 
+(define (decl-push decl decl-stack)
145 
+  (cond ((null? decl-stack)
146 
+	 (list decl))
147 
+	(else (nconc (nreverse (combine-decls (car decl-stack) decl))
148 
+		     (cdr decl-stack)))))
149 
+
150 
+(define (combine-decls decl1 decl2)
151 
+  (if (and (is-type? 'valdef decl1)
152 
+	   (is-type? 'valdef decl2)
153 
+	   (same-decl-var? (valdef-lhs decl1) (valdef-lhs decl2)))
154 
+      (if (eqv? (length (single-fun-def-args (car (valdef-definitions decl1))))
155 
+		(length (single-fun-def-args (car (valdef-definitions decl2)))))
156 
+	  (begin
157 
+	    (setf (valdef-definitions decl1)
158 
+		  (nconc (valdef-definitions decl1)
159 
+			 (valdef-definitions decl2)))
160 
+	    (list decl1))
161 
+	  (signal-multiple-definitions-arity-mismatch (valdef-lhs decl1)))
162 
+      (list decl1 decl2)))
163 
+
164 
+(define (same-decl-var? pat1 pat2)
165 
+  (and (is-type? 'var-pat pat1)
166 
+       (is-type? 'var-pat pat2)
167 
+       (eq? (var-ref-name (var-pat-var pat1))
168 
+	    (var-ref-name (var-pat-var pat2)))))
169 
+
170 
+(define (signal-multiple-definitions-arity-mismatch pat)
171 
+  (parser-error 'multiple-definitions-arity-mismatch
172 
+		"Definition of ~a does not match arity of previous definition."
173 
+		pat))
174 
+
175 
+
parser/exp-parser.scm
History View file @ 4e98702
0 176 
new file mode 100644
... ... 
@@ -0,0 +1,230 @@
1 
+;;; File: expr-parser           Author: John
2 
+
3 
+(define (parse-exp)
4 
+ (trace-parser exp
5 
+   (parse-exp-0)))
6 
+
7 
+(define (parse-exp-0)  ;; This picks up expr type signatures
8 
+  (let ((exp (parse-exp-i)))
9 
+    (token-case
10 
+     (\:\: (let ((signature (parse-signature)))
11 
+	     (make exp-sign (exp exp) (signature signature))))
12 
+   (else exp))))
13 
+
14 
+(define (parse-exp-i)  ;; This collects a list of exps for later prec parsing
15 
+  (let ((exps (parse-infix-exps)))
16 
+    (if (null? (cdr exps))
17 
+	(car exps)
18 
+	(make pp-exp-list (exps exps)))))
19 
+
20 
+(define (parse-infix-exps)
21 
+  (token-case
22 
+     (- (cons (make negate) (parse-infix-exps)))
23 
+     (\\ (list (parse-lambda)))
24 
+     (|let| (list (parse-let)))
25 
+     (|if| (list (parse-if)))
26 
+     (|case| (parse-possible-app (parse-case)))
27 
+     (else (let ((aexp (parse-aexp)))
28 
+	     (parse-possible-app aexp)))))
29 
+
30 
+(define (parse-possible-app exp)
31 
+  (token-case
32 
+    (aexp-start
33 
+     (let ((exp2 (parse-aexp)))
34 
+      (parse-possible-app (make app (fn exp) (arg exp2)))))
35 
+    (varop
36 
+     (let ((varop (varop->ast)))
37 
+       (if (eq-token? '\))
38 
+	   (list exp varop)
39 
+	   `(,exp ,varop ,@(parse-infix-exps)))))
40 
+    (conop
41 
+     (let ((conop (conop->ast)))
42 
+       (if (eq-token? '\))
43 
+	   (list exp conop)
44 
+	   `(,exp ,conop ,@(parse-infix-exps)))))
45 
+    (else (list exp))))
46 
+
47 
+(define (parse-lambda)
48 
+  (trace-parser lambda
49 
+   (save-parser-context
50 
+    (let ((pats (parse-apat-list)))
51 
+      (require-token -> (signal-missing-token "`->'" "lambda expression"))
52 
+      (let ((exp (parse-exp)))
53 
+	(make lambda (pats pats) (body exp)))))))
54 
+
55 
+(define (parse-let)
56 
+  (trace-parser let
57 
+   (save-parser-context
58 
+    (let ((decls (parse-decl-list)))
59 
+      (require-token |in| (signal-missing-token "`in'" "let expression"))
60 
+      (let ((exp (parse-exp)))
61 
+	(make let (decls decls) (body exp)))))))
62 
+
63 
+(define (parse-if)
64 
+  (trace-parser if
65 
+   (save-parser-context
66 
+    (let ((test-exp (parse-exp)))
67 
+      (require-token |then| (signal-missing-token "`then'" "if expression"))
68 
+      (let ((then-exp (parse-exp)))
69 
+	(require-token |else| (signal-missing-token "`else'" "if expression"))
70 
+	(let ((else-exp (parse-exp)))
71 
+	  (make if (test-exp test-exp)
72 
+		   (then-exp then-exp)
73 
+		   (else-exp else-exp))))))))
74 
+
75 
+(define (parse-case)
76 
+  (trace-parser case
77 
+   (save-parser-context
78 
+    (let ((exp (parse-exp)))
79 
+      (require-token |of| (signal-missing-token "`of'" "case expression"))
80 
+      (let ((alts (start-layout (function parse-alts))))
81 
+	(make case (exp exp) (alts alts)))))))
82 
+
83 
+(define (parse-alts in-layout?)
84 
+  (token-case
85 
+    (pat-start
86 
+     (let ((alt (parse-alt)))
87 
+       (token-case
88 
+	(\; (cons alt (parse-alts in-layout?)))
89 
+	(else (close-layout in-layout?)
90 
+	      (list alt)))))
91 
+    (else
92 
+     (close-layout in-layout?)
93 
+     '())))
94 
+
95 
+(define (parse-alt)
96 
+ (trace-parser alt
97 
+  (let* ((pat (parse-pat))
98 
+	 (rhs-list (token-case
99 
+		    (-> (let ((exp (parse-exp)))
100 
+			  (list (make guarded-rhs (guard (make omitted-guard))
101 
+				                  (rhs exp)))))
102 
+		    (\| (parse-guarded-alt-rhs))
103 
+		    (else (signal-missing-token "`->' or `|'" "rhs of alt"))))
104 
+	 (decls (parse-where-decls)))
105 
+    (make alt (pat pat) (rhs-list rhs-list) (where-decls decls)))))
106 
+
107 
+(define (parse-guarded-alt-rhs)
108 
+  (let ((guard (parse-exp)))
109 
+    (require-token -> (signal-missing-token "`->'" "alt"))
110 
+    (let* ((exp (parse-exp))
111 
+	   (res (make guarded-rhs (guard guard) (rhs exp))))
112 
+      (token-case
113 
+       (\| (cons res (parse-guarded-alt-rhs)))
114 
+       (else (list res))))))
115 
+
116 
+(define (parse-aexp)
117 
+ (trace-parser aexp
118 
+  (token-case
119 
+    (var (save-parser-context (var->ast)))
120 
+    (con (save-parser-context (con->ast)))
121 
+    (literal (literal->ast))
122 
+    (\(
123 
+     (token-case
124 
+       (\) (**con/def (core-symbol "UnitConstructor")))
125 
+       ((no-advance -) (parse-exp-or-tuple))
126 
+       (varop
127 
+	(let ((varop (varop->ast)))
128 
+	  (make-right-section varop)))
129 
+       (conop
130 
+	(let ((conop (conop->ast)))
131 
+	  (make-right-section conop)))
132 
+       (else
133 
+	(parse-exp-or-tuple))))
134 
+    (\[
135 
+     (token-case
136 
+      (\] (make list-exp (exps '())))
137 
+      (else
138 
+       (let ((exp (parse-exp)))
139 
+        (token-case
140 
+         (\, (let ((exp2 (parse-exp)))
141 
+	       (token-case
142 
+		 (\] (make list-exp (exps (list exp exp2))))
143 
+		 (\.\. (token-case
144 
+			 (\] (make sequence-then (from exp) (then exp2)))
145 
+			 (else
146 
+			   (let ((exp3 (parse-exp)))
147 
+			     (require-token
148 
+			       \]
149 
+			       (signal-missing-token
150 
+				 "`]'" "sequence expression"))
151 
+			     (make sequence-then-to (from exp) (then exp2)
152 
+				                    (to exp3))))))
153 
+		 (else
154 
+		  (make list-exp
155 
+			(exps `(,exp ,exp2 ,@(parse-exp-list))))))))
156 
+	 (\.\. (token-case
157 
+		 (\] (make sequence (from exp)))
158 
+		 (else
159 
+		  (let ((exp2 (parse-exp)))
160 
+		    (require-token
161 
+		      \]
162 
+		      (signal-missing-token "`]'" "sequence expression"))
163 
+		    (make sequence-to (from exp) (to exp2))))))
164 
+	 (\] (make list-exp (exps (list exp))))
165 
+	 (\| (parse-list-comp exp))
166 
+	 (else
167 
+	  (signal-invalid-syntax
168 
+	    "a list, sequence, or list comprehension")))))))
169 
+    (else
170 
+     (signal-invalid-syntax "an aexp")))))
171 
+
172 
+(define (make-right-section op)
173 
+  (let ((exps (parse-infix-exps)))
174 
+    (token-case
175 
+     (\) (make pp-exp-list (exps (cons op exps))))
176 
+     (else (signal-missing-token "`)'" "right section expression")))))
177 
+
178 
+(define (parse-exp-list)
179 
+  (token-case
180 
+   (\] '())
181 
+   (\, (let ((exp (parse-exp))) (cons exp (parse-exp-list))))
182 
+   (else (signal-missing-token "`]' or `,'" "list expression"))))
183 
+
184 
+(define (parse-exp-or-tuple)
185 
+  (let ((exp (parse-exp)))
186 
+    (token-case
187 
+     (\) exp)  ; Note - sections ending in an op are parsed elsewhere
188 
+     (else (make-tuple-cons (cons exp (parse-tuple-exp)))))))
189 
+
190 
+(define (parse-tuple-exp)
191 
+  (token-case
192 
+   (\) '())
193 
+   (\, (let ((exp (parse-exp))) (cons exp (parse-tuple-exp))))
194 
+   (else (signal-missing-token
195 
+	  "`)' or `,'" "tuple or parenthesized expression"))))
196 
+
197 
+;;; List comprehensions
198 
+
199 
+;;; Assume | has been consumed
200 
+
201 
+(define (parse-list-comp exp)
202 
+ (save-parser-context
203 
+  (let ((quals (parse-qual-list)))
204 
+    (make list-comp (exp exp) (quals quals)))))
205 
+
206 
+(define (parse-qual-list)
207 
+  (let ((qual (parse-qual)))
208 
+    (token-case
209 
+      (\, (cons qual (parse-qual-list)))
210 
+      (\] (list qual))
211 
+      (else (signal-missing-token "`]' or `,'" "list comprehension")))))
212 
+
213 
+(define (parse-qual)
214 
+ (trace-parser qual
215 
+  (save-parser-context
216 
+   (let* ((saved-excursion (save-scanner-state))
217 
+	  (is-gen? (and (scan-pat) (eq-token? '<-))))
218 
+    (restore-excursion saved-excursion)
219 
+    (cond (is-gen?
220 
+	   (let ((pat (parse-pat)))
221 
+	     (advance-token) ; past the <-
222 
+	     (let ((exp (parse-exp)))
223 
+	       (make qual-generator (pat pat) (exp exp)))))
224 
+	  (else
225 
+	   (let ((exp (parse-exp)))
226 
+	     (make qual-filter (exp exp)))))))))
227 
+
228 
+(define (make-tuple-cons args)
229 
+  (let ((tuple-con (**con/def (tuple-constructor (length args)))))
230 
+    (**app/l tuple-con args)))
parser/interface-parser.scm
History View file @ 4e98702
0 231 
new file mode 100644
... ... 
@@ -0,0 +1,98 @@
1 
+;;; This is the parser for interface files.
2 
+
3 
+(define (parse-tokens/interface tokens)
4 
+  (init-token-stream tokens)
5 
+  (let ((interface (token-case
6 
+		    (|interface| (parse-interface))
7 
+		    (|module| (interface-required-error))
8 
+		    (else (crud-in-interface-error)))))
9 
+    (cons interface (parse-interface-list))))
10 
+
11 
+(define (interface-required-error)
12 
+  (parser-error 'interface-required "Expecting `interface' keyword"))
13 
+
14 
+(define (crud-in-interface-error)
15 
+  (parser-error 'unexpected-interface-crud "Junk after interface"))
16 
+
17 
+(define (parse-interface-list)
18 
+  (token-case
19 
+   (|interface|
20 
+     (let ((interface (parse-interface)))
21 
+       (cons interface (parse-interface-list))))
22 
+   (|module| (interface-required-error))
23 
+   (eof '())
24 
+   (else (crud-in-interface-error))))
25 
+
26 
+(define (parse-interface)
27 
+  (token-case
28 
+   (modid
29 
+    (let ((module-name (token->symbol)))
30 
+      (require-token |where|
31 
+       (signal-missing-token "`where'" "interface definition"))
32 
+      (let ((mod-ast (make module (name module-name)
33 
+			          (type 'interface)
34 
+				  (exports '()))))
35 
+	(start-layout (lambda (in-layout?)
36 
+		       (parse-interface-decls mod-ast in-layout? 'import))))))))
37 
+
38 
+(define (parse-interface-decls mod-ast in-layout? state)
39 
+  (token-case
40 
+    (|import| (let ((import (parse-import)))
41 
+		(when (not (eq? (import-decl-mode import) 'by-name))
42 
+		   (phase-error 'illegal-import
43 
+    "Imports in interfaces must specify specific entities"))
44 
+		(if (eq? state 'import)
45 
+		    (push-decl-list import (module-imports mod-ast))
46 
+		    (signal-misplaced-import)))
47 
+	      (terminate-interface-topdecl mod-ast in-layout? state))
48 
+    (|infix| (terminate-interface-topdecl mod-ast in-layout?
49 
+			       (parse-fixity 'n mod-ast state)))
50 
+    (|infixl| (terminate-interface-topdecl mod-ast in-layout?
51 
+			       (parse-fixity 'l mod-ast state)))
52 
+    (|infixr| (terminate-interface-topdecl mod-ast in-layout?
53 
+			       (parse-fixity 'r mod-ast state)))
54 
+    (|data| (let ((data-decl (parse-type-decl '#t)))
55 
+	      (push-decl-list data-decl (module-algdatas mod-ast)))
56 
+	    (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
57 
+    (|type| (let ((synonym-decl (parse-synonym-decl)))
58 
+	     (push-decl-list synonym-decl (module-synonyms mod-ast)))
59 
+	    (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
60 
+    (|class| (let ((class-decl (parse-class-decl)))
61 
+	       (check-class-default-decls class-decl)
62 
+	       (push-decl-list class-decl (module-classes mod-ast)))
63 
+	     (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
64 
+    (|instance| (let ((instance-decl (parse-instance-decl '#t)))
65 
+		  (push-decl-list instance-decl (module-instances mod-ast)))
66 
+		(terminate-interface-topdecl mod-ast in-layout? 'topdecl))
67 
+    (var (let ((decl (parse-signdecl)))
68 
+	   (setf (module-decls mod-ast)
69 
+		 (decl-push decl (module-decls mod-ast))))
70 
+	 (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
71 
+    ((begin-annotation no-advance)
72 
+     (let ((annotations (parse-annotations)))
73 
+       (setf (module-annotations mod-ast)
74 
+	     (append (module-annotations mod-ast) annotations)))
75 
+     (terminate-interface-topdecl mod-ast in-layout? state))
76 
+    (else
77 
+     (maybe-end-interface mod-ast in-layout?))))
78 
+
79 
+(define (maybe-end-interface mod-ast in-layout?)
80 
+  (cond ((or (eq-token? '|interface|) (eq-token? 'eof) (eq-token? '\})
81 
+	     (eq-token? '$\}))
82 
+	 (close-layout in-layout?)
83 
+	 (wrapup-module mod-ast)
84 
+	 mod-ast)
85 
+	(else
86 
+	 (signal-invalid-syntax "a topdecl"))))
87 
+
88 
+(define (terminate-interface-topdecl mod-ast in-layout? state)
89 
+  (token-case
90 
+   (\; (parse-interface-decls mod-ast in-layout? state))
91 
+   (else (maybe-end-interface mod-ast in-layout?))))
92 
+
93 
+(define (check-class-default-decls class-decl)
94 
+  (dolist (d (class-decl-decls class-decl))
95 
+    (when (valdef? d)
96 
+      (remember-context d
97 
+       (recoverable-error 'no-defaults-in-interface
98 
+         "Class defaults should not be put in interface files")))))
parser/lexer.scm
History View file @ 4e98702
0 99 
new file mode 100644
... ... 
@@ -0,0 +1,651 @@
1 
+;;; File: parser/lexer    Author: John
2 
+
3 
+;;; token data structure: a list with the token type in the
4 
+;;; car and other information in the rest of the list.  Symbols
5 
+;;; designate the token type.
6 
+
7 
+;;; Reserved tokens use the name as the type and have no args.
8 
+;;; Reserved tokens:
9 
+;;;  case class data default deriving else hiding if import in infix
10 
+;;;  infixl infixr instance interface let module of renaming then to
11 
+;;;  type where .. :: => = @ \ | ~ <- -> `
12 
+;;; Other tokens:
13 
+;;;  (file string)
14 
+;;;  (newline line indent-column)
15 
+;;;  (conid string)
16 
+;;;  (varid string)
17 
+;;;  (consym string)
18 
+;;;  (varsym string)
19 
+;;;  (comment string) ;;; not used at the moment
20 
+;;;  (integer integer)
21 
+;;;  (float integer fraction exponent)
22 
+;;;  (string string)
23 
+;;;  (eof)
24 
+
25 
+
26 
+;;; *** All of the stuff for lexing character and string literals is
27 
+;;; *** broken because it assumes that the host Lisp uses the ASCII
28 
+;;; *** encoding for characters and supports at least 255 characters.
29 
+;;; *** I have marked the specific places in the code where these
30 
+;;; *** assumptions are made, but fixing the problem will probably
31 
+;;; *** require more drastic changes anyway -- such as using integers
32 
+;;; *** instead of characters and vectors of integers instead of characters
33 
+;;; *** throughout the compiler.
34 
+
35 
+(define *max-char* 255)  ; highest char-code allowed.
36 
+
37 
+;;; This defines the long names of the control chars.  Note that some of
38 
+;;; this duplicates the table above & the reader.
39 
+
40 
+(define *control-char-names* '(
41 
+  ("NUL" . 0) ("SOH" . 1) ("STX" . 2) ("ETX" . 3)
42 
+  ("EOT" . 4) ("ENQ" . 5) ("ACK" . 6) ("BEL" . 7)
43 
+  ("BS" . 8) ("HT" . 9) ("LF" . 10) ("VT" . 11)
44 
+  ("FF" . 12) ("CR" . 13) ("SO" . 14) ("SI" . 15)
45 
+  ("DLE" . 16) ("DC1" . 17) ("DC2" . 18) ("DC3" . 19)
46 
+  ("DC4" . 20) ("NAK" . 21) ("SYN" . 22) ("ETB" . 23)
47 
+  ("CAN" . 24) ("EM" . 25) ("SUB" . 26) ("ESC" . 27)
48 
+  ("FS" . 28) ("GS" . 29) ("RS" . 30) ("US" . 31)
49 
+  ("SP" . 32) ("DEL" . 127)))
50 
+
51 
+;;; This defines the short names for a few control chars.  This
52 
+;;; is keyed off the previous table
53 
+
54 
+(define *short-control-char-names* '(
55 
+   (#\a . "BEL")    (#\b . "BS")    (#\f . "FF")    (#\n . "LF")
56 
+   (#\r . "CR") (#\t . "HT") (#\v . "VT")))
57 
+
58 
+;;; This is used in the ^X construct.  Assume that ^X = code for ^A + X-A
59 
+;;; *** This is an invalid assumption.
60 
+
61 
+(define *control-A* 1)
62 
+
63 
+;;; This function is the interface between the lexer and the rest
64 
+;;; of the system.  Note that the `file' reported in error messages
65 
+;;; must be bound in an outer context.
66 
+
67 
+
68 
+;;; *** I think this function should be binding these variables and not
69 
+;;; *** just assigning them.
70 
+
71 
+(define (lex-port port literate?)
72 
+  (setf *lex-literate?* literate?)
73 
+  (setf *current-line* 1)
74 
+  (setf *current-col* 0)
75 
+  (setf *on-new-line?* '#t)
76 
+  (setf *save-col?* '#f)
77 
+  (setf *port* port)
78 
+  (setf *tokens* '())
79 
+  (setf *char* (read-char *port*))
80 
+  (setf *peek-char* (read-char *port*))
81 
+  (when (eof-object? *char*)
82 
+	(setf *char* '#\space))
83 
+  (when (eof-object? *peek-char*)
84 
+	(setf *peek-char* '#\space))
85 
+  (setf *at-eof/p?* '#f)
86 
+  (setf *at-eof?* '#f)
87 
+  (when *lex-literate?*
88 
+     (process-literate-comments '#t))
89 
+  (parse-till-eof)
90 
+  (nreverse *tokens*))
91 
+
92 
+(define (parse-till-eof)
93 
+  (cond (*at-eof?*
94 
+	 (emit-token 'eof)
95 
+	 '())
96 
+	(else
97 
+	 (lex-one-token)
98 
+	 (parse-till-eof))))
99 
+
100 
+;;; There is an assumption that the scanner never peeks beyond a newline.
101 
+;;; In literate mode, this may reveal the wrong thing.
102 
+
103 
+(define (advance-char)
104 
+  (if (and *lex-literate?* (eqv? *char* #\newline))
105 
+      (process-literate-comments '#f)
106 
+      (advance-char-1)))
107 
+
108 
+(define (advance-char-1)
109 
+  (cond ((eqv? *char* #\newline)
110 
+	 (setf *on-new-line?* '#t)
111 
+	 (incf (the fixnum *current-line*))
112 
+	 (setf *current-col* 0))
113 
+	((eqv? *char* #\tab)
114 
+	 (incf (the fixnum *current-col*) (- 8 (modulo *current-col* 8))))
115 
+	(else
116 
+	 (incf (the fixnum *current-col*))))
117 
+  (setf *char* *peek-char*)
118 
+  (setf *at-eof?* *at-eof/p?*)
119 
+  (setf *peek-char* (read-char *port*))
120 
+  (when (eof-object? *peek-char*)
121 
+     (setf *at-eof/p?* '#t)
122 
+     (setf *peek-char* '#\space))
123 
+  *char*)
124 
+
125 
+(define (peek-char-2)
126 
+  (let ((ch (peek-char *port*)))
127 
+    (if (eof-object? ch)
128 
+	'#\space
129 
+	ch)))
130 
+
131 
+(define (lex-one-token)
132 
+ (setf *start-line* *current-line*) ; capture the loc at the start of the token
133 
+ (setf *start-col* *current-col*)
134 
+ (unless *at-eof?*
135 
+  (char-case *char*
136 
+    (whitechar
137 
+     (advance-char)
138 
+     (lex-one-token))
139 
+    (#\- (char-case *peek-char*
140 
+	    (#\- (lex-comment))
141 
+	    (#\> (advance-char)
142 
+		 (advance-char)
143 
+		 (emit-token '\-\>))
144 
+	    (#\} (signal-missing-begin-comment)
145 
+		 (advance-char)
146 
+		 (advance-char)
147 
+		 (lex-one-token))
148 
+	    (else
149 
+	     (lex-varsym))))
150 
+    (#\{ (cond ((char=? *peek-char* '#\-)
151 
+		(advance-char)
152 
+		(advance-char)
153 
+		(cond ((char=? *char* '#\#)
154 
+		       (advance-char)
155 
+		       (emit-token 'begin-annotation))
156 
+		      (else
157 
+		       (lex-ncomment)
158 
+		       (lex-one-token))))
159 
+	       (else
160 
+		(advance-char)
161 
+		(emit-token '\{ ))))
162 
+    (small (lex-varid))
163 
+    (large (lex-conid))
164 
+    (#\( (advance-char)
165 
+	 (emit-token '\())
166 
+    (#\: (lex-consym))
167 
+    (#\` (advance-char)
168 
+	 (emit-token '\`))
169 
+    ((symbol presymbol) (lex-varsym))
170 
+    (digit (lex-numeric))
171 
+    (#\' (lex-char))
172 
+    (#\" (lex-string))
173 
+    (#\) (advance-char)
174 
+	 (emit-token '\)))
175 
+    (#\, (advance-char)
176 
+	 (emit-token '\,))
177 
+    (#\; (advance-char)
178 
+	 (emit-token '\;))
179 
+    (#\[ (advance-char)
180 
+	 (emit-token '\[))
181 
+    (#\] (advance-char)
182 
+	 (emit-token '\]))
183 
+    (#\_ (advance-char)
184 
+	 (emit-token '\_))
185 
+    (#\} (advance-char)
186 
+	 (emit-token '\}))
187 
+    (else
188 
+     (signal-invalid-character *char*)
189 
+     (advance-char)
190 
+     (lex-one-token)))))
191 
+
192 
+(define (signal-missing-begin-comment)
193 
+  (lexer-error 'missing-begin-comment
194 
+	       "`-}' appears outside of a nested comment."))
195 
+
196 
+(define (signal-invalid-character ch)
197 
+  (lexer-error 'invalid-character
198 
+	       "Invalid character `~a' appears in source program." ch))
199 
+
200 
+(define (advance-past-white)
201 
+  (unless *at-eof?*
202 
+    (char-case *char*
203 
+      (whitechar
204 
+        (advance-char)
205 
+	(advance-past-white))
206 
+      (else
207 
+       '()))))
208 
+
209 
+(define (process-literate-comments at-start?)
210 
+  (unless at-start? (advance-char-1))
211 
+  (let ((l (classify-line)))
212 
+    (cond ((or *at-eof?* (eq? l 'program))
213 
+	   '())
214 
+	  ((eq? l 'blank)
215 
+	   (skip-literate-comment '#t))
216 
+	  (else
217 
+	   (when (not at-start?)
218 
+		 (lexer-error 'blank-line-needed
219 
+		    "Literate comments must be preceeded by a blank line"))
220 
+	   (skip-literate-comment '#f)))))
221 
+
222 
+(define (skip-literate-comment prev-blank)
223 
+  (skip-past-line)
224 
+  (let ((l (classify-line)))
225 
+    (cond (*at-eof?*
226 
+	   '())
227 
+	  ((eq? l 'comment)
228 
+	   (skip-literate-comment '#f))
229 
+	  ((eq? l 'blank)
230 
+	   (skip-literate-comment '#t))
231 
+	  (else
232 
+	   (when (not prev-blank)
233 
+	     (lexer-error 'blank-line-needed
234 
+		  "Literate comments must be followed by a blank line"))))))
235 
+
236 
+(define (classify-line)
237 
+  (if *at-eof?*
238 
+      'blank
239 
+      (char-case *char*
240 
+       (#\>
241 
+	(advance-char-1)
242 
+	'program)
243 
+       (#\newline 'blank)
244 
+       (whitechar
245 
+	(classify-line-1))
246 
+       (else 'comment))))
247 
+
248 
+(define (classify-line-1)
249 
+  (advance-char-1)
250 
+  (char-case *char*
251 
+    (#\newline 'blank)
252 
+    (whitechar (classify-line-1))
253 
+    (else 'comment)))
254 
+
255 
+(define (skip-past-line)
256 
+  (when (not *at-eof?*)
257 
+    (char-case *char*
258 
+      (#\newline
259 
+       (advance-char-1))
260 
+      (else
261 
+       (advance-char-1)
262 
+       (skip-past-line)))))
263 
+
264 
+(define (lex-comment)  ;; a -- style comment
265 
+  (advance-char)
266 
+  (cond (*at-eof?* (lexer-eof-in-comment *current-line*))
267 
+	((char=? *char* #\newline)
268 
+	 (lex-one-token))
269 
+	(else
270 
+	 (lex-comment))))
271 
+
272 
+(define (lexer-eof-in-comment start-line)
273 
+  (signal-eof-in-comment start-line)
274 
+  (lex-one-token))  ; will return the eof token
275 
+
276 
+(define (signal-eof-in-comment start-line)
277 
+  (lexer-error 'eof-in-comment
278 
+	       "End of file in comment starting at line ~A." start-line))
279 
+
280 
+;;; Here *char* and *peek-char* are the first two chars on a line.
281 
+
282 
+(define (scan-symbol)
283 
+  (scan-list-of (symbol #\:)))
284 
+
285 
+(define (scan-var-con)
286 
+  (scan-list-of (large small digit #\' #\_)))
287 
+
288 
+(define (lex-ncomment)
289 
+  (lex-ncomment-1 *current-line*))
290 
+
291 
+(define (lex-ncomment-1 start-line)
292 
+ (if *at-eof?*
293 
+  (lexer-eof-in-comment start-line)
294 
+  (char-case *char*
295 
+    (#\- (cond ((char=? *peek-char* #\})
296 
+		(advance-char)
297 
+		(advance-char))
298 
+	       (else
299 
+		(advance-char)
300 
+		(lex-ncomment-1 start-line))))
301 
+    (#\{ (cond ((char=? *peek-char* #\-)
302 
+		(advance-char)
303 
+		(advance-char)
304 
+		(lex-ncomment)
305 
+		(lex-ncomment-1 start-line))
306 
+	       (else
307 
+		(advance-char)
308 
+		(lex-ncomment-1 start-line))))
309 
+    (else
310 
+     (advance-char)
311 
+     (lex-ncomment-1 start-line)))))
312 
+
313 
+(define (lex-varid)
314 
+  (let ((sym (scan-var-con)))
315 
+    (parse-reserved sym varid
316 
+       "case" "class"
317 
+       "data" "default" "deriving"
318 
+       "else"
319 
+       "hiding"
320 
+       "if" "import" "in" "infix" "infixl" "infixr" "instance" "interface"
321 
+       "let"
322 
+       "module"
323 
+       "of"
324 
+       "renaming"
325 
+       "then" "to" "type"
326 
+       "where")))
327 
+
328 
+(define (lex-conid)
329 
+  (let ((sym (scan-var-con)))
330 
+    (emit-token/string 'conid sym)))
331 
+
332 
+(define (lex-consym)
333 
+  (let ((sym (scan-symbol)))
334 
+    (cond ((string=/list? (cdr sym) ":")
335 
+	   (emit-token '\:\:))
336 
+	  (else
337 
+	   (emit-token/string 'consym sym)))))
338 
+
339 
+(define (lex-varsym)
340 
+  (let ((sym (scan-symbol)))
341 
+    (cond ((and (string=/list? sym "<") (char=? *char* #\-))
342 
+	   (advance-char)
343 
+	   (emit-token '\<\-))
344 
+	  ((and (string=/list? sym "#")
345 
+		(char=? *char* #\-)
346 
+		(char=? *peek-char* #\}))
347 
+	   (advance-char)
348 
+	   (advance-char)
349 
+	   (emit-token 'end-annotation))
350 
+	  (else
351 
+	   (parse-reserved sym varsym
352 
+	      ".."
353 
+	      "=>" "="
354 
+	      "@"
355 
+	      "\\"
356 
+	      "|"
357 
+	      "~")))))
358 
+
359 
+(define (lex-integer radix)
360 
+  (lex-integer-1 radix 0))
361 
+
362 
+(define (lex-integer-1 radix psum)
363 
+  (declare (type fixnum radix)
364 
+	   (type integer psum))
365 
+  (let ((d  (char->digit *char* radix)))
366 
+    (if d
367 
+	(begin
368 
+	  (advance-char)
369 
+	  (lex-integer-1 radix (+ (* psum radix) (the fixnum d))))
370 
+	psum)))
371 
+
372 
+(define (lex-fraction int-part denominator)
373 
+  (declare (type integer int-part denominator))
374 
+  (let ((d  (char->digit *char* 10)))
375 
+    (if d
376 
+	(begin
377 
+	  (advance-char)
378 
+	  (lex-fraction
379 
+	    (+ (* int-part 10) (the fixnum d)) (* denominator 10)))
380 
+	(values int-part denominator))))
381 
+
382 
+(define (lex-numeric)
383 
+  (let ((int-part (lex-integer 10)))
384 
+    (if (and (char=? *char* #\.)
385 
+	     (char->digit *peek-char* 10))
386 
+	(lex-float int-part)
387 
+	(emit-token 'integer int-part))))
388 
+
389 
+(define (lex-float int-part)
390 
+  (advance-char)
391 
+  (multiple-value-bind (numerator denominator) (lex-fraction int-part 1)
392 
+    (let ((no-exponent
393 
+	   (lambda () (emit-token 'float numerator denominator 0))))
394 
+      (char-case *char*
395 
+	(exponent
396 
+	  (char-case *peek-char*
397 
+	    (digit
398 
+	     (advance-char)
399 
+	     (lex-float/exp numerator denominator 1))
400 
+	    ((#\+ #\-)
401 
+	     (cond ((char->digit (peek-char-2) 10)
402 
+		    (let ((sign (if (char=? *peek-char* '#\+) 1 -1)))
403 
+		      (advance-char)
404 
+		      (advance-char)
405 
+		    (lex-float/exp numerator denominator sign)))
406 
+		 (else
407 
+		  (funcall no-exponent))))
408 
+	  (else
409 
+	   (funcall no-exponent))))
410 
+       (else
411 
+	(emit-token 'float numerator denominator 0))))))
412 
+
413 
+(define (lex-float/exp numerator denominator sign)
414 
+  (let ((exponent (lex-integer 10)))
415 
+    (emit-token 'float numerator denominator (* sign exponent))))
416 
+
417 
+(define (lex-char)
418 
+  (advance-char)
419 
+  (let ((c
420 
+    (char-case *char*
421 
+      (#\' (signal-null-character)
422 
+	   '#\?)
423 
+      (#\\ (lex-escaped-char '#f))
424 
+      ((#\space graphic)
425 
+       (let ((ch *char*))
426 
+	 (advance-char)
427 
+	 ch))
428 
+      (else
429 
+       (signal-bad-character-constant *char*)
430 
+       (advance-char)
431 
+       `#\?))))
432 
+    (cond ((char=? *char* '#\')
433 
+	   (advance-char)
434 
+	   (emit-token 'char c))
435 
+	  (else
436 
+	   (signal-missing-char-quote)
437 
+	   (skip-to-quote-or-eol)))))
438 
+
439 
+(define (signal-null-character)
440 
+  (lexer-error 'null-character
441 
+	       "Null character '' is illegal - use '\\'' for a quote."))
442 
+
443 
+(define (signal-bad-character-constant ch)
444 
+  (lexer-error 'bad-character-constant
445 
+	       "The character `~a' may not appear in a character literal." ch))
446 
+
447 
+(define (signal-missing-char-quote)
448 
+  (lexer-error 'missing-char-quote
449 
+	       "Character constant has more than one character."))
450 
+
451 
+
452 
+(define (skip-to-quote-or-eol)
453 
+  (if *at-eof?*
454 
+      (lex-one-token)
455 
+      (char-case *char*
456 
+	 (#\' (advance-char)
457 
+	      (lex-one-token))
458 
+	 (#\newline (advance-char)
459 
+		    (lex-one-token))
460 
+	 (else
461 
+	  (advance-char)
462 
+	  (skip-to-quote-or-eol)))))
463 
+
464 
+(define (lex-string)
465 
+  (advance-char)
466 
+  (emit-token 'string (list->string (gather-string-chars))))
467 
+
468 
+(define (gather-string-chars)
469 
+  (char-case *char*
470 
+    (#\\
471 
+      (let ((ch (lex-escaped-char '#t)))
472 
+	(if (eq? ch 'null)
473 
+	    (gather-string-chars)
474 
+	    (cons ch (gather-string-chars)))))
475 
+    (#\"
476 
+      (advance-char)
477 
+      '())
478 
+    ((graphic #\space)
479 
+     (let ((ch *char*))
480 
+       (advance-char)
481 
+       (cons ch (gather-string-chars))))
482 
+    (#\newline
483 
+     (signal-missing-string-quote)
484 
+     '())
485 
+    (else
486 
+     (signal-bad-string-constant *char*)
487 
+     (advance-char)
488 
+     (gather-string-chars))))
489 
+
490 
+(define (signal-missing-string-quote)
491 
+  (lexer-error 'missing-string-quote
492 
+	       "String continued over end of line."))
493 
+
494 
+(define (signal-bad-string-constant ch)
495 
+  (lexer-error 'bad-string-constant
496 
+	       "The character `~a' may not appear in a string literal." ch))
497 
+
498 
+
499 
+(define (convert-stupid-control-character-names)
500 
+  (let ((c1 *char*)
501 
+	(c2 *peek-char*))
502 
+    (advance-char)
503 
+    (advance-char)
504 
+    (let ((s2 (string c1 c2))
505 
+	  (s3 (string c1 c2 *char*)))
506 
+      (let ((srch3 (assoc s3 *control-char-names*)))
507 
+	(cond (srch3
508 
+	       (advance-char)
509 
+	       (integer->char (cdr srch3)))
510 
+	      (else
511 
+	       (let ((srch2 (assoc s2 *control-char-names*)))
512 
+		 (cond (srch2
513 
+			(integer->char (cdr srch2)))
514 
+		       (else
515 
+			(signal-bad-control-char s3)
516 
+			`#\?)))))))))
517 
+
518 
+(define (signal-bad-control-char name)
519 
+  (lexer-error 'invalid-control-char
520 
+	       "`~a' is not a recognized control character name." name))
521 
+
522 
+
523 
+(define (lex-escaped-char in-string?)
524 
+  (advance-char)
525 
+  (char-case *char*
526 
+    ((#\a #\b #\f #\n #\r #\t #\v)
527 
+     (let* ((ccode (cdr (assoc *char* *short-control-char-names*)))
528 
+	    (ccode1 (cdr (assoc ccode *control-char-names*))))
529 
+       (advance-char)
530 
+       (integer->char ccode1)))
531 
+    ((#\\ #\' #\")
532 
+     (let ((ch *char*))
533 
+       (advance-char)
534 
+       ch))
535 
+    (#\&
536 
+     (advance-char)
537 
+     (cond (in-string? 'null)
538 
+	   (else
539 
+	    (signal-bad-&-escape)
540 
+	    '#\?)))
541 
+    (#\^
542 
+     ;; *** This code is problematic because it assumes
543 
+     ;; *** (1) that you can do the arithmetic on the character codes
544 
+     ;; *** (2) that the resulting integer can actually be coerced to
545 
+     ;; ***     the right character object in the host Lisp.
546 
+     (advance-char)
547 
+     (char-case *char*
548 
+       ((large #\@ #\[ #\\ #\] #\^ #\_)
549 
+	(let ((code (+ (- (char->integer *char*)
550 
+			  (char->integer '#\A))
551 
+		       *control-A*)))
552 
+	  (advance-char)
553 
+	  (integer->char code)))
554 
+       (else
555 
+	(signal-bad-^-escape *char*)
556 
+	'#\?)))
557 
+    (large
558 
+     (convert-stupid-control-character-names))
559 
+    (digit
560 
+     (convert-num-to-char (lex-integer 10)))
561 
+    (#\o
562 
+     (advance-char)
563 
+     (cond ((char->digit *char* 8)
564 
+	    (convert-num-to-char (lex-integer 8)))
565 
+	   (else
566 
+	    (signal-missing-octal-digits)
567 
+	    '#\?)))
568 
+    (#\x
569 
+     (advance-char)
570 
+     (cond ((char->digit *char* 16)
571 
+	    (convert-num-to-char (lex-integer 16)))
572 
+	   (else
573 
+	    (signal-missing-hex-digits)
574 
+	    `#\?)))
575 
+    (whitechar
576 
+     (cond (in-string?
577 
+	    (lex-gap))
578 
+	   (else
579 
+	    (signal-bad-gap)
580 
+	    `#\?)))
581 
+    (else
582 
+     (signal-bad-escape *char*)
583 
+     `#\?)))
584 
+
585 
+(define (signal-bad-&-escape)
586 
+  (lexer-error 'bad-&-escape
587 
+	       "The escape `\\&' is not allowed inside a character literal."))
588 
+
589 
+(define (signal-bad-^-escape ch)
590 
+  (lexer-error 'bad-^-escape
591 
+	       "The escape `\\^~a' is not recognized." ch))
592 
+
593 
+(define (signal-missing-octal-digits)
594 
+  (lexer-error 'missing-octal-digits
595 
+	       "No digits provided for `\\o' escape."))
596 
+
597 
+(define (signal-missing-hex-digits)
598 
+  (lexer-error 'missing-hex-digits
599 
+	       "No digits provided for `\\x' escape."))
600 
+
601 
+(define (signal-bad-gap)
602 
+  (lexer-error 'invalid-gap
603 
+	       "Gaps are not allowed inside character literals."))
604 
+
605 
+(define (signal-bad-escape ch)
606 
+  (lexer-error 'bad-escape
607 
+	       "The escape `\\~a' is not recognized." ch))
608 
+
609 
+
610 
+
611 
+;;; *** This code is problematic because it assumes that integers
612 
+;;; *** between 0 and 255 map on to characters with the corresponding
613 
+;;; *** ASCII encoding in the host Lisp, and that the host Lisp actually
614 
+;;; *** supports 255 characters.
615 
+
616 
+(define (convert-num-to-char num)
617 
+  (cond ((and (>= num 0) (>= *max-char* num))
618 
+	 (integer->char num))
619 
+	(else
620 
+	 (signal-char-out-of-range num)
621 
+	 '#\?)))
622 
+
623 
+(define (signal-char-out-of-range num)
624 
+  (lexer-error 'char-out-of-range
625 
+	       "There is no character corresponding to code ~s." num))
626 
+
627 
+
628 
+(define (lex-gap)
629 
+  (cond (*at-eof?*
630 
+	 (signal-eof-in-gap)
631 
+	 'null)
632 
+	(else
633 
+	 (char-case *char*
634 
+	   (whitechar
635 
+	    (advance-char)
636 
+	    (lex-gap))
637 
+	   (#\\
638 
+	    (advance-char)
639 
+	    'null)
640 
+	   (else
641 
+	    (signal-missing-gap)
642 
+	    'null)))))
643 
+
644 
+
645 
+(define (signal-eof-in-gap)
646 
+  (lexer-error 'eof-in-gap
647 
+	       "End of file encountered inside gap."))
648 
+
649 
+(define (signal-missing-gap)
650 
+  (lexer-error 'missing-gap
651 
+	       "Missing gap delimiter, or junk inside gap."))
parser/module-parser.scm
History View file @ 4e98702
0 652 
new file mode 100644
... ... 
@@ -0,0 +1,312 @@
1 
+;;; File: module-parser         Author: John
2 
+
3 
+;;; This is for using the parser to parse strings.
4 
+
5 
+(define (parse-from-string string parse-proc filename)
6 
+ (dynamic-let ((*current-file* filename))
7 
+  (call-with-input-string string
8 
+    (lambda (port)
9 
+      (let ((tokens (lex-port port '#f)))
10 
+	(init-token-stream tokens)
11 
+	(let ((res (funcall parse-proc)))
12 
+	  (if (not (eq-token? 'eof))
13 
+	      (signal-leftover-tokens)
14 
+	      res)))))))
15 
+
16 
+(define (signal-leftover-tokens)
17 
+  (fatal-error 'leftover-tokens
18 
+	       "Leftover tokens after parsing."))
19 
+
20 
+
21 
+;;; This file deals with the basic structure of a module.  It also adds
22 
+;;; the `module Main where' required by abbreviated modules.
23 
+
24 
+(define (parse-tokens tokens)
25 
+  (init-token-stream tokens)
26 
+  (let ((mod (token-case
27 
+	      (|module| (parse-module))
28 
+	      (else (parse-modules/named '|Main| '())))))
29 
+    (cons mod (parse-module-list))))
30 
+
31 
+(define (parse-module)
32 
+  (token-case
33 
+   (modid (let* ((mod-name (token->symbol))
34 
+		 (exports (parse-exports)))
35 
+	    (require-token
36 
+	      |where|
37 
+	      (signal-missing-token "`where'" "module definition"))
38 
+	    (parse-modules/named mod-name exports)))
39 
+   (else (signal-missing-token "<modid>" "module definition"))))
40 
+
41 
+(define (parse-module-list)
42 
+  (token-case
43 
+   (|module|
44 
+    (let ((mod (parse-module)))
45 
+      (cons mod (parse-module-list))))
46 
+   (eof '())
47 
+   (else (signal-missing-module))))
48 
+
49 
+(define (signal-missing-module)
50 
+  (parser-error 'missing-module
51 
+		"Missing `module', or leftover junk after module definition."))
52 
+
53 
+(define (parse-exports)
54 
+  (token-case
55 
+   (\( (parse-export-list))
56 
+   (else '())))
57 
+
58 
+(define (parse-export-list)
59 
+  (let ((entity (parse-entity 'export)))
60 
+    (token-case
61 
+     (\) (list entity))
62 
+     (\, (cons entity (parse-export-list)))
63 
+     (else (signal-missing-token "`)' or ','" "export list")))))
64 
+
65 
+(define (parse-modules/named mod-name exports)
66 
+  (trace-parser module
67 
+    (let ((mod-ast (make module
68 
+		     (name mod-name)
69 
+		     (type 'standard)
70 
+		     (exports exports)
71 
+		     (default *standard-module-default*))))
72 
+      (start-layout (lambda (in-layout?)
73 
+		      (parse-module-decls mod-ast in-layout? 'import))))))
74 
+
75 
+;;; The mod-ast fields are kept in non-reversed order by appending
76 
+;;; each decl to the end of the appropriate list.  This loses for
77 
+;;; value decls, so these are in reversed order!!
78 
+
79 
+(define (parse-module-decls mod-ast in-layout? state)
80 
+  (token-case
81 
+   (|import| (let ((import (parse-import)))
82 
+	       (if (eq? state 'import)
83 
+		   (push-decl-list import (module-imports mod-ast))
84 
+		   (signal-misplaced-import)))
85 
+	     (terminate-topdecl mod-ast in-layout? state))
86 
+   (|infix| (terminate-topdecl mod-ast in-layout?
87 
+			       (parse-fixity 'n mod-ast state)))
88 
+   (|infixl| (terminate-topdecl mod-ast in-layout?
89 
+				(parse-fixity 'l mod-ast state)))
90 
+   (|infixr| (terminate-topdecl mod-ast in-layout?
91 
+				(parse-fixity 'r mod-ast state)))
92 
+   (|data| (let ((data-decl (parse-type-decl '#f)))
93 
+	     (push-decl-list data-decl (module-algdatas mod-ast)))
94 
+	   (terminate-topdecl mod-ast in-layout? 'topdecl))
95 
+   (|type| (let ((synonym-decl (parse-synonym-decl)))
96 
+	     (push-decl-list synonym-decl (module-synonyms mod-ast)))
97 
+	   (terminate-topdecl mod-ast in-layout? 'topdecl))
98 
+   (|class| (let ((class-decl (parse-class-decl)))
99 
+	      (push-decl-list class-decl (module-classes mod-ast)))
100 
+	    (terminate-topdecl mod-ast in-layout? 'topdecl))
101 
+   (|instance| (let ((instance-decl (parse-instance-decl '#f)))
102 
+		 (push-decl-list instance-decl (module-instances mod-ast)))
103 
+	       (terminate-topdecl mod-ast in-layout? 'topdecl))
104 
+   (|default| (let ((types
105 
+		     (token-case
106 
+		      (\( (token-case (\) '())
107 
+				      (else (parse-type-list))))
108 
+		      (else (list (parse-type))))))
109 
+		(if (eq? (module-default mod-ast) *standard-module-default*)
110 
+		    (setf (module-default mod-ast)
111 
+			  (make default-decl (types types)))
112 
+		    (signal-multiple-defaults)))
113 
+    (terminate-topdecl mod-ast in-layout? 'topdecl))
114 
+   ((begin-annotation no-advance)
115 
+    (let ((annotations (parse-annotations)))
116 
+      (setf (module-annotations mod-ast)
117 
+	    (append (module-annotations mod-ast) annotations)))
118 
+    (terminate-topdecl mod-ast in-layout? state))
119 
+   (pat-start (let ((decl (parse-decl)))
120 
+		(setf (module-decls mod-ast)
121 
+		      (decl-push decl (module-decls mod-ast))))
122 
+	      (terminate-topdecl mod-ast in-layout? 'topdecl))
123 
+   (else
124 
+    (maybe-end-module mod-ast in-layout? state))))
125 
+
126 
+(define (signal-misplaced-import)
127 
+  (parser-error 'misplaced-import
128 
+		"The import declaration is misplaced."))
129 
+
130 
+(define (signal-multiple-defaults)
131 
+  (parser-error 'multiple-defaults
132 
+		"There are multiple default declarations."))
133 
+
134 
+(define (terminate-topdecl mod-ast in-layout? state)
135 
+  (token-case
136 
+   (\; (parse-module-decls mod-ast in-layout? state))
137 
+   (else (maybe-end-module mod-ast in-layout? state))))
138 
+
139 
+(define (maybe-end-module mod-ast in-layout? state)
140 
+  (declare (ignore state))
141 
+  (cond ((or (eq-token? '|module|) (eq-token? 'eof) (eq-token? '\})
142 
+	     (eq-token? '$\}))
143 
+	 (close-layout in-layout?)
144 
+	 (wrapup-module mod-ast)
145 
+	 mod-ast)
146 
+	(else
147 
+	 (signal-invalid-syntax "a topdecl"))))
148 
+
149 
+(define (wrapup-module mod-ast)
150 
+  (setf (module-decls mod-ast)
151 
+	(nreverse (module-decls mod-ast)))
152 
+  (when (and (null? (module-imports mod-ast))
153 
+	     (null? (module-decls mod-ast))
154 
+	     (null? (module-algdatas mod-ast))
155 
+	     (null? (module-synonyms mod-ast))
156 
+	     (null? (module-instances mod-ast))
157 
+	     (null? (module-classes mod-ast)))
158 
+    (signal-empty-module)))
159 
+
160 
+(define (signal-empty-module)
161 
+  (parser-error 'empty-module "Module definition is empty."))
162 
+
163 
+(define (parse-import)
164 
+ (save-parser-context
165 
+  (token-case
166 
+   (modid (let ((mod (token->symbol))
167 
+		(mode 'all)
168 
+		(specs '()))
169 
+	    (token-case
170 
+	     (\( (setf mode 'by-name)
171 
+		 (token-case
172 
+		  (\) (setf specs '()))
173 
+		  (else (setf specs (parse-import-list)))))
174 
+	     (|hiding| (require-token
175 
+			 \(
176 
+			 (signal-missing-token "`('" "hiding clause"))
177 
+		       (setf specs (parse-import-list)))
178 
+	     (else '()))
179 
+	    (let ((renamings (token-case (|renaming|
180 
+					   (require-token
181 
+					     \(
182 
+					     (signal-missing-token
183 
+					       "`('" "renaming clause"))
184 
+					   (parse-renamings))
185 
+					 (else '()))))
186 
+	      (make import-decl (module-name mod) (mode mode) (specs specs)
187 
+		                (renamings renamings)))))
188 
+   (else
189 
+    (signal-missing-token "<modid>" "import declaration")))))
190 
+
191 
+(define (parse-import-list)
192 
+  (let ((import (parse-entity 'import)))
193 
+    (token-case
194 
+     (\, (cons import (parse-import-list)))
195 
+     (\) (list import))
196 
+     (else (signal-missing-token "`)' or `,'" "import list")))))
197 
+
198 
+(define (parse-renamings)
199 
+ (let ((renaming
200 
+	(save-parser-context
201 
+	 (token-case
202 
+	  (var (let ((name1 (var->symbol)))
203 
+		 (require-token
204 
+		   |to|
205 
+		   (signal-missing-token "`to'" "import renaming clause"))
206 
+		 (token-case
207 
+		  (var (let ((name2 (var->symbol)))
208 
+			 (make renaming (from name1) (to name2)
209 
+			       (referenced? '#f))))
210 
+		  (else (signal-invalid-syntax "import renaming clause")))))
211 
+	  (con (let ((name1 (con->symbol)))
212 
+		 (require-token
213 
+ 		   |to|
214 
+		   (signal-missing-token "`to'" "import renaming clause"))
215 
+		 (token-case
216 
+		  (con (let ((name2 (con->symbol)))
217 
+			 (make renaming (from name1) (to name2)
218 
+			       (referenced? '#f))))
219 
+		  (else (signal-invalid-syntax "import renaming clause")))))
220 
+	  (else (signal-invalid-syntax "import renaming clause"))))))
221 
+    (token-case (\, (cons renaming (parse-renamings)))
222 
+		(\) (list renaming)))))
223 
+
224 
+(define (parse-fixity associativity mod-ast state)
225 
+  (let ((fixity-decl
226 
+	 (save-parser-context
227 
+	  (let* ((prec (token-case
228 
+			(k (let ((p (token->integer)))
229 
+			     (cond ((<= p 9)
230 
+				    p)
231 
+				   (else
232 
+				    (signal-bad-fixity)
233 
+				    9))))
234 
+			(else 9)))
235 
+		 (ops (parse-op-list))
236 
+		 (fixity (make fixity (associativity associativity)
237 
+		       (precedence prec))))
238 
+	    (make fixity-decl (fixity fixity) (names ops))))))
239 
+    (push-decl-list fixity-decl (module-fixities mod-ast))
240 
+    (cond ((or (eq? state 'import)
241 
+	       (eq? state 'fixity))
242 
+	   'fixity)
243 
+	  (else
244 
+	   (signal-misplaced-fixity)
245 
+	   state))))
246 
+
247 
+
248 
+(define (signal-bad-fixity)
249 
+  (parser-error 'bad-fixity
250 
+		"Expecting fixity value of 0 - 9."))
251 
+
252 
+(define (signal-misplaced-fixity)
253 
+  (parser-error 'misplaced-fixity "The fixity declaration is misplaced."))
254 
+
255 
+(define (parse-op-list)
256 
+  (let ((name (token-case
257 
+	       (op (op->symbol))
258 
+	       (else (signal-missing-token "<op>" "fixity declaration")))))
259 
+    (token-case
260 
+     (\, (cons name (parse-op-list)))
261 
+     (else (list name)))))
262 
+
263 
+(define (parse-entity context)
264 
+ (trace-parser entity
265 
+  (save-parser-context
266 
+   (token-case
267 
+    (var (var->entity))
268 
+    (tycon
269 
+     (let ((name (token->symbol)))
270 
+       (token-case
271 
+	(\( (token-case
272 
+	     (\.\. (require-token
273 
+		     '\)
274 
+		     (signal-missing-token "`)'" "class or datatype entity"))
275 
+		   (make entity-abbreviated (name name)))
276 
+	     (var (parse-entity-class name))
277 
+	     (con (parse-entity-datatype name))
278 
+	     (\) (make entity-class (name name) (methods '())))
279 
+	     (else (signal-invalid-syntax "an entity"))))
280 
+	(\.\. (if (eq? context 'export)
281 
+		  (make entity-module (name name))
282 
+		  (signal-invalid-syntax "an entity")))
283 
+	(else
284 
+	 (make entity-con (name name))))))
285 
+    (else (signal-invalid-syntax "an entity"))))))
286 
+
287 
+(define (parse-entity-class class-name)
288 
+  (let ((vars (parse-var-list)))
289 
+    (make entity-class (name class-name) (methods vars))))
290 
+
291 
+(define (parse-entity-datatype type-name)
292 
+  (let ((constrs (parse-con-list)))
293 
+    (make entity-datatype (name type-name) (constructors constrs))))
294 
+
295 
+(define (parse-var-list)
296 
+  (token-case
297 
+   (var (let ((name (var->symbol)))
298 
+	  (token-case
299 
+	   (\) (list name))
300 
+	   (\, (cons name (parse-var-list)))
301 
+	   (else
302 
+	    (signal-missing-token "`)' or `,'" "class entity")))))
303 
+   (else (signal-missing-token "<var>" "class entity"))))
304 
+
305 
+(define (parse-con-list)
306 
+  (token-case
307 
+   (con (let ((name (con->symbol)))
308 
+	  (token-case
309 
+	   (\) (list name))
310 
+	   (\, (cons name (parse-con-list)))
311 
+	   (else (signal-missing-token "`)' or `,'" "datatype entity")))))
312 
+   (else (signal-missing-token "<con>" "datatype entity"))))
parser/parser-debugger.scm
History View file @ 4e98702
0 313 
new file mode 100644
... ... 
@@ -0,0 +1,81 @@
1 
+;;; These routines are strictly for debugging the parser.  They could
2 
+;;; be removed from the system later.
3 
+
4 
+;;; define some debugging stuff
5 
+;;;  Here's the debugging control:
6 
+;;;  Capabilities:
7 
+;;;      record start (line,token,production,k)
8 
+;;;      record end (line,token,prodection,k)
9 
+;;;      print end (line,token,prodection,k,value)
10 
+;;;      break start
11 
+;;;      break end
12 
+
13 
+(define *parser-debug-options* '())
14 
+(define *parser-debug-lines* '())
15 
+(define *parser-debug-id* 0)
16 
+
17 
+(define (watch-lines . lines)
18 
+  (setf *parser-debug-lines* lines))
19 
+
20 
+(define (watching-this-line?)
21 
+ (and (not (eq? *parser-debug-lines* 'none))
22 
+  (or (null? *parser-debug-lines*)
23 
+      (and (>= *current-line* (car *parser-debug-lines*))
24 
+	   (or (null? (cdr *parser-debug-lines*))
25 
+	       (<= *current-line* (cadr *parser-debug-lines*)))))))
26 
+
27 
+(define (ptrace-print-obj x)
28 
+  (pprint x))
29 
+
30 
+(define (ptrace-breakpoint)
31 
+  (error "Breakpoint~%"))
32 
+
33 
+(define (parser-show-context id tag msg)
34 
+  (format '#t "~A parse of ~A(~A)  Line: ~A  Token: ~A"
35 
+	  msg tag id *current-line* *token*)
36 
+  (when (not (null? *token-args*))
37 
+     (format '#t " ~A" *token-args*))
38 
+  (format '#t "~%"))
39 
+
40 
+(define (ptrace-clear)
41 
+  (setf *parser-debug-options* '()))
42 
+
43 
+(define (ptrace-pop)
44 
+  (pop *parser-debug-options*))
45 
+
46 
+(define (ptrace-watch . things)
47 
+  (dolist (x things)
48 
+     (push (cons x 'watch) *parser-debug-options*)))
49 
+
50 
+(define (ptrace-show . things)
51 
+  (dolist (x things)
52 
+     (push (cons x 'show) *parser-debug-options*)))
53 
+
54 
+(define (ptrace-break . things)
55 
+  (dolist (x things)
56 
+     (push (cons x 'break) *parser-debug-options*)))
57 
+
58 
+;;; Routines called by the trace-parser macro
59 
+
60 
+(define (tracing-parse/entry tag)
61 
+  (let ((all? (assq 'all *parser-debug-options*))
62 
+	(this? (assq tag *parser-debug-options*)))
63 
+    (cond ((or all? this?)
64 
+	   (incf *parser-debug-id*)
65 
+	   (parser-show-context *parser-debug-id* tag "Entering")
66 
+	   (when (and this? (eq? (cdr this?) 'break))
67 
+		 (ptrace-breakpoint))
68 
+	   *parser-debug-id*)
69 
+	  (else 0))))
70 
+
71 
+(define (tracing-parse/exit tag id res)
72 
+  (let ((all? (assq 'all *parser-debug-options*))
73 
+	(this? (assq tag *parser-debug-options*)))
74 
+    (when (and (or all? this?) (not (eq? tag 0)))
75 
+      (setf (dynamic *returned-obj*) res)
76 
+      (parser-show-context id tag "Exiting")
77 
+      (when (and this? (eq? (cdr this?) 'show))
78 
+	    (ptrace-print-obj res))
79 
+      (when (and this? (eq? (cdr this?) 'break))
80 
+	    (ptrace-breakpoint)))))
81 
+
parser/parser-driver.scm
History View file @ 4e98702
0 82 
new file mode 100644
... ... 
@@ -0,0 +1,48 @@
1 
+
2 
+;;; This is the top level entry to the parse.  The input is a list of file
3 
+;;; names to be parsed and the output is a list of modules.  Interface files
4 
+;;; generate modules similar to ordinary files.
5 
+
6 
+(define (parse-files filenames)
7 
+  (let ((all-mods '()))
8 
+    (dolist (file filenames)
9 
+      (let* ((ext (filename-type file))
10 
+	     (mods (cond ((string=? ext ".hs")
11 
+			  (parse-single-file file))
12 
+			 ((string=? ext ".lhs")
13 
+			  (parse-single-file/literate file))
14 
+			 ((string=? ext ".hi")
15 
+			  (parse-single-file/interface file)))))
16 
+	   (setf all-mods (append all-mods mods))))
17 
+    all-mods))
18 
+
19 
+(define (parse-single-file filename)
20 
+  (parse-single-file-1 filename '#f '#f))
21 
+
22 
+(define (parse-single-file/literate filename)
23 
+  (parse-single-file-1 filename '#t '#f))
24 
+
25 
+(define (parse-single-file/interface filename)
26 
+  (parse-single-file-1 filename '#f '#t))
27 
+
28 
+(define (parse-single-file-1 filename literate? interface?)
29 
+  (when (memq 'reading *printers*)
30 
+      (format '#t "Reading Haskell source file ~s.~%" filename))
31 
+  (when (not (file-exists? filename))
32 
+    (signal-file-not-found filename))
33 
+  (dynamic-let ((*current-file* filename))
34 
+    (let ((mods '()))
35 
+      (call-with-input-file filename
36 
+        (lambda (port)
37 
+	  (let* ((tokens (lex-port port literate?))
38 
+		 (module-asts (if interface?
39 
+				  (parse-tokens/interface tokens)
40 
+				  (parse-tokens tokens))))
41 
+	    (setf mods module-asts))))
42 
+      (when (memq 'parse *printers*)
43 
+	(dolist (m mods)
44 
+	  (format '#t "~%")
45 
+	  (print-full-module m)))
46 
+      mods)))
47 
+
48 
+
parser/parser-errors.scm
History View file @ 4e98702
0 49 
new file mode 100644
... ... 
@@ -0,0 +1,74 @@
1 
+;;; This contains parser error handlers.  They, in turn, call the
2 
+;;; system error handlers.
3 
+
4 
+(define (lexer-error id . msgs)
5 
+  (parser-error/common id 'recoverable msgs '#t)
6 
+  `#\?)
7 
+
8 
+(define (parser-error id . msgs)
9 
+  (parser-error/common id 'phase msgs '#f)
10 
+  (if (null? *layout-stack*)
11 
+      (abort-compilation)
12 
+      (recover-to-next-decl *token-stream*)))
13 
+
14 
+(define (parser-error/recoverable id . args)
15 
+  (parser-error/common id 'recoverable args '#f))
16 
+
17 
+(define (parser-error/common id type msgs in-lexer?)
18 
+  (let ((place
19 
+	 (if in-lexer?
20 
+	     (list "Error occured at in file ~A at line ~A, column ~A."
21 
+		   *current-file* *current-line* *current-col*)
22 
+	     (list "Error occured at in file ~A at line ~A, token ~A."
23 
+		   *current-file* *current-line*
24 
+		   (cond ((null? *token-args*)
25 
+			  *token*)
26 
+			 ((null? (cdr *token-args*))
27 
+			  (car *token-args*))
28 
+			 (else *token-args*)))))) ; could be better
29 
+    (haskell-error id type (list place msgs))))
30 
+
31 
+(define (recover-to-next-decl tokens)
32 
+  (cond ((null? tokens)
33 
+	 (abort-compilation))
34 
+	((eq? (car (car tokens)) 'line)
35 
+	 (search-layout-stack *layout-stack* tokens (caddr (car tokens))))
36 
+	(else (recover-to-next-decl (cdr tokens)))))
37 
+
38 
+(define (search-layout-stack layouts tokens column)
39 
+  (cond ((null? layouts)
40 
+	 (abort-compilation))
41 
+	((> column (layout-col (car layouts)))
42 
+	 (recover-to-next-decl (cdr tokens)))
43 
+	((= column (layout-col (car layouts)))
44 
+	 (setf *current-col* column)
45 
+	 (setf *current-line* (cadr (car tokens)))
46 
+	 (setf *token-stream* (cdr tokens))
47 
+	 (advance-token)  ; loads up *token*
48 
+	 ;; *** layout-recovery-fn is not defined anywhere!
49 
+	 (funcall (layout-recovery-fn (car layouts))))
50 
+	(else
51 
+	 (setf *layout-stack* (cdr *layout-stack*))
52 
+	 (search-layout-stack (cdr layouts) tokens column))))
53 
+
54 
+
55 
+;;; Here are some very commonly used signalling functions.
56 
+;;; Other (more specific) signalling functions are defined near
57 
+;;; the places where they are called.
58 
+
59 
+
60 
+;;; This is used when a particular token isn't found.
61 
+
62 
+(define (signal-missing-token what where)
63 
+  (parser-error 'missing-token
64 
+		"Missing ~a in ~a." what where))
65 
+
66 
+
67 
+;;; This is used to signal more complicated parse failures involving
68 
+;;; failure to match a nonterminal.
69 
+
70 
+(define (signal-invalid-syntax where)
71 
+  (parser-error 'invalid-syntax
72 
+		"Invalid syntax appears where ~a is expected." where))
73 
+
74 
+
parser/parser-globals.scm
History View file @ 4e98702
0 75 
new file mode 100644
... ... 
@@ -0,0 +1,27 @@
1 
+;;; Global vars used in the parser
2 
+
3 
+(define *current-line* '())  ;  current line the scanner is on
4 
+(define *current-col* '())   ;  current col; valid at start of line &
5 
+                             ;  after where,let,of
6 
+
7 
+;;; Lexer
8 
+
9 
+(define *lex-literate?* '#f)
10 
+(define *start-line* 0)
11 
+(define *start-col* 0)
12 
+(define *on-new-line?* '#t)
13 
+(define *save-col?* '#f)
14 
+(define *port* '())
15 
+(define *tokens* '())
16 
+(define *char* 0)
17 
+(define *peek-char* 0)
18 
+(define *at-eof/p?* 0)
19 
+(define *at-eof?* 0)
20 
+(define *on-new-line? '#f)
21 
+
22 
+;;; Parser
23 
+
24 
+(define *token-stream* '())  ;  remaining tokens to be parsed
25 
+(define *token* '())         ;  current token type
26 
+(define *token-args* '())    ;  current token arguments
27 
+(define *layout-stack* '())  ;  columns at which layout is being done
parser/parser-macros.scm
History View file @ 4e98702
0 28 
new file mode 100644
... ... 
@@ -0,0 +1,327 @@
1 
+;;; Macro definitions for the parser & lexer.
2 
+
3 
+
4 
+;;; This macro allows debugging of the lexer.  Before releasing, this can
5 
+;;; be replaced by (begin ,@body) for faster code.
6 
+
7 
+(define-syntax (trace-parser tag . body)
8 
+;  `(begin
9 
+;     (let* ((k (tracing-parse/entry ',tag))
10 
+;	    (res (begin ,@body)))
11 
+;       (tracing-parse/exit ',tag k res)
12 
+;       res))
13 
+  (declare (ignore tag))
14 
+  `(begin ,@body)
15 
+  )
16 
+
17 
+;;; Macros used by the lexer.
18 
+
19 
+;;; The lexer used a macro, char-case, to dispatch on the syntactic catagory of
20 
+;;; a character.  These catagories (processed at compile time) are defined
21 
+;;; here.  Note that some of these definitions use the char-code
22 
+;;; directly and would need updating for different character sets.
23 
+
24 
+(define *lex-definitions*
25 
+  '((vtab 11)  ; define by ascii code to avoid relying of the reader
26 
+    (formfeed 12)
27 
+    (whitechar #\newline #\space #\tab formfeed vtab)
28 
+    (small #\a - #\z)
29 
+    (large #\A - #\Z)
30 
+    (digit #\0 - #\9)
31 
+    (symbol #\! #\# #\$ #\% #\& #\* #\+ #\. #\/ #\< #\= #\> #\? #\@
32 
+      #\\ #\^ #\|)
33 
+    (presymbol #\- #\~)
34 
+    (exponent #\e #\E)
35 
+    (graphic large small digit
36 
+             #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+
37 
+             #\, #\- #\. #\/ #\: #\; #\< #\= #\> #\? #\@
38 
+	     #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~)
39 
+    (charesc #\a #\b #\f #\n #\r #\t #\v #\\ #\" #\' #\&)
40 
+    (cntrl large #\@ #\[ #\\ #\] #\^ #\_)))
41 
+
42 
+;;; The char-case macro is similar to case using characters to select.
43 
+;;; The following capabilities are added by char-case:
44 
+;;;   pre-defined constants are denoted by symbols (defined above)
45 
+;;;   ranges of characters are represented using -.  For example,
46 
+;;;     (#\a - #\z #\A - #\Z) denotes all alphabetics.
47 
+;;;   numbers refer to the char code of a character.
48 
+;;; The generated code is optimized somewhat to take advantage of
49 
+;;; consecutive character ranges.  With a little work, this could be
50 
+;;; implemented using jump tables someday.
51 
+
52 
+(define-syntax (char-case exp . alts)
53 
+  (expand-char-case exp alts))
54 
+
55 
+(define (expand-char-case exp alts)
56 
+  (let ((temp (gensym)))
57 
+    `(let ((,temp ,exp))
58 
+       ,(expand-char-case1 temp alts))))
59 
+
60 
+(define (expand-char-case1 temp alts)
61 
+  (if (null? alts)
62 
+      '()
63 
+      (let* ((alt (car alts))
64 
+	     (test (car alt))
65 
+	     (body (cons 'begin (cdr alt)))
66 
+	     (rest (expand-char-case1 temp (cdr alts))))
67 
+	(cond ((eq? test 'else)
68 
+	       body)
69 
+	      (else
70 
+	       `(if (or ,@(gen-char-tests temp
71 
+			     (if (pair? test) test (list test))))
72 
+		    ,body
73 
+		    ,rest))))))
74 
+
75 
+(define (gen-char-tests temp tests)
76 
+  (gen-char-tests-1 temp
77 
+	(sort-list (gather-char-tests tests) (function char<?))))
78 
+
79 
+(define (gen-char-tests-1 temp chars)
80 
+  (cond ((null? chars)
81 
+	 '())
82 
+	((long-enough-run? chars 3)
83 
+	 (gen-range-check temp (car chars) (car chars) (cdr chars)))
84 
+	(else
85 
+	 `((char=? ,temp ',(car chars))
86 
+	   ,@(gen-char-tests-1 temp (cdr chars))))))
87 
+
88 
+(define (gen-range-check temp first current chars)
89 
+  (if (and (pair? chars) (consec-chars? current (car chars)))
90 
+      (gen-range-check temp first (car chars) (cdr chars))
91 
+      `((and (char>=? ,temp ',first)
92 
+	     (char<=? ,temp ',current))
93 
+	,@(gen-char-tests-1 temp chars))))
94 
+
95 
+(define (consec-chars? c1 c2)
96 
+  (eqv? (+ 1 (char->integer c1)) (char->integer c2)))
97 
+
98 
+(define (long-enough-run? l n)
99 
+  (or (eqv? n 1)
100 
+      (and (pair? (cdr l))
101 
+	   (consec-chars? (car l) (cadr l))
102 
+	   (long-enough-run? (cdr l) (1- n)))))
103 
+
104 
+(define (gather-char-tests tests)
105 
+  (cond ((null? tests)
106 
+	 '())
107 
+	((symbol? (car tests))
108 
+	 (let ((new-test (assq (car tests) *lex-definitions*)))
109 
+	   (if new-test
110 
+	       (gather-char-tests (append (cdr new-test) (cdr tests)))
111 
+	       (error "Unknown character class: ~A~%" (car tests)))))
112 
+	((integer? (car tests))
113 
+	 (cons (integer->char (car tests))
114 
+	       (gather-char-tests (cdr tests))))
115 
+	((and (pair? (cdr tests)) (eq? '- (cadr tests)))
116 
+	 (letrec ((fn (lambda (a z)
117 
+			(if (char>? a z)
118 
+			    (gather-char-tests (cdddr tests))
119 
+			    (cons a (funcall
120 
+				      fn (integer->char
121 
+					 (+ 1 (char->integer a))) z))))))
122 
+	   (funcall fn (car tests) (caddr tests))))
123 
+	((char? (car tests))
124 
+	 (cons (car tests) (gather-char-tests (cdr tests))))
125 
+	(else
126 
+	 (error "Invalid selector in char-case: ~A~%" (car tests)))))
127 
+
128 
+;;; This macro scans a list of characters on a given syntaxtic catagory.
129 
+;;; The current character is always included in the resulting list.
130 
+
131 
+(define-syntax (scan-list-of char-type)
132 
+ `(letrec ((test-next (lambda ()
133 
+		       (char-case *char*
134 
+			(,char-type
135 
+			 (let ((c *char*))
136 
+			   (advance-char)
137 
+			   (cons c (funcall test-next))))
138 
+			(else '())))))
139 
+    (let ((c *char*))
140 
+      (advance-char)
141 
+      (cons c (funcall test-next)))))
142 
+
143 
+;;; This macro tests for string equality in which the strings are
144 
+;;; represented by lists of characters.  The comparisons are expanded
145 
+;;; inline (really just a little partial evaluation going on here!) for
146 
+;;; fast execution.  The tok argument evaluate to a list of chars.  The string
147 
+;;; argument must be a string constant, which is converted to characters
148 
+;;; as the macro expands.
149 
+
150 
+(define-syntax (string=/list? tok string)
151 
+  (let ((temp (gensym)))
152 
+    `(let ((,temp ,tok))
153 
+       ,(expand-string=/list? temp (string->list string)))))
154 
+
155 
+(define (expand-string=/list? var chars)
156 
+  (if (null? chars)
157 
+      `(null? ,var)
158 
+      (let ((new-temp (gensym)))
159 
+	`(and (pair? ,var)
160 
+	      (char=? (car ,var) ',(car chars))
161 
+	      (let ((,new-temp (cdr ,var)))
162 
+		,(expand-string=/list? new-temp (cdr chars)))))))
163 
+
164 
+;;; This macro extends the string equality defined above to search a
165 
+;;; list of reserved words quickly for keywords.  It does this by a case
166 
+;;; dispatch on the first character of the string and then processing
167 
+;;; the remaining characters wirh string=/list.  This would go a little
168 
+;;; faster with recursive char-case statements, but I'm a little too
169 
+;;; lazy at for this at the moment.  If a keyword is found is emitted
170 
+;;; as a symbol.  If not, the token string is emitted with the token
171 
+;;; type indicated.  Assume the string being scanned is a list of
172 
+;;; chars assigned to a var.  (Yeah - I know - I should add a gensym
173 
+;;; var for this argument!!).
174 
+
175 
+(define-syntax (parse-reserved var token-type . reserved-words)
176 
+ (let ((sorted-rws (sort-list reserved-words (function string<?))))
177 
+  `(let ((thunk (lambda () (emit-token/string ',token-type ,var))))
178 
+    (char-case (car ,var)
179 
+     ,@(expand-parse-reserved var
180 
+        (group-by-first-char (list (car sorted-rws)) (cdr sorted-rws)))
181 
+      (else (funcall thunk))))))
182 
+
183 
+(define (group-by-first-char group rest)
184 
+  (cond ((null? rest)
185 
+	 (list group))
186 
+	((char=? (string-ref (car group) 0)
187 
+		 (string-ref (car rest) 0))
188 
+	 (group-by-first-char (append group (list (car rest))) (cdr rest)))
189 
+	(else
190 
+	 (cons group (group-by-first-char (list (car rest)) (cdr rest))))))
191 
+
192 
+(define (expand-parse-reserved var groups)
193 
+  (if (null? groups)
194 
+      '()
195 
+      `((,(string-ref (caar groups) 0)
196 
+	 (cond ,@(expand-parse-reserved/group var (car groups))
197 
+	       (else (funcall thunk))))
198 
+	,@(expand-parse-reserved var (cdr groups)))))
199 
+
200 
+(define (expand-parse-reserved/group var group)
201 
+  (if (null? group)
202 
+      '()
203 
+      `(((string=/list? (cdr ,var)
204 
+	     ,(substring (car group) 1 (string-length (car group))))
205 
+	 (emit-token ',(string->symbol (car group))))
206 
+	,@(expand-parse-reserved/group var (cdr group)))))
207 
+
208 
+
209 
+;;; The following macros are used by the parser.
210 
+
211 
+;;; The primary macro used by the parser is token-case, which dispatches
212 
+;;; on the type of the current token (this is always *token* - unlike the
213 
+;;; lexer, no lookahead is provided; however, some of these dispatches are
214 
+;;; procedures that do a limited lookahead.  The problem with lookahead is that
215 
+;;; the layout rule adds tokens which are not visible looking into the
216 
+;;; token stream directly.
217 
+
218 
+;;; Unlike char-case, the token is normally advanced unless the selector
219 
+;;; includes `no-advance'.  The final else also avoids advancing the token.
220 
+
221 
+;;; In addition to raw token types, more complex types can be used.  These
222 
+;;; are defined here.  The construct `satisfies fn' calls the indicated
223 
+;;; function to determine whether the current token matches.
224 
+
225 
+;;; If the token type to be matched is not a constant, the construct
226 
+;;; `unquote var' matches the current token against the type in the var.
227 
+
228 
+(define *predefined-syntactic-catagories* '(
229 
+  (+ satisfies at-varsym/+?)
230 
+  (- satisfies at-varsym/-?)
231 
+  (tycon no-advance conid)
232 
+  (tyvar no-advance varid)
233 
+  (var no-advance varid satisfies at-varsym/paren?)
234 
+  (con no-advance conid satisfies at-consym/paren?)
235 
+  (name no-advance var con)
236 
+  (consym/paren no-advance satisfies at-consym/paren?)
237 
+  (varsym? no-advance varsym)
238 
+  (consym? no-advance consym)
239 
+  (varid? no-advance varid)
240 
+  (conid? no-advance conid)
241 
+  (op no-advance varsym consym \`)
242 
+  (varop no-advance varsym satisfies at-varid/quoted?)
243 
+  (conop no-advance consym satisfies at-conid/quoted?)
244 
+  (modid no-advance conid)
245 
+  (literal no-advance integer float char string)
246 
+  (numeric no-advance integer float)
247 
+  (k no-advance integer)
248 
+  (+k no-advance satisfies at-+k?)
249 
+  (-n no-advance satisfies at--n?)
250 
+  (apat-start no-advance varid conid literal _ \( \[ \~)
251 
+  (pat-start no-advance - apat-start)
252 
+  (atype-start no-advance tycon tyvar \( \[)
253 
+  (aexp-start no-advance varid conid \( \[ literal)
254 
+  ))
255 
+
256 
+;;; The format of token-case is
257 
+;;;  (token-case
258 
+;;;    (sel1 . e1) (sel2 . e2) ... [(else . en)])
259 
+;;; If the sel is a symbol it is the same as a singleton list: (@ x) = ((@) x)
260 
+
261 
+;;; Warning: this generates rather poor code!  Should be fixed up someday.
262 
+
263 
+(define-syntax (token-case . alts)
264 
+  `(cond ,@(map (function gen-token-case-alt) alts)))
265 
+
266 
+(define (gen-token-case-alt alt)
267 
+  (let ((test (car alt))
268 
+	(code (cdr alt)))
269 
+    (cond ((eq? test 'else)
270 
+	   `(else ,@code))
271 
+	  ((symbol? test)
272 
+	   (gen-token-case-alt-1 (expand-catagories (list test)) code))
273 
+	  (else
274 
+	   (gen-token-case-alt-1 (expand-catagories test) code)))))
275 
+
276 
+(define (expand-catagories terms)
277 
+  (if (null? terms)
278 
+      terms
279 
+      (let ((a (assq (car terms) *predefined-syntactic-catagories*))
280 
+	    (r (expand-catagories (cdr terms))))
281 
+	(if (null? a)
282 
+	    (cons (car terms) r)
283 
+	    (expand-catagories (append (cdr a) r))))))
284 
+
285 
+(define (gen-token-case-alt-1 test code)
286 
+  `((or ,@(gen-token-test test))
287 
+    ,@(if (memq 'no-advance test) '() '((advance-token)))
288 
+    ,@code))
289 
+
290 
+(define (gen-token-test test)
291 
+  (cond ((null? test)
292 
+	 '())
293 
+	((eq? (car test) 'no-advance)
294 
+	 (gen-token-test (cdr test)))
295 
+	((eq? (car test) 'unquote)
296 
+	 (cons `(eq? *token* ,(cadr test)) (gen-token-test (cddr test))))
297 
+	((eq? (car test) 'satisfies)
298 
+	 (cons (list (cadr test)) (gen-token-test (cddr test))))
299 
+	(else
300 
+	 (cons `(eq? *token* ',(car test)) (gen-token-test (cdr test))))))
301 
+
302 
+;;; require-tok requires a specific token to be at the scanner.  If it
303 
+;;; is found, the token is advanced over.  Otherwise, the error
304 
+;;; routine is called.
305 
+
306 
+(define-syntax (require-token tok error-handler)
307 
+  `(token-case
308 
+    (,tok '())
309 
+    (else ,error-handler)))
310 
+
311 
+;;; The save-parser-context macro captures the current line & file and
312 
+;;; attaches it to the ast node generated.
313 
+
314 
+(define-syntax (save-parser-context . body)
315 
+  (let ((temp1 (gensym))
316 
+	(temp2 (gensym)))
317 
+    `(let ((,temp1 (capture-current-line))
318 
+	   (,temp2 (begin ,@body)))
319 
+       (setf (ast-node-line-number ,temp2) ,temp1)
320 
+       ,temp2)))
321 
+
322 
+(define (capture-current-line)
323 
+  (make source-pointer (line *current-line*) (file *current-file*)))
324 
+
325 
+(define-syntax (push-decl-list decl place)
326 
+  `(setf ,place (nconc ,place (list ,decl))))
327 
+
parser/parser.scm
History View file @ 4e98702
0 328 
new file mode 100644
... ... 
@@ -0,0 +1,54 @@
1 
+;;; parser.scm -- compilation unit definition for the lexer and parser
2 
+;;;
3 
+;;; author :  John
4 
+;;; date   :  10 Dec 1991
5 
+;;;
6 
+
7 
+(define-compilation-unit parser
8 
+  (source-filename "$Y2/parser/")
9 
+  (require global)
10 
+  (unit parser-globals
11 
+    (source-filename "parser-globals.scm"))
12 
+  (unit parser-macros
13 
+    (source-filename "parser-macros.scm")
14 
+    (require parser-globals))
15 
+  (unit parser-errors
16 
+    (source-filename "parser-errors.scm")
17 
+    (require parser-macros))
18 
+  (unit lexer
19 
+    (source-filename "lexer.scm")
20 
+    (require parser-macros))
21 
+  (unit token
22 
+    (source-filename "token.scm")
23 
+    (require parser-macros))
24 
+  (unit parser-driver
25 
+    (source-filename "parser-driver.scm")
26 
+    (require parser-macros))
27 
+  (unit module-parser
28 
+    (source-filename "module-parser.scm")
29 
+    (require parser-macros))
30 
+  (unit interface-parser
31 
+    (source-filename "interface-parser.scm")
32 
+    (require parser-macros))
33 
+  (unit decl-parser
34 
+    (source-filename "decl-parser.scm")
35 
+    (require parser-macros))
36 
+  (unit type-parser
37 
+    (source-filename "type-parser.scm")
38 
+    (require parser-macros))
39 
+  (unit typedecl-parser
40 
+    (source-filename "typedecl-parser.scm")
41 
+    (require parser-macros))
42 
+  (unit exp-parser
43 
+    (source-filename "exp-parser.scm")
44 
+    (require parser-macros))
45 
+  (unit annotation-parser
46 
+    (source-filename "annotation-parser.scm")
47 
+    (require parser-macros))
48 
+  (unit pattern-parser
49 
+    (source-filename "pattern-parser.scm")
50 
+    (require parser-macros))
51 
+  (unit parser-debugger
52 
+    (source-filename "parser-debugger.scm")
53 
+    (require parser-macros)))
54 
+
parser/pattern-parser.scm
History View file @ 4e98702
0 55 
new file mode 100644
... ... 
@@ -0,0 +1,220 @@
1 
+;;;  File: pattern-parser        Author: John
2 
+
3 
+;;; This parses the pattern syntax except for the parts which need to be
4 
+;;; resolved by precedence parsing.
5 
+
6 
+;;; This parses a list of alternating pats & conops.
7 
+
8 
+(define (parse-pat)
9 
+ (trace-parser pat
10 
+   (let ((res (parse-pat/list)))
11 
+     (if (null? (cdr res))
12 
+	 (car res)
13 
+	 (make pp-pat-list (pats res))))))
14 
+
15 
+;;; This parses a list of patterns with intervening conops and + patterns
16 
+
17 
+(define (parse-pat/list)
18 
+  (token-case
19 
+    (con (let ((pcon (pcon->ast)))
20 
+	   (setf (pcon-pats pcon) (parse-apat-list))
21 
+	   (cons pcon (parse-pat/tail))))
22 
+    (-n
23 
+     (advance-token) ; past -
24 
+     (token-case
25 
+      (numeric (let ((val (literal->ast)))
26 
+		 (cons (make pp-pat-negated)
27 
+		       (cons (make const-pat (value val))
28 
+			     (parse-pat/tail)))))
29 
+      (else
30 
+       (signal-missing-token "<number>" "negative literal pattern"))))
31 
+    (var
32 
+     (let ((var (var->ast)))
33 
+       (token-case
34 
+	(+k (cons (make var-pat (var var))
35 
+		  (parse-+k-pat)))
36 
+	(@  (let ((pattern (parse-apat)))
37 
+	      (cons (make as-pat (var var) (pattern pattern))
38 
+		    (parse-pat/tail))))
39 
+	(else (cons (make var-pat (var var)) (parse-pat/tail))))))
40 
+    (_
41 
+     (let ((pat (make wildcard-pat)))
42 
+       (token-case
43 
+	(+k (cons pat (parse-+k-pat)))
44 
+	(else (cons pat (parse-pat/tail))))))
45 
+    (else (let ((apat (parse-apat)))
46 
+	    (cons apat (parse-pat/tail))))))
47 
+
48 
+
49 
+(define (parse-+k-pat)
50 
+  (advance-token)  ; past +
51 
+  (token-case
52 
+   (k (let ((val (literal->ast)))
53 
+	(cons (make pp-pat-plus)
54 
+	      (cons (make const-pat (value val))
55 
+		    (parse-pat/tail)))))
56 
+   (else (signal-missing-token "<integer>" "successor pattern"))))
57 
+
58 
+(define (parse-pat/tail)
59 
+   (token-case
60 
+     (conop
61 
+      (let ((con (pconop->ast)))
62 
+	(cons con (parse-pat/list))))
63 
+     (else '())))
64 
+
65 
+(define (parse-apat)
66 
+ (trace-parser apat
67 
+   (token-case
68 
+     (var (let ((var (var->ast)))
69 
+	    (token-case
70 
+	     (@
71 
+	      (let ((pattern (parse-apat)))
72 
+		(make as-pat (var var) (pattern pattern))))
73 
+	     (else (make var-pat (var var))))))
74 
+     (con (pcon->ast))
75 
+     (literal (let ((value (literal->ast)))
76 
+		(make const-pat (value value))))
77 
+     (_ (make wildcard-pat))
78 
+     (\( (token-case
79 
+           (\) (**pcon/def (core-symbol "UnitConstructor") '()))
80 
+	   (else
81 
+	    (let ((pat (parse-pat)))
82 
+	      (token-case
83 
+		(\, (**pcon/tuple (cons pat (parse-pat-list '\)))))
84 
+		(\) pat)
85 
+		(else
86 
+		 (signal-missing-token "`)' or `,'" "pattern")))))))
87 
+     (\[ (token-case
88 
+	  (\] (make list-pat (pats '())))
89 
+	  (else (make list-pat (pats (parse-pat-list '\]))))))
90 
+     (\~ (let ((pattern (parse-apat)))
91 
+	   (make irr-pat (pattern pattern))))
92 
+     (else
93 
+      (signal-invalid-syntax "an apat")))))
94 
+
95 
+(define (parse-pat-list term)  ;; , separated
96 
+  (let ((pat (parse-pat)))
97 
+    (token-case
98 
+     (\, (cons pat (parse-pat-list term)))
99 
+     ((unquote term) (list pat))
100 
+     (else
101 
+      (signal-missing-token
102 
+        (if (eq? term '\)) "`)'" "`]'")
103 
+	"pattern")))))
104 
+
105 
+(define (parse-apat-list)  ;; space separated
106 
+  (token-case
107 
+    (apat-start
108 
+     (let ((pat (parse-apat)))
109 
+       (cons pat (parse-apat-list))))
110 
+    (else
111 
+     '())))
112 
+
113 
+;;; The following routine scans patterns without creating ast structure.
114 
+;;; They return #t or #f depending on whether a valid pattern was encountered.
115 
+;;; The leave the scanner pointing to the next token after the pattern.
116 
+
117 
+(define (scan-pat)  ; same as parse-pat/list
118 
+  (and
119 
+   (token-case
120 
+    (con (scan-con)
121 
+	 (scan-apat-list))
122 
+    (-n (advance-token)
123 
+	(token-case
124 
+	 (numeric (advance-token)
125 
+		  '#t)
126 
+	 (else '#f)))
127 
+    (var (and (scan-var)
128 
+	      (token-case
129 
+	       (@ (scan-apat))
130 
+	       (+k (scan-+k))
131 
+	       (else '#t))))
132 
+    (_ (scan-+k))
133 
+    (else (scan-apat)))
134 
+   (scan-pat/tail)))
135 
+
136 
+(define (scan-pat/tail)
137 
+  (token-case
138 
+   (conop (and (scan-conop)
139 
+	       (scan-pat)))
140 
+   (else '#t)))
141 
+
142 
+(define (scan-apat)
143 
+  (token-case
144 
+   (var (scan-var)
145 
+	(token-case
146 
+	 (@ (scan-apat))
147 
+	 (else '#t)))
148 
+   (con (scan-con))
149 
+   (literal (advance-token)
150 
+	    '#t)
151 
+   (_ '#t)
152 
+   (\( (token-case
153 
+	(\) '#t)
154 
+	(else
155 
+	 (and (scan-pat)
156 
+	      (token-case
157 
+	       (\, (scan-pat-list '\)))
158 
+	       (\) '#t)
159 
+	       (else '#f))))))
160 
+   (\[ (token-case
161 
+	(\] '#t)
162 
+	(else (scan-pat-list '\]))))
163 
+   (\~ (scan-apat))
164 
+   (else '#f)))
165 
+
166 
+(define (scan-pat-list term)
167 
+  (and (scan-pat)
168 
+       (token-case
169 
+	(\, (scan-pat-list term))
170 
+	((unquote term) '#t)
171 
+	(else '#f))))
172 
+
173 
+(define (scan-apat-list)
174 
+  (token-case
175 
+   (apat-start
176 
+    (and (scan-apat)
177 
+	 (scan-apat-list)))
178 
+   (else '#t)))
179 
+
180 
+(define (scan-var)
181 
+  (token-case
182 
+   (varid '#t)
183 
+   (\( (token-case
184 
+	(varsym
185 
+	 (token-case
186 
+	  (\) '#t)
187 
+	  (else '#f)))
188 
+	(else '#f)))
189 
+   (else '#f)))
190 
+
191 
+(define (scan-con)
192 
+  (token-case
193 
+   (conid '#t)
194 
+   (\( (token-case
195 
+	(consym
196 
+	 (token-case
197 
+	  (\) '#t)
198 
+	  (else '#f)))
199 
+	(else '#f)))
200 
+   (else '#f)))
201 
+
202 
+(define (scan-conop)
203 
+  (token-case
204 
+   (consym '#t)
205 
+   (\` (token-case
206 
+	(conid
207 
+	 (token-case
208 
+	  (\` '#t)
209 
+	  (else '#f)))
210 
+	(else '#f)))
211 
+   (else '#f)))
212 
+
213 
+(define (scan-+k)
214 
+  (token-case
215 
+   (+k (advance-token)  ; past the +
216 
+       (token-case
217 
+	(integer '#t)
218 
+	(else '#f)))
219 
+   (else '#t)))
220 
+
parser/token.scm
History View file @ 4e98702
0 221 
new file mode 100644
... ... 
@@ -0,0 +1,364 @@
1 
+;;;  This file abstracts the representation of tokens.  It is used by both
2 
+;;;  the lexer & parser.  This also contains routines for converting
3 
+;;;  individual tokens to ast structure.  Routines used by the
4 
+;;;  token-case macro in `satisfies' clauses are here too.
5 
+
6 
+;;; Lexer routines for emitting tokens:
7 
+
8 
+(define (emit-token type . args)
9 
+  (cond (*on-new-line?*
10 
+	 (push (list 'line *start-line* *start-col*) *tokens*))
11 
+	(*save-col?*
12 
+	 (push (list 'col *start-col*) *tokens*)))
13 
+  (push (cons type args) *tokens*)
14 
+  (setf *on-new-line?* '#f)
15 
+  (setf *save-col?* (memq type '(|where| |of| |let|))))
16 
+
17 
+(define (emit-token/string type string-as-list)
18 
+  (emit-token type (list->string string-as-list)))
19 
+
20 
+;;; Parser routines:
21 
+
22 
+;;;  These routines take care of the token stream in the parser.  They
23 
+;;;  maintain globals for the current token and its location.
24 
+
25 
+;;;  Globals used:
26 
+;;;   *token-stream*   remaining tokens to be parsed
27 
+;;;   *token*          current token type
28 
+;;;   *token-args*     current token arguments
29 
+;;;   *layout-stack*   columns at which layout is being done
30 
+;;;   *current-line*   current line the scanner is on
31 
+;;;   *current-col*    current col; valid at start of line & after where,let,of
32 
+;;;   *current-file*
33 
+
34 
+(define (init-token-stream tokens)
35 
+  (setf *token-stream* tokens)
36 
+  (setf *layout-stack* '())
37 
+  (advance-token))
38 
+
39 
+(define (advance-token)
40 
+  (cond ((null? *token-stream*)
41 
+	 (setf *token* 'eof))
42 
+	(else
43 
+	 (let* ((token (car *token-stream*)))
44 
+	   (setf *token-stream* (cdr *token-stream*))
45 
+	   (advance-token-1 (car token) (cdr token))))))
46 
+
47 
+(define (advance-token-1 type args)
48 
+  (cond ((eq? type 'file)
49 
+	 (setf *current-file* (car args))
50 
+	 (advance-token))
51 
+	((eq? type 'col)
52 
+	 (setf *current-col* (car args))
53 
+	 (advance-token))
54 
+	((eq? type 'line)  ;; assume blank lines have been removed
55 
+	 (let ((line (car args))
56 
+	       (col (cadr args)))
57 
+	   (setf *current-line* line)
58 
+	   (setf *current-col* col)
59 
+	   (setf *token-stream*
60 
+		 (resolve-layout *token-stream* *layout-stack*)))
61 
+	 (advance-token))
62 
+	(else
63 
+	 (setf *token* type)
64 
+	 (setf *token-args* args)
65 
+	 type)))
66 
+
67 
+(define (insert-extra-token tok-type stream) ; used by layout
68 
+  (cons (list tok-type) stream))
69 
+
70 
+;;; This looks for the { to decide of layout will apply.  If so, the layout
71 
+;;; stack is pushed.  The body function, fn, is called with a boolean which
72 
+;;; tells it the whether layout rule is in force.
73 
+
74 
+;;; *** The CMU CL compiler barfs with some kind of internal error
75 
+;;; *** on this function.  See the revised definition below.
76 
+
77 
+;(define (start-layout fn)
78 
+;  (token-case
79 
+;   (\{ (funcall fn '#f))
80 
+;   (else
81 
+;    (let/cc recovery-fn
82 
+;      (push (cons *current-col* (lambda ()
83 
+;				  (let ((res (funcall fn '#t)))
84 
+;				    (funcall recovery-fn res))))
85 
+;	    *layout-stack*)
86 
+;      (funcall fn '#t)))))
87 
+
88 
+(define (start-layout fn)
89 
+  (token-case
90 
+   (\{ (funcall fn '#f))
91 
+   (else
92 
+    (let/cc recovery-fn
93 
+      (start-layout-1 fn recovery-fn)))))
94 
+
95 
+(define (start-layout-1 fn recovery-fn)
96 
+  (push (cons *current-col*
97 
+	      (lambda ()
98 
+		(let ((res (funcall fn '#t)))
99 
+		  (funcall recovery-fn res))))
100 
+	*layout-stack*)
101 
+  (funcall fn '#t))
102 
+
103 
+(define (layout-col x)
104 
+  (car x))
105 
+
106 
+(define (layout-recovery-fn x)
107 
+  (cdr x))
108 
+
109 
+(define (close-layout in-layout?)
110 
+  (cond (in-layout?
111 
+	 (setf *layout-stack* (cdr *layout-stack*))
112 
+	 (token-case
113 
+	  ($\} '())   ; the advance-token routine may have inserted this
114 
+	  (else '())))
115 
+	(else
116 
+	 (token-case
117 
+	  (\} '())
118 
+	  (else
119 
+	   (signal-missing-brace))))))
120 
+
121 
+(define (signal-missing-brace)
122 
+  (parser-error 'missing-brace
123 
+		"Missing `}'."))
124 
+
125 
+(define (resolve-layout stream layout-stack)
126 
+  (if (null? layout-stack)
127 
+      stream
128 
+      (let ((col  (layout-col (car layout-stack))))
129 
+	(declare (type fixnum col))
130 
+	(cond ((= (the fixnum *current-col*) col)
131 
+	       (insert-extra-token '\; stream))
132 
+	      ((< (the fixnum *current-col*) col)
133 
+	       (insert-extra-token
134 
+	         '$\} (resolve-layout stream (cdr layout-stack))))
135 
+	      (else
136 
+	       stream)
137 
+	      ))))
138 
+
139 
+
140 
+;;; The following routines are used for backtracking.  This is a bit of
141 
+;;; a hack at the moment.
142 
+
143 
+(define (save-scanner-state)
144 
+  (vector *token* *token-args* *token-stream* *layout-stack* *current-line*
145 
+	  *current-col*))
146 
+
147 
+(define (restore-excursion state)
148 
+  (setf *token* (vector-ref state 0))
149 
+  (setf *token-args* (vector-ref state 1))
150 
+  (setf *token-stream* (vector-ref state 2))
151 
+  (setf *layout-stack* (vector-ref state 3))
152 
+  (setf *current-line* (vector-ref state 4))
153 
+  (setf *current-col* (vector-ref state 5)))
154 
+
155 
+(define (eq-token? type)
156 
+  (eq? type *token*))
157 
+
158 
+(define (eq-token-arg? str)
159 
+  (string=? str (car *token-args*)))
160 
+
161 
+;;; lookahead into the token stream
162 
+
163 
+(define (peek-1-type)
164 
+  (peek-toks 0 *token-stream*))
165 
+
166 
+(define (peek-2-type)
167 
+  (peek-toks 1 *token-stream*))
168 
+
169 
+;;; This is a Q&D way of looking ahead.  It does not expand the layout
170 
+;;; as it goes so there may be missing } and ;.  This should not matter
171 
+;;; in the places where this is used since these would be invalid anyway.
172 
+;;; To be safe, token types are rechecked while advancing to verify the
173 
+;;; lookahead.
174 
+
175 
+(define (peek-toks n toks)
176 
+  (declare (type fixnum n))
177 
+  (cond ((null? toks)
178 
+	 'eof)
179 
+	((memq (caar toks) '(col line))
180 
+	 (peek-toks n (cdr toks)))
181 
+	((eqv? n 0)
182 
+	 (caar toks))
183 
+	(else (peek-toks (1- n) (cdr toks)))))
184 
+
185 
+;; These routines handle the `satisfies' clauses used in token-case.
186 
+
187 
+(define (at-varsym/+?)
188 
+  (and (eq? *token* 'varsym)
189 
+       (string=? (car *token-args*) "+")))
190 
+
191 
+(define (at-varsym/-?)
192 
+  (and (eq? *token* 'varsym)
193 
+       (string=? (car *token-args*) "-")))
194 
+
195 
+(define (at-varsym/paren?)
196 
+  (and (eq? *token* '\()
197 
+       (eq? (peek-1-type) 'varsym)
198 
+       (eq? (peek-2-type) '\))))
199 
+
200 
+(define (at-consym/paren?)
201 
+  (and (eq? *token* '\()
202 
+       (eq? (peek-1-type) 'consym)
203 
+       (eq? (peek-2-type) '\))))
204 
+
205 
+(define (at-varid/quoted?)
206 
+  (and (eq? *token* '\`)
207 
+       (eq? (peek-1-type) 'varid)))
208 
+
209 
+(define (at-conid/quoted?)
210 
+  (and (eq? *token* '\`)
211 
+       (eq? (peek-1-type) 'conid)))
212 
+
213 
+(define (at-+k?)
214 
+  (and (at-varsym/+?)
215 
+       (eq? (peek-1-type) 'integer)))
216 
+
217 
+(define (at--n?)
218 
+  (and (at-varsym/-?)
219 
+       (memq (peek-1-type) '(integer float))))
220 
+
221 
+;;;  The following routines convert the simplest tokens to AST structure.
222 
+
223 
+(define-local-syntax (return+advance x)
224 
+  `(let ((x ,x))
225 
+     (advance-token)
226 
+     x))
227 
+
228 
+(define (token->symbol)
229 
+ (return+advance
230 
+  (string->symbol (car *token-args*))))
231 
+
232 
+(define (token->symbol/con)  ; for conid, aconid
233 
+ (return+advance
234 
+  (string->symbol (add-con-prefix (car *token-args*)))))
235 
+
236 
+(define (var->symbol)
237 
+  (token-case
238 
+   (\( (token-case
239 
+	(varsym?
240 
+	 (let ((res (token->symbol)))
241 
+	   (token-case
242 
+	    (\) res)
243 
+	    (else (signal-missing-token "`)'" "var")))))
244 
+	(else (signal-missing-token "<varsym>" "var"))))
245 
+   (varid? (token->symbol))))
246 
+
247 
+(define (var->ast)
248 
+  (let ((vname (var->symbol)))
249 
+    (make var-ref (name vname) (infix? '#f) (var *undefined-def*))))
250 
+
251 
+(define (var->entity)
252 
+  (let ((vname (var->symbol)))
253 
+    (make entity-var (name vname))))
254 
+
255 
+(define (con->symbol)
256 
+  (token-case
257 
+   (\( (token-case
258 
+	(consym?
259 
+	 (let ((res (token->symbol/con)))
260 
+	   (token-case
261 
+	    (\) res)
262 
+	    (else (signal-missing-token "`)'" "con")))))
263 
+	(else (signal-missing-token "<consym>" "con"))))
264 
+   (conid? (token->symbol/con))))
265 
+
266 
+(define (varop->symbol)
267 
+  (token-case
268 
+   (\` (token-case
269 
+	(varid?
270 
+	 (let ((res (token->symbol)))
271 
+	   (token-case
272 
+	    (\` res)
273 
+	    (else (signal-missing-token "``'" "varop")))))
274 
+	(else (signal-missing-token "<varid>" "varop"))))
275 
+   (varsym? (token->symbol))))
276 
+
277 
+(define (varop->ast)
278 
+  (let ((varop-name (varop->symbol)))
279 
+    (make var-ref (name varop-name) (infix? '#t) (var *undefined-def*))))
280 
+
281 
+(define (conop->symbol)
282 
+  (token-case
283 
+   (\` (token-case
284 
+	(conid?
285 
+	 (let ((res (token->symbol/con)))
286 
+	   (token-case
287 
+	    (\` res)
288 
+	    (else (signal-missing-token "``'" "conop")))))
289 
+	(else (signal-missing-token "<conid>" "conop"))))
290 
+   (consym? (token->symbol/con))))
291 
+
292 
+(define (conop->ast)
293 
+  (let ((conop-name (conop->symbol)))
294 
+    (make con-ref (name conop-name) (infix? '#t) (con *undefined-def*))))
295 
+
296 
+(define (op->symbol)
297 
+  (token-case
298 
+   (\` (token-case
299 
+	(conid?
300 
+	 (let ((res (token->symbol/con)))
301 
+	   (token-case
302 
+	    (\` res)
303 
+	    (else (signal-missing-token "``'" "op")))))
304 
+	(varid?
305 
+	 (let ((res (token->symbol)))
306 
+	   (token-case
307 
+	    (\` res)
308 
+	    (else (signal-missing-token "``'" "op")))))
309 
+	(else (signal-missing-token "<conid> or <varid>" "op"))))
310 
+   (consym? (token->symbol/con))
311 
+   (varsym? (token->symbol))))
312 
+
313 
+(define (con->ast)  ; for conid, aconid
314 
+  (let ((name (con->symbol)))
315 
+    (make con-ref (name name) (con *undefined-def*) (infix? '#f))))
316 
+
317 
+(define (pcon->ast) ; for aconid, conid
318 
+  (let ((name (con->symbol)))
319 
+    (make pcon (name name) (con *undefined-def*) (pats '()) (infix? '#f))))
320 
+
321 
+(define (pconop->ast) ; for aconop, conop
322 
+  (let ((name (conop->symbol)))
323 
+    (make pcon (name name) (con *undefined-def*) (pats '()) (infix? '#t))))
324 
+
325 
+(define (tycon->ast) ; for aconid
326 
+  (let ((name (token->symbol)))
327 
+    (make tycon (name name) (def *undefined-def*) (args '()))))
328 
+
329 
+(define (class->ast) ; for aconid
330 
+  (let ((name (token->symbol)))
331 
+    (make class-ref (name name) (class *undefined-def*))))
332 
+
333 
+(define (tyvar->ast) ; for avarid
334 
+  (let ((name (token->symbol)))
335 
+    (make tyvar (name name))))
336 
+
337 
+(define (token->integer) ; for integer
338 
+ (return+advance
339 
+  (car *token-args*)))
340 
+
341 
+(define (integer->ast) ; for integer
342 
+ (return+advance
343 
+  (make integer-const (value (car *token-args*)))))
344 
+
345 
+(define (float->ast)
346 
+ (return+advance
347 
+  (make float-const (numerator (car *token-args*))
348 
+	            (denominator (cadr *token-args*))
349 
+	            (exponent (caddr *token-args*)))))
350 
+
351 
+(define (string->ast)
352 
+ (return+advance
353 
+  (make string-const (value (car *token-args*)))))
354 
+
355 
+(define (char->ast)
356 
+ (return+advance
357 
+  (make char-const (value (car *token-args*)))))
358 
+
359 
+(define (literal->ast)
360 
+  (token-case
361 
+    ((no-advance integer) (integer->ast))
362 
+    ((no-advance float) (float->ast))
363 
+    ((no-advance string) (string->ast))
364 
+    ((no-advance char) (char->ast))))
parser/type-parser.scm
History View file @ 4e98702
0 365 
new file mode 100644
... ... 
@@ -0,0 +1,116 @@
1 
+;;; File: type-parser        Author: John
2 
+
3 
+(define (parse-type)
4 
+  (let ((type (parse-btype)))
5 
+    (token-case
6 
+      (->
7 
+       (**tycon/def (core-symbol "Arrow") (list type (parse-type))))
8 
+      (else type))))
9 
+
10 
+(define (parse-btype)
11 
+  (token-case
12 
+   (tycon (let* ((tycon (tycon->ast))
13 
+		 (tycon-args (parse-atype-list)))
14 
+	    (setf (tycon-args tycon) tycon-args)
15 
+	    tycon))
16 
+   (else
17 
+    (parse-atype))))
18 
+
19 
+(define (parse-atype-list)
20 
+  (token-case
21 
+    (atype-start
22 
+     (let ((atype (parse-atype)))
23 
+       (cons atype (parse-atype-list))))
24 
+    (else '())))
25 
+
26 
+(define (parse-atype)
27 
+  (token-case
28 
+    (tyvar (tyvar->ast))
29 
+    (tycon (tycon->ast))
30 
+    (\( (token-case
31 
+	  (\) (**tycon/def (core-symbol "UnitType") '()))
32 
+	  (else
33 
+	    (let ((type (parse-type)))
34 
+	      (token-case
35 
+	       (\) type)
36 
+	       (\, (let ((types  (cons type (parse-type-list))))
37 
+		     (**tycon/def (tuple-tycon (length types)) types)))
38 
+	       (else
39 
+		(signal-missing-token "`)' or `,'" "type expression")))))))
40 
+    (\[ (let ((type (parse-type)))
41 
+	  (require-token \] (signal-missing-token "`]'" "type expression"))
42 
+	  (**tycon/def (core-symbol "List") (list type))))
43 
+    (else
44 
+     (signal-invalid-syntax "an atype"))))
45 
+
46 
+(define (parse-type-list)
47 
+  (let ((type (parse-type)))
48 
+    (token-case (\, (cons type (parse-type-list)))
49 
+		(\) (list type))
50 
+		(else (signal-missing-token "`)' or `,'" "type expression")))))
51 
+
52 
+;;; This is used to determine whether a type is preceded by a context
53 
+
54 
+(define (has-optional-context?)
55 
+  (let* ((saved-excursion (save-scanner-state))
56 
+	 (res (token-case
57 
+		(conid
58 
+		 (token-case
59 
+		  (varid (eq-token? '=>))
60 
+		  (else '#f)))
61 
+		(\( (scan-context))
62 
+		(else '#f))))
63 
+    (restore-excursion saved-excursion)
64 
+    res))
65 
+
66 
+(define (scan-context)
67 
+  (token-case
68 
+    (conid
69 
+     (token-case
70 
+       (varid
71 
+	 (token-case
72 
+	   (\) (eq-token? '=>))
73 
+	   (\, (scan-context))
74 
+	   (else '#f)))
75 
+       (else '#f)))
76 
+    (else '#f)))
77 
+
78 
+(define (parse-context)
79 
+ (let ((contexts (token-case
80 
+	           (tycon
81 
+		    (list (parse-single-context)))
82 
+		   (\( (parse-contexts))
83 
+		   (else
84 
+		    (signal-invalid-syntax "a context")))))
85 
+   (require-token => (signal-missing-token "`=>'" "context"))
86 
+   contexts))
87 
+
88 
+(define (parse-single-context)
89 
+  (let ((class (class->ast)))
90 
+    (token-case
91 
+      (tyvar
92 
+       (let ((tyvar (token->symbol)))
93 
+	 (make context (class class) (tyvar tyvar))))
94 
+      (else (signal-missing-token "<tyvar>" "class assertion")))))
95 
+
96 
+(define (parse-contexts)
97 
+  (token-case
98 
+    (tycon (let ((context (parse-single-context)))
99 
+	      (token-case
100 
+		(\, (cons context (parse-contexts)))
101 
+		(\) (list context))
102 
+		(else (signal-missing-token "`)' or `,'" "context")))))
103 
+    (else (signal-missing-token "<tycon>" "class assertion"))))
104 
+
105 
+(define (parse-optional-context)
106 
+  (if (has-optional-context?)
107 
+      (parse-context)
108 
+      '()))
109 
+
110 
+(define (parse-signature)
111 
+  (let* ((contexts (parse-optional-context))
112 
+	 (type (parse-type)))
113 
+    (make signature (context contexts) (type type))))
114 
+
115 
+
116 
+
0 117 
\ No newline at end of file
parser/typedecl-parser.scm
History View file @ 4e98702
1 118 
new file mode 100644
... ... 
@@ -0,0 +1,163 @@
1 
+;;; File: parser/typedecl-parser     Author: John
2 
+
3 
+(define (parse-type-decl interface?)
4 
+ (save-parser-context
5 
+  (let* ((sig (parse-signature))
6 
+	 (contexts (signature-context sig))
7 
+	 (simple (signature-type sig))
8 
+	 (deriving '())
9 
+	 (constrs '()))
10 
+    ;; #t = builtins ([] (,,) ->) not allowed
11 
+    (check-simple simple '#t "type declaration")
12 
+    (let ((annotations (parse-constr-annotations)))
13 
+     (token-case
14 
+      (= (setf constrs (parse-constrs))
15 
+	 (token-case
16 
+	  (|deriving|
17 
+	   (setf deriving
18 
+	     (token-case
19 
+		 (\(
20 
+		  (token-case
21 
+		   (\) '())
22 
+		   (else (parse-class-list))))
23 
+		 (tycon (list (class->ast)))
24 
+		 (else (signal-invalid-syntax "a deriving clause")))))))
25 
+      (else
26 
+       (when (not interface?)
27 
+	 (signal-missing-constructors))))
28 
+    (make data-decl (context contexts) (simple simple)
29 
+		    (constrs constrs) (deriving deriving)
30 
+		    (annotations annotations))))))
31 
+
32 
+(define (signal-missing-constructors)
33 
+  (parser-error 'missing-constructors
34 
+		"Data type definition requires constructors"))
35 
+
36 
+(define (check-simple simple fresh? where)
37 
+  (when (not (tycon? simple))
38 
+    (signal-not-simple where))
39 
+  (when (and fresh? (not (eq? (tycon-def simple) *undefined-def*)))
40 
+    (signal-not-simple where))
41 
+  (let ((tyvars (map (lambda (arg)
42 
+		       (when (not (tyvar? arg))
43 
+			     (signal-not-simple where))
44 
+		       (tyvar-name arg))
45 
+		     (tycon-args simple))))
46 
+    (when (not (null? (find-duplicates tyvars)))
47 
+      (signal-unique-tyvars-required))))
48 
+
49 
+(define (signal-unique-tyvars-required)
50 
+  (parser-error 'unique-tyvars-required
51 
+		"Duplicate type variables appear in simple."))
52 
+
53 
+(define (signal-not-simple where)
54 
+  (parser-error 'not-simple "Simple type required in ~a." where))
55 
+
56 
+(define (parse-constrs)
57 
+  (let ((constr (parse-constr)))
58 
+    (token-case
59 
+     (\| (cons constr (parse-constrs)))
60 
+     (else (list constr)))))
61 
+
62 
+(define (parse-constr)
63 
+ (save-parser-context
64 
+  (let ((saved-excursion (save-scanner-state)))
65 
+    (token-case
66 
+     (consym/paren
67 
+      (parse-prefix-constr))
68 
+     (else
69 
+      (let ((type1 (parse-btype))
70 
+	    (anns (parse-constr-annotations)))
71 
+	(token-case
72 
+	 (conop
73 
+	  (parse-infix-constr (tuple type1 anns)))
74 
+	 (else
75 
+	  (restore-excursion saved-excursion)
76 
+	  (parse-prefix-constr)))))))))
77 
+
78 
+(define (parse-prefix-constr)
79 
+  (token-case
80 
+   (con
81 
+    (let* ((con (con->ast))
82 
+	   (types (parse-constr-type-list)))
83 
+      (make constr (constructor con) (types types))))
84 
+   (else
85 
+    (signal-missing-token "<con>" "constrs list"))))
86 
+
87 
+(define (parse-constr-type-list)
88 
+  (token-case
89 
+    (atype-start
90 
+     (let* ((atype (parse-atype))
91 
+	    (anns (parse-constr-annotations)))
92 
+       (cons (tuple atype anns)
93 
+	     (parse-constr-type-list))))
94 
+    (else '())))
95 
+
96 
+(define (parse-infix-constr t+a1)
97 
+  (let* ((con (conop->ast))
98 
+	 (type2 (parse-btype))
99 
+	 (anns (parse-constr-annotations)))
100 
+    (make constr (constructor con) (types (list t+a1 (tuple type2 anns))))))
101 
+
102 
+(define (parse-class-list)
103 
+  (token-case
104 
+   (tycon (let ((class (class->ast)))
105 
+	     (token-case
106 
+	      (\, (cons class (parse-class-list)))
107 
+	      (\) (list class))
108 
+	      (else (signal-missing-token "`)' or `,'" "deriving clause")))))
109 
+   (else (signal-missing-token "<tycon>" "deriving clause"))))
110 
+
111 
+(define (parse-constr-annotations)
112 
+  (token-case
113 
+   ((begin-annotation no-advance)
114 
+    (let ((annotations (parse-annotations)))
115 
+      (append annotations (parse-constr-annotations))))
116 
+   (else '())))
117 
+
118 
+(define (parse-synonym-decl)
119 
+ (save-parser-context
120 
+  (let* ((sig (parse-signature))
121 
+	 (contexts (signature-context sig))
122 
+	 (simple (signature-type sig)))
123 
+    (check-simple simple '#t "type synonym declaration")
124 
+    (when (not (null? contexts))
125 
+      (signal-no-context-in-synonym))
126 
+    (require-token = (signal-missing-token "`='" "type synonym declaration"))
127 
+    (let ((body (parse-type)))
128 
+      (make synonym-decl (simple simple) (body body))))))
129 
+
130 
+(define (signal-no-context-in-synonym)
131 
+  (parser-error 'no-context-in-synonym
132 
+		"Context is not permitted in type synonym declaration."))
133 
+
134 
+(define (parse-class-decl)
135 
+ (save-parser-context
136 
+  (let ((supers (parse-optional-context)))
137 
+    (token-case
138 
+     (tycon
139 
+      (let ((class (class->ast)))
140 
+	(token-case
141 
+	 (tyvar
142 
+	  (let* ((class-var (token->symbol))
143 
+		 (decls (parse-where-decls)))
144 
+	    (make class-decl (class class) (super-classes supers)
145 
+		             (class-var class-var) (decls decls))))
146 
+	 (else
147 
+	  (signal-missing-token "<tyvar>" "class declaration")))))
148 
+     (else (signal-missing-token "<tycon>" "class declaration"))))))
149 
+
150 
+(define (parse-instance-decl interface?)
151 
+ (save-parser-context
152 
+  (let ((contexts (parse-optional-context))
153 
+	(decls '()))
154 
+    (token-case
155 
+     (tycon
156 
+      (let* ((class (class->ast))
157 
+	     (simple (parse-type)))
158 
+	(when (not interface?)
159 
+	   (setf decls (parse-where-decls)))
160 
+	(check-simple simple '#f "instance declaration")
161 
+	(make instance-decl (context contexts) (class class)
162 
+	                    (simple simple) (decls decls))))
163 
+     (else (signal-missing-token "<tycon>" "instance declaration"))))))
prec/README
History View file @ 4e98702
0 164 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+This directory contains the code walker for the scoping and
2 
+precedence parsing phase of the compiler.
prec/prec-parse.scm
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,253 @@
1 
+;;; prec-parse.scm -- do precedence parsing of expressions and patterns
2 
+;;;
3 
+;;; author :  John & Sandra
4 
+;;; date   :  04 Feb 1992
5 
+;;;
6 
+;;;
7 
+
8 
+
9 
+;;; ==================================================================
10 
+;;; Handling for pp-exp-list
11 
+;;; ==================================================================
12 
+
13 
+;;; This function is called during the scope phase after all of the
14 
+;;; exps in a pp-exp-list have already been walked.  Basically, the
15 
+;;; purpose is to turn the original pp-exp-list into something else.
16 
+;;; Look for the section cases first and treat them specially.
17 
+
18 
+;;; Sections are handled by inserting a magic cookie (void) into the
19 
+;;; list where the `missing' operand of the section would be and then
20 
+;;; making sure the cookie stays at the top.
21 
+
22 
+;;; Unary minus needs checking to avoid things like a*-a.
23 
+
24 
+(define (massage-pp-exp-list exps)
25 
+ (let* ((first-term (car exps))
26 
+        (last-term (car (last exps)))
27 
+        (type (cond ((infix-var-or-con? first-term) 'section-l)
28 
+		    ((infix-var-or-con? last-term) 'section-r)
29 
+		    (else 'exp)))
30 
+	(exps1 (cond ((eq? type 'section-l)
31 
+		      (cons (make void) exps))
32 
+		     ((eq? type 'section-r)
33 
+		      (append exps (list (make void))))
34 
+		     (else exps)))
35 
+	(parsed-exp (parse-pp-list '#f exps1)))
36 
+   (if (eq? type 'exp)
37 
+       parsed-exp
38 
+       (if (or (not (app? parsed-exp))
39 
+	       (not (app? (app-fn parsed-exp))))
40 
+	   (begin
41 
+	     (signal-section-precedence-conflict
42 
+	      (if (eq? type 'section-l) first-term last-term))
43 
+	     (make void))
44 
+	   (let ((rhs (app-arg parsed-exp))
45 
+		 (op (app-fn (app-fn parsed-exp)))
46 
+		 (lhs (app-arg (app-fn parsed-exp))))
47 
+	     (if (eq? type 'section-l)
48 
+		 (if (void? lhs)
49 
+		     (make section-l (op op) (exp rhs))
50 
+		     (begin
51 
+		       (signal-section-precedence-conflict first-term)
52 
+		       (make void)))
53 
+		 (if (void? rhs)
54 
+		     (make section-r (op op) (exp lhs))
55 
+		     (begin
56 
+		       (signal-section-precedence-conflict last-term)
57 
+		       (make void)))))))))
58 
+
59 
+
60 
+;;; ==================================================================
61 
+;;; Handling for pp-pat-list
62 
+;;; ==================================================================
63 
+
64 
+;;; In this case, we have to do an explicit walk of the pattern looking
65 
+;;; at all of its subpatterns.
66 
+;;;  ** This is a crock - the scope walker needs fixing.
67 
+
68 
+(define (massage-pattern pat)
69 
+  (cond ((is-type? 'as-pat pat)
70 
+	 (setf (as-pat-pattern pat) (massage-pattern (as-pat-pattern pat)))
71 
+	 pat)
72 
+	((is-type? 'irr-pat pat)
73 
+	 (setf (irr-pat-pattern pat) (massage-pattern (irr-pat-pattern pat)))
74 
+	 pat)
75 
+	((is-type? 'plus-pat pat)
76 
+	 (setf (plus-pat-pattern pat) (massage-pattern (plus-pat-pattern pat)))
77 
+	 pat)
78 
+	((is-type? 'pcon pat)
79 
+	 (when (eq? (pcon-con pat) *undefined-def*)
80 
+	   (setf (pcon-con pat) (lookup-toplevel-name (pcon-name pat))))
81 
+	 (setf (pcon-pats pat) (massage-pattern-list (pcon-pats pat)))
82 
+	 pat)
83 
+	((is-type? 'list-pat pat)
84 
+	 (setf (list-pat-pats pat) (massage-pattern-list (list-pat-pats pat)))
85 
+	 pat)
86 
+	((is-type? 'pp-pat-list pat)
87 
+	 (parse-pp-list '#t (massage-pattern-list (pp-pat-list-pats pat))))
88 
+	(else
89 
+	 pat)))
90 
+
91 
+(define (massage-pattern-list pats)
92 
+  (map (function massage-pattern) pats))
93 
+
94 
+
95 
+;;; ==================================================================
96 
+;;; Shared support
97 
+;;; ==================================================================
98 
+
99 
+;;; This is the main routine.
100 
+
101 
+(define (parse-pp-list pattern? l)
102 
+  (mlet (((stack terms) (push-pp-stack '() l)))
103 
+    (pp-parse-next-term pattern? stack terms)))
104 
+
105 
+(define (pp-parse-next-term pattern? stack terms)
106 
+  (if (null? terms)
107 
+      (reduce-complete-stack pattern? stack)
108 
+      (let ((stack (reduce-stronger-ops pattern? stack (car terms))))
109 
+	(mlet (((stack terms)
110 
+		(push-pp-stack (cons (car terms) stack) (cdr terms))))
111 
+	   (pp-parse-next-term pattern? stack terms)))))
112 
+
113 
+(define (reduce-complete-stack pattern? stack)
114 
+  (if (pp-stack-op-empty? stack)
115 
+      (car stack)
116 
+      (reduce-complete-stack pattern? (reduce-pp-stack pattern? stack))))
117 
+
118 
+(define (reduce-pp-stack pattern? stack)
119 
+  (let ((term (car stack))
120 
+	(op (cadr stack)))
121 
+    (if pattern?
122 
+	(cond ((pp-pat-plus? op)
123 
+	       (let ((lhs (caddr stack)))
124 
+		 (cond ((or (not (const-pat? term))
125 
+			    (and (not (var-pat? lhs))
126 
+				 (not (wildcard-pat? lhs))))
127 
+			(signal-plus-precedence-conflict term)
128 
+			(cddr stack))
129 
+		       (else
130 
+			(cons (make plus-pat (pattern lhs)
131 
+				             (k (integer-const-value
132 
+						 (const-pat-value term))))
133 
+			      (cdddr stack))))))
134 
+	      ((pp-pat-negated? op)
135 
+	       (cond ((const-pat? term)
136 
+		      (let ((v (const-pat-value term)))
137 
+			(if (integer-const? v)
138 
+			    (setf (integer-const-value v)
139 
+				  (- (integer-const-value v)))
140 
+			    (setf (float-const-numerator v)
141 
+				  (- (float-const-numerator v)))))
142 
+		      (cons term (cddr stack)))
143 
+		     (else
144 
+		      (signal-minus-precedence-conflict term)
145 
+		      (cons term (cddr stack)))))
146 
+	      (else
147 
+	       (setf (pcon-pats op) (list (caddr stack) term))
148 
+	       (cons op (cdddr stack))))
149 
+	(cond ((negate? op)
150 
+	       (cons (**app (**var/def (core-symbol "negate")) term)
151 
+		     (cddr stack)))
152 
+	      (else
153 
+	       (cons (**app op (caddr stack) term) (cdddr stack)))))))
154 
+
155 
+(define (pp-stack-op-empty? stack)
156 
+  (null? (cdr stack)))
157 
+
158 
+(define (top-stack-op stack)
159 
+  (cadr stack))
160 
+
161 
+(define (push-pp-stack stack terms)
162 
+  (let ((term (car terms)))
163 
+    (if (or (negate? term) (pp-pat-negated? term))
164 
+	(begin
165 
+	  (when (and stack (stronger-op? (car stack) term))
166 
+	      (unary-minus-prec-conflict term))
167 
+	  (push-pp-stack (cons term stack) (cdr terms)))
168 
+	(values (cons term stack) (cdr terms)))))
169 
+
170 
+(define (reduce-stronger-ops pattern? stack op)
171 
+  (cond ((pp-stack-op-empty? stack) stack)
172 
+	((stronger-op? (top-stack-op stack) op)
173 
+	 (reduce-stronger-ops pattern? (reduce-pp-stack pattern? stack) op))
174 
+	(else stack)))
175 
+
176 
+(define (stronger-op? op1 op2)
177 
+  (let ((fixity1 (get-op-fixity op1))
178 
+	(fixity2 (get-op-fixity op2)))
179 
+    (cond ((> (fixity-precedence fixity1) (fixity-precedence fixity2))
180 
+	   '#t)
181 
+	  ((< (fixity-precedence fixity1) (fixity-precedence fixity2))
182 
+	   '#f)
183 
+	  (else
184 
+	   (let ((a1 (fixity-associativity fixity1))
185 
+		 (a2 (fixity-associativity fixity2)))
186 
+	     (if (eq? a1 a2)
187 
+		 (cond ((eq? a1 'l)
188 
+			'#t)
189 
+		       ((eq? a1 'r)
190 
+			'#f)
191 
+		       (else
192 
+			(signal-precedence-conflict op1 op2)
193 
+			'#t))
194 
+		 (begin
195 
+		   (signal-precedence-conflict op1 op2)
196 
+		   '#t))))
197 
+	  )))
198 
+
199 
+(define (get-op-fixity op)
200 
+  (cond ((var-ref? op)
201 
+	 (pp-get-var-fixity (var-ref-var op)))
202 
+	((con-ref? op)
203 
+	 (pp-get-con-fixity (con-ref-con op)))
204 
+	((pcon? op)
205 
+	 (pp-get-con-fixity (pcon-con op)))
206 
+	((or (negate? op) (pp-pat-negated? op))
207 
+	 (pp-get-var-fixity (core-symbol "-")))
208 
+	((pp-pat-plus? op)
209 
+	 (pp-get-var-fixity (core-symbol "+")))
210 
+	(else
211 
+	 (error "Bad op ~s in pp-parse." op))))
212 
+
213 
+(define (pp-get-var-fixity def)
214 
+  (if (eq? (var-fixity def) '#f)
215 
+      default-fixity
216 
+      (var-fixity def)))
217 
+
218 
+(define (pp-get-con-fixity def)
219 
+  (if (eq? (con-fixity def) '#f)
220 
+      default-fixity
221 
+      (con-fixity def)))
222 
+
223 
+;;; Error handlers
224 
+
225 
+(define (signal-section-precedence-conflict op)
226 
+  (phase-error 'section-precedence-conflict
227 
+    "Operators in section body have lower precedence than section operator ~A."
228 
+   op))
229 
+
230 
+(define (signal-precedence-conflict op1 op2)
231 
+  (phase-error 'precedence-conflict
232 
+    "The operators ~s and ~s appear consecutively, but they have the same~%~
233 
+     precedence and are not either both left or both right associative.~%
234 
+     You must add parentheses to avoid a precedence conflict."
235 
+    op1 op2))
236 
+
237 
+(define (signal-plus-precedence-conflict term)
238 
+  (phase-error 'plus-precedence-conflict
239 
+    "You need to put parentheses around the plus-pattern ~a~%~
240 
+     to avoid a precedence conflict."
241 
+    term))
242 
+
243 
+(define (signal-minus-precedence-conflict arg)
244 
+  (phase-error 'minus-precedence-conflict
245 
+    "You need to put parentheses around the negative literal ~a~%~
246 
+     to avoid a precedence conflict."
247 
+    arg))
248 
+
249 
+(define (unary-minus-prec-conflict arg)
250 
+  (recoverable-error 'minus-precedence-conflict
251 
+     "Operator ~A too strong for unary minus - add parens please!~%"
252 
+     arg))
253 
+
prec/prec.scm
History View file @ 4e98702
0 254 
new file mode 100644
... ... 
@@ -0,0 +1,18 @@
1 
+;;; prec.scm -- module definition for scoping/precedence-parsing phase
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  13 Feb 1992
5 
+;;;
6 
+
7 
+
8 
+(define-compilation-unit prec
9 
+  (source-filename "$Y2/prec/")
10 
+  (require ast haskell-utils)
11 
+  (unit scope
12 
+	(source-filename "scope.scm"))
13 
+  (unit prec-parse
14 
+	(source-filename "prec-parse.scm")))
15 
+
16 
+
17 
+
18 
+
prec/scope.scm
History View file @ 4e98702
0 19 
new file mode 100644
... ... 
@@ -0,0 +1,367 @@
1 
+;;; scope.scm -- variable scoping and precedence parsing phase
2 
+;;;
3 
+;;; author :  John & Sandra
4 
+;;; date   :  11 Feb 1992
5 
+;;;
6 
+;;;
7 
+
8 
+
9 
+;;;===================================================================
10 
+;;; Basic support
11 
+;;;===================================================================
12 
+
13 
+(define (scope-modules modules)
14 
+  (walk-modules modules
15 
+    (lambda ()
16 
+      (setf (module-decls *module*) (scope-ast-decls (module-decls *module*)))
17 
+      (dolist (a (module-annotations *module*))
18 
+;;; This is currently bogus since it assumes only vars are annotated.
19 
+	 (when (annotation-decl? a)
20 
+	   (dolist (n (annotation-decl-names a))
21 
+	      (let ((v (table-entry *symbol-table* n)))
22 
+		(when (or (eq? v '#f) (not (var? v)))
23 
+		  (fatal-error 'unknown-annotation-name
24 
+			       "~A: not a var in annotation decl~%" n))
25 
+		(when (not (eq? (def-module v) *module-name*))
26 
+		  (fatal-error 'non-local-name-in-annotation
27 
+			       "~A: not a local var in annotation decl~%" n))
28 
+		(setf (var-annotations v)
29 
+		      (append (var-annotations v)
30 
+			      (annotation-decl-annotations a))))))))))
31 
+
32 
+;;; Define the basic walker and some helper functions.
33 
+
34 
+(define-walker scope ast-td-scope-walker)
35 
+
36 
+(define (scope-ast-1 x env)
37 
+;  (call-walker scope x env))
38 
+  (remember-context x
39 
+    (call-walker scope x env)))
40 
+
41 
+
42 
+(define (scope-ast/list l env)
43 
+  (scope-ast/list-aux l env)
44 
+  l)
45 
+
46 
+(define (scope-ast/list-aux l env)
47 
+  (when (not (null? l))
48 
+    (setf (car l) (scope-ast-1 (car l) env))
49 
+    (scope-ast/list-aux (cdr l) env)))
50 
+
51 
+;;; This filters out signdecls from decl lists.  These declarations are moved
52 
+;;; into the var definitions.
53 
+
54 
+(define (scope-ast/decl-list l env)
55 
+  (if (null? l)
56 
+      '()
57 
+      (let ((x (scope-ast-1 (car l) env))
58 
+	    (rest (scope-ast/decl-list (cdr l) env)))
59 
+	(if (or (annotation-decls? x)
60 
+		(and (signdecl? x)
61 
+		     (not (eq? (module-type *module*) 'interface))))
62 
+	    rest
63 
+	    (begin
64 
+	      (setf (car l) x)
65 
+	      (setf (cdr l) rest)
66 
+	      l)))))
67 
+
68 
+;;; This is the main entry point.  It is called by the driver
69 
+;;; on each top-level decl in the module.
70 
+
71 
+(define (scope-ast-decls x)
72 
+  (let ((result  (scope-ast/decl-list x '())))
73 
+;    (pprint result)   ;*** debug
74 
+    result))
75 
+
76 
+
77 
+;;; All top-level names are entered in the *symbol-table* hash table.
78 
+;;; This is done by the import/export phase of the compiler before
79 
+;;; we get here.
80 
+;;; The env is a list of a-lists that associates locally-defined names with
81 
+;;; their definitions.  Each nested a-list corresponds to a "level" or
82 
+;;; scope.
83 
+;;; *** If many variables are being added in each scope, it might be
84 
+;;; *** better to use a table instead of an alist to represent each contour.
85 
+
86 
+(define (lookup-name name env)
87 
+  (if (null? env)
88 
+      (lookup-toplevel-name name)
89 
+      (let ((info  (assq name (car env))))
90 
+	(if info
91 
+	    (cdr info)
92 
+	    (lookup-name name (cdr env))))))
93 
+
94 
+
95 
+;;; Some kinds of names (e.g. type definitions) appear only at top-level,
96 
+;;; so use this to look for them directly.
97 
+
98 
+(define (lookup-toplevel-name name)
99 
+  (or (resolve-toplevel-name name)
100 
+      (begin
101 
+        (signal-undefined-symbol name)
102 
+	*undefined-def*)))
103 
+
104 
+
105 
+;;; Some kinds of lookups (e.g., matching a signature declaration)
106 
+;;; require that the name be defined in the current scope and not
107 
+;;; an outer one.  Use this function.
108 
+
109 
+(define (lookup-local-name name env)
110 
+  (if (null? env)
111 
+      (lookup-toplevel-name name)
112 
+      (let ((info  (assq name (car env))))
113 
+	(if info
114 
+	    (cdr info)
115 
+	    (begin
116 
+	      (signal-undefined-local-symbol name)
117 
+	      *undefined-def*)))))
118 
+
119 
+
120 
+;;; Add local declarations to the environment, returning a new env.
121 
+;;; Do not actually walk the local declarations here.
122 
+
123 
+(define *scope-info* '())
124 
+
125 
+(define (add-local-declarations decls env)
126 
+  (if (null? decls)
127 
+      env
128 
+      (let ((contour   '()))
129 
+	(dolist (d decls)
130 
+	  (if (is-type? 'valdef d)
131 
+	      (setf contour
132 
+		    (add-bindings (collect-pattern-vars (valdef-lhs d))
133 
+				  contour))))
134 
+	(cons contour env))))
135 
+
136 
+
137 
+;;; Similar, but for adding lambda and function argument bindings to the
138 
+;;; environment.
139 
+
140 
+(define (add-pattern-variables patterns env)
141 
+  (if (null? patterns)
142 
+      env
143 
+      (let ((contour   '()))
144 
+	(dolist (p patterns)
145 
+	  (setf contour (add-bindings (collect-pattern-vars p) contour)))
146 
+	(cons contour env))))
147 
+
148 
+
149 
+;;; Given a list of var-refs, create defs for them and add them to
150 
+;;; the local environment.
151 
+;;; Also check to see that there are no duplicates.
152 
+
153 
+(define (add-bindings var-refs contour)
154 
+  (dolist (v var-refs)
155 
+   (when (eq? (var-ref-var v) *undefined-def*)
156 
+    (let* ((name     (var-ref-name v))
157 
+	   (def      (create-local-definition name)))
158 
+      (setf (var-ref-var v) def)
159 
+      (if (assq name contour)
160 
+	  (signal-multiple-bindings name)
161 
+	  (push (cons name def) contour)))))
162 
+  contour)
163 
+
164 
+
165 
+;;; Error signalling utilities.
166 
+
167 
+(define (signal-undefined-local-symbol name)
168 
+  (phase-error 'undefined-local-symbol
169 
+    "The name ~a has no definition in the current scope."
170 
+    name))
171 
+
172 
+(define (signal-multiple-signatures name)
173 
+  (phase-error 'multiple-signatures
174 
+    "There are multiple signatures for the name ~a."
175 
+    name))
176 
+
177 
+(define (signal-multiple-bindings name)
178 
+  (phase-error 'multiple-bindings
179 
+    "The name ~a appears more than once in a function or pattern binding."
180 
+    name))
181 
+
182 
+
183 
+
184 
+;;;===================================================================
185 
+;;; Default traversal methods
186 
+;;;===================================================================
187 
+
188 
+
189 
+(define-local-syntax (make-scope-code slot type)
190 
+  (let ((stype  (sd-type slot))
191 
+	(sname  (sd-name slot)))
192 
+    (cond ((and (symbol? stype)
193 
+		(or (eq? stype 'exp)
194 
+		    (subtype? stype 'exp)))
195 
+	   `(setf (struct-slot ',type ',sname object)
196 
+		  (scope-ast-1 (struct-slot ',type ',sname object) env)))
197 
+	  ((and (pair? stype)
198 
+		(eq? (car stype) 'list)
199 
+		(symbol? (cadr stype))
200 
+		(or (eq? (cadr stype) 'exp)
201 
+		    (subtype? (cadr stype) 'exp)))
202 
+	   `(setf (struct-slot ',type ',sname object)
203 
+		  (scope-ast/list (struct-slot ',type ',sname object) env)))
204 
+	  (else
205 
+;	   (format '#t "Scope: skipping slot ~A in ~A~%"
206 
+;		   (sd-name slot)
207 
+;		   type)
208 
+	   '#f))))
209 
+
210 
+
211 
+(define-modify-walker-methods scope
212 
+  (guarded-rhs  ; exp slots
213 
+   if           ; exp slots
214 
+   app          ; exp slots
215 
+   integer-const float-const char-const string-const  ; no slots
216 
+   list-exp     ; (list exp) slot
217 
+   sequence sequence-to sequence-then sequence-then-to ; exp slots
218 
+   section-l section-r ; exp slots
219 
+   omitted-guard overloaded-var-ref ; no slots
220 
+   negate ; no slots
221 
+   sel
222 
+   prim-definition
223 
+   con-number cast
224 
+   )
225 
+  (object env)
226 
+  make-scope-code)
227 
+
228 
+
229 
+;;;===================================================================
230 
+;;; valdef-structs
231 
+;;;===================================================================
232 
+
233 
+
234 
+;;; Signature declarations must appear at the same level as the names
235 
+;;; they apply to.  There must not be more than one signature declaration
236 
+;;; applying to a given name.
237 
+
238 
+(define-walker-method scope signdecl (object env)
239 
+  (let ((signature  (signdecl-signature object)))
240 
+    (resolve-signature signature)
241 
+    (let ((gtype (ast->gtype (signature-context signature)
242 
+			     (signature-type signature))))
243 
+      (dolist (v (signdecl-vars object))
244 
+	(when (eq? (var-ref-var v) *undefined-def*)
245 
+	      (setf (var-ref-var v)
246 
+		    (lookup-local-name (var-ref-name v) env)))
247 
+	(let ((def  (var-ref-var v)))
248 
+	  (when (not (eq? def *undefined-def*))
249 
+	    ;; The lookup-local-name may fail if there is a program error.
250 
+	    ;; In that case, skip this.
251 
+	    (if (var-signature def)
252 
+		(signal-multiple-signatures (var-ref-name v))
253 
+		(setf (var-signature def) gtype))))))
254 
+    object))
255 
+
256 
+;;; This attaches annotations to locally defined vars in the same
257 
+;;; manner as signdecl annotations.
258 
+
259 
+(define-walker-method scope annotation-decls (object env)
260 
+  (let ((anns (annotation-decls-annotations object)))
261 
+    (dolist (a anns)
262 
+      (cond ((annotation-value? a)
263 
+	     (recoverable-error 'unknown-annotation "Unknown annotation: ~A" a))
264 
+	    ((annotation-decl? a)
265 
+	     (dolist (v (annotation-decl-names a))
266 
+	       (let ((name (lookup-local-name v env)))
267 
+		 (when (not (eq? name *undefined-def*))
268 
+		   (setf (var-annotations name)
269 
+			 (append (var-annotations name)
270 
+			      (annotation-decl-annotations a))))))))))
271 
+  object)
272 
+
273 
+(define-walker-method scope exp-sign (object env)
274 
+  (resolve-signature (exp-sign-signature object))
275 
+  (setf (exp-sign-exp object) (scope-ast-1 (exp-sign-exp object) env))
276 
+  object)
277 
+
278 
+;;; By the time we get to walking a valdef, all the variables it
279 
+;;; declares have been entered into the environment.  All we need to
280 
+;;; do is massage the pattern and recursively walk the definitions.
281 
+
282 
+(define-walker-method scope valdef (object env)
283 
+  (setf (valdef-module object) *module-name*)
284 
+  (setf (valdef-lhs object) (massage-pattern (valdef-lhs object)))
285 
+  (setf (valdef-definitions object)
286 
+	(scope-ast/list (valdef-definitions object) env))
287 
+  object)
288 
+
289 
+
290 
+;;; For a single-fun-def, do the where-decls first, and then walk the
291 
+;;; rhs in an env that includes both the where-decls and the args.
292 
+
293 
+(define-walker-method scope single-fun-def (object env)
294 
+  (setf env (add-pattern-variables (single-fun-def-args object) env))
295 
+  (setf env (add-local-declarations (single-fun-def-where-decls object) env))
296 
+  (setf (single-fun-def-where-decls object)
297 
+	(scope-ast/decl-list (single-fun-def-where-decls object) env))
298 
+  (setf (single-fun-def-args object)
299 
+	(massage-pattern-list (single-fun-def-args object)))
300 
+  (setf (single-fun-def-rhs-list object)
301 
+	(scope-ast/list (single-fun-def-rhs-list object) env))
302 
+  object)
303 
+
304 
+
305 
+;;;===================================================================
306 
+;;; exp-structs
307 
+;;;===================================================================
308 
+
309 
+(define-walker-method scope lambda (object env)
310 
+  (setf env (add-pattern-variables (lambda-pats object) env))
311 
+  (setf (lambda-pats object) (massage-pattern-list (lambda-pats object)))
312 
+  (setf (lambda-body object) (scope-ast-1 (lambda-body object) env))
313 
+  object)
314 
+
315 
+(define-walker-method scope let (object env)
316 
+  (setf env (add-local-declarations (let-decls object) env))
317 
+  (setf (let-decls object) (scope-ast/decl-list (let-decls object) env))
318 
+  (setf (let-body object) (scope-ast-1 (let-body object) env))
319 
+  object)
320 
+
321 
+
322 
+;;; Case alts are treated very much like single-fun-defs.
323 
+
324 
+(define-walker-method scope case (object env)
325 
+  (setf (case-exp object) (scope-ast-1 (case-exp object) env))
326 
+  (dolist (a (case-alts object))
327 
+    (let ((env  (add-pattern-variables (list (alt-pat a)) env)))
328 
+      (setf env (add-local-declarations (alt-where-decls a) env))
329 
+      (setf (alt-where-decls a)
330 
+	    (scope-ast/decl-list (alt-where-decls a) env))
331 
+      (setf (alt-pat a) (massage-pattern (alt-pat a)))
332 
+      (setf (alt-rhs-list a)
333 
+	    (scope-ast/list (alt-rhs-list a) env))))
334 
+  object)
335 
+
336 
+
337 
+(define-walker-method scope var-ref (object env)
338 
+  (when (eq? (var-ref-var object) *undefined-def*)
339 
+	(setf (var-ref-var object)
340 
+	      (lookup-name (var-ref-name object) env)))
341 
+  object)
342 
+
343 
+(define-walker-method scope con-ref (object env)
344 
+  (declare (ignore env))
345 
+  (when (eq? (con-ref-con object) *undefined-def*)
346 
+	(setf (con-ref-con object)
347 
+	      (lookup-toplevel-name (con-ref-name object))))
348 
+  object)
349 
+
350 
+(define-walker-method scope list-comp (object env)
351 
+  (dolist (q (list-comp-quals object))
352 
+    (cond ((is-type? 'qual-generator q)
353 
+	   (setf (qual-generator-exp q)
354 
+		 (scope-ast-1 (qual-generator-exp q) env))
355 
+	   (setf env
356 
+		 (add-pattern-variables (list (qual-generator-pat q)) env))
357 
+	   (setf (qual-generator-pat q)
358 
+		 (massage-pattern (qual-generator-pat q))))
359 
+	  ((is-type? 'qual-filter q)
360 
+	   (setf (qual-filter-exp q)
361 
+		 (scope-ast-1 (qual-filter-exp q) env)))))
362 
+  (setf (list-comp-exp object) (scope-ast-1 (list-comp-exp object) env))
363 
+  object)
364 
+
365 
+(define-walker-method scope pp-exp-list (object env)
366 
+  (massage-pp-exp-list (scope-ast/list (pp-exp-list-exps object) env)))
367 
+
printers/README
History View file @ 4e98702
0 368 
new file mode 100644
... ... 
@@ -0,0 +1,19 @@
1 
+This directory contains print routines for the structures defined in
2 
+the ast/ directory.
3 
+
4 
+The global *print-structure* controls printing of objects in the
5 
+structure system.  Values are:
6 
+  haskell  -- Prints haskell format expressions from ast
7 
+  struct   -- Prints the raw structs (with circularity check)
8 
+  top      -- Prints top level only of the struct
9 
+
10 
+The file defs.scm has the basic hooks to the printer mechanism.  The
11 
+idea is that when *print-structure* is 'haskell, the print function stored
12 
+in the type descriptor will get used.  If there isn't a print function,
13 
+or if *print-structure* is false, then the thing will print out in
14 
+some generic way that's good for debugging purposes.
15 
+
16 
+The macro define-printer is used to associate a print function with a
17 
+structure type.  Since these can be defined on the fly, the print
18 
+dispatching routine has to look up the inheritance chain of type
19 
+descriptors looking for the first inherited type that has a printer.
printers/print-exps.scm
History View file @ 4e98702
0 20 
new file mode 100644
... ... 
@@ -0,0 +1,410 @@
1 
+;;; print-exps.scm -- print expression AST structures
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  10 Jan 1992
5 
+;;;
6 
+;;; This file corresponds to ast/exp-structs.scm.
7 
+;;;
8 
+
9 
+(define-ast-printer lambda (object xp)
10 
+  (with-ast-block (xp)
11 
+    (write-string "\\ " xp)
12 
+    (write-delimited-list
13 
+      (lambda-pats object) xp (function write-apat) "" "" "")
14 
+    (write-string " ->" xp)
15 
+    (write-whitespace xp)
16 
+    (write (lambda-body object) xp)))
17 
+
18 
+(define-ast-printer let (object xp)
19 
+  (write-lets-body "let " (let-decls object) (let-body object) xp))
20 
+
21 
+(define (write-lets-body let-name decls body xp)
22 
+  (pprint-logical-block (xp '() "" "")  ; no extra indentation
23 
+    (write-string let-name xp)
24 
+    (write-layout-rule (remove-recursive-grouping decls) xp (function write))
25 
+    (write-whitespace xp)
26 
+    (write-string "in " xp)
27 
+    (write body xp)))
28 
+
29 
+(define-ast-printer if (object xp)
30 
+  (with-ast-block (xp)
31 
+    (write-string "if " xp)
32 
+    (write (if-test-exp object) xp)
33 
+    (write-whitespace xp)
34 
+    (with-ast-block (xp)
35 
+      (write-string "then" xp)
36 
+      (write-whitespace xp)
37 
+      (write (if-then-exp object) xp))
38 
+    (write-whitespace xp)
39 
+    (with-ast-block (xp)
40 
+      (write-string "else" xp)
41 
+      (write-whitespace xp)
42 
+      (write (if-else-exp object) xp))))
43 
+
44 
+(define-ast-printer case (object xp)
45 
+  (with-ast-block (xp)
46 
+    (write-string "case " xp)
47 
+    (write (case-exp object) xp)
48 
+    (write-string " of" xp)
49 
+    (write-whitespace xp)
50 
+    (write-layout-rule (case-alts object) xp (function write))))
51 
+
52 
+(define-ast-printer alt (object xp)
53 
+  (with-ast-block (xp)
54 
+    (write (alt-pat object) xp)
55 
+    (dolist (r (alt-rhs-list object))
56 
+      (write-whitespace xp)
57 
+      (unless (is-type? 'omitted-guard (guarded-rhs-guard r))
58 
+	(write-string "| " xp)
59 
+	(write (guarded-rhs-guard r) xp))
60 
+      (write-string " -> " xp)
61 
+      (write (guarded-rhs-rhs r) xp))
62 
+    (write-wheredecls (alt-where-decls object) xp)))
63 
+
64 
+(define-ast-printer exp-sign (object xp)
65 
+  (with-ast-block (xp)
66 
+    (write (exp-sign-exp object) xp)
67 
+    (write-string " ::" xp)
68 
+    (write-whitespace xp)
69 
+    (write (exp-sign-signature object) xp)))
70 
+
71 
+;;; Have to look for application of special-case constructors before
72 
+;;; doing the normal prefix/infix cases.
73 
+
74 
+(define-ast-printer app (object xp)
75 
+  (let* ((fn          (app-fn object))
76 
+	 (arg         (app-arg object)))
77 
+    (multiple-value-bind (con args) (extract-constructor fn (list arg))
78 
+      (cond ;; ((eq? con (core-symbol "UnitConstructor"))
79 
+	    ;;  *** Does this ever happen?
80 
+	    ;;  (write-string "()" xp))
81 
+	    ((and con (is-tuple-constructor? con))
82 
+	     (write-commaized-list args xp))
83 
+	    (else
84 
+	     (multiple-value-bind (fixity op arg1) (extract-infix-operator fn)
85 
+	       (if fixity
86 
+		   (write-infix-application fixity op arg1 arg xp)
87 
+		   (write-prefix-application fn arg xp))))
88 
+	    ))))
89 
+
90 
+
91 
+(define (write-infix-application fixity op arg1 arg2 xp)
92 
+  (let ((precedence      (fixity-precedence fixity))
93 
+	(associativity   (fixity-associativity fixity)))
94 
+    (with-ast-block (xp)
95 
+      (write-exp-with-precedence
96 
+        arg1 (1+ precedence) (if (eq? associativity 'l) 'l '#f) xp)
97 
+      (write-whitespace xp)
98 
+      (write op xp)
99 
+      (write-whitespace xp)
100 
+      (write-exp-with-precedence
101 
+        arg2 (1+ precedence) (if (eq? associativity 'r) 'r '#f) xp))))
102 
+
103 
+(define (write-prefix-application fn arg xp)
104 
+  (with-ast-block (xp)
105 
+    (write-exp-with-precedence fn 10 '#f xp)
106 
+    (write-whitespace xp)
107 
+    (write-aexp arg xp)))
108 
+
109 
+
110 
+;;; Write an expression with at least the given precedence.  If the
111 
+;;; actual precedence is lower, put parens around it.
112 
+
113 
+(define *print-exp-parens* '#f)
114 
+
115 
+(define (write-exp-with-precedence exp precedence associativity xp)
116 
+  (if *print-exp-parens*
117 
+      (write-aexp exp xp)
118 
+      (if (< (precedence-of-exp exp associativity) precedence)
119 
+	  (begin
120 
+	    (write-char #\( xp)
121 
+	    (write exp xp)
122 
+	    (write-char #\) xp))
123 
+	  (write exp xp))))
124 
+
125 
+
126 
+;;; Similar to the above: write an aexp.
127 
+
128 
+(define *print-original-code* '#t)
129 
+
130 
+(define (write-aexp object xp)
131 
+  (if (is-type? 'save-old-exp object)
132 
+      (write-aexp (if *print-original-code*
133 
+		      (save-old-exp-old-exp object)
134 
+		      (save-old-exp-new-exp object))
135 
+		  xp)
136 
+      (if (or (is-type? 'aexp object)
137 
+	      (pp-exp-list-section? object)
138 
+	      (is-type? 'negate object))
139 
+	  (write object xp)
140 
+	  (begin
141 
+	    (write-char #\( xp)
142 
+	    (write object xp)
143 
+	    (write-char #\) xp)))))
144 
+
145 
+
146 
+;;; The infix? slot on var-ref and con-ref structs refers to whether
147 
+;;; the thing appears as an infix operator or not, not whether the name
148 
+;;; has operator or identifier syntax.
149 
+
150 
+(define-ast-printer var-ref (object xp)
151 
+  (let ((name  (var-ref-name object)))
152 
+    (if (var-ref-infix? object)
153 
+	(write-varop name xp)
154 
+	(write-varid name xp))))
155 
+
156 
+(define-ast-printer con-ref (object xp)
157 
+  (if (eq? (con-ref-con object) (core-symbol "UnitConstructor"))
158 
+      (write-string "()" xp)
159 
+      (let ((name  (con-ref-name object)))
160 
+	(if (con-ref-infix? object)
161 
+	    (write-conop name xp)
162 
+	    (write-conid name xp)))))
163 
+
164 
+
165 
+(define-ast-printer integer-const (object xp)
166 
+  (write (integer-const-value object) xp))
167 
+
168 
+(define-ast-printer float-const (object xp)
169 
+  (let* ((numerator   (float-const-numerator object))
170 
+	 (denominator (float-const-denominator object))
171 
+	 (exponent    (float-const-exponent object))
172 
+	 (whole       (quotient numerator denominator))
173 
+	 (fraction    (remainder numerator denominator)))
174 
+    (write whole xp)
175 
+    (write-char #\. xp)
176 
+    (write-precision-integer fraction denominator xp)
177 
+    (unless (zero? exponent)
178 
+      (write-char #\E xp)
179 
+      (write exponent xp))))
180 
+
181 
+(define (write-precision-integer fraction denominator xp)
182 
+  (cond ((eqv? denominator 1)
183 
+	 ; no fraction
184 
+	 )
185 
+	((eqv? denominator 10)
186 
+	 (write-digit fraction xp))
187 
+	(else
188 
+	 (write-digit (quotient fraction 10) xp)
189 
+	 (write-precision-integer (remainder fraction 10)
190 
+				  (quotient denominator 10)
191 
+				  xp))
192 
+	))
193 
+
194 
+(define (write-digit n xp)
195 
+  (write-char (string-ref "0123456789" n) xp))
196 
+
197 
+
198 
+;;; Character and string printers need to handle weird escapes.
199 
+;;; Fortunately we can just choose one canonical style for printing
200 
+;;; unprintable characters.
201 
+
202 
+(define-ast-printer char-const (object xp)
203 
+  (write-char #\' xp)
204 
+  (write-char-literal (char-const-value object) xp #\')
205 
+  (write-char #\' xp))
206 
+
207 
+(define-ast-printer string-const (object xp)
208 
+  (write-char #\" xp)
209 
+  (let ((s  (string-const-value object)))
210 
+    (dotimes (i (string-length s))
211 
+      (write-char-literal (string-ref s i) xp #\")))
212 
+  (write-char #\" xp))
213 
+
214 
+(define (write-char-literal c xp special)
215 
+  (cond ((eqv? c special)
216 
+	 (write-char #\\ xp)
217 
+	 (write c xp))
218 
+	((eqv? c #\newline)
219 
+	 (write-char #\\ xp)
220 
+	 (write-char #\n xp))
221 
+	(else
222 
+	 (let ((code  (char->integer c)))
223 
+	   (if (and (>= code 32) (< code 128))
224 
+	       ;; printing ascii characters
225 
+	       (write-char c xp)
226 
+	       ;; "control" characters print in \ddd notation
227 
+	       (begin
228 
+		 (write-char #\\ xp)
229 
+		 (write code xp)))))
230 
+	))
231 
+
232 
+(define-ast-printer list-exp (object xp)
233 
+  (write-delimited-list
234 
+    (list-exp-exps object) xp (function write) "," "[" "]"))
235 
+
236 
+(define-ast-printer sequence (object xp)
237 
+  (with-ast-block (xp)
238 
+    (write-string "[" xp)
239 
+    (write (sequence-from object) xp)
240 
+    (write-string "..]" xp)))
241 
+
242 
+(define-ast-printer sequence-to (object xp)
243 
+  (with-ast-block (xp)
244 
+    (write-string "[" xp)
245 
+    (write (sequence-to-from object) xp)
246 
+    (write-string " .." xp)
247 
+    (write-whitespace xp)
248 
+    (write (sequence-to-to object) xp)
249 
+    (write-string "]" xp)))
250 
+
251 
+(define-ast-printer sequence-then (object xp)
252 
+  (with-ast-block (xp)
253 
+    (write-string "[" xp)
254 
+    (write (sequence-then-from object) xp)
255 
+    (write-string "," xp)
256 
+    (write-whitespace xp)
257 
+    (write (sequence-then-then object) xp)
258 
+    (write-string "..]" xp)))
259 
+
260 
+(define-ast-printer sequence-then-to (object xp)
261 
+  (with-ast-block (xp)
262 
+    (write-string "[" xp)
263 
+    (write (sequence-then-to-from object) xp)
264 
+    (write-string "," xp)
265 
+    (write-whitespace xp)
266 
+    (write (sequence-then-to-then object) xp)
267 
+    (write-string " .." xp)
268 
+    (write-whitespace xp)
269 
+    (write (sequence-then-to-to object) xp)
270 
+    (write-string "]" xp)))
271 
+
272 
+(define-ast-printer list-comp (object xp)
273 
+  (with-ast-block (xp)
274 
+    (write-string "[" xp)
275 
+    (write (list-comp-exp object) xp)
276 
+    (write-string " |" xp)
277 
+    (write-whitespace xp)
278 
+    (write-delimited-list
279 
+      (list-comp-quals object) xp (function write) "," "" "")
280 
+    (write-string "]" xp)))
281 
+
282 
+
283 
+(define-ast-printer section-l (object xp)
284 
+  (let* ((exp           (section-l-exp object))
285 
+	 (op            (section-l-op object))
286 
+	 (fixity        (operator-fixity op))
287 
+	 (precedence    (fixity-precedence fixity)))
288 
+    (with-ast-block (xp)
289 
+      (write-string "(" xp)
290 
+      (write op xp)
291 
+      (write-whitespace xp)
292 
+      (write-exp-with-precedence exp (1+ precedence) '#f xp)
293 
+      (write-string ")" xp))))
294 
+
295 
+(define-ast-printer section-r (object xp)
296 
+  (let* ((exp           (section-r-exp object))
297 
+	 (op            (section-r-op object))
298 
+	 (fixity        (operator-fixity op))
299 
+	 (precedence    (fixity-precedence fixity)))
300 
+    (with-ast-block (xp)
301 
+      (write-string "(" xp)
302 
+      (write-exp-with-precedence exp (1+ precedence) '#f xp)
303 
+      (write-whitespace xp)
304 
+      (write op xp)
305 
+      (write-string ")" xp))))
306 
+
307 
+(define-ast-printer qual-generator (object xp)
308 
+  (with-ast-block (xp)
309 
+    (write (qual-generator-pat object) xp)
310 
+    (write-string " <-" xp)
311 
+    (write-whitespace xp)
312 
+    (write (qual-generator-exp object) xp)))
313 
+
314 
+(define-ast-printer qual-filter (object xp)
315 
+  (write (qual-filter-exp object) xp))
316 
+
317 
+
318 
+;;; A pp-exp-list with an op as the first or last element is really
319 
+;;; a section.  These always get parens and are treated like aexps.
320 
+;;; Other pp-exp-lists are treated as exps with precedence 0.
321 
+;;; Bleah...  Seems like the parser ought to recognize this up front....
322 
+;;;                                                     Yeah but I'm lazy ...
323 
+
324 
+(define-ast-printer pp-exp-list (object xp)
325 
+  (let ((section?  (pp-exp-list-section? object)))
326 
+    (if section? (write-char #\( xp))
327 
+    (write-delimited-list
328 
+      (pp-exp-list-exps object) xp (function write-aexp) "" "" "")
329 
+    (if section? (write-char #\) xp))))
330 
+
331 
+(define-ast-printer negate (object xp)
332 
+  (declare (ignore object))
333 
+  (write-string "-" xp))
334 
+
335 
+(define-ast-printer def (object xp)
336 
+  (write-string (symbol->string (def-name object)) xp))
337 
+
338 
+(define-ast-printer con (object xp)
339 
+  (write-string (remove-con-prefix (symbol->string (def-name object))) xp))
340 
+
341 
+(define-ast-printer con-number (object xp)
342 
+  (with-ast-block (xp)
343 
+    (write-string "con-number/" xp)
344 
+    (write (con-number-type object) xp)
345 
+    (write-whitespace xp)
346 
+    (write-aexp (con-number-value object) xp)))
347 
+
348 
+(define-ast-printer sel (object xp)
349 
+  (with-ast-block (xp)
350 
+    (write-string "sel/" xp)
351 
+    (write (sel-constructor object) xp)
352 
+    (write-whitespace xp)
353 
+    (write (sel-slot object) xp)
354 
+    (write-whitespace xp)
355 
+    (write-aexp (sel-value object) xp)))
356 
+
357 
+(define-ast-printer is-constructor (object xp)
358 
+(with-ast-block (xp)
359 
+    (write-string "is-constructor/" xp)
360 
+    (write (is-constructor-constructor object) xp)
361 
+    (write-whitespace xp)
362 
+    (write-aexp (is-constructor-value object) xp)))
363 
+
364 
+(define-ast-printer void (object xp)
365 
+  (declare (ignore object))
366 
+  (write-string "Void" xp))
367 
+
368 
+;;; Special cfn constructs
369 
+
370 
+(define-ast-printer case-block (object xp)
371 
+  (with-ast-block (xp)
372 
+    (write-string "case-block " xp)
373 
+    (write (case-block-block-name object) xp)
374 
+    (write-whitespace xp)
375 
+    (write-layout-rule (case-block-exps object) xp (function write))))
376 
+
377 
+(define-ast-printer return-from (object xp)
378 
+  (with-ast-block (xp)
379 
+    (write-string "return-from " xp)
380 
+    (write (return-from-block-name object) xp)
381 
+    (write-whitespace xp)
382 
+    (write (return-from-exp object) xp)))
383 
+
384 
+(define-ast-printer and-exp (object xp)
385 
+  (with-ast-block (xp)
386 
+    (write-string "and " xp)
387 
+    (write-layout-rule (and-exp-exps object) xp (function write))))
388 
+
389 
+;;; Expression types used by the type checker.
390 
+
391 
+(define-ast-printer dict-placeholder (object xp)
392 
+  (cond ((not (eq? (dict-placeholder-exp object) '#f))
393 
+	 (write (dict-placeholder-exp object) xp))
394 
+	(else
395 
+	 (write-string "%" xp)
396 
+	 (write-string (symbol->string
397 
+			(def-name (dict-placeholder-class object))) xp))))
398 
+
399 
+(define-ast-printer recursive-placeholder (object xp)
400 
+  (cond ((not (eq? (recursive-placeholder-exp object) '#f))
401 
+	 (write (recursive-placeholder-exp object) xp))
402 
+	(else
403 
+	 (write-varid (def-name (recursive-placeholder-var object)) xp))))
404 
+
405 
+;;; This should probably have a flag to allow the dictionary converted code
406 
+;;; to be printed during debugging.
407 
+
408 
+(define-ast-printer save-old-exp (object xp)
409 
+  (write (save-old-exp-old-exp object) xp))
410 
+
printers/print-modules.scm
History View file @ 4e98702
0 411 
new file mode 100644
... ... 
@@ -0,0 +1,125 @@
1 
+;;; print-modules.scm -- print routines for module-related AST structures
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  6 Jan 1992
5 
+;;;
6 
+;;;
7 
+;;; This file corresponds to the file ast/modules.scm.
8 
+
9 
+;;; Note: by default, only the module name is printed.  To print the
10 
+;;; full module, the function print-full-module must be called.
11 
+
12 
+(define *print-abbreviated-modules* '#t)
13 
+
14 
+(define-ast-printer module (object xp)
15 
+ (if *print-abbreviated-modules*
16 
+     (begin
17 
+       (write-string "Module " xp)
18 
+       (write-string (symbol->string (module-name object)) xp))
19 
+     (do-print-full-module object xp)))
20 
+
21 
+(define (print-full-module object . maybe-stream)
22 
+  (let ((stream  (if (not (null? maybe-stream))
23 
+		     (car maybe-stream)
24 
+		     (current-output-port))))
25 
+    (dynamic-let ((*print-abbreviated-modules* '#f))
26 
+       (pprint object stream))))
27 
+
28 
+(define (do-print-full-module object xp)
29 
+ (dynamic-let ((*print-abbreviated-modules* '#t))
30 
+  (let ((modid    (module-name object))
31 
+	(exports  (module-exports object))
32 
+	(body     (append (module-imports object)
33 
+			  (module-fixities object)
34 
+			  (module-synonyms object)
35 
+			  (module-algdatas object)
36 
+			  (module-classes object)
37 
+			  (module-instances object)
38 
+			  (if (or (not (module-default object))
39 
+				  (eq? (module-default object)
40 
+				       *standard-module-default*))
41 
+			      '()
42 
+			      (list (module-default object)))
43 
+			  (module-decls object))))
44 
+    (write-string "module " xp)
45 
+    (write-modid modid xp)
46 
+    (when (not (null? exports))
47 
+      (write-whitespace xp)
48 
+      (write-commaized-list exports xp))
49 
+    (write-wheredecls body xp))))
50 
+
51 
+(define-ast-printer import-decl (object xp)
52 
+  (let ((modid     (import-decl-module-name object))
53 
+	(mode      (import-decl-mode object))
54 
+	(specs     (import-decl-specs object))
55 
+	(renamings (import-decl-renamings object)))
56 
+    (with-ast-block (xp)
57 
+      (write-string "import " xp)
58 
+      (write-modid modid xp)
59 
+      (if (eq? mode 'all)
60 
+	  (when (not (null? specs))
61 
+	    (write-whitespace xp)
62 
+	    (write-string "hiding " xp)
63 
+	    (write-commaized-list specs xp))
64 
+	  (begin
65 
+	    (write-whitespace xp)
66 
+	    (write-commaized-list specs xp)))
67 
+      (when (not (null? renamings))
68 
+	(write-whitespace xp)
69 
+	(write-string "renaming " xp)
70 
+	(write-commaized-list renamings xp))
71 
+      )))
72 
+
73 
+(define-ast-printer entity-module (object xp)
74 
+  (write-modid (entity-name object) xp)
75 
+  (write-string ".." xp))
76 
+
77 
+(define-ast-printer entity-var (object xp)
78 
+  (write-varid (entity-name object) xp))
79 
+
80 
+(define-ast-printer entity-con (object xp)
81 
+  (write-tyconid (entity-name object) xp))
82 
+
83 
+(define-ast-printer entity-abbreviated (object xp)
84 
+  (write-tyconid (entity-name object) xp)
85 
+  (write-string "(..)" xp))
86 
+
87 
+(define-ast-printer entity-class (object xp)
88 
+  (with-ast-block (xp)
89 
+    (write-tyclsid (entity-name object) xp)
90 
+    (write-whitespace xp)
91 
+    (write-delimited-list (entity-class-methods object) xp
92 
+			  (function write-varid) "," "(" ")")))
93 
+
94 
+(define-ast-printer entity-datatype (object xp)
95 
+  (with-ast-block (xp)
96 
+    (write-tyconid (entity-name object) xp)
97 
+    (write-whitespace xp)
98 
+    (write-delimited-list (entity-datatype-constructors object) xp
99 
+			  (function write-conid) "," "(" ")")))
100 
+
101 
+
102 
+(define-ast-printer renaming (object xp)
103 
+  (with-ast-block (xp)
104 
+    (write-varid-conid (renaming-from object) xp)
105 
+    (write-string " to" xp)
106 
+    (write-whitespace xp)
107 
+    (write-varid-conid (renaming-to object) xp)))
108 
+
109 
+;;; *** Should it omit precedence if it's 9?
110 
+
111 
+(define-ast-printer fixity-decl (object xp)
112 
+  (let* ((fixity         (fixity-decl-fixity object))
113 
+	 (associativity  (fixity-associativity fixity))
114 
+	 (precedence     (fixity-precedence fixity))
115 
+	 (ops            (fixity-decl-names object)))
116 
+    (with-ast-block (xp)
117 
+      (cond ((eq? associativity 'l)
118 
+	     (write-string "infixl " xp))
119 
+	    ((eq? associativity 'r)
120 
+	     (write-string "infixr " xp))
121 
+	    ((eq? associativity 'n)
122 
+	     (write-string "infix " xp)))
123 
+      (write precedence xp)
124 
+      (write-whitespace xp)
125 
+      (write-delimited-list ops xp (function write-varop-conop) "," "" ""))))
printers/print-ntypes.scm
History View file @ 4e98702
0 126 
new file mode 100644
... ... 
@@ -0,0 +1,61 @@
1 
+;;; These printers deal with ntype structures.
2 
+
3 
+;;; Too much of this file is copied from print-types!
4 
+
5 
+(define-ast-printer ntyvar (object xp)
6 
+  (let ((object (prune object)))
7 
+    (if (ntyvar? object)
8 
+	(begin
9 
+	  (write-char #\t xp)
10 
+	  (write (tyvar->number object) xp))
11 
+	(write object xp))))
12 
+
13 
+;;; Various type special cases have a magic cookie in the def field.
14 
+
15 
+(define-ast-printer ntycon (object xp)
16 
+  (let ((tycon (ntycon-tycon object)))
17 
+    (if (eq? tycon '#f)
18 
+	(write-string "<Bogus tycon>" xp)
19 
+	(print-general-tycon tycon (ntycon-args object) object xp))))
20 
+
21 
+(define-ast-printer gtype (object xp)
22 
+  (let ((var 0)
23 
+	(res '()))
24 
+    (dolist (classes (gtype-context object))
25 
+       (let ((v (gtyvar->symbol var)))
26 
+	 (dolist (class classes)
27 
+	    (push (**context (**class/def class) v) res)))
28 
+       (incf var))
29 
+    (write-contexts (reverse res) xp)
30 
+    (write (gtype-type object) xp)))
31 
+
32 
+(define-ast-printer gtyvar (object xp)
33 
+  (write-string (symbol->string (gtyvar->symbol (gtyvar-varnum object))) xp))
34 
+
35 
+(define (gtyvar->symbol n)
36 
+  (cond ((< n 26)
37 
+	 (list-ref '(|a| |b| |c| |d| |e| |f| |g|
38 
+		     |h| |i| |j| |k| |l| |m| |n|
39 
+		     |o| |p| |q| |r| |s| |t| |u|
40 
+		     |v| |w| |x| |y| |z|)
41 
+		   n))
42 
+	(else
43 
+	 (string->symbol (format '#f "g~A" (- n 25))))))
44 
+
45 
+(define-ast-printer recursive-type (object xp)
46 
+  (write (recursive-type-type object) xp))
47 
+
48 
+(define (tyvar->number tyvar)
49 
+  (tyvar->number-1 tyvar (dynamic *printed-tyvars*) 1))
50 
+
51 
+(define (tyvar->number-1 tyvar vars n)
52 
+  (cond ((null? vars)
53 
+	 (setf (dynamic *printed-tyvars*)
54 
+	       (nconc (dynamic *printed-tyvars*) (list tyvar)))
55 
+	 n)
56 
+	((eq? tyvar (car vars))
57 
+	 n)
58 
+	(else
59 
+	 (tyvar->number-1 tyvar (cdr vars) (1+ n)))))
60 
+
61 
+
printers/print-types.scm
History View file @ 4e98702
0 62 
new file mode 100644
... ... 
@@ -0,0 +1,201 @@
1 
+;;; print-types.scm -- print type-related AST structures
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  15 Jan 1991
5 
+;;;
6 
+;;; This file corresponds to the stuff in ast/type-structs.scm
7 
+;;;
8 
+
9 
+(define-ast-printer tyvar (object xp)
10 
+  (write-avarid (tyvar-name object) xp))
11 
+
12 
+
13 
+;;; Various type special cases have a magic cookie in the def field.
14 
+
15 
+(define-ast-printer tycon (object xp)
16 
+  (print-general-tycon (tycon-def object) (tycon-args object) object xp))
17 
+
18 
+(define (print-general-tycon def args object xp)
19 
+    (cond ((eq? def (core-symbol "Arrow"))
20 
+	   (write-arrow-tycon args xp))
21 
+	  ((eq? def (core-symbol "UnitType"))
22 
+	   (write-unit-tycon xp))
23 
+	  ((eq? def (core-symbol "List"))
24 
+	   (write-list-tycon args xp))
25 
+	  ((is-tuple-tycon? def)
26 
+	   (write-tuple-tycon args xp))
27 
+	  (else
28 
+	   (write-ordinary-tycon def args object xp))))
29 
+
30 
+(define (write-arrow-tycon args xp)
31 
+  (with-ast-block (xp)
32 
+    (write-btype (car args) xp)
33 
+    (write-string " ->" xp)
34 
+    (write-whitespace xp)
35 
+    (write (cadr args) xp)))
36 
+
37 
+(define (write-unit-tycon xp)
38 
+  (write-string "()" xp))
39 
+
40 
+(define (write-list-tycon args xp)
41 
+  (with-ast-block (xp)
42 
+    (write-char #\[ xp)
43 
+    (write (car args) xp)
44 
+    (write-char #\] xp)))
45 
+
46 
+(define (write-tuple-tycon args xp)
47 
+  (write-commaized-list args xp))
48 
+
49 
+(define (write-ordinary-tycon def args object xp)
50 
+  (with-ast-block (xp)
51 
+    (if (tycon? object)
52 
+	(write-tyconid (tycon-name object) xp)
53 
+	(write-tyconid (def-name def) xp))
54 
+    (when (not (null? args))
55 
+      (write-whitespace xp)
56 
+      (write-delimited-list
57 
+        args xp (function write-atype) "" "" ""))))
58 
+
59 
+
60 
+;;; All of the special cases above except "Arrow" are atypes, as is
61 
+;;; a tyvar or a tycon with no arguments.
62 
+
63 
+(define (write-atype object xp)
64 
+ (let ((object (maybe-prune object)))
65 
+  (if (or (tyvar? object)
66 
+	  (gtyvar? object)
67 
+	  (ntyvar? object)
68 
+	  (is-some-tycon? object
69 
+	     (lambda (def)
70 
+	       (or (eq? def (core-symbol "UnitType"))
71 
+		   (eq? def (core-symbol "List"))
72 
+		   (is-tuple-tycon? def)))))
73 
+      (write object xp)
74 
+      (begin
75 
+        (write-char #\( xp)
76 
+	(write object xp)
77 
+	(write-char #\) xp)))))
78 
+
79 
+
80 
+;;; A btype is any type except the arrow tycon.
81 
+
82 
+(define (write-btype object xp)
83 
+ (let ((object (maybe-prune object)))
84 
+  (if (or (and (tycon? object)
85 
+	       (eq? (tycon-def object) (core-symbol "Arrow")))
86 
+	  (and (ntycon? object)
87 
+	       (eq? (ntycon-tycon object) (core-symbol "Arrow"))))
88 
+      (begin
89 
+        (write-char #\( xp)
90 
+	(write object xp)
91 
+	(write-char #\) xp))
92 
+      (write object xp))))
93 
+
94 
+(define (maybe-prune object)
95 
+  (if (ntyvar? object)
96 
+      (prune object)
97 
+      object))
98 
+
99 
+(define (is-some-tycon? object fn)
100 
+  (let ((object (maybe-prune object)))
101 
+    (or (and (tycon? object)
102 
+	     (or (null? (tycon-args object))
103 
+		 (funcall fn (tycon-def object))))
104 
+	(and (ntycon? object)
105 
+	     (or (null? (ntycon-args object))
106 
+		 (funcall fn (ntycon-tycon object)))))))
107 
+
108 
+(define-ast-printer context (object xp)
109 
+  (with-ast-block (xp)
110 
+    (write (context-class object) xp)
111 
+    (write-whitespace xp)
112 
+    (write-avarid (context-tyvar object) xp)))
113 
+
114 
+(define-ast-printer signature (object xp)
115 
+  (write-contexts (signature-context object) xp)
116 
+  (write (signature-type object) xp))
117 
+
118 
+(define (write-contexts contexts xp)
119 
+  (when (not (null? contexts))
120 
+    (if (null? (cdr contexts))
121 
+	(write (car contexts) xp)
122 
+	(write-commaized-list contexts xp))
123 
+    (write-string " =>" xp)
124 
+    (write-whitespace xp)))
125 
+
126 
+(define-ast-printer synonym-decl (object xp)
127 
+  (with-ast-block (xp)
128 
+    (write-string "type " xp)
129 
+    (write (synonym-decl-simple object) xp)
130 
+    (write-string " =" xp)
131 
+    (write-whitespace xp)
132 
+    (write (synonym-decl-body object) xp)))
133 
+
134 
+(define-ast-printer data-decl (object xp)
135 
+  (with-ast-block (xp)
136 
+    (write-string "data " xp)
137 
+    (write-contexts (data-decl-context object) xp)
138 
+    (write (data-decl-simple object) xp)
139 
+    (write-whitespace xp)
140 
+    (write-char #\= xp)
141 
+    (write-whitespace xp)
142 
+    (write-delimited-list
143 
+      (data-decl-constrs object) xp (function write) " |" "" "")
144 
+    (write-whitespace xp)
145 
+    (let ((deriving  (data-decl-deriving object)))
146 
+      (when (not (null? deriving))
147 
+	(write-string "deriving " xp)
148 
+	(if (null? (cdr deriving))
149 
+	    (write (car deriving) xp)
150 
+	    (write-commaized-list deriving xp))))))
151 
+
152 
+(define-ast-printer constr (object xp)
153 
+  (if (con-ref-infix? (constr-constructor object))
154 
+      (with-ast-block (xp)
155 
+        (write-btype (car (constr-types object)) xp)
156 
+	(write-whitespace xp)
157 
+	(write (constr-constructor object) xp)
158 
+	(write-whitespace xp)
159 
+	(write-btype (cadr (constr-types object)) xp))
160 
+      (with-ast-block (xp)
161 
+	(write (constr-constructor object) xp)
162 
+	(when (not (null? (constr-types object)))
163 
+	  (write-whitespace xp)
164 
+	  (write-delimited-list
165 
+	   (constr-types object) xp (function write-atype) "" "" "")))))
166 
+
167 
+
168 
+(define-ast-printer class-decl (object xp)
169 
+  (with-ast-block (xp)
170 
+    (write-string "class " xp)
171 
+    (write-contexts (class-decl-super-classes object) xp)
172 
+    (write (class-decl-class object) xp)
173 
+    (write-whitespace xp)
174 
+    (write-avarid (class-decl-class-var object) xp)
175 
+    (write-wheredecls (class-decl-decls object) xp)))
176 
+
177 
+(define-ast-printer instance-decl (object xp)
178 
+  (with-ast-block (xp)
179 
+    (write-string "instance " xp)
180 
+    (write-contexts (instance-decl-context object) xp)
181 
+    (write (instance-decl-class object) xp)
182 
+    (write-whitespace xp)
183 
+    (write-atype (instance-decl-simple object) xp)
184 
+    (write-wheredecls (instance-decl-decls object) xp)))
185 
+
186 
+
187 
+;;; Don't print out default decl if the value is the default.
188 
+
189 
+(define-ast-printer default-decl (object xp)
190 
+  (with-ast-block (xp)
191 
+    (write-string "default " xp)
192 
+    (let ((types  (default-decl-types object)))
193 
+      (if (null? (cdr types))
194 
+	  (write (car types) xp)
195 
+	  (write-commaized-list types xp)))))
196 
+
197 
+(define-ast-printer class-ref (object xp)
198 
+  (write-tyclsid (class-ref-name object) xp))
199 
+
200 
+
201 
+
printers/print-valdefs.scm
History View file @ 4e98702
0 202 
new file mode 100644
... ... 
@@ -0,0 +1,180 @@
1 
+;;; print-valdefs.scm -- print AST structures for local declarations
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  14 Jan 1992
5 
+;;;
6 
+;;; This file corresponds to ast/valdef-structs.scm.
7 
+;;;
8 
+;;;
9 
+
10 
+
11 
+
12 
+(define-ast-printer signdecl (object xp)
13 
+  (with-ast-block (xp)
14 
+    (write-delimited-list (signdecl-vars object) xp (function write) "," "" "")
15 
+    (write-string " ::" xp)
16 
+    (write-whitespace xp)
17 
+    (write (signdecl-signature object) xp)))
18 
+
19 
+
20 
+;;; This interacts with the layout rule stuff.  See util.scm.
21 
+
22 
+(define-ast-printer valdef (object xp)
23 
+  (let ((lhs         (valdef-lhs object))
24 
+	(definitions (valdef-definitions object)))
25 
+    (write-definition lhs (car definitions) xp)
26 
+    (dolist (d (cdr definitions))
27 
+      (if (dynamic *print-pretty*)
28 
+	  (pprint-newline 'mandatory xp)
29 
+	  (write-string "; " xp))
30 
+      (write-definition lhs d xp))))
31 
+
32 
+
33 
+(define (write-definition lhs d xp)
34 
+  (with-ast-block (xp)
35 
+    (let ((args        (single-fun-def-args d))
36 
+	  (rhs-list    (single-fun-def-rhs-list d))
37 
+	  (where-decls (single-fun-def-where-decls d))
38 
+	  (infix?      (single-fun-def-infix? d)))
39 
+      (write-lhs lhs args infix? xp)
40 
+      (write-rhs rhs-list xp)
41 
+      (write-wheredecls where-decls xp)
42 
+      )))
43 
+
44 
+(define (write-lhs lhs args infix? xp)
45 
+  (cond ((null? args)
46 
+	 ;; pattern definition
47 
+	 (write-apat lhs xp)
48 
+	 )
49 
+        ;; If there are args, the lhs is always a var-pat pointing to a
50 
+        ;; var-ref. The infix? slot from the single-fun-def must override
51 
+	;; the slot on the var-ref, since there can be a mixture of
52 
+	;; infix and prefix definitions for the same lhs.
53 
+	(infix?
54 
+	 ;; operator definition
55 
+	 (when (not (null? (cddr args)))
56 
+	   (write-char #\( xp))
57 
+	 (write-apat (car args) xp)
58 
+	 (write-whitespace xp)
59 
+	 (write-varop (var-ref-name (var-pat-var lhs)) xp)
60 
+	 (write-whitespace xp)
61 
+	 (write-apat (cadr args) xp)
62 
+	 (when (not (null? (cddr args)))
63 
+	   (write-char #\) xp)
64 
+	   (write-whitespace xp)
65 
+	   (write-delimited-list (cddr args) xp (function write-apat)
66 
+				 "" "" "")))
67 
+	(else
68 
+	 ;; normal prefix function definition
69 
+	 (write-varid (var-ref-name (var-pat-var lhs)) xp)
70 
+	 (write-whitespace xp)
71 
+	 (write-delimited-list args xp (function write-apat) "" "" ""))
72 
+	))
73 
+
74 
+(define (write-rhs rhs-list xp)
75 
+  (let ((guard   (guarded-rhs-guard (car rhs-list)))
76 
+	(rhs     (guarded-rhs-rhs   (car rhs-list))))
77 
+    (when (not (is-type? 'omitted-guard guard))
78 
+      (write-string " | " xp)
79 
+      (write guard xp))
80 
+    (write-string " =" xp)
81 
+    (write-whitespace xp)
82 
+    (write rhs xp)
83 
+    (when (not (null? (cdr rhs-list)))
84 
+      (write-newline xp)
85 
+      (write-rhs (cdr rhs-list) xp))))
86 
+
87 
+
88 
+;;; Pattern printers
89 
+
90 
+
91 
+;;; As per jcp suggestion, don't put whitespace after @; line break comes
92 
+;;; before, not after (as is the case for other infix-style punctuation).
93 
+
94 
+(define-ast-printer as-pat (object xp)
95 
+  (with-ast-block (xp)
96 
+    (write (as-pat-var object) xp)
97 
+    (write-whitespace xp)
98 
+    (write-string "@" xp)
99 
+    (write-apat (as-pat-pattern object) xp)))
100 
+
101 
+(define (write-apat pat xp)
102 
+  (if (or (is-type? 'apat pat)
103 
+	  (is-type? 'pp-pat-plus pat)  ; hack per jcp
104 
+	  (and (is-type? 'pcon pat)
105 
+	       (or (null? (pcon-pats pat))
106 
+		   (eq? (pcon-con pat) (core-symbol "UnitConstructor"))
107 
+		   (is-tuple-constructor? (pcon-con pat)))))
108 
+      (write pat xp)
109 
+      (begin
110 
+        (write-char #\( xp)
111 
+        (write pat xp)
112 
+        (write-char #\) xp))))
113 
+
114 
+(define-ast-printer irr-pat (object xp)
115 
+  (write-string "~" xp)
116 
+  (write-apat (irr-pat-pattern object) xp))
117 
+
118 
+(define-ast-printer var-pat (object xp)
119 
+  (write (var-pat-var object) xp))
120 
+
121 
+(define-ast-printer wildcard-pat (object xp)
122 
+  (declare (ignore object))
123 
+  (write-char #\_ xp))
124 
+
125 
+(define-ast-printer const-pat (object xp)
126 
+  (write (const-pat-value object) xp))
127 
+
128 
+(define-ast-printer plus-pat (object xp)
129 
+  (write (plus-pat-pattern object) xp)
130 
+  (write-string " + " xp)
131 
+  (write (plus-pat-k object) xp))
132 
+
133 
+
134 
+
135 
+(define-ast-printer pcon (object xp)
136 
+  (let ((name    (pcon-name object))
137 
+	(pats    (pcon-pats object))
138 
+	(infix?  (pcon-infix? object))
139 
+	(def     (pcon-con object)))
140 
+    (cond ((eq? def (core-symbol "UnitConstructor"))
141 
+	   (write-string "()" xp))
142 
+	  ((is-tuple-constructor? def)
143 
+	   (write-commaized-list pats xp))
144 
+          ((null? pats)
145 
+	   (if infix?
146 
+	       ;; infix pcon with no arguments can happen inside pp-pat-list
147 
+	       ;; before precedence parsing happens.
148 
+	       (write-conop name xp)
149 
+	       (write-conid name xp)))
150 
+	  (infix?
151 
+	   ;; This could be smarter about dealing with precedence of patterns.
152 
+	   (with-ast-block (xp)
153 
+	     (write-apat (car pats) xp)
154 
+	     (write-whitespace xp)
155 
+	     (write-conop name xp)
156 
+	     (write-whitespace xp)
157 
+	     (write-apat (cadr pats) xp)))
158 
+	  (else
159 
+	   (with-ast-block (xp)
160 
+	     (write-conid name xp)
161 
+	     (write-whitespace xp)
162 
+	     (write-delimited-list pats xp (function write-apat) "" "" "")))
163 
+	  )))
164 
+
165 
+(define-ast-printer list-pat (object xp)
166 
+  (write-delimited-list
167 
+    (list-pat-pats object) xp (function write) "," "[" "]"))
168 
+
169 
+(define-ast-printer pp-pat-list (object xp)
170 
+  (write-delimited-list (pp-pat-list-pats object) xp (function write-apat)
171 
+			"" "" ""))
172 
+
173 
+(define-ast-printer pp-pat-plus (object xp)
174 
+  (declare (ignore object))
175 
+  (write-string "+ " xp))
176 
+
177 
+(define-ast-printer pp-pat-negated (object xp)
178 
+  (declare (ignore object))
179 
+  (write-string "-" xp))
180 
+
printers/printers.scm
History View file @ 4e98702
0 181 
new file mode 100644
... ... 
@@ -0,0 +1,28 @@
1 
+;;; printers.scm -- compilation unit definition for structure printers
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  3 Jan 1992
5 
+;;;
6 
+;;;
7 
+
8 
+(define-compilation-unit printer-support
9 
+  (source-filename "$Y2/printers/")
10 
+  (require global)
11 
+  (unit util
12 
+	(source-filename "util.scm")))
13 
+
14 
+(define-compilation-unit printers
15 
+  (source-filename "$Y2/printers/")
16 
+  (require printer-support)
17 
+  (unit print-exps
18 
+	(source-filename "print-exps.scm"))
19 
+  (unit print-modules
20 
+	(source-filename "print-modules.scm"))
21 
+  (unit print-types
22 
+	(source-filename "print-types.scm"))
23 
+  (unit print-ntypes
24 
+	(source-filename "print-ntypes.scm"))
25 
+  (unit print-valdefs
26 
+	(source-filename "print-valdefs.scm"))
27 
+  )
28 
+
printers/util.scm
History View file @ 4e98702
0 29 
new file mode 100644
... ... 
@@ -0,0 +1,214 @@
1 
+;;; util.scm -- utilities for printing AST structures
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  15 Jan 1992
5 
+;;;
6 
+;;;
7 
+
8 
+
9 
+;;; The AST syntax printers are only used if this variable is true.
10 
+
11 
+(define *print-ast-syntax* '#t)
12 
+
13 
+
14 
+;;; Here's a macro for defining AST printers.
15 
+
16 
+(define-syntax (define-ast-printer type lambda-list . body)
17 
+  (let ((printer  (symbol-append 'write- type)))
18 
+    `(begin
19 
+       (define (,printer ,@lambda-list) ,@body)
20 
+       (define-struct-printer ,type ,printer))
21 
+    ))
22 
+
23 
+
24 
+;;; This variable controls how much indentation to perform on block
25 
+;;; bodies.
26 
+
27 
+(define *print-ast-indent* 2)
28 
+
29 
+
30 
+;;; Begin a logical block with the default indentation.
31 
+
32 
+(define-syntax (with-ast-block xp-stuff . body)
33 
+  (let ((xp  (car xp-stuff)))
34 
+    `(pprint-logical-block (,xp '() "" "")
35 
+       (pprint-indent 'block (dynamic *print-ast-indent*) ,xp)
36 
+       (pprint-pop)  ; prevents unused variable warning
37 
+       ,@body)))
38 
+
39 
+
40 
+;;; Write a space and maybe a fill line break.
41 
+
42 
+(define (write-whitespace xp)
43 
+  (write-char #\space xp)
44 
+  (pprint-newline 'fill xp))
45 
+
46 
+
47 
+;;; Write a space and maybe a mandatory line break.
48 
+
49 
+(define (write-newline xp)
50 
+  (write-char #\space xp)
51 
+  (pprint-newline 'mandatory xp))
52 
+
53 
+
54 
+
55 
+;;; Write a list of things separated by delimiters and maybe
56 
+;;; surrounded by delimiters.
57 
+
58 
+(define (write-delimited-list objects xp fn delim prefix suffix)
59 
+  (pprint-logical-block (xp '() prefix suffix)
60 
+    (do ((objects objects (cdr objects)))
61 
+	((null? objects) '#f)
62 
+	(pprint-pop)
63 
+	(funcall fn (car objects) xp)
64 
+	(when (cdr objects)
65 
+	  (write-string delim xp)
66 
+	  (write-whitespace xp)))))
67 
+
68 
+
69 
+;;; Here's a couple common special cases of the above.
70 
+
71 
+(define (write-commaized-list objects xp)
72 
+  (write-delimited-list objects xp (function write) "," "(" ")"))
73 
+
74 
+(define (write-ordinary-list objects xp)
75 
+  (write-delimited-list objects xp (function write) "" "" ""))
76 
+
77 
+
78 
+;;; Here's another helper function that's used to implement the layout
79 
+;;; rule.  The layout rule is only used to format output if *print-pretty*
80 
+;;; is true.
81 
+;;; *** should do pprint-indent here?
82 
+
83 
+(define (write-layout-rule objects xp fn)
84 
+  (pprint-logical-block (xp '()
85 
+			    (if (dynamic *print-pretty*) "" "{")
86 
+			    (if (dynamic *print-pretty*) "" "}"))
87 
+    (do ((objects objects (cdr objects)))
88 
+	((null? objects) '#f)
89 
+	(pprint-pop)
90 
+	(funcall fn (car objects) xp)
91 
+	(when (cdr objects)
92 
+	  (if (dynamic *print-pretty*)
93 
+	      (pprint-newline 'mandatory xp)
94 
+	      (write-string "; " xp))))))
95 
+
96 
+
97 
+;;; This filters a list of decls, removing the recursive marker added by
98 
+;;; dependency analysis.
99 
+
100 
+(define (remove-recursive-grouping decls)
101 
+  (cond ((null? decls) '())
102 
+	((is-type? 'recursive-decl-group (car decls))
103 
+	 (append (recursive-decl-group-decls (car decls))
104 
+		 (remove-recursive-grouping (cdr decls))))
105 
+	(else
106 
+	 (cons (car decls) (remove-recursive-grouping (cdr decls))))))
107 
+
108 
+;;; Write where-decls, using the layout rule if appropriate.
109 
+
110 
+(define (write-wheredecls decls xp)
111 
+  (when (not (null? decls))
112 
+    (write-whitespace xp)
113 
+    (write-string "where" xp)
114 
+    (write-whitespace xp)
115 
+    (write-layout-rule (remove-recursive-grouping decls) xp (function write))))
116 
+
117 
+
118 
+;;; Write an ordinary variable name.
119 
+
120 
+(define (write-avarid name xp)
121 
+  (write-string (symbol->string name) xp))
122 
+
123 
+
124 
+;;; Constructor name symbols have a funny prefix attached; have to strip
125 
+;;; this off, so can't just print the symbol using write-avarid.
126 
+
127 
+(define (write-aconid name xp)
128 
+  (let ((s  (symbol->string name)))
129 
+    (write-string (substring s 1 (string-length s)) xp)))
130 
+
131 
+
132 
+;;; There are a couple places where conids and varids are mixed up
133 
+;;; together.
134 
+
135 
+(define (conid? name)
136 
+  (eqv? (string-ref (symbol->string name) 0) #\;))
137 
+
138 
+(define (write-varop-conop name xp)
139 
+  (if (conid? name)
140 
+      (write-conop name xp)
141 
+      (write-varop name xp)))
142 
+
143 
+(define (write-varid-conid name xp)
144 
+  (if (conid? name)
145 
+      (write-conid name xp)
146 
+      (write-varid name xp)))
147 
+
148 
+
149 
+
150 
+;;; Stuff for writing a variable name as either an operator or an ordinary
151 
+;;; variable ID.  This is necessary because some kinds of symbol names
152 
+;;; default to being operators and others default to being ordinary names.
153 
+;;; Bleah....
154 
+
155 
+
156 
+(define (write-varop name xp)
157 
+  (if (avarid? name)
158 
+      (begin
159 
+        (write-char #\` xp)
160 
+	(write-avarid name xp)
161 
+	(write-char #\` xp))
162 
+      (write-avarid name xp)))
163 
+
164 
+(define (write-varid name xp)
165 
+  (if (avarid? name)
166 
+      (write-avarid name xp)
167 
+      (begin
168 
+        (write-char #\( xp)
169 
+	(write-avarid name xp)
170 
+	(write-char #\) xp))))
171 
+
172 
+
173 
+;;; This tests for alphabetic rather than lower-case characters
174 
+;;; so that gensym'ed variables with uppercase names don't print funny.
175 
+
176 
+(define (avarid? name)
177 
+  (let ((ch  (string-ref (symbol->string name) 0)))
178 
+    (char-alphabetic? ch)))
179 
+
180 
+
181 
+;;; Similar stuff for doing constructor names.  Moby bleah....
182 
+
183 
+(define (write-conop name xp)
184 
+  (if (aconid? name)
185 
+      (begin
186 
+        (write-char #\` xp)
187 
+	(write-aconid name xp)
188 
+	(write-char #\` xp))
189 
+      (write-aconid name xp)))
190 
+
191 
+(define (write-conid name xp)
192 
+  (if (aconid? name)
193 
+      (write-aconid name xp)
194 
+      (begin
195 
+        (write-char #\( xp)
196 
+	(write-aconid name xp)
197 
+	(write-char #\) xp))))
198 
+
199 
+(define (aconid? name)
200 
+  (let ((ch  (string-ref (symbol->string name) 1)))
201 
+    (char-upper-case? ch)))
202 
+
203 
+
204 
+;;; These are officially aconid in the syntax, but they aren't
205 
+;;; prefixed so write them using write-avarid instead.  Barf.
206 
+
207 
+(define (write-modid name xp)
208 
+  (write-avarid name xp))
209 
+
210 
+(define (write-tyconid name xp)
211 
+  (write-avarid name xp))
212 
+
213 
+(define (write-tyclsid name xp)
214 
+  (write-avarid name xp))
progs/README
History View file @ 4e98702
0 215 
new file mode 100644
... ... 
@@ -0,0 +1,9 @@
1 
+This directory contains Haskell source code.
2 
+Subdirectories:
3 
+prelude               The prelude used in this system
4 
+tutorial              The online supplement to the Hudak & Fasel tutorial
5 
+demo                  A set of random demo programs
6 
+lib                   Various random extensions
7 
+
8 
+Other programs can be found in the Haskell program library on the
9 
+official Haskell ftp sites.
progs/demo/Calendar.hs
History View file @ 4e98702
0 10 
new file mode 100644
... ... 
@@ -0,0 +1,138 @@
1 
+-- This is a modification of the calendar program described in section 4.5
2 
+-- of Bird and Wadler's ``Introduction to functional programming'', with
3 
+-- two ways of printing the calendar ... as in B+W, or like UNIX `cal':
4 
+--
5 
+-- Use from within Yale Haskell:
6 
+--
7 
+--   Main> :l Calendar
8 
+--   Now in module Calendar.
9 
+--   Calendar> @ do cal 1992
10 
+--   Calendar> :e
11 
+--
12 
+--   ... Unix style calendar ...
13 
+--
14 
+--   Calendar> @ do calendar 1992
15 
+--   Calendar> :e
16 
+--
17 
+--   ... Bird and Wadler style calendar ...
18 
+--
19 
+--   Calendar>
20 
+
21 
+module Calendar(cal,calendar) where
22 
+
23 
+infixr 5 `above`, `beside`
24 
+
25 
+do cal year    = appendChan stdout (cal year) exit done
26 
+
27 
+-- Picture handling:
28 
+
29 
+type Picture   =  [[Char]]
30 
+
31 
+height, width :: Picture -> Int
32 
+height p       = length p
33 
+width  p       = length (head p)
34 
+
35 
+above, beside :: Picture -> Picture -> Picture
36 
+above          = (++)
37 
+beside         = zipWith (++)
38 
+
39 
+stack, spread :: [Picture] -> Picture
40 
+stack          = foldr1 above
41 
+spread         = foldr1 beside
42 
+
43 
+empty         :: (Int,Int) -> Picture
44 
+empty (h,w)    = copy h (copy w ' ')
45 
+
46 
+block, blockT :: Int -> [Picture] -> Picture
47 
+block n        = stack . map spread . group n
48 
+blockT n       = spread . map stack . group n
49 
+
50 
+group         :: Int -> [a] -> [[a]]
51 
+group n []     = []
52 
+group n xs     = take n xs : group n (drop n xs)
53 
+
54 
+lframe        :: (Int,Int) -> Picture -> Picture
55 
+lframe (m,n) p = (p `beside` empty (h,n-w)) `above` empty (m-h,n)
56 
+		 where h = height p
57 
+                       w = width p
58 
+
59 
+-- Information about the months in a year:
60 
+
61 
+monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31]
62 
+                    where feb | leap year = 29
63 
+                              | otherwise = 28
64 
+
65 
+leap year         = if year`mod`100 == 0 then year`mod`400 == 0
66 
+                                         else year`mod`4   == 0
67 
+
68 
+monthNames        = ["January","February","March","April",
69 
+		     "May","June","July","August",
70 
+		     "September","October","November","December"]
71 
+
72 
+jan1st year       = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7
73 
+                    where last = year - 1
74 
+
75 
+firstDays year    = take 12
76 
+                         (map (`mod`7)
77 
+                              (scanl (+) (jan1st year) (monthLengths year)))
78 
+
79 
+-- Producing the information necessary for one month:
80 
+
81 
+dates fd ml = map (date ml) [1-fd..42-fd]
82 
+              where date ml d | d<1 || ml<d  = ["   "]
83 
+                              | otherwise    = [rjustify 3 (show d)]
84 
+
85 
+-- The original B+W calendar:
86 
+
87 
+calendar :: Int -> String
88 
+calendar  = unlines . block 3 . map picture . months
89 
+            where picture (mn,yr,fd,ml)  = title mn yr `above` table fd ml
90 
+                  title mn yr    = lframe (2,25) [mn ++ " " ++ show yr]
91 
+                  table fd ml    = lframe (8,25)
92 
+                                          (daynames `beside` entries fd ml)
93 
+                  daynames       = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"]
94 
+                  entries fd ml  = blockT 7 (dates fd ml)
95 
+                  months year    = zip4 monthNames
96 
+                                        (copy 12 year)
97 
+                                        (firstDays year)
98 
+                                        (monthLengths year)
99 
+
100 
+-- In a format somewhat closer to UNIX cal:
101 
+
102 
+cal     :: Int -> String
103 
+cal year = unlines (banner year `above` body year)
104 
+           where banner yr      = [cjustify 75 (show yr)] `above` empty (1,75)
105 
+                 body           = block 3 . map (pad . pic) . months
106 
+                 pic (mn,fd,ml) = title mn `above` table fd ml
107 
+                 pad p          = (side`beside`p`beside`side)`above`end
108 
+                 side           = empty (8,2)
109 
+                 end            = empty (1,25)
110 
+                 title mn       = [cjustify 21 mn]
111 
+                 table fd ml    = daynames `above` entries fd ml
112 
+                 daynames       = [" Su Mo Tu We Th Fr Sa"]
113 
+                 entries fd ml  = block 7 (dates fd ml)
114 
+                 months year    = zip3 monthNames
115 
+                                       (firstDays year)
116 
+                                       (monthLengths year)
117 
+
118 
+-- Additional (B+W)-isms: these really ought to go in a separate module,
119 
+-- in a spearate file.  But for ease of packaging this simple application,
120 
+-- it doesn't seem worth the trouble!
121 
+
122 
+copy    :: Int -> a -> [a]
123 
+copy n x = take n (repeat x)
124 
+
125 
+space   :: Int -> String
126 
+space n  = copy n ' '
127 
+
128 
+-- Simple string formatting:
129 
+
130 
+cjustify, ljustify, rjustify :: Int -> String -> String
131 
+
132 
+cjustify n s = space halfm ++ s ++ space (m - halfm)
133 
+               where m     = n - length s
134 
+                     halfm = m `div` 2
135 
+ljustify n s = s ++ space (n - length s)
136 
+rjustify n s = space (n - length s) ++ s
137 
+
138 
+-- End of calendar program
progs/demo/README
History View file @ 4e98702
0 139 
new file mode 100644
... ... 
@@ -0,0 +1,15 @@
1 
+
2 
+This directory contains Haskell demo programs.  All of these programs
3 
+compile and execute properly.
4 
+
5 
+This directory contains:
6 
+
7 
+
8 
+fact.hs			factorial
9 
+merge.hs		merge sort
10 
+pfac.hs			parallel factorial
11 
+primes.hs		prime number generator
12 
+qs.hs			quick sort
13 
+queens.hs               N queens
14 
+symalg/                 A symbolic algebra program
15 
+prolog/                 A prolog interpreter
progs/demo/X11/animation/README
History View file @ 4e98702
0 16 
new file mode 100644
... ... 
@@ -0,0 +1,22 @@
1 
+In his paper "A Functional Animation Starter Kit" [ARYA88], Kevi Arya
2 
+proposes an approach to animation that uses functional languages. As
3 
+Arya describes, the cost of computing power is falling. This is making
4 
+the use of computer animation much more prevalent. However, languages
5 
+such as C make it difficult to program animations. What is needed is
6 
+a simpler, faster and more accessible way to program graphics. Functional
7 
+languages are a very effective means for this, due to their higher order
8 
+functions.
9 
+
10 
+	Kevi Arya goes on to provide such a functional animation package in
11 
+the language Miranda. Haskell in particular is good functional language for
12 
+two reasons. It is a completely functional language, doing even I/O in a
13 
+functional manner. Variables are evaluated in a lazy manner allowing infinite
14 
+lists to be manipulated easily, which suits the infinite frames format
15 
+of animation.
16 
+
17 
+The following animations are provided here:
18 
+
19 
+  seaside.hs  - a seaside scene
20 
+  planets.hs  - planets in orbit
21 
+  palm.hs     - another seaside scene
22 
+  birds.hs    - flying birds
progs/demo/X11/animation/animation.hs
History View file @ 4e98702
0 23 
new file mode 100644
... ... 
@@ -0,0 +1,16 @@
1 
+-- This bundles all the animation stuff into a single module.
2 
+
3 
+module Animation(R_Ptypes..,R_Constants..,R_Utility..,R_Picture..,R_Behaviour..,
4 
+                 R_Movie..,R_Shapes..,R_Defaults..,R_Inbetween..,
5 
+                 R_Display..) where
6 
+import R_Ptypes
7 
+import R_Constants
8 
+import R_Utility
9 
+import R_Picture
10 
+import R_Behaviour
11 
+import R_Movie
12 
+import R_Shapes
13 
+import R_Defaults
14 
+import R_Inbetween
15 
+import R_Display
16 
+
progs/demo/X11/animation/animation.hu
History View file @ 4e98702
0 17 
new file mode 100644
... ... 
@@ -0,0 +1,6 @@
1 
+animation.hs
2 
+r_movie.hu
3 
+r_defaults.hu
4 
+r_shapes.hu
5 
+r_inbetween.hu
6 
+r_display.hu
progs/demo/X11/animation/birds.hs
History View file @ 4e98702
0 7 
new file mode 100644
... ... 
@@ -0,0 +1,28 @@
1 
+module Birds where
2 
+
3 
+import Animation
4 
+
5 
+bird :: Movie
6 
+--bird = osc [bird1,bird2]
7 
+bird = rOVERLAY
8 
+         [apply (bPar [right,right,right,right]) bm1,
9 
+          apply (bPar [up,right,right,right]) bm2]
10 
+         where bm1 = osc [bird1]
11 
+               bm2 = osc [bird2]
12 
+
13 
+bird1 = [(black,b1)]
14 
+        where b1 = [(0,90),(20,100),(30,110),(40,110),(50,100),(110,120),
15 
+                    (130,100),(120,90),(80,90),(0,90),
16 
+                    (80,90),(90,70),(140,50),(120,90),(80,90),
17 
+                    (80,90),(70,70),(80,60),(90,70)]
18 
+
19 
+bird2 = [(red,b2)]
20 
+        where b2 = [(0,60),(20,70),(30,80),(40,80),(50,70),(110,70),
21 
+                    (140,30),(110,35),(100,35),(70,50),(50,60),(0,60),
22 
+	            (70,50),(100,90),(150,100),(120,60),(110,35),
23 
+                    (70,50),(65,100),(85,115),(97,86)]
24 
+
25 
+main = getEnv "DISPLAY" exit
26 
+       (\ host -> displaym host 30 bird)
27 
+
28 
+
progs/demo/X11/animation/birds.hu
History View file @ 4e98702
0 29 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+birds.hs
3 
+animation.hu
progs/demo/X11/animation/doc.tex
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,578 @@
1 
+
2 
+%  This is obsolete regarding the X system  -- jcp
3 
+
4 
+% -*-latex-*-
5 
+% Creator: John Tinmouth
6 
+% Creation Date: Thu May 9 1991
7 
+\documentstyle[11pt]{article}
8 
+\newcommand{\X}[1]{{#1}\index{{#1}}}
9 
+\begin{document}
10 
+
11 
+\title{A Functional Animation Package in Haskell}
12 
+\author{
13 
+        John Tinmouth\\
14 
+        Computer Science Senior Project\\
15 
+         Yale University\\
16 
+         Professor Paul Hudak }
17 
+\date{9 May 1991}
18 
+\maketitle
19 
+
20 
+
21 
+
22 
+\section{Introduction}
23 
+
24 
+  	In his paper "A Functional Animation Starter Kit" [ARYA88], Kevi Arya
25 
+proposes an approach to animation that uses functional languages. As
26 
+Arya describes, the cost of computing power is falling. This is making
27 
+the use of computer animation much more prevalent. However, languages
28 
+such as C make it difficult to program animations. What is needed is
29 
+a simpler, faster and more accessible way to program graphics. Functional
30 
+languages are a very effective means for this, due to their higher order
31 
+functions.
32 
+
33 
+	Kevi Arya goes on to provide such a functional animation package in
34 
+the language Miranda. Haskell in particular is good functional language for
35 
+two reasons. It is a completely functional language, doing even I/O in a
36 
+functional manner. Variables are evaluated in a lazy manner allowing infinite
37 
+lists to be manipulated easily, which suits the infinite frames format
38 
+of animation. As it is now possible to complete the implementation of
39 
+this package is Haskell, my work has been converting these Miranda programs
40 
+to Haskell version 1.0-0, Yale Haskell Group.
41 
+
42 
+
43 
+
44 
+\section{How to Use the Graphics:  Overview}
45 
+
46 
+  By using higher order functions, it becomes very easy to do rapid
47 
+prototyping of animations. You can quickly throw out an animation of
48 
+simple images manipulated in simple ways. For example, if there was
49 
+an image of a car, and you wanted it to move left, you could almost
50 
+just describe it in english, and that would be the animation.
51 
+\begin{verbatim}
52 
+     movie = apply left car
53 
+\end{verbatim}
54 
+
55 
+	After the simple model is done, converting it to a more complex model
56 
+is simple. Simply make the image, "car" in this case, more complex, and
57 
+then modify the "left" function, and you are done.
58 
+
59 
+	There are three stages in making a movie. First of all, you must
60 
+define your basic images. These will tend to be Pics put into lists, either
61 
+finite or infinite, to be basic Movies. Second, you decide precisely
62 
+what kind of motion you want in animation. These are behaviours. A behaviour
63 
+modifies a movie over time, changing each successive frame. This includes
64 
+motion, changing size, changing from one image to another and so forth. These
65 
+are applied to your basic Movies. Third, you must combine your basic Movies
66 
+into your final Movie. If you want a scene of clouds and a man walking, you
67 
+must overlay your basic Movie of clouds with your Movie of a walking man.
68 
+
69 
+\section {Original Images or Pics}
70 
+
71 
+	A Movie is a list of frames called Pics. Each of these Pics is a list
72 
+of colored polygons. The Pic is a Color followed by a list of Vectors,
73 
+representing the vertices of the Polygon. The original Pic usually must
74 
+be entered by hand, although simple generation routines for boxes,
75 
+triangles and circles are available. You need to produce some of these
76 
+basic images in one way or another, so that you have something to
77 
+manipulate.
78 
+
79 
+	To make a Movie, you need a list of these Pics. With a single Pic, you
80 
+can generate a sequence of that Pic. With several Pics, you can oscillate
81 
+through the Pics in an inifinite list. To generate an infinite list of
82 
+Pics of p1, define a Movie, m1 = i p1.
83 
+  The following datatypes are used in this package:
84 
+
85 
+\begin{verbatim}
86 
+type Vec	= (Int,Int)
87 
+type Color	= Int
88 
+type Poly	= (Color,[Vec])
89 
+type Pic 	= [Poly]
90 
+type Movie	= [Pic]
91 
+type Behaviour	= [Pic -> Pic]
92 
+\end{verbatim}
93 
+
94 
+
95 
+\subsection {Modifying Pics}
96 
+
97 
+  Starting with a single Pic, it is possible to create a short list of
98 
+Pics to oscillate on. You can flip it, scale it, or otherwise modify the
99 
+original Pic (p1) in some way to create another Pic (p2). You can either
100 
+keep doing this and produce N images for a Movie of [p1,p2,...,pN], or use
101 
+the interpolation functions available to shift from p1 to p2 in N frames,
102 
+resulting in a Movie [p1,interp1,interp2,...,interpN-2,p2].
103 
+  The list of specific Pic-to-Pic functions is included in the next section,
104 
+along with short explanations of what they do.
105 
+
106 
+\subsection {Pic-to-Pic Functions Available}
107 
+
108 
+\begin{verbatim}
109 
+overlay_Pic     Args: Pic Pic
110 
+                This takes 2 Pics and just puts them together into one Pic.
111 
+                module: R_Picture
112 
+
113 
+put_Pic	        Args: Vec Pic Pic
114 
+                This overlays the two Pics, putting Pic-1's center the Vec
115 
+                distance away from Pic-2's center.
116 
+                module: R_Picture
117 
+
118 
+over_Pic        Args: Pic Pic
119 
+                This puts two images on top of one another, explicitly
120 
+                centering the first on top of the second and forms one Pic.
121 
+                module: R_Picture
122 
+
123 
+above_Pic       Args: Pic Pic
124 
+                This puts the first Pic above the second Pic, at a distance
125 
+                of half the combined heights of the Pics and overlays them
126 
+                to form one Pic.
127 
+                module: R_Picture
128 
+
129 
+beside_Pic      Args: Pic Pic
130 
+                This puts the first Pic to the right of the second Pic, at
131 
+                a distance of half the combined widths of the Pics and
132 
+                overlays them to form one Pic.
133 
+                module: R_Picture
134 
+
135 
+beside2_Pic     Args: Pic Pic
136 
+                Withouth analysing the widths of the Pics, it puts the
137 
+                first Pic the width of the second Pic to the right and
138 
+                overlays them to form one Pic.
139 
+                module: R_Picture
140 
+
141 
+scale_Pic       Args: Int Pic
142 
+                This scales the picture in elevenths around its own origin
143 
+                and returns that Pic. So if the Int is 22, the Pic will
144 
+                scaled by a factor of 2 (22/11).
145 
+                module: R_Picture
146 
+
147 
+scale_rel_Pic   Args: Vev Int Pic
148 
+                This is another scaling function, but it scales the image
149 
+                from the Vec, treating it as the origin.
150 
+                module: R_Picture
151 
+
152 
+mov_Pic         Args: Vec Pic
153 
+                This moves the Pic by the amount of the vector.
154 
+                module: R_Picture
155 
+
156 
+movto_Pic       Args: Vec Pic
157 
+                This moves the Pic's center to the Vec.
158 
+                module: R_Picture
159 
+
160 
+to_orig         Args: Pic
161 
+                This moves the Pic's center to the lower,left side of
162 
+                the Pic.
163 
+                module: R_Picture
164 
+
165 
+rot_Pic         Args: Vec Float Pic
166 
+                This rotates the Pic by the Float in radians, using the Vec
167 
+                as the origin of rotation.
168 
+                module: R_Picture
169 
+
170 
+twist_Pic       Args: Float Pic
171 
+                This rotates the Pic by the Float amount of radians around
172 
+                its own center.
173 
+                module: R_Picture
174 
+
175 
+rot_Pic'        Args: Vec Pic
176 
+                This rotates the Pic by a certain amount (set in R_Constants)
177 
+                using the Vec as the center of rotation. The set amount of
178 
+                rotation makes it faster than rot_Pic.
179 
+                module: R_Picture
180 
+
181 
+twist_Pic'      Args: Pic
182 
+                This rotates the Pic by a certain amoutn (set in R_Constants)
183 
+                around the Pic's origin. The set amount of rotation makes
184 
+                it faster than twist_Pic.
185 
+                module: R_Picture
186 
+
187 
+flipx_Pic       Args: Int Pic
188 
+                This flips the Pic around the line x=Int, essentially giving
189 
+                a mirror image of the Pic, reversing right and left.
190 
+                module: R_Picture
191 
+
192 
+
193 
+flipy_Pic       Args: Int Pic
194 
+                This flips the Pic around the line y=Int, mirror-imaging the
195 
+                Pic, reversing up and down.
196 
+                module: R_Picture
197 
+
198 
+flip_Pic        Args: Pic
199 
+                This flips the Pic around its own x-origin, reversing
200 
+                left and right.
201 
+                module: R_Picture
202 
+
203 
+flock_Pic       Args: Int Pic
204 
+                This takes the image Pic and copies it out Int*Int times in
205 
+                a Int by Int grid pattern, and returns that as an Pic.
206 
+                module: R_Picture
207 
+
208 
+set_Color       Args: Int Pic
209 
+                This takes an Int standing for a color, and changes the
210 
+                color of the Pic to that.
211 
+                module: R_Picture
212 
+\end{verbatim}
213 
+
214 
+\subsection{Other Functions for Manipulating Pics}
215 
+
216 
+\begin{verbatim}
217 
+i               Args: Any
218 
+                This will take anything and return an infinite stream of them.
219 
+                module: R_Utility
220 
+
221 
+osc             Args: [Any]
222 
+                This will take a Movie, which is a list of Pics and
223 
+                oscillate them.
224 
+                    [p1]           will give [p1,p1,p1,p1....]
225 
+                    [p1,p2,p3,p4]  will give [p1,p2,p3,p4,p3,p2,p1,p2...]
226 
+                module: R_Utility
227 
+\end{verbatim}
228 
+
229 
+\section{Behaviours and their Application to Movies}
230 
+
231 
+	A Behaviour is a list of functions that will convert one Pic to
232 
+another Pic. This list then can be applied to any Movie with one
233 
+of the application functions (most often apply). The beauty of the Behaviour
234 
+is that once you have a behaviour for moving left, you can move any
235 
+Movie left without rewriting the routine every time.
236 
+
237 
+	There are specific functions that take a Behaviour and a Movie and
238 
+return a new Movie. These are apply and while. If you had a Movie of a
239 
+man walking in place, and a Behaviour called left that moves Pics ever
240 
+increasing distances left, then you could create a man walking left by:
241 
+\begin{verbatim}
242 
+        apply left man
243 
+\end{verbatim}
244 
+
245 
+	If you want to apply more than one Behaviour to a Movie, you must first
246 
+decide whether to do that in sequence or in parallel, and use bSeq and bPar
247 
+to reduce the list of Behaviours to a single Behaviour, and then apply
248 
+that to a movie. For example:
249 
+\begin{verbatim}
250 
+        apply (bPar left up) gull
251 
+\end{verbatim}
252 
+will take a Movie of a gull and move the Pics up and left.
253 
+
254 
+	Most of the basic Behaviours are defined in R\_Behaviour.
255 
+
256 
+
257 
+\subsection{Defining Customized Packages of Behaviours}
258 
+
259 
+	Often you will have more specialized, or just simpler Behaviours you
260 
+want to use. Using the Behaviours and Pic-to-Pic functions, it is very
261 
+easy to create your own small library of Behaviours. R\_Defaults is a
262 
+module of such Behaviours. For example, to create a Behaviour to move
263 
+a Movie right, you  would create a list of mov\_Pic's, each taking a
264 
+everincreasingly large x-coordinate.
265 
+\begin{verbatim}
266 
+        right = [ mov_Pic (x,y) | (x,y) <- zip [0,10,..] [0,..] ]
267 
+\end{verbatim}
268 
+
269 
+	Or if you wanted a behavour to place a Movie at (100,100) twice as
270 
+large as before, you could create a new Behaviour from old ones as:
271 
+    scaleat= bPar [movto (i (100,100)), scale (i 22)]
272 
+
273 
+\subsection{Behaviours Available}
274 
+\begin{verbatim}
275 
+flip            Args: none
276 
+                This will flip every Pic around its x-origin, resulting in
277 
+                mirror images reversing left and right.
278 
+                module: R_Behaviour
279 
+
280 
+twist'          Args: none
281 
+                This will rotate each Pic by the amount rotunit (see
282 
+                R_Constants) around its origin.
283 
+                module: R_Behaviour
284 
+
285 
+mov             Args: [Vec]
286 
+                This will move each Pic by its corresponding vector.
287 
+                module: R_Behaviour
288 
+
289 
+movto           Args: [Vec]
290 
+                This will move each Pic's origin to its corresponding vector.
291 
+                module: R_Behaviour
292 
+
293 
+circ_mov        Args: Float Float
294 
+                This will move each Pic in a circle, of radius of the first
295 
+                Float and by an increment of the second Float, using (0,0)
296 
+                as the origin of rotation.
297 
+                module: R_Behaviour
298 
+
299 
+scale           Args: [Int]
300 
+                Scales every Pic on its origin by the the corresponding Int
301 
+                in the list. These Ints represents elevenths, so that a
302 
+                [2,2,...] will scale every Pic by 2/11 .
303 
+                module: R_Behaviour
304 
+
305 
+scale_rel       Args: Vec [Int]
306 
+                Same as scale, except that the Pics are all scaled using the
307 
+                Vec as the point of origin.
308 
+                module: R_Behaviour
309 
+
310 
+twist           Args: [Float]
311 
+                This will rotate every Pic by its corresponding Float from
312 
+                the list in radians.
313 
+                module: R_Behaviour
314 
+
315 
+set_color       Args: [Int]
316 
+                This sets each Pic to the color indicated by its
317 
+                corresponding int in the list.
318 
+                module: R_Behaviour
319 
+
320 
+rot             Args: [Vec] [Float]
321 
+                This will rotate each Pic around its corresponding Vec by
322 
+                its corresponding Float in radians.
323 
+                module: R_Behaviour
324 
+
325 
+big             Args: none
326 
+                Scales every Pic up by scaleunit
327 
+                module: R_Defaults
328 
+
329 
+huge            Args: none
330 
+                This scales every Pic up by 2*scaleunit
331 
+                module: R_Defaults
332 
+
333 
+small           Args: none
334 
+                This scales every Pic down by 10/11
335 
+                module: R_Defaults
336 
+
337 
+tiny            Args: none
338 
+                This scale every Pic down by 5/11
339 
+                module: R_Defaults
340 
+
341 
+bigger          Args: none
342 
+                This scales every Pic in the list by scaleunit more
343 
+                than the previous Pic, so that the n-th element is
344 
+                scaled up by (n-1)*scaleunit
345 
+                module: R_Defaults
346 
+
347 
+smaller         Args: none
348 
+                This scales every Pic down, so that the n-th element
349 
+		is scaled down by (n-1)*(10/11)
350 
+                module: R_Defaults
351 
+
352 
+ccw             Args: none
353 
+                This rotates every Pic by one rotunit more than the
354 
+                previous Pic, in a counterclockwise fashion.
355 
+                module: R_Defaults
356 
+
357 
+cw              Args: none
358 
+                This rotates every Pic by one rotunit more than the
359 
+                previous Pic, in a clockwise fashion.
360 
+                module: R_Defaults
361 
+
362 
+up              Args: none
363 
+                This moves every Pic up by one unit more than the
364 
+                Previous Pic, so that the n-th element is moved up
365 
+                (n-1) units.
366 
+                module: R_Defaults
367 
+
368 
+down            Args: none
369 
+                This is same as up, but the Pics move down.
370 
+                module: R_Defaults
371 
+
372 
+right           Args: none
373 
+                This is same as up, but the Pics move right.
374 
+                module: R_Defaults
375 
+
376 
+left            Args: none
377 
+                This is same as up, but the Pics move left.
378 
+                module: R_Defaults
379 
+\end{verbatim}
380 
+
381 
+\subsection{Functions For Behaviours}
382 
+
383 
+\begin{verbatim}
384 
+do              Args: Int Behaviour
385 
+                This takes the first Int elements of the Behaviour and
386 
+                return that.
387 
+                module: R_Behaviour
388 
+
389 
+rpt             Args: Int Behaviour
390 
+                This takes an Int and returns a Behaviour of length Int.
391 
+                However, the n-th Pic-to-Pic in the Behaviour returned
392 
+                is made up of the first through (n-1)the Pic-to-Pics of
393 
+                the input list.
394 
+                module: R_Behaviour
395 
+
396 
+forever         Args: Behaviour
397 
+                This makes a finite Behaviour list an infinite one by
398 
+                appending the list to itself endlessly.
399 
+                module: R_Behaviour
400 
+
401 
+apply           Args: Behaviour Movie
402 
+                This takes a Behaviour and applies it to a Movie
403 
+                module: R_Behaviour
404 
+
405 
+while           Args: (Boolean function) Behaviour Movie
406 
+                As long as the Boolean function evaluates true, this
407 
+                takes a Behaviour and applies it to a Movie. When it
408 
+                evaluates to false, no more Pics are produced and
409 
+                the Movie is cut short there.
410 
+                module: R_Behaviour
411 
+
412 
+bseq            Args: Behaviour Behaviour
413 
+                This takes two Behaviour and creates one Behaviour made
414 
+                up of the two inputs applies in sequence.
415 
+                module: R_Behaviour
416 
+
417 
+bSeq            Args: [Behaviour] Behaviour
418 
+                This takes two Behaviour and creates one Behaviour made
419 
+                up of the two inputs applies in sequence.
420 
+                module: R_Behaviour
421 
+
422 
+bpar            Args: Behaviour Behaviour
423 
+                This takes two Behaviour and creates one Behaviour made
424 
+                up of the two inputs applies in parallel.
425 
+                module: R_Behaviour
426 
+
427 
+bPar            Args: [Behaviour] Behaviour
428 
+                This takes two Behaviour and creates one Behaviour made
429 
+                up of the two inputs applies in parallel.
430 
+                module: R_Behaviour
431 
+\end{verbatim}
432 
+
433 
+\section{Creating the Final Movie}
434 
+
435 
+	Finally, you have your basic Movies made up of Pictures and Behaviours.
436 
+Now you need to combine them into one Movie. The functions that do this
437 
+are found in the module R\_Movie. These functions will take a list of
438 
+Movies and return a single Movie combining all the Movies in the list.
439 
+How they are combined can be controlled to some extent. Usually they are
440 
+just overlayed, but they can be put beside one another, or on top of
441 
+one another, or put a Vec distance apart.
442 
+
443 
+	It is also possible to use a combination of these forms. If you wanted
444 
+to overaly M1 and M2, and then put that beside M3, you would do:
445 
+\begin{verbatim}
446 
+        rBESIDE [M3, rOVERLAY [M1,M2] ]
447 
+\end{verbatim}
448 
+This is acceptable as rOVERLAY will return a single Movie.
449 
+
450 
+\subsection{Movie Combining Functions}
451 
+
452 
+\begin{verbatim}
453 
+rABOVE          Args: [Movie]
454 
+                Puts all the Movies into one movie, all above one another.
455 
+                module: R_Movie
456 
+
457 
+rBESIDE         Args: [Movie]
458 
+                Puts all the Movies into one movie, all beside one another.
459 
+                module: R_Movie
460 
+
461 
+rBESIDE2        Args: [Movie]
462 
+                Using their absolute coordinates, puts all the Movies
463 
+                beside one another.
464 
+                module: R_Movie
465 
+
466 
+rOVER           Args: [Movie]
467 
+                This lays the Movies on top of one another, centering
468 
+                each Pic so that they share the same origin.
469 
+                module: R_Movie
470 
+
471 
+rOVERLAY        Args: [Movie]
472 
+                This lays the Movies on top of one another, centering
473 
+                each Pic so that they share the smae origin.
474 
+                module: R_Movie
475 
+
476 
+pUT             Args: [Vec] Movie Movie
477 
+                This takes a list of Vec, and puts each Pic of the
478 
+                first Movie in the location of the corresponding
479 
+                Vec on top of the Pic of the second Movie and
480 
+                returns that list as the new Movie.
481 
+                module: R_Movie
482 
+
483 
+\end{verbatim}
484 
+
485 
+\section{Displaying Your Movie}
486 
+
487 
+	Once you have your function for the Movie defined, you need to output
488 
+it in some way. Currently, this is done by outputting characters to a file and
489 
+running a C Program in X-Windows that displays the contents of the file
490 
+as a graphic in the X system. First of all, you must convert the
491 
+Movie variable to a stream of characters. This is done by running
492 
+"showm" on the Movie. Be carefull you don't try to convert an infinite list
493 
+into characters as the compiler will take awhile to do this. Instead, take
494 
+a certain number of frames and convert them with "showm".
495 
+\begin{verbatim}
496 
+        man\_vm = rOVERLAY [man,vm]
497 
+        man\_vmstring = showm (take 20 man&vm)
498 
+\end{verbatim}
499 
+  Now that you have this string, you need to write it to disk. The
500 
+"writetofile" function does this. It takes a characater string(ie [Char] )
501 
+as an argument, and then prompts you for a filename. It then writes the
502 
+string to the filename. So to put man\_vm string into a file:
503 
+\begin{verbatim}
504 
+        main = writetofile man_vmstring
505 
+\end{verbatim}
506 
+and run the program, where you will prompted for the filename. Or you could:
507 
+\begin{verbatim}
508 
+        main = writetofile (showm (take 20 man_vm))
509 
+\end{verbatim}
510 
+to make it more compact.
511 
+
512 
+
513 
+\subsection{Miscellaneous Usefull Functions}
514 
+
515 
+\begin{verbatim}
516 
+inbetween       Args: Int Pic Pic
517 
+                This takes an Int and two Pics and returns a Movie
518 
+                with Int Pics interpolating between the two Pics.
519 
+                module: R_Inbetween
520 
+
521 
+tween           Args: Int Movie Movie
522 
+                This takes an Int and two Movies and returns one
523 
+                Movie made up of the first Movie, Int number of
524 
+                frames of Pics interpolating between the last
525 
+                Pic of the first Movie and the first Pic of the
526 
+                second Movie, followed by the second Movie
527 
+                module: R_Inbetween
528 
+
529 
+box             Args: Int Int Int
530 
+                This takes 3 Ints, the color, width and height of
531 
+                the box and returns a Pic of a box
532 
+                module: R_Shapes
533 
+
534 
+tri             Args: Int Vec Vec Vec
535 
+                This takes a color and three vectors and returns a
536 
+                Pic of a triangle of that colour with those vertices.
537 
+                module: R_Shapes
538 
+
539 
+circ            Args: Int Int Int
540 
+                This takes a color, the radius and the number of points
541 
+                around the circle, and returns a circle with origin at
542 
+                (0,0).
543 
+                module: R_Shapes
544 
+\end{verbatim}
545 
+
546 
+\pagebreak
547 
+\large {\bf Appendix:  C Programs to Display on X-Windows}
548 
+\\
549 
+\\
550 
+	The program currently used to run these graphics is called "xcshow".
551 
+This takes one argument, the name of the file to be run. When run
552 
+in X-Windows, it will produce a window with the first Pic. To run it, click
553 
+on the left mouse button inside the window. Clicking again will freeze it.
554 
+This will keep cycling through the file, replaying again when it hits the
555 
+end of the file, until the window is killed.
556 
+
557 
+	There is also "xshow" which is used to run the monochrome Movies, as
558 
+"xcshow" is used to run the color Movies. As this animation package
559 
+only produces color Movies, it isn't too usefull.
560 
+
561 
+
562 
+\pagebreak
563 
+\large {\bf References}
564 
+\\
565 
+\\
566 
+\begin{verbatim}
567 
+[ARYA88] "The Formal Analysis of a Functiona Animation System", Kevi Arya,
568 
+          DPhil,Thesis,Oxford University, Programming Research Group,
569 
+          April 1988
570 
+
571 
+[ARYA89] "Processes In A Functional Animation System", Kevi Arya,IBM
572 
+          T.J. Research Center, 1989
573 
+
574 
+[HASK90] "Report On The Programming Language Haskell, Version 1.0",
575 
+          YALEU/DCS/RR-777,Yale University,1990
576 
+\end{verbatim}
577 
+
578 
+\end{document}
progs/demo/X11/animation/palm.hs
History View file @ 4e98702
0 579 
new file mode 100644
... ... 
@@ -0,0 +1,47 @@
1 
+module Palm (main) where
2 
+
3 
+import Animation
4 
+import SeaFigs
5 
+
6 
+main = getEnv "DISPLAY" exit
7 
+       (\ host -> displaym host 30 trans)
8 
+
9 
+trans :: Movie
10 
+trans = manright++change++gull2
11 
+
12 
+manright::Movie
13 
+manright =  mirrorx (take 10 (apply left man))
14 
+
15 
+gull2::Movie
16 
+gull2 = apply (bPar [right,up,huge,huge,huge,(mov (i (275,0)))])  gull
17 
+
18 
+change::Movie
19 
+change = inbetween 5  manf1 gull1
20 
+              where gull1 = head gull2
21 
+	            manf1 = last manright
22 
+
23 
+
24 
+
25 
+mirrorx :: Movie -> Movie
26 
+mirrorx m = map (flipx_Pic x) m
27 
+              where (x,_)=orig_Movie m
28 
+
29 
+
30 
+orig_Movie :: Movie -> Vec
31 
+orig_Movie m = ((x2-x1) `div` 2,(y2-y1) `div` 2)
32 
+                  where x2 = reduce max (map maxx m)
33 
+                        x1 = reduce min (map minx m)
34 
+			y2 = reduce max (map maxy m)
35 
+			y1 = reduce min (map miny m)
36 
+
37 
+maxx :: Pic -> Int
38 
+maxx p = reduce max [x | (c,q) <- p, (x,y) <- q]
39 
+
40 
+minx :: Pic -> Int
41 
+minx p = reduce min [x | (c,q) <- p, (x,y) <- q]
42 
+
43 
+maxy :: Pic -> Int
44 
+maxy p = reduce max [y | (c,q) <- p, (x,y) <- q]
45 
+
46 
+miny :: Pic -> Int
47 
+miny p = reduce min [y | (c,q) <- p, (x,y) <- q]
progs/demo/X11/animation/palm.hu
History View file @ 4e98702
0 48 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+palm.hs
3 
+seafigs.hu
progs/demo/X11/animation/planets.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,30 @@
1 
+module Planets (main) where
2 
+
3 
+import Animation
4 
+
5 
+planets:: Float -> Float -> Int -> Int -> Int -> Int -> Movie
6 
+planets i1 i2 r1 r2 c1 c2
7 
+    = rOVERLAY
8 
+       [ apply f1 earth,
9 
+         apply (bpar f1 f2) moon
10 
+       ]
11 
+        where f1 = circ_mov (fromIntegral r1) i1
12 
+              f2 = circ_mov (fromIntegral r2) i2
13 
+              earth = osc [mov_Pic (vplus center (r1,0)) (box c1 30 30)]
14 
+              moon = osc [mov_Pic (vplus center (r1+r2,0)) (box c2 15 15)]
15 
+
16 
+gen a b c d = c :(gen a b (c+b) d)
17 
+
18 
+
19 
+planet_scene:: Movie
20 
+planet_scene = rOVERLAY
21 
+                 [apply (bpar (set_color (i yellow)) (movto (i center))) orb,
22 
+                  planets (pi/40.0) (pi/10.0) 450 80 darkblue lightblue,
23 
+                  planets (pi/20.0) (pi/8.0) 300 50 brown black,
24 
+                  planets (pi/10.0) (pi/4.0) 150 40 green red
25 
+                 ]
26 
+
27 
+orb = osc [circ red 50 10]
28 
+
29 
+main = getEnv "DISPLAY" exit
30 
+       (\ host -> displaym host 60 planet_scene)
progs/demo/X11/animation/planets.hu
History View file @ 4e98702
0 31 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+planets.hs
3 
+animation.hu
progs/demo/X11/animation/r_behaviour.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,158 @@
1 
+{-**********************************************************************
2 
+  MODULE R_BEHAVIOUR
3 
+
4 
+    This module defines the basic Behaviours available to manipulate
5 
+  Movies. These functions can either be used directly, or used to
6 
+  easily create personnalized Behaviours (see R_Defaults).
7 
+    There are the Behaviours that affect one Movie, which are mov,movto
8 
+  circ_mov,scale,scale_rel,rot,flip and set_color. These change some
9 
+  aspect of the movie over time.
10 
+    There are functions that combine several movies into one, namely
11 
+  bseq,bSeq,bpar and bPar.
12 
+    Some functions modify the Behaviours. These are do, rpt and forever.
13 
+  They put limits on how long the Behaviour is.
14 
+    Finally, there are the functions that apply the Behaviours to a Movie.
15 
+  These are apply and while. Apply applies a Behaviour to a Movie until
16 
+  it runs out of Movie or Behaviour. While takes a conditional and
17 
+  applies the Behaviour to it until that condition is fullfilled.
18 
+
19 
+***********************************************************************-}
20 
+
21 
+module R_Behaviour (mov,movto,circ_mov,scale,scale_rel,rot,flipb,
22 
+		    set_color,
23 
+   		    bseq,bSeq,bpar,bPar,
24 
+		    do,rpt,forever,
25 
+		    apply,while )  where
26 
+
27 
+import R_Ptypes
28 
+import R_Utility
29 
+import R_Picture
30 
+
31 
+  -- takes a Pic to Pic and makes an infinite list Behaviour out of it
32 
+makeb1 :: (Pic->Pic) -> Behaviour
33 
+makeb1 f = f : makeb1 f
34 
+
35 
+  -- takes a movie and flips it around the x-origin using flip_Pic
36 
+flipb :: Behaviour
37 
+flipb = makeb1 flip_Pic
38 
+
39 
+  -- twist makes twist_Pic into a Behaviour, rotating the image by rotunit
40 
+twist' :: Behaviour
41 
+twist' = makeb1 twist_Pic'
42 
+
43 
+  -- makeb2 makes a Behaviour out of a function that takes a list and a
44 
+  -- function and outputs a Behaviour.
45 
+makeb2 :: (a->Pic->Pic) -> [a] -> Behaviour
46 
+makeb2 f [] = []
47 
+makeb2 f (v:vs) = f v : makeb2 f vs
48 
+
49 
+  -- mov takes a list of Vec's and applies each Pic-to-Pic in the Behaviour
50 
+  -- list to its corresponding Vec, and gives back a new Behaviour
51 
+mov :: [Vec] ->Behaviour
52 
+mov = makeb2 mov_Pic
53 
+
54 
+  -- movto creates a list of Pic-to-Pic Behaviours that move each Pic to its
55 
+  -- corresponding Vec
56 
+movto :: [Vec] -> Behaviour
57 
+movto = makeb2 movto_Pic
58 
+
59 
+  -- produces a Behaviour that produces movement in a circle, taking
60 
+  -- the radius and the increment as arguments.
61 
+circ_mov :: Float -> Float -> Behaviour
62 
+circ_mov r inc = mov (map (vmin' (head vs')) vs')
63 
+                    where vs = [ (r*(cos theta),r*(sin theta)) |
64 
+                               theta <- gen inc 0.0  ]
65 
+                          vmin' x y = vmin y x
66 
+                          vs' = map vftov vs
67 
+
68 
+gen :: Float -> Float -> [Float]
69 
+gen b c = c : (gen b (c+b) )
70 
+
71 
+
72 
+  -- scale outputs a list of Pic-to-Pic's that scale according to its
73 
+  -- corresponding Int in the input list
74 
+scale :: [Int] -> Behaviour
75 
+scale = makeb2 scale_Pic
76 
+
77 
+  -- scale_rel does the same thing, but centers on the lower-left corner of
78 
+  -- the image
79 
+scale_rel :: Vec -> [Int] -> Behaviour
80 
+scale_rel v = makeb2 (scale_rel_Pic v)
81 
+
82 
+  -- twist outputs a list of Behaviours that rotate each pick by its
83 
+  -- corresponding Float in the list
84 
+twist :: [Float] -> Behaviour
85 
+twist = makeb2 twist_Pic
86 
+
87 
+  -- set_color takes a list of Colors, and returns a list of Pic-to-Pic's
88 
+  -- that change to the corresponding color in the list
89 
+set_color :: [Color] -> Behaviour
90 
+set_color = makeb2 set_Color_Pic
91 
+
92 
+  -- makeb3 takes a function with two inputs, and two input lists and
93 
+  -- returns a behaviour made up of functions with inputs fromt the lists
94 
+makeb3 :: (a->b->Pic->Pic) -> [a] -> [b] -> Behaviour
95 
+makeb3 f [] (p:ps) = []
96 
+makeb3 f (v:vs) [] = []
97 
+makeb3 f (v:vs) (p:ps) = f v p : makeb3 f vs ps
98 
+
99 
+  -- rot produces behaviours rotating by the Float, around the point
100 
+  -- of the Vec, both provided by lists.
101 
+rot :: [Vec] -> [Float] -> Behaviour
102 
+rot = makeb3 rot_Pic
103 
+
104 
+  -- bseq takes two Behaviours and combines them into one, in sequence.
105 
+  -- It first applies all of the first Behaviour, then all of the second
106 
+bseq :: Behaviour -> Behaviour -> Behaviour
107 
+bseq ps [] = []
108 
+bseq [] qs = []
109 
+bseq ps qs = ps ++ (mapc (last ps) qs)
110 
+
111 
+  -- bSeq takes a list of Behaviour and makes them into one Behaviour, in
112 
+  -- sequence.
113 
+bSeq :: [Behaviour] -> Behaviour
114 
+bSeq = reduce bseq
115 
+
116 
+  -- bpar takes two behaviours and applies them both simultaneously,
117 
+  -- producing a list of Pic-to-Pic's, each one made up of a function
118 
+  -- from the first list combined with a function from the second list
119 
+bpar :: Behaviour -> Behaviour -> Behaviour
120 
+bpar [] (q:qs) = []
121 
+bpar (p:ps) [] = []
122 
+bpar (p:ps) (q:qs) = (p.q):(bpar ps qs)
123 
+
124 
+  -- bPar takes a list of Behaviours and makes them all into one Behaviour,
125 
+  -- in paralell
126 
+bPar :: [Behaviour] -> Behaviour
127 
+bPar = reduce bpar
128 
+
129 
+  -- takes the first n POic-to-Pics in a Behaviour and returns that Behaviour
130 
+do :: Int -> Behaviour -> Behaviour
131 
+do n f = take n f
132 
+
133 
+  -- applies bseq to the list of behaviours, so that the nth element of
134 
+  -- the returned list has n-1 behaviours in it, applied in sequence
135 
+rpt :: Int -> Behaviour -> Behaviour
136 
+rpt n f = replicate n bseq [] f
137 
+
138 
+  -- takes the behaviour and applies all the behaviours up the nth element
139 
+  -- to the nth element, in an infinite list
140 
+forever :: Behaviour -> Behaviour
141 
+forever f = bseq f (forever f)
142 
+
143 
+  -- takes a behaviour, applies each from to a Pic in a Movie and returns
144 
+  -- the new Movie
145 
+apply :: Behaviour -> Movie -> Movie
146 
+apply [] ms = []
147 
+apply fs [] = []
148 
+apply (f:fs) (m:ms) = (f m):(apply fs ms)
149 
+
150 
+  -- applies the Behaviour to the Movie until the condition is fullfilled,
151 
+  -- then returns the movie to that point
152 
+while :: (Pic -> Bool) -> Behaviour -> Movie -> Movie
153 
+while c [] ms = []
154 
+while c fs [] = []
155 
+while c (f:fs) (m:ms) = if (c m) then ( (f m):(while c fs ms))
156 
+                        else []
157 
+
158 
+
progs/demo/X11/animation/r_behaviour.hu
History View file @ 4e98702
0 159 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+r_behaviour.hs
3 
+r_picture.hu
progs/demo/X11/animation/r_constants.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,129 @@
1 
+{-****************************************************************
2 
+   MODULE R_CONSTANTS
3 
+
4 
+     This module sets up all the constants used in this functional
5 
+   animation package.
6 
+     Defined here are the basic units of movement, scale and rotation.
7 
+   The screen height and width are set, and the various parts of
8 
+   the screen such as the top-middle, lower-left and center are
9 
+   all set. Finally the color values used by xcshow, the c-program
10 
+   that displays the movies in X, are set.
11 
+
12 
+******************************************************************-}
13 
+
14 
+module R_Constants (fps, unit, hf, qt, scaleunit, rotunit,
15 
+                    nullpic, nullseq,
16 
+                    sinunit,cosunit,
17 
+                    screenwid, screenht, botl, leftm, topl, topm, topr,
18 
+                    rightm, botr, botm, center,
19 
+		    white,black,red,green,darkblue,lightblue,brown,yellow,
20 
+		    colorName, allColors
21 
+			) where
22 
+
23 
+import R_Ptypes
24 
+
25 
+  -- units are set. The scaleunit is in 11th, so that the 12 is
26 
+  -- actually 12/11'ths
27 
+fps :: Int
28 
+unit :: Int
29 
+hf :: Int
30 
+qt :: Int
31 
+scaleunit :: Int
32 
+fps = 25
33 
+unit = 15
34 
+hf =  unit `div` 2
35 
+qt =  unit `div`4
36 
+scaleunit = 12
37 
+  --scaleunit is div'ed by 12 later
38 
+
39 
+rotunit :: Float
40 
+rotunit  = pi/18
41 
+sinunit  = sin rotunit
42 
+cosunit  = cos rotunit
43 
+
44 
+
45 
+nullpic :: Pic
46 
+nullpic = []
47 
+nullseq :: Movie
48 
+nullseq= nullpic : [ nullseq2 | nullseq2 <- nullseq]
49 
+
50 
+  -- Screen Parameters
51 
+screenwid :: Int
52 
+screenwid = 800
53 
+screenht :: Int
54 
+screenht  = 800
55 
+
56 
+botl :: Vec
57 
+leftm :: Vec
58 
+topl :: Vec
59 
+topm :: Vec
60 
+topr :: Vec
61 
+rightm :: Vec
62 
+botr :: Vec
63 
+botm :: Vec
64 
+center :: Vec
65 
+
66 
+leftmb :: Vec
67 
+leftmt :: Vec
68 
+topml :: Vec
69 
+topmr :: Vec
70 
+rightmt :: Vec
71 
+rightmb :: Vec
72 
+botml :: Vec
73 
+botmr :: Vec
74 
+
75 
+botl   = ( 0, 0 )
76 
+leftm  = ( 0, screenht `div` 2)
77 
+topl   = ( 0, screenht )
78 
+topm   = ( screenwid `div` 2, screenht )
79 
+topr   = ( screenwid, screenht )
80 
+rightm = ( screenwid, screenht `div` 2 )
81 
+botr   = ( screenwid, 0 )
82 
+botm   = ( screenwid `div` 2, 0 )
83 
+center = ( screenwid `div` 2, screenht `div` 2 )
84 
+
85 
+leftmb  = ( 0, screenht `div` 4 )
86 
+leftmt  = ( 0, (screenht*3) `div` 4 )
87 
+topml   = ( screenwid `div` 4, screenht )
88 
+topmr   = ( (screenwid*3) `div` 4, screenht )
89 
+rightmt = ( screenwid, (screenht*3) `div` 4 )
90 
+rightmb = ( screenwid, screenht `div` 4 )
91 
+botml   = ( screenwid `div` 4, 0 )
92 
+botmr   = ( (screenwid*3) `div` 4, 0 )
93 
+
94 
+  -- Colors values set to names
95 
+
96 
+white :: Color
97 
+white = 1
98 
+black :: Color
99 
+black = 2
100 
+red :: Color
101 
+red = 4
102 
+green :: Color
103 
+green = 6
104 
+darkblue :: Color
105 
+darkblue = 8
106 
+lightblue :: Color
107 
+lightblue = 10
108 
+yellow :: Color
109 
+yellow = 12
110 
+brown :: Color
111 
+brown = 14
112 
+
113 
+colorName :: Color -> String
114 
+colorName 1 = "white"
115 
+colorName 2 = "black"
116 
+colorName 4 = "red"
117 
+colorName 6 = "green"
118 
+colorName 8 = "blue"
119 
+colorName 10 = "lightblue"
120 
+colorName 12 = "yellow"
121 
+colorName 14 = "brown"
122 
+
123 
+allColors :: [Color]
124 
+allColors = [1,2,4,6,8,10,12,14]
125 
+
126 
+
127 
+
128 
+
129 
+
progs/demo/X11/animation/r_constants.hu
History View file @ 4e98702
0 130 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+r_constants.hs
3 
+r_ptypes.hu
progs/demo/X11/animation/r_curve.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,60 @@
1 
+{-**************************************************************
2 
+  MODULE R_CURVE
3 
+
4 
+    This module produces sequences of numbers to be used by
5 
+  Behaviours. The sequences used for moving or scaling can
6 
+  be produced here, in either linear sequences or accelerating
7 
+  and decelerating sequences.
8 
+    The acceleration functions produce floats, so the vftov function
9 
+  would have to be used to convert floating point vectors to integer
10 
+  vectors.
11 
+
12 
+***************************************************************-}
13 
+
14 
+module R_Curve(lnr,hold, acc, dec, accdec, decacc) where
15 
+
16 
+import R_Ptypes
17 
+import R_Constants
18 
+import R_Utility
19 
+import R_Picture
20 
+import R_Behaviour
21 
+
22 
+  -- lnr takes the start, finish and the number of intervals and
23 
+  -- produces a linear list of ints going from the start to finish.
24 
+lnr :: Int -> Int -> Int ->[Int]
25 
+lnr start fin n = take n [start,(start+step)..]
26 
+			where step = ((fin-start)`div`(n-1))
27 
+
28 
+  -- hold produces an infinite number of ints starting at v, modified
29 
+  -- by step every time.
30 
+hold :: Int -> Int -> [Int]
31 
+hold v step  = [v,v+step..]
32 
+
33 
+  -- acc accelerates from 0 to the max in n steps.
34 
+acc :: Int -> Int -> Int -> [Int]
35 
+acc min max n = min:acc' min (max-min) n 1
36 
+
37 
+acc' ::  Int -> Int -> Int -> Int -> [Int]
38 
+acc' min max n c | (c>n) = []
39 
+acc' min max n c         = (min + (((max*c*c) `div` (n*n))))
40 
+                           : (acc' min max n (c+1))
41 
+
42 
+
43 
+  -- dec decelerates from the max to 0 in n steps.
44 
+dec :: Int -> Int -> Int -> [Int]
45 
+dec min max n = reverse (acc min max n)
46 
+
47 
+  -- accdec accelerates from start up to max and back to fin, in an steps
48 
+  -- accelerating and dn steps decelerating
49 
+accdec :: Int -> Int -> Int -> Int -> Int -> [Int]
50 
+accdec start max fin an dn = (acc start max an)++(tail (dec fin max dn))
51 
+
52 
+  -- decacc decelerates from start to min in dn steps and then accelerates
53 
+  -- back up to fin in an more steps
54 
+decacc :: Int -> Int -> Int -> Int -> Int -> [Int]
55 
+decacc start min fin dn an = (dec min start dn)++(tail (acc min fin an))
56 
+
57 
+
58 
+
59 
+
60 
+
progs/demo/X11/animation/r_curve.hu
History View file @ 4e98702
0 61 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+r_curve.hs
3 
+r_behaviour.hu
progs/demo/X11/animation/r_defaults.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,76 @@
1 
+{-****************************************************************
2 
+  MODULE R_DEFAULTS
3 
+
4 
+    This module uses the R_Behaviour module to define convient and
5 
+  easy to use behaviours. These aren't very sophistated, but they
6 
+  can be used to quickly animate a movie. For more sophistated
7 
+  animation, a similiar library of sophistocated personnalized
8 
+  functions can be created.
9 
+
10 
+******************************************************************-}
11 
+
12 
+module R_Defaults (big, huge, bigger, smaller, ccw, cw,
13 
+                   up, down, left, right,small,tiny)
14 
+where
15 
+
16 
+import R_Ptypes
17 
+import R_Constants
18 
+import R_Utility
19 
+import R_Picture
20 
+import R_Behaviour
21 
+
22 
+
23 
+  -- big scales everything up by the scaleunit (now 12/11ths)
24 
+big :: Behaviour
25 
+big = [scale_Pic x | x <- [scaleunit,scaleunit..]]
26 
+
27 
+  -- huge scales everything up by twice the scaleunit (24/11ths)
28 
+huge :: Behaviour
29 
+huge= [scale_Pic x | x <- [scaleunit*2,(scaleunit*2)..]]
30 
+
31 
+  -- small scales everything down by 10/11ths
32 
+small :: Behaviour
33 
+small = [scale_Pic x | x <- [s,s..]]
34 
+        where s = 10
35 
+
36 
+  -- tiny scales everything down by 5/11ths
37 
+tiny :: Behaviour
38 
+tiny  = [scale_Pic x | x <- [s,s..]]
39 
+        where s = 5
40 
+
41 
+  -- bigger causes the Pics to be scaled up by 12/11ths,24/11ths,36/11ths
42 
+  -- and so on, everincreasing.
43 
+bigger :: Behaviour
44 
+bigger = [scale_Pic x | x <- (rept (\x -> div (x*scaleunit) 11) 1)]
45 
+
46 
+  -- smaller causes the Pics to be scaled downwards in ever decreasing
47 
+  -- amounts.
48 
+smaller :: Behaviour
49 
+smaller = [scale_Pic x | x <- (rept (\x -> div (x*10) 11) 1)]
50 
+
51 
+  -- a hardwired version of ccw that rotates the Pics by one rotunit
52 
+  -- more every Pic, counterclockwise.
53 
+ccw :: Behaviour
54 
+ccw = [twist_Pic x | x <- [0.0,rotunit..]]
55 
+
56 
+  -- same as ccw, but rotates the Pics clockwise
57 
+cw :: Behaviour
58 
+cw = [twist_Pic x | x <- [0.0,-rotunit..]]
59 
+
60 
+  -- moves the Pic up by one more unit every Pic.
61 
+up :: Behaviour
62 
+up    = [mov_Pic (x,y) | (x,y)<- zip2 [0,0..] [0,unit..]]
63 
+
64 
+  -- moves the Pic down by one more unit every Pic.
65 
+down :: Behaviour
66 
+down  = [mov_Pic (x,y) | (x,y)<-zip2 [0,0..] [0,-unit]]
67 
+
68 
+  -- moves the Pic left by one more unit every Pic.
69 
+left :: Behaviour
70 
+left  = [mov_Pic (x,y) | (x,y)<- zip2 [0,-unit..] [0,0..]]
71 
+
72 
+  -- moves the Pic right by one more unit every Pic.
73 
+right :: Behaviour
74 
+right = [mov_Pic (x,y) | (x,y)<- zip2 [0,unit..] [0,0..]]
75 
+
76 
+
progs/demo/X11/animation/r_defaults.hu
History View file @ 4e98702
0 77 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+r_defaults.hs
3 
+r_behaviour.hu
progs/demo/X11/animation/r_display.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,114 @@
1 
+module R_Display (displaym) where
2 
+
3 
+import R_Ptypes
4 
+import R_Utility
5 
+import Xlib
6 
+import R_Constants
7 
+
8 
+displaym :: String -> Int -> Movie -> IO ()
9 
+
10 
+displaym host n movie =
11 
+  let
12 
+    movie' = cycle (take n (map (map translatePoly) movie))
13 
+  in
14 
+  xOpenDisplay host
15 
+  `thenIO` \ display ->
16 
+  let (screen:_) = xDisplayRoots display
17 
+      fg_color = xScreenBlackPixel screen
18 
+      bg_color = xScreenWhitePixel screen
19 
+      color_map = xScreenDefaultColormap screen
20 
+      getPixels [] = returnIO []
21 
+      getPixels (c:cs) =
22 
+        xLookupColor color_map c `thenIO` \ (xc, _) ->
23 
+     	xAllocColor color_map xc `thenIO` \ (p,_,_) ->
24 
+        getPixels cs `thenIO` \ ps ->
25 
+        returnIO (p:ps)
26 
+  in
27 
+  getPixels (map colorName allColors)
28 
+  `thenIO` \ pixels ->
29 
+  let
30 
+    lookupPixel c = lookupPixel1 c allColors pixels
31 
+
32 
+    lookupPixel1 x []     _      = head pixels
33 
+    lookupPixel1 x (c:cs) (p:ps) =
34 
+      if x == c then p
35 
+                else lookupPixel1  x cs ps
36 
+    parent = xScreenRoot screen
37 
+  in
38 
+  xMArrayCreate [lookupPixel i | i <- [0..15]]
39 
+  `thenIO` \ pixelArray ->
40 
+  xCreateGcontext (XDrawWindow parent)
41 
+                  [XGCBackground bg_color,
42 
+                   XGCForeground fg_color]
43 
+  `thenIO` \ gcontext ->
44 
+  xCreateGcontext (XDrawWindow parent)
45 
+                  [XGCBackground bg_color,
46 
+                   XGCForeground bg_color]
47 
+  `thenIO` \ blank_gcontext ->
48 
+  xCreateWindow parent
49 
+                (XRect 100 100 500 500)
50 
+                [XWinBackground bg_color,
51 
+                 XWinEventMask (XEventMask [XButtonPress])]
52 
+  `thenIO` \window ->
53 
+  let depth = xDrawableDepth (XDrawWindow window)
54 
+  in
55 
+  xCreatePixmap (XSize 500 500) depth (XDrawWindow parent)
56 
+  `thenIO` \ pixmap ->
57 
+  xMapWindow window
58 
+  `thenIO` \() ->
59 
+  let
60 
+    dispFrame m =
61 
+      xDrawRectangle (XDrawPixmap pixmap)
62 
+                     blank_gcontext
63 
+		     (XRect 0 0 500 500)
64 
+		     True
65 
+      `thenIO_`
66 
+      dispPic m
67 
+      `thenIO_`
68 
+      xCopyArea (XDrawPixmap pixmap) gcontext (XRect 0 0 500 500)
69 
+                (XDrawWindow window) (XPoint 0 0)
70 
+      `thenIO_`
71 
+      xDisplayForceOutput display
72 
+
73 
+    dispPic [] = returnIO ()
74 
+    dispPic (p:ps) = dispPoly p `thenIO_` dispPic ps
75 
+
76 
+    dispPoly (c, vec) =
77 
+--      xLookupColor color_map (colorName c) `thenIO` \ ec ->
78 
+--      xAllocColor color_map ec `thenIO` \ p ->
79 
+      xMArrayLookup pixelArray c `thenIO` \p ->
80 
+      xUpdateGcontext gcontext [XGCForeground p] `thenIO` \ () ->
81 
+--      xSetGcontextForeground gcontext (lookupPixel c) `thenIO` \ () ->
82 
+      xDrawLines (XDrawPixmap pixmap) gcontext vec True
83 
+
84 
+    untilButton3 (frame:frames) =
85 
+      let
86 
+        action = dispFrame frame `thenIO_` untilButton3 frames
87 
+      in
88 
+      xEventListen display `thenIO` \count ->
89 
+      if count == 0 then action else
90 
+      xGetEvent display `thenIO` \event ->
91 
+        case (xEventType event) of
92 
+	 XButtonPressEvent ->
93 
+	   case (xEventCode event) of
94 
+	     3 -> returnIO ()
95 
+	     _ -> action
96 
+         _                       -> action
97 
+  in
98 
+  printString ("Click right button to end.\n") `thenIO_`
99 
+  untilButton3 movie' `thenIO_`
100 
+  xFreePixmap pixmap `thenIO_`
101 
+  xCloseDisplay display
102 
+
103 
+type Movie' = [Pic']
104 
+type Pic' = [Poly']
105 
+type Poly' = (Int, [XPoint])
106 
+
107 
+translatePoly :: Poly -> Poly'
108 
+translatePoly (c, vs) = (c, flatten_2 vs)
109 
+
110 
+flatten_2 []        = []
111 
+flatten_2 ((a,b):r) = (XPoint (a `div` 2) (b `div` 2)):(flatten_2 r)
112 
+
113 
+printString :: String -> IO ()
114 
+printString s = appendChan "stdout" s abort (returnIO ())
progs/demo/X11/animation/r_display.hu
History View file @ 4e98702
0 115 
new file mode 100644
... ... 
@@ -0,0 +1,6 @@
1 
+:o= foldr inline constant
2 
+r_constants.hu
3 
+r_utility.hu
4 
+r_ptypes.hu
5 
+r_display.hs
6 
+$HASKELL_LIBRARY/X11/xlib.hu
progs/demo/X11/animation/r_inbetween.hs
History View file @ 4e98702
0 7 
new file mode 100644
... ... 
@@ -0,0 +1,82 @@
1 
+{-******************************************************************
2 
+  MODULE R_INBETWEEN
3 
+
4 
+    This module takes care of interpolation functions. Basically,
5 
+  given two Pics, inbetween will give you a movie gradually
6 
+  converting from one Pic to the other Pic, using linear interpolation.
7 
+    Tween will take two Movies, and append them, interpolating n
8 
+  frames between the last Pic of the first Movie and the first Pic of
9 
+  the last Movie.
10 
+
11 
+******************************************************************-}
12 
+
13 
+module R_Inbetween (inbetween,tween) where
14 
+
15 
+import R_Ptypes
16 
+import R_Utility
17 
+import R_Picture
18 
+import R_Behaviour
19 
+
20 
+  -- inbetween takes an int and two Pics, and interpolates n Pics
21 
+  -- of interpolated Pics.
22 
+inbetween :: Int -> Pic -> Pic -> Movie
23 
+inbetween n p1 p2 | (length p1 == length p2) =
24 
+                       ((zip1.(map (inbetweenp n))).zip1) [p1,p2]
25 
+inbetween  n p1 p2       = inbetween n [(col,p1')] [(col,p2')]
26 
+                          where p1' = concat [ vs | (c,vs) <- p1]
27 
+                                p2' = concat [ vs | (c,vs) <- p2]
28 
+                                col = head [ c | (c,vs) <- p1 ]
29 
+
30 
+  -- inbetweenp takes a list of 2 Polygons ([[Vec]]) and returns a
31 
+  -- sequence of interpolated Polygons. Should the Number of vertices
32 
+  -- of one Polygon be less than those in the other, it splits it so
33 
+  -- as to have two Polygons of the same length.
34 
+inbetweenp :: Int -> Pic -> Pic
35 
+inbetweenp n  [(c1,vs),(c2,ws)] =
36 
+   if ((length vs) < (length ws)) then
37 
+         inbetween1 (split (length ws) (c1,vs)) (c2,ws) 0 n
38 
+   else if ((length vs) > (length ws)) then
39 
+         inbetween1 (c1,vs) (split (length vs) (c2,ws)) 0 n
40 
+   else inbetween1 (c1,vs) (c2,ws) 0 n
41 
+
42 
+
43 
+  -- inbetween1 returns a sequence of interpolated Polygons.
44 
+inbetween1 :: Poly -> Poly -> Int -> Int -> Pic
45 
+inbetween1 p1 p2 m n | m>n || n<=0 = []
46 
+inbetween1 p1 p2 m n               = inbetween2 p1 p2 m n
47 
+                                     :inbetween1 p1 p2 (m+1) n
48 
+
49 
+  -- inbetween2 returns ONE of the required sequence of
50 
+  -- interpolated Polygons.
51 
+inbetween2 :: Poly -> Poly -> Int -> Int -> Poly
52 
+inbetween2 (c1,vs) (c2,ws) p q = (c1, map (partway p q) (zip1 [vs,ws]))
53 
+
54 
+  -- split splits up a Polygon so as to have the given #vertices.
55 
+split :: Int -> Poly -> Poly
56 
+split n (c,vs) = (c, split' n vs)
57 
+
58 
+split' :: Int -> [Vec] -> [Vec]
59 
+split' n vs | n<= (length vs) = vs
60 
+split' n vs = if (n>double) then
61 
+                     split' n (split' double vs)
62 
+              else
63 
+                     v1:(mid v1 v2):(split' (n-2) (v2:vss))
64 
+              where double = 2*((length vs)) - 1
65 
+                    (v1:v2:vss) = vs
66 
+
67 
+
68 
+  -- tween will interpolate n Pics transforming the last Pic of
69 
+  -- the first Movie into the first Pic of the second Movie, and
70 
+  -- then run the second Movie
71 
+tween :: Int -> Movie -> Movie -> Movie
72 
+tween n m1 []   = m1
73 
+tween n m1 m2  = m1 ++ (inbetween n (last m1) (head m2')) ++ (tail m2')
74 
+            where m2' = apply (mov (repeat v)) m2
75 
+                  v = vmin (orig_Pic (last m1)) (orig_Pic (head m2))
76 
+
77 
+  -- tweens will take a list of Movies and append them all, interpolating
78 
+  -- n frames between every Movie.
79 
+tweens :: Int -> [Movie] -> Movie
80 
+tweens n = foldr (tween n) []
81 
+
82 
+
progs/demo/X11/animation/r_inbetween.hu
History View file @ 4e98702
0 83 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+r_inbetween.hs
3 
+r_behaviour.hu
progs/demo/X11/animation/r_movie.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,114 @@
1 
+{-*********************************************************************
2 
+  MODULE R_MOVIE
3 
+
4 
+    This module contains necessary functions for editing Movies. There
5 
+  are several that give information on a Movie, such as the heights or
6 
+  wirdths of its Pics. The others all deal with the various ways of
7 
+  combining various Movies into one Movie, a vital set of functions.
8 
+
9 
+*********************************************************************-}
10 
+
11 
+module R_Movie (ht, wid, orig,
12 
+                above, rABOVE, beside, rBESIDE,rBESIDE2, over, rOVER,
13 
+                overlay, rOVERLAY, pUT,
14 
+                uncurry, curry
15 
+                ) where
16 
+
17 
+import R_Ptypes
18 
+import R_Constants
19 
+import R_Utility
20 
+import R_Picture
21 
+
22 
+  -- takes a function and a list and returns a new list of element operated
23 
+  -- on by the function.
24 
+promote:: (a->b)->[a]->[b]
25 
+promote f []     = []
26 
+promote f [p]    = f p:promote f [p]
27 
+promote f (p:ps) = f p:promote f ps
28 
+
29 
+  -- promote1 takes a function that analyzes a Pic, and then applies it
30 
+  -- to analyse a movie, returning a list.
31 
+promote1:: (Pic->a) -> Movie -> [a]
32 
+promote1 f ps = [f p | p <- ps]
33 
+
34 
+  -- ht takes a Movie and returns a list of the heights of the Pics
35 
+ht :: Movie -> [Int]
36 
+ht   = promote1 ht_Pic
37 
+
38 
+  -- wid takes a Movie and returns a list of the widths of the Pics
39 
+wid :: Movie -> [Int]
40 
+wid  = promote1 wid_Pic
41 
+
42 
+  -- orig takes a Movie and returns a list of vectors that are the
43 
+  -- origins of the Pics
44 
+orig:: Movie -> [Vec]
45 
+orig = promote1 orig_Pic
46 
+
47 
+  -- promote2 takes a function accepting an element and a Pic, and
48 
+  -- applies the function to the Movie and list, producing a new Movie
49 
+promote2:: (a->Pic->Pic) -> [a] -> Movie -> Movie
50 
+promote2 f ps qs = [f p q | (p,q) <- zip2 ps qs]
51 
+
52 
+  -- takes two Movies and puts them above one another
53 
+above:: Movie -> Movie -> Movie
54 
+above = promote2 above_Pic
55 
+
56 
+  -- takes a list of Movies and puts them all above one another
57 
+rABOVE:: [Movie] -> Movie
58 
+rABOVE = reduce above
59 
+
60 
+  -- takes two Movies and puts them beside one another
61 
+beside:: Movie -> Movie -> Movie
62 
+beside = promote2 beside_Pic
63 
+
64 
+  -- takes a list of Movies and puts them all beside one another
65 
+rBESIDE:: [Movie] -> Movie
66 
+rBESIDE = reduce beside
67 
+
68 
+  -- same as beside, but with absolute coordinates.
69 
+beside2:: Movie -> Movie -> Movie
70 
+beside2 = promote2 beside2_Pic
71 
+
72 
+  -- same as rBESIDE, but with absolute coordinates.
73 
+rBESIDE2:: [Movie] -> Movie
74 
+rBESIDE2 = reduce beside2
75 
+
76 
+  -- puts one Movie on top of the other Movie
77 
+over:: Movie -> Movie -> Movie
78 
+over = promote2 over_Pic
79 
+
80 
+  -- takes a list of Movies, and puts the n-th on top of the first
81 
+  -- through 9n-1)th.
82 
+rOVER:: [Movie] -> Movie
83 
+rOVER = reduce over
84 
+
85 
+  -- just overlays the two Movies by appending the Pics.
86 
+overlay:: Movie -> Movie -> Movie
87 
+overlay = promote2 overlay_Pic
88 
+
89 
+  -- overlays a list of Movies by appending the Pics
90 
+rOVERLAY:: [Movie] -> Movie
91 
+rOVERLAY = reduce overlay
92 
+
93 
+  -- promote3 takes a function that takes two items and a Pic and
94 
+  -- returns a Pic, and then applies it to two input lists and a Movie,
95 
+  -- producing a new Movie.
96 
+promote3:: (a->b->Pic->Pic) -> [a] -> [b] -> Movie -> Movie
97 
+promote3 f ps qs rs = [f p q r | (p,q,r) <- zip3 ps qs rs]
98 
+
99 
+  -- pUT takes a list of Vectors, and puts each Pic of the first Movie
100 
+  -- in the location of the corresponding vector, on top  of the Pic of
101 
+  -- the second Movie, and returns that list as a new Movie.
102 
+pUT:: [Vec] -> Movie -> Movie -> Movie
103 
+pUT = promote3 put_Pic
104 
+
105 
+  -- uncurry takes a function that takes two elements and a list of
106 
+  -- two elements and applies the function to them.
107 
+uncurry:: (a->a->b) -> [a] -> b
108 
+uncurry f [a,b] = f a b
109 
+
110 
+  -- curry takes a function that takes a list, and two elements, and
111 
+  -- then applies the function to the elements in a list.
112 
+curry:: ([a]->b) -> a -> a -> b
113 
+curry f a b = f [a,b]
114 
+
progs/demo/X11/animation/r_movie.hu
History View file @ 4e98702
0 115 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+r_movie.hs
3 
+r_picture.hu
progs/demo/X11/animation/r_picture.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,188 @@
1 
+{-************************************************************
2 
+   MODULE R_PICTURE
3 
+
4 
+     This module contains all the functions that can be used to manipulate
5 
+   Pic's. The user will probably never use any of these functions. They
6 
+   are used by Behaviours and such higher-order functions, which apply
7 
+   these routines to all the Pic's in the list.
8 
+
9 
+*************************************************************-}
10 
+
11 
+module R_Picture (close_Pic, ht_Pic, wid_Pic, orig_Pic,
12 
+                  overlay_Pic, put_Pic, over_Pic, above_Pic, beside_Pic,
13 
+                  map_Pic,beside2_Pic,
14 
+                  scale_Pic, scale_rel_Pic, mov_Pic, rot_Pic, twist_Pic,
15 
+                  twist_Pic', flipx_Pic, flipy_Pic, flip_Pic, {- flock_Pic, -}
16 
+                  set_Color_Pic,
17 
+                  to_orig_Pic,
18 
+		  movto_Pic
19 
+                  ) where
20 
+
21 
+import R_Ptypes
22 
+import R_Constants
23 
+import R_Utility
24 
+
25 
+  -- close_Pic makes sure that the polygon is closed
26 
+close_Pic:: Pic -> Pic
27 
+close_Pic p = map close_Poly p
28 
+              where
29 
+              close_Poly (c,ply) | (head ply) == (last ply) = (c,ply)
30 
+              close_Poly (c,ply)       = (c,ply++(tail (reverse ply)))
31 
+
32 
+  --these functions find the max and min x and y coordinates of a Pic
33 
+maxx :: Pic -> Int
34 
+maxx p = reduce max [x | (c,q) <- p, (x,y) <- q]
35 
+
36 
+minx :: Pic -> Int
37 
+minx p = reduce min [x | (c,q) <- p, (x,y) <- q]
38 
+
39 
+maxy :: Pic -> Int
40 
+maxy p = reduce max [y | (c,q) <- p, (x,y) <- q]
41 
+
42 
+miny :: Pic -> Int
43 
+miny p = reduce min [y | (c,q) <- p, (x,y) <- q]
44 
+
45 
+  -- these functions find the height, width and origin of a Pic
46 
+ht_Pic :: Pic -> Int
47 
+ht_Pic p = (maxy p) - (miny p)
48 
+
49 
+wid_Pic :: Pic -> Int
50 
+wid_Pic p = (maxx p) - (minx p)
51 
+
52 
+orig_Pic:: Pic -> Vec
53 
+orig_Pic p = ( (maxx p + minx p) `div` 2, (maxy p + miny p) `div` 2 )
54 
+
55 
+-- PICTURE COMBINING OPERATIONS:
56 
+
57 
+  -- overlay_Pic just takes 2 Pics and puts them together into one
58 
+overlay_Pic:: Pic -> Pic -> Pic
59 
+overlay_Pic p q = p ++ q
60 
+
61 
+  -- put_Pic overlays the Pics, offsetting the first Pic by a vector
62 
+  -- amount from the origin of the second
63 
+put_Pic:: Vec -> Pic -> Pic -> Pic
64 
+put_Pic v p q = overlay_Pic
65 
+                     (movto_Pic (vplus (orig_Pic q) v) p )
66 
+                     q
67 
+
68 
+  -- over_Pic puts one Pic directly on top of the other
69 
+over_Pic:: Pic -> Pic -> Pic
70 
+over_Pic p q = put_Pic (0,0) p q
71 
+
72 
+  -- above_Pic puts the first Pic on top of the second
73 
+above_Pic:: Pic -> Pic -> Pic
74 
+above_Pic p q = put_Pic (0,(((ht_Pic q) + (ht_Pic p)) `div` 2)) p q
75 
+
76 
+  -- beside_Pic puts the first Pic beside the second. The width of
77 
+  -- the Pic is defined as the max x minus the min x, so a moving
78 
+  -- figure will stand still in this implementation
79 
+beside_Pic:: Pic -> Pic -> Pic
80 
+beside_Pic p q = put_Pic (((wid_Pic q)+(wid_Pic p)) `div` 2, 0) p q
81 
+
82 
+  -- beside2_Pic puts the first Pic beside the second, without
83 
+  -- shifting to the width of the Pic. It uses the absolute coordinates.
84 
+beside2_Pic:: Pic -> Pic -> Pic
85 
+beside2_Pic p q = put ((wid_Pic q), 0) p q
86 
+     where put v p q = overlay_Pic (mov_Pic v p) q
87 
+
88 
+
89 
+  -- The following maps a given function over the Vector-list of each Polygon:
90 
+map_Pic:: (Vec -> Vec) -> Pic -> Pic
91 
+map_Pic f p = map f' p
92 
+              where f' (c,vs) = (c, map f vs)
93 
+
94 
+-- THE GEOMETRIC TRANSFORMATIONS:
95 
+
96 
+  -- scales the Pic by r, where r is in units of 11th. ie r=1, the Pic is
97 
+  -- scaled by 1/11 to its origin.
98 
+scale_Pic :: Int -> Pic -> Pic
99 
+scale_Pic r p
100 
+   = map_Pic (scalep r) p
101 
+     where scalep r (v1,v2) = (div ((r*(v1-dx))+dx) 11,div ((r*(v2-dy))+dy) 11)
102 
+           dx = fst (orig_Pic p)
103 
+           dy = snd (orig_Pic p)
104 
+
105 
+  -- this is another scaling function, but it centers the image at the Vec
106 
+scale_rel_Pic :: Vec -> Int -> Pic -> Pic
107 
+scale_rel_Pic v r
108 
+   = map_Pic (scalep r)
109 
+     where scalep r (v1,v2) = (div ((r*(v1-dx))+dx) 11,div ((r*(v2-dy))+dy) 11)
110 
+           dx = fst v
111 
+           dy = snd v
112 
+
113 
+  -- moves a Pic by the vector amount
114 
+mov_Pic:: Vec -> Pic -> Pic
115 
+mov_Pic v = map_Pic (vplus v)
116 
+
117 
+  -- moves a Pic to the vector
118 
+movto_Pic:: Vec -> Pic -> Pic
119 
+movto_Pic v p = mov_Pic (vmin v (orig_Pic p)) p
120 
+
121 
+  -- moves the origin of the Pic to the lower left side of the Pic
122 
+to_orig_Pic:: Pic -> Pic
123 
+to_orig_Pic p = mov_Pic (-mx,-my) p
124 
+                where mx = minx p
125 
+                      my = miny p
126 
+
127 
+  -- rotates the Pic about the Vector by theta
128 
+rot_Pic :: Vec -> Float -> Pic -> Pic
129 
+rot_Pic (a,b) theta
130 
+                   = map_Pic  (rotp (a,b) theta)
131 
+                     where rotp (a,b) t (v1,v2)
132 
+                             = vftov (a2+ (u * cos theta - v * sin theta),
133 
+                                      b2+ (u * sin theta + v * cos theta))
134 
+                                where u =  u1 -a2
135 
+                                      v =  u2 -b2
136 
+				      (u1,u2) = vtovf (v1,v2)
137 
+ 				      (a2,b2) = vtovf (a,b)
138 
+
139 
+  -- rotates a Pic about its origin by theta
140 
+twist_Pic :: Float -> Pic -> Pic
141 
+twist_Pic theta p = rot_Pic (orig_Pic p) theta p
142 
+
143 
+
144 
+  -- hardwired version of rot_Pic that runs faster by rotating a set
145 
+  -- unit, the rotunit, every time
146 
+rot_Pic':: Vec -> Pic -> Pic
147 
+rot_Pic' (a,b) = map_Pic (rotp (a,b))
148 
+                 where rotp (a,b) (v1,v2)
149 
+                         = vftov (a2+ (u * cosunit - v * sinunit),
150 
+                                  b2+ (u * sinunit + v * cosunit))
151 
+                            where u = u1-a2
152 
+                                  v = u2-b2
153 
+				  (u1,u2) = vtovf (v1,v2)
154 
+				  (a2,b2) = vtovf (a,b)
155 
+
156 
+  -- hardwired version of twist_Pic that runs faster using rot_Pic'
157 
+twist_Pic':: Pic -> Pic
158 
+twist_Pic' p = rot_Pic' (orig_Pic p) p
159 
+
160 
+  -- flips the Pic about the line x=n (x-coordinates change)
161 
+flipx_Pic :: Int -> Pic -> Pic
162 
+flipx_Pic n  = map_Pic (flipvx n)
163 
+               where
164 
+               flipvx n (a,b) = (2*(n-a)+a,b)
165 
+
166 
+  -- flips the Pic about the line y=n (y-coordinates change)
167 
+flipy_Pic :: Int -> Pic -> Pic
168 
+flipy_Pic n = map_Pic (flipvy n)
169 
+              where
170 
+              flipvy n (a,b) = (a, 2*(n-b)+b)
171 
+
172 
+  -- flips the Pic about its own x origin.
173 
+flip_Pic:: Pic -> Pic
174 
+flip_Pic p = map_Pic (flipvx x) p
175 
+             where (x,y) = orig_Pic p
176 
+                   flipvx n (a,b) = (2*(n-a)+a,b)
177 
+
178 
+  -- copies the Pic into another Pic n*n times in an n by n array pattern
179 
+flock_Pic :: Int -> Pic -> Pic
180 
+flock_Pic 1 p = p
181 
+flock_Pic (n+2) p = beside_Pic (flock_Pic (n-1) p) (row n p)
182 
+                    where row n p = replicate n above_Pic nullpic p
183 
+
184 
+  -- changes the color of the Pic
185 
+set_Color_Pic:: Color -> Pic -> Pic
186 
+set_Color_Pic c p = map f p
187 
+                    where f (c',vs) = (c,vs)
188 
+
progs/demo/X11/animation/r_picture.hu
History View file @ 4e98702
0 189 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+:o= all
2 
+r_picture.hs
3 
+r_constants.hu
4 
+r_utility.hu
progs/demo/X11/animation/r_ptypes.hs
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,67 @@
1 
+{-***********************************************************************
2 
+   MODULE PTYPES
3 
+
4 
+     This module contains the definitions for all the basic datatypes used to
5 
+   create functional movies.
6 
+     The basis of all the images is the Poly, which is a tuple of a color
7 
+   and a list of points. This is displayed as a polygon of that color. The
8 
+   form is a line drawn to each of the points, in order.
9 
+     A list of these Poly's is a Pic, or picture. Each picture is a single
10 
+   frame of the movie. A list of Pic's makes up a Movie, which is a series
11 
+   of Pic's displayed in order.
12 
+     Behaviours affect the movies, such as moving them left, or right.
13 
+     PictoPic's affect a single picture.
14 
+     The other functions simply convert regular values such as integers
15 
+   and floats to the datatypes used by the functional programming.
16 
+
17 
+************************************************************************-}
18 
+
19 
+
20 
+module R_Ptypes (Vec(..), Color(..), Pic(..), Poly(..), Movie(..), Behaviour(..), PictoPic(..), Process(..),
21 
+		 Vecfloat(..),
22 
+                 Msg(..), Chan(..),
23 
+                 Val (..),
24 
+                 ntov, vtov, nstov, vstov, pstov, bstov
25 
+                )   where
26 
+
27 
+
28 
+  --These are the basic data types for storing and manipulating the movies.
29 
+
30 
+type Vec = (Int,Int)
31 
+type Color = Int
32 
+type Pic = [Poly]
33 
+type Poly = (Color,[Vec])
34 
+type Movie = [Pic]
35 
+type Behaviour = [Pic -> Pic]
36 
+type PictoPic  = Pic -> Pic
37 
+
38 
+type Process = [Msg] -> [Msg]
39 
+type Msg     = [(Chan,Val)]
40 
+type Chan    = [Char]
41 
+
42 
+data Val     = N Int | V (Int,Int) | P Pic | B PictoPic
43 
+
44 
+type Vecfloat = (Float,Float)
45 
+
46 
+
47 
+
48 
+--Those convert from the various regular values to Val's.
49 
+
50 
+ntov n   = N n
51 
+
52 
+vtov:: Vec -> Val
53 
+vtov v   = V v
54 
+
55 
+ptov:: Pic -> Val
56 
+ptov  p  = P p
57 
+
58 
+nstov ns = [N n|n<-ns]
59 
+
60 
+vstov:: [Vec] -> [Val]
61 
+vstov vs = [V v|v<-vs]
62 
+
63 
+pstov:: [Pic] -> [Val]
64 
+pstov ps = [P p|p<-ps]
65 
+
66 
+bstov:: [PictoPic] -> [Val]
67 
+bstov bs = [B b|b<-bs]
progs/demo/X11/animation/r_ptypes.hu
History View file @ 4e98702
0 68 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+:o= all
2 
+r_ptypes.hs
progs/demo/X11/animation/r_shapes.hs
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,38 @@
1 
+{-*****************************************************************
2 
+  MODULE R_SHAPES
3 
+
4 
+    This modules produces Pic's of boxes and triangles to help build
5 
+  Pic's to animate.
6 
+
7 
+******************************************************************-}
8 
+
9 
+module R_Shapes (box, tri, circ_mov, circ) where
10 
+
11 
+import R_Ptypes
12 
+import R_Utility
13 
+import R_Picture
14 
+import R_Behaviour
15 
+
16 
+  -- box takes four three ints, the color, width and height of the box and
17 
+  -- returns a Pic of a box
18 
+box :: Int -> Int -> Int -> Pic
19 
+box c width height= [(c,[(0,0),(width,0),(width,height),(0,height),(0,0)])]
20 
+
21 
+  -- tri takes a color and three vectors, and returns a Pic of a triangle
22 
+  -- with the vectors as vertices
23 
+tri:: Color -> Vec -> Vec -> Vec -> Pic
24 
+tri c (x1,y1) (x2,y2) (x3,y3) = [(c,[(x1,y1),(x2,y2),(x3,y3),(x1,y1)])]
25 
+
26 
+
27 
+  -- circ takes a color, the radius
28 
+circ :: Color -> Int -> Int -> Pic
29 
+circ c r inc = [(c,(r+r,r):(circ' r' inc' 1.0))]
30 
+               where r' = (fromIntegral r)
31 
+                     inc' = (fromIntegral inc)
32 
+
33 
+circ' :: Float -> Float -> Float  -> [Vec]
34 
+circ' r inc c | c>inc = []
35 
+circ' r inc c         = vftov (x+r,y+r) : (circ' r inc (c+1.0))
36 
+                	where x = r*(cos((2*c*pi)/inc))
37 
+                      	      y = r*(sin((2*c*pi)/inc))
38 
+
progs/demo/X11/animation/r_shapes.hu
History View file @ 4e98702
0 39 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+r_shapes.hs
3 
+r_behaviour.hu
progs/demo/X11/animation/r_utility.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,150 @@
1 
+{-*********************************************************************
2 
+    MODULE R_UTILITY
3 
+
4 
+      This module contains all the basic utility functions that the other
5 
+    modules need to have to write their code. These are made generally
6 
+    low level functions, manipulating vectors or defining very
7 
+    general functions
8 
+
9 
+**********************************************************************-}
10 
+
11 
+
12 
+module R_Utility (vtovf,vftov,
13 
+		  vplus, vmin, mid, partway,
14 
+                  mag,
15 
+                  reduce, power, i,
16 
+                  member, repeat, zip1, zip2, zip3, rept, replicate,
17 
+                  mapc,
18 
+                  append, flatten, rptseq, osc
19 
+                  ) where
20 
+
21 
+import R_Ptypes
22 
+
23 
+
24 
+-- CONVERSION
25 
+
26 
+  -- vtovf takes a vector of integers, and converts it to a vector of floats
27 
+vtovf :: Vec -> Vecfloat
28 
+vtovf (x,y) = (fromIntegral x,fromIntegral y)
29 
+
30 
+  -- vftov takes a vector of floats and converts it to a vector of integers.
31 
+  -- It rounds the floats off to do this.
32 
+vftov :: Vecfloat -> Vec
33 
+vftov (x,y) = (round x,round y)
34 
+
35 
+
36 
+-- VECTOR OPERATIONS:
37 
+
38 
+  -- vector addition
39 
+vplus:: Vec -> Vec -> Vec
40 
+vplus (a,b) (c,d) = (a+c,b+d)
41 
+
42 
+  -- vector substraction
43 
+vmin:: Vec -> Vec -> Vec
44 
+vmin (a,b) (c,d) = (a-c,b-d)
45 
+
46 
+  -- finds the midpoint between two vectors
47 
+mid:: Vec -> Vec -> Vec
48 
+mid (x1,y1) (x2,y2) = (div (x1+x2) 2,div (y1+y2) 2 )
49 
+
50 
+  -- finds a point p/q along the way between two vectors
51 
+partway :: Int -> Int -> [Vec] -> Vec
52 
+partway p q [(x1,y1),(x2,y2)]
53 
+        = vplus (x1,y1) ( div (p*(x2-x1)) q, div (p*(y2-y1)) q )
54 
+
55 
+  -- finds the magnitude of two vectors
56 
+mag :: Vec -> Int
57 
+mag p = round (magfloat (vtovf p))
58 
+
59 
+magfloat :: Vecfloat -> Float
60 
+magfloat (x,y) = sqrt (x*x + y*y)
61 
+
62 
+  -- returns a vector at right angles to the input vector
63 
+normal:: Vec -> Vec
64 
+normal (x,y) = (-y,x)
65 
+
66 
+  -- returns the first vector projected onto the second
67 
+project:: Vec -> Vec -> Vec
68 
+project (vx,vy) (wx,wy) = partway (vx*wx+vy*wy) (mw*mw) [(0,0),(wx,wy)]
69 
+			     where mw = mag (wx,wy)
70 
+
71 
+
72 
+-- HIGHER-ORDER FUNCTIONS:
73 
+
74 
+  -- just foldr1. It applies a function of two inputs to an entire list
75 
+  -- recursively, and displays the single element result
76 
+reduce :: (a->a->a) -> [a] -> a
77 
+reduce = foldr1
78 
+
79 
+  -- power applies a single function n times to a seed
80 
+power :: Int -> (a->a) -> a -> a
81 
+power 0 f seed = seed
82 
+power (n+1) f seed = f (power n f seed)
83 
+
84 
+  -- i takes an element and returns an infinite list of them
85 
+i :: a -> [a]
86 
+i x = x: (i x)
87 
+
88 
+  -- checks to see if x is in the list of xs
89 
+member :: (Eq a) => [a] -> a -> Bool
90 
+member [] x = False
91 
+member (y:ys) x = x == y || member ys x
92 
+
93 
+  -- zip1 takes lists of lists, and rearranges them so that all the first
94 
+  -- elements are in the first list, all the second in the second and so on.
95 
+zip1 :: (Eq a) => [[a]] -> [[a]]
96 
+zip1 xs | member xs [] = []
97 
+zip1 xs = (map head xs):(zip1 (map tail xs))
98 
+
99 
+  -- takes two lists and makes a list of tuples.
100 
+zip2 :: [a] -> [b] -> [(a,b)]
101 
+zip2=zip
102 
+
103 
+  -- rept takes a function and a list of elements, and applies the function
104 
+  -- n-1 times to the n-th element
105 
+rept :: (a->a) -> a -> [a]
106 
+rept f x =  x:(rept f (f x))
107 
+
108 
+  -- replicate creates an list n elements long of a, with the function
109 
+  -- applies to the n-th element n-1 times.
110 
+replicate :: Int -> (a->a->a) -> a -> a -> a
111 
+replicate 0 f zero a = zero
112 
+replicate 1 f zero a = a
113 
+replicate (n+2) f zero a = f a (replicate (n+1) f zero a)
114 
+
115 
+  -- mapc is a map function for lists of functions (behaviours)
116 
+mapc :: (a->b) -> [c->a] -> [c->b]
117 
+mapc f as = [f.a | a <- as]
118 
+
119 
+
120 
+-- FUNCTIONS OVER SEQUENCES:
121 
+
122 
+  -- append takes a list of lists, and makes them into one giant happy list.
123 
+append :: [[a]] -> [a]
124 
+append = foldr (++) []
125 
+
126 
+  -- flatten takes a list of lists of tuples and gives one giant happy list
127 
+  -- of single elements back.
128 
+flatten:: [[(a,a)]] -> [a]
129 
+flatten s = foldr f []  (append s)
130 
+            where f (x,y) [] = [x,y]
131 
+                  f (x,y) (z:zs) = x:y:(z:zs)
132 
+
133 
+  -- rptseq takes a list of elements and applies a function to them,
134 
+  -- n-1 times for the n-th element, but using map
135 
+rptseq :: (a->a) -> [a] -> [a]
136 
+rptseq f [] = []
137 
+rptseq f (x:xs) = x:rptseq f (map f xs)
138 
+
139 
+  -- osc takes a list, and makes sure it oscillates. If the head is
140 
+  -- equal to the tail, it simply repeats the sequence infinitely. If
141 
+  -- the head is not equal to the tail, it adds the sequence then adds
142 
+  -- the reversed sequence minus the first and last elements, and then repeats
143 
+osc :: [a] -> [a]
144 
+osc s  | (length s) == 0 = []
145 
+osc s  | (length s) == 1 = head s: osc s
146 
+osc s           = (s ++ (((tail.reverse).tail) s)) ++ (osc s)
147 
+
148 
+
149 
+
150 
+
progs/demo/X11/animation/r_utility.hu
History View file @ 4e98702
0 151 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+r_utility.hs
3 
+r_ptypes.hu
progs/demo/X11/animation/seafigs.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,158 @@
1 
+module Seafigs (sky,blue_sky,clouds,clouds2,gull,man,sun,vm,windmill,palm) where
2 
+
3 
+import Animation
4 
+
5 
+blue_sky:: Movie
6 
+blue_sky = osc [box lightblue 1000 1000]
7 
+
8 
+sky:: Color -> Movie
9 
+sky c = osc [box c 1000 1000]
10 
+
11 
+clouds2:: Movie
12 
+clouds2 = apply (mov (i (cld_wid,0))) (rBESIDE[cld,cld])
13 
+         where cld_wid = -(wid_Pic (cld!!0))
14 
+               cld= apply (bPar [right,mov (repeat (250,-50))]) cldm1
15 
+               cldm1=osc[cloud1]
16 
+
17 
+clouds:: Movie
18 
+clouds
19 
+  = rOVERLAY
20 
+      [apply (bPar [right,mov (repeat (250,-50))]) cloudm1,
21 
+       apply (bPar [right,mov (repeat (0,-50))]) cloudm2,
22 
+       apply (bPar [right,mov (repeat (250,-75))]) cloudm2,
23 
+       apply (bPar [right,flipb,smaller,mov(repeat (200,-100))]) cloudm2,
24 
+       apply (bPar [right,flipb,smaller,mov(repeat (300,-125))]) cloudm1,
25 
+       apply (bPar [right,right,mov (repeat (-50,50))]) cloudm1]
26 
+       where cloudm1 = osc [cloud1]
27 
+             cloudm2 = osc [cloud2]
28 
+
29 
+
30 
+cloud1 = [(white,ply)]
31 
+         where ply = [(142,301),(169,309),(180,315),(192,312),
32 
+                      (196,308),(202,302),(216,300),(224,308),
33 
+                      (238,312),(258,311),(274,301),(278,283),
34 
+                      (265,279),(246,279),(230,281),(197,286),
35 
+                      (185,288),(167,287),(148,287),(136,292),
36 
+                      (136,292),(142,301)]
37 
+
38 
+
39 
+cloud2 = [(white,ply)]
40 
+         where ply = [(51,262), (56,266),
41 
+                      (66,265), (90,264), (92,266), (98,270),
42 
+                      (111,268),(137,268),(155,266),(174,266),
43 
+                      (183,262),(183,253),(162,251),(136,254),
44 
+                      (132,250),(126,248),(115,252),(109,253),
45 
+                      (98,252), (90,253), (88,254), (67,254),
46 
+                      (56,252), (49,254), (47,259), (51,262)]
47 
+
48 
+gull :: Movie
49 
+gull = osc [gull1,gull2]
50 
+
51 
+gull1 = [(black,[(2,4),(6,4),(9,2),(10,0),(11,2),
52 
+               (16,4),(20,4)])]
53 
+
54 
+gull2 = [(black,[(0,0),(2,2),(6,3),(9,2),(12,3),
55 
+               (16,2),(18,0)])]
56 
+
57 
+man :: Movie
58 
+man = osc [man1,man2,man3]
59 
+
60 
+
61 
+man1 = [(black,[(0,0),(10,0),(20,40),(30,60),(40,20),
62 
+                (60,0),(50,0)]),
63 
+        (black,[(0,40),(20,60),(30,80),(50,70),(60,60)]),
64 
+        (black,[(30,60),(30,100)]),
65 
+        (black,[(30,100),(25,100),(20,105),(23,112),
66 
+                (20,115),(30,120),(35,120),(40,115),
67 
+                (40,110),(35,105),(30,100)])
68 
+                 ]
69 
+
70 
+man2 = [(black,[(20,0),(30,0),(20,40),(30,60),(45,30),
71 
+                (60,20),(50,0)]),
72 
+        (black,[(0,60),(20,60),(20,80),(40,80),(50,60)]),
73 
+        (black,[(30,60),(20,100)]),
74 
+        (black,[(20,100),(15,100),(10,105),(13,112),
75 
+                (10,115),(20,120),(30,120),(30,115),
76 
+                (30,110),(25,105),(20,100)])
77 
+                 ]
78 
+
79 
+man3 = [(black,[(0,15),(5,10),(15,45),(30,60),(35,25),
80 
+            (44,10),(35,0)]),
81 
+        (black,[(10,40),(22,60),(20,80),(40,75),(45,44)]),
82 
+        (black,[(30,60),(20,100)]),
83 
+        (black,[(20,100),(19,100),(14,105),(17,112),
84 
+                (14,115),(24,120),(34,120),(34,115),
85 
+                (34,110),(29,105),(200,100)])
86 
+                 ]
87 
+
88 
+sun :: Movie
89 
+sun = osc [sun']
90 
+      where
91 
+      sun' = reduce overlay_Pic [sun1,
92 
+                                 twist_Pic (pi/24.0) sun1,
93 
+                                 twist_Pic (pi/12.0) sun1]
94 
+
95 
+sun1 = [(yellow,[(43,16),(18,27),(9,51),(20,71),(42,81),
96 
+                 (66,73),(76,47),(69,25),(43,15),(43,16)])]
97 
+
98 
+vm :: Movie
99 
+vm =  osc[vm1,vm2]
100 
+
101 
+vm1 = beside_Pic (box brown 10 15)
102 
+                 (above_Pic light1 (box brown 40 80))
103 
+      where light1 = box yellow 10 10
104 
+
105 
+vm2 = beside_Pic (box brown 10 15)
106 
+                 (reduce above_Pic [light,light2,box brown 40 80])
107 
+      where light2 = over_Pic (box red 10 10) (box white 5 5)
108 
+            light  = [ (red,[(5,5), (10,2), (0,30),(5,5)]),
109 
+                       (red,[(20,2),(25,5),(30,30),(20,2)]),
110 
+                       (red,[(15,15),(20,15),(15,50),(10,25)])]
111 
+
112 
+windmill :: Movie
113 
+windmill
114 
+   = apply
115 
+       (bpar (mov (repeat (unit*3,0))) (scale_rel (0,0) (repeat 3)))
116 
+       (overlay body (apply (movto (repeat (100,400))) prop))
117 
+
118 
+blade = osc [tri red (0,0) (100,0) (50,300)]
119 
+prop  = apply cw fan
120 
+
121 
+fan  = rOVERLAY [fan1,fan2,fan3,fan4]
122 
+fan1 = blade
123 
+fan2 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan1
124 
+fan3 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan2
125 
+fan4 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan3
126 
+
127 
+body = osc [ [(brown,[(0,0),(200,0),(170,300),
128 
+                     (100,400),(30,300),(0,0)]) ] ]
129 
+
130 
+
131 
+palm :: Movie
132 
+palm
133 
+  = osc palms
134 
+    where palms = inbetween 3 palm1 (flipx_Pic 100 palm1)
135 
+          palm1 = reduce overlay_Pic [trunk,frond1,frond2,frond3,frond4]
136 
+              where frond1 = [ (green,[(50,60),(60,70),(80,60)]),
137 
+                               (green,[(50,70),(60,80),(80,70)]),
138 
+                               (green,[(50,80),(55,90),(70,80)]),
139 
+                               (green,[(60,70),(55,90),(50,100)]) ]
140 
+
141 
+                    frond2 = flipx_Pic 50 frond1
142 
+
143 
+                    frond3 = [ (green,[(10,70),(5,80)]),
144 
+                               (green,[(10,80),(10,90)]),
145 
+                               (green,[(20,90),(20,100)]),
146 
+                               (green,[(30,95),(40,104)]),
147 
+                               (green,[(5,80),(20,100),(40,104),
148 
+                                       (50,100)])]
149 
+
150 
+                    frond4 = [(green,[(0,100),(5,110)]),
151 
+                              (green,[(15,105),(15,115)]),
152 
+                              (green,[(25,105),(30,115)]),
153 
+                              (green,[(35,105),(40,115)]),
154 
+                              (green,[(5,110),(30,115),(50,110),
155 
+                                      (50,100)])]
156 
+
157 
+                    trunk  = [(brown,[(100,0),(95,40),(80,80),
158 
+                                      (70,90),(60,97),(50,100)])]
progs/demo/X11/animation/seafigs.hu
History View file @ 4e98702
0 159 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+animation.hu
3 
+seafigs.hs
progs/demo/X11/animation/seaside.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,25 @@
1 
+module Seaside (main) where
2 
+
3 
+import Animation
4 
+import Seafigs
5 
+
6 
+seaside :: Movie
7 
+seaside = rOVERLAY [blue_sky,
8 
+		    apply (bPar [up,cw,movto (repeat botm)]) sun,
9 
+		    apply right clouds,
10 
+		    apply (bPar [right,bigger]) gull,
11 
+		    apply (bPar [right,right,bigger]) gull,
12 
+		    apply (bPar [up,up,right,bigger]) gull,
13 
+		    apply (bPar [up,right,right,right]) gull,
14 
+		    windm,
15 
+		    apply (mov (repeat botm)) palm,
16 
+		    man_and_vm
17 
+           	   ]
18 
+	where man_and_vm = rBESIDE2 [manfig, vm]
19 
+              manfig = apply left (apply (mov (i (700,0)))
20 
+ 					         man)
21 
+	      windm = apply (mov (i (500,0))) windmill
22 
+
23 
+
24 
+main = getEnv "DISPLAY" exit
25 
+       (\ host -> displaym host 30 (map (flipy_Pic 500) seaside))
progs/demo/X11/animation/seaside.hu
History View file @ 4e98702
0 26 
new file mode 100644
... ... 
@@ -0,0 +1,5 @@
1 
+:o= all
2 
+seaside.hs
3 
+seafigs.hu
4 
+
5 
+
progs/demo/X11/draw/README
History View file @ 4e98702
0 6 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+This is the draw program used in the X window documentation
progs/demo/X11/draw/draw.hs
History View file @ 4e98702
0 2 
new file mode 100644
... ... 
@@ -0,0 +1,41 @@
1 
+module Draw where
2 
+
3 
+import Xlib
4 
+
5 
+main = getEnv "DISPLAY" exit (\ host -> draw host)
6 
+
7 
+draw :: String -> IO ()
8 
+draw host =
9 
+  xOpenDisplay host `thenIO` \ display ->
10 
+  let (screen:_) = xDisplayRoots display
11 
+      fg_color = xScreenBlackPixel screen
12 
+      bg_color = xScreenWhitePixel screen
13 
+      root = xScreenRoot screen
14 
+  in
15 
+  xCreateWindow root
16 
+                (XRect 100 100 400 400)
17 
+                [XWinBackground bg_color,
18 
+                 XWinEventMask (XEventMask [XButtonMotion,
19 
+		                            XButtonPress,
20 
+                                            XKeyPress])]
21 
+  `thenIO` \window ->
22 
+  xMapWindow window `thenIO` \() ->
23 
+  xCreateGcontext (XDrawWindow root)
24 
+                  [XGCBackground bg_color,
25 
+                   XGCForeground fg_color] `thenIO` \ gcontext ->
26 
+  let
27 
+    handleEvent :: XPoint -> IO ()
28 
+    handleEvent last =
29 
+      xGetEvent display `thenIO` \event ->
30 
+        let pos = xEventPos event
31 
+	in
32 
+	case (xEventType event) of
33 
+          XButtonPressEvent  -> handleEvent pos
34 
+          XMotionNotifyEvent ->
35 
+            xDrawLine (XDrawWindow window) gcontext last pos `thenIO` \() ->
36 
+	    handleEvent pos
37 
+          XKeyPressEvent     -> xCloseDisplay display
38 
+          _                  -> handleEvent last
39 
+  in
40 
+  appendChan stdout "Press any key to quit.\n" exit done `thenIO` \ _ ->
41 
+  handleEvent (XPoint 0 0)
progs/demo/X11/draw/draw.hu
History View file @ 4e98702
0 42 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+$HASKELL_LIBRARY/X11/xlib.hu
2 
+draw.hs
progs/demo/X11/gobang/README
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,66 @@
1 
+gobang       Weiming Wu & Niping Wu
2 
+
3 
+
4 
+Introduction
5 
+
6 
+Our final project is to design and implement a Gobang game under
7 
+X-Window3.2 environment, using the Haskell programming language. Users
8 
+can play the game human-vs-human.  The program also provides a robot
9 
+player with whom the user can play the game with.  We wrote altogether
10 
+ten modules which were saved in different files to control the whole
11 
+game.
12 
+
13 
+
14 
+About Gobang
15 
+
16 
+The checkerboard of Gobang consists of 19 vertical lines and 19
17 
+horizontal lines.  Two players in turn place a unit on the
18 
+checkerboard.  Each unit should be put on an unoccupied intersection
19 
+of a vertical and a horizontal line.  The winner is the player who
20 
+first makes five consecutive units on either vertical, horizontal or
21 
+diagonal direction.
22 
+
23 
+The program is able to perform the following tasks: 1) Use a new
24 
+window under X-Window interface to display the checkerboard.  Players
25 
+will use a mouse to place units onto the chessboard, where a unit is a
26 
+circle with the color black or white.  2) Prompt for the names of both
27 
+players and display them.  3) Calculate the time both players have
28 
+used up.  4) Supervise the progress of the game, declare winner and
29 
+end the game once one player wins.  5) At each point of the game,
30 
+store the progress of the game, so players can review each step during
31 
+the game.  6) There are five buttons on the screen which would provide
32 
+some special services such as starting a new game, quitting the game,
33 
+saving the game, importing the saved game, or reviewing the game as
34 
+soon as the user selects the corresponding buttons.  7) Provide a
35 
+moderately well robot player for that game (using minimum-maximum
36 
+algorithm).
37 
+
38 
+
39 
+Running Gobang
40 
+
41 
+A window titled "gobang" will appear on the screen.  On it is a
42 
+checkerboard, clocks and buttons.  There will be an instruction saying
43 
+"Please enter the name of player-1".  The user can do two things:
44 
+either enter the name of a player or choose the "import" button. Once
45 
+the "import" button is selected, an unfinished game, which was saved
46 
+in the file "###go.bhs###" will be imported.  Please notice that the
47 
+character "@" is reserved for the robot player, so if the user types
48 
+in @ as the name of the first player, it is assumed that player-1 is
49 
+the robot player.  Then the name of player 2 is prompted.  The game
50 
+starts and at each turn an instruction like "Please enter your play."
51 
+would appear on the screen.  The user should put a unit onto the
52 
+checkerboard.  If the button is clicked on a wrong place or a unit is
53 
+put onto an occupied position, an error message saying "Wrong Point.
54 
+Please reenter." will appear on the screen and the user should reenter
55 
+his play.  The marker next to the name of a player indicates whose
56 
+turn it is.  At any point of the game the user can choose the other
57 
+four buttons.  If the "new" button is selected, the present game will
58 
+be terminated and a new blank checkerboard will be displayed on the
59 
+screen; if the "review" button is selected, one step of the previous
60 
+plays will be displayed each time after the user hits any key; if the
61 
+"save" button is selected, the steps so far will be saved into the
62 
+file "###go.bhs###"; if the "quit" button is selected, the game will
63 
+be terminated.
64 
+
65 
+
66 
+
progs/demo/X11/gobang/gobang.hs
History View file @ 4e98702
0 67 
new file mode 100644
... ... 
@@ -0,0 +1,364 @@
1 
+module Gobang where
2 
+
3 
+import Xlib
4 
+import Utilities
5 
+import Redraw
6 
+import Weights
7 
+
8 
+getXInfo :: String -> IO XInfo
9 
+getXInfo host =
10 
+  xOpenDisplay host `thenIO` \ display ->
11 
+  let (screen:_) = xDisplayRoots display
12 
+      fg_pixel = xScreenBlackPixel screen
13 
+      bg_pixel = xScreenWhitePixel screen
14 
+      root = xScreenRoot screen
15 
+  in
16 
+  xCreateWindow root
17 
+                (XRect 0 0 900 600)
18 
+                [XWinBackground bg_pixel,
19 
+                 XWinEventMask (XEventMask [XButtonPress,
20 
+                                            XKeyPress,
21 
+                                            XExposure])]
22 
+                 `thenIO` \ window ->
23 
+  xSetWmName window "Gobang" `thenIO` \() ->
24 
+  xMapWindow window `thenIO` \() ->
25 
+  xOpenFont display "10x20" `thenIO`  \ playerfont ->
26 
+  xOpenFont display "6x13" `thenIO` \ genericfont ->
27 
+  xCreateGcontext (XDrawWindow window)
28 
+                  [XGCBackground bg_pixel,
29 
+                   XGCForeground fg_pixel] `thenIO` \ gcontext  ->
30 
+  xCreateGcontext (XDrawWindow window)
31 
+                  [XGCBackground fg_pixel,
32 
+                   XGCForeground bg_pixel,
33 
+                   XGCFont       genericfont] `thenIO` \ gcontext2 ->
34 
+  xCreateGcontext (XDrawWindow window)
35 
+                  [XGCBackground bg_pixel,
36 
+                   XGCForeground fg_pixel,
37 
+                   XGCFont       playerfont] `thenIO` \ gcontextp ->
38 
+  returnIO (XInfo display window gcontext gcontext2 gcontextp)
39 
+
40 
+demo = main
41 
+
42 
+main = getEnv "DISPLAY" exit $ \ host ->
43 
+       xHandleError (\(XError msg) -> appendChan stdout msg exit done) $
44 
+       gobang host
45 
+
46 
+gobang :: String -> IO ()
47 
+gobang host =
48 
+  getXInfo host `thenIO` \ xinfo ->
49 
+  xMArrayCreate [1..361] `thenIO` \ board ->
50 
+  xMArrayCreate [1..361] `thenIO` \ weight1 ->
51 
+  xMArrayCreate [1..361] `thenIO` \ weight2 ->
52 
+  xMArrayCreate [1..722] `thenIO` \ steps ->
53 
+  xMArrayCreate [""] `thenIO` \ player1 ->
54 
+  xMArrayCreate [""] `thenIO` \ player2 ->
55 
+  xMArrayCreate [1..4] `thenIO`  \ time ->
56 
+  xMArrayCreate [1] `thenIO` \ numbersteps ->
57 
+  xMArrayCreate [""] `thenIO` \ promptString ->
58 
+  xMArrayCreate [1] `thenIO` \ next_player ->
59 
+  let state = GameState player1 player2 board steps weight1 weight2 time
60 
+                        numbersteps promptString next_player
61 
+  in
62 
+  initGame xinfo state `thenIO` \ _ ->
63 
+  promptPlayers xinfo state `thenIO` \ _ ->
64 
+  playGame xinfo state
65 
+
66 
+promptPlayers xinfo state =
67 
+  let (XInfo display window gcontext gcontext2 gcontextp) = xinfo
68 
+      (GameState player1 player2 board steps weight1 weight2 time
69 
+                 numbersteps promptString next_player) = state
70 
+  in
71 
+  promptFor "player 1:" xinfo state `thenIO` \ player1_name ->
72 
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 65) player1_name
73 
+  `thenIO` \ _ ->
74 
+  xMArrayUpdate player1 0 player1_name `thenIO` \ _ ->
75 
+  promptFor "player 2:" xinfo state `thenIO` \ player2_name ->
76 
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 205) player2_name
77 
+  `thenIO` \ _ ->
78 
+  xMArrayUpdate player2 0 player2_name `thenIO` \ _ ->
79 
+  clearCmd xinfo state
80 
+
81 
+initGame :: XInfo -> GameState -> IO ()
82 
+initGame xinfo
83 
+         state@(GameState player1 player2 board steps weight1 weight2 time
84 
+                          numbersteps promptString next_player) =
85 
+          getTime `thenIO` \ curtime ->
86 
+          initArray time 0 2 0 `thenIO` \() ->
87 
+          initArray time 2 4 curtime `thenIO` \() ->
88 
+          initArray numbersteps 0 1 0 `thenIO` \() ->
89 
+          initArray board 0 361 0 `thenIO` \() ->
90 
+          initArray weight1 0 361 0 `thenIO` \() ->
91 
+          initArray weight2 0 361 0 `thenIO` \ () ->
92 
+          initArray next_player 0 1 1 `thenIO` \ () ->
93 
+          clearCmd xinfo state `thenIO` \ () ->
94 
+          redraw xinfo state
95 
+
96 
+
97 
+handleButton :: XPoint -> XInfo -> GameState -> GameCont -> IO ()
98 
+handleButton (XPoint x y)
99 
+             xinfo
100 
+             state@(GameState player1 player2 board steps weight1 weight2 time
101 
+                              numbersteps promptString next_player)
102 
+             cont
103 
+       | buttonPress 700 330 x y  = initArray player1 0 1 "" `thenIO` \ _ ->
104 
+                                    initArray player2 0 1 "" `thenIO` \ _ ->
105 
+                                    initGame xinfo state `thenIO` \ _ ->
106 
+                                    promptPlayers xinfo state `thenIO` \ _ ->
107 
+                                    playGame xinfo state
108 
+       | buttonPress 700 360 x y  = initGame xinfo state `thenIO` \ _ ->
109 
+                                    playGame xinfo state
110 
+       | buttonPress 700 390 x y  = undoGame xinfo state cont
111 
+       | buttonPress 700 420 x y  = loadGame xinfo state cont
112 
+       | buttonPress 700 450 x y  = saveGame xinfo state `thenIO` \ () ->
113 
+                                    cont xinfo state
114 
+       | buttonPress 700 480 x y  = quitGame xinfo state cont
115 
+       | ishelp x y          = helpGame xinfo state `thenIO` \ () ->
116 
+                               cont xinfo state
117 
+       | otherwise           = cont xinfo state
118 
+
119 
+when :: Bool -> IO () -> IO ()
120 
+when cond action = if cond then action else returnIO ()
121 
+
122 
+undoGame xinfo@(XInfo display window gcontext gcontext2 gcontextp)
123 
+         state@(GameState player1 player2 board steps weight1 weight2 time
124 
+                          numbersteps promptString next_player)
125 
+         cont =
126 
+  xMArrayLookup next_player 0 `thenIO` \ next_p ->
127 
+  xMArrayLookup player1 0 `thenIO` \ name1 ->
128 
+  xMArrayLookup player2 0 `thenIO` \ name2 ->
129 
+  let undoStep n =
130 
+        xMArrayLookup steps (2*n) `thenIO` \ x ->
131 
+        xMArrayLookup steps (2*n+1) `thenIO` \ y ->
132 
+        xMArrayUpdate board ((x-1)*19 + y-1) 0 `thenIO` \ _ ->
133 
+        (if (name1 == "computer" || name2 == "computer")
134 
+            then draw_unit board weight1 weight2 x y
135 
+            else returnIO ()) `thenIO` \ _ ->
136 
+       xDrawRectangle (XDrawWindow window) gcontext2
137 
+                      (XRect (x*30-15) (y*30-15) 30 30) True
138 
+       `thenIO` \() ->
139 
+--        drawBoard xinfo `thenIO` \ _ ->
140 
+--        drawPieces 1 1 board xinfo `thenIO` \ _ ->
141 
+        let x30 = x * 30
142 
+            y30 = y * 30
143 
+            c = XPoint x30 y30
144 
+            w = XPoint (x30-15) y30
145 
+            e = XPoint (x30+15) y30
146 
+            no = XPoint x30 (y30-15)
147 
+            s = XPoint x30 (y30+15)
148 
+            m = XArc (x30-3) (y30-3) 6 6 (-1.0) 6.283
149 
+        in
150 
+        when (x > 1) (xDrawLine (XDrawWindow window) gcontext w c)
151 
+        `thenIO` \ _ ->
152 
+        when (x < 19) (xDrawLine (XDrawWindow window) gcontext c e)
153 
+        `thenIO` \ _ ->
154 
+        when (y > 1) (xDrawLine (XDrawWindow window) gcontext no c)
155 
+        `thenIO` \ _ ->
156 
+        when (y < 19) (xDrawLine (XDrawWindow window) gcontext c s)
157 
+        `thenIO` \ _ ->
158 
+        when ((x `elem` [4,10,16]) && (y `elem` [4,10,16]))
159 
+             (xDrawArc (XDrawWindow window) gcontext m True)
160 
+        `thenIO` \ _ ->
161 
+        xDisplayForceOutput display `thenIO` \ _ ->
162 
+        xMArrayUpdate numbersteps 0 n `thenIO` \ _ ->
163 
+        xMArrayLookup next_player 0 `thenIO` \ next_p ->
164 
+        xMArrayUpdate next_player 0 (if next_p == 1 then 2 else 1)
165 
+
166 
+      cur_name = if next_p == 1 then name1 else name2
167 
+      last_name = if next_p == 1 then name2 else name1
168 
+  in
169 
+  xMArrayLookup numbersteps 0 `thenIO` \ n ->
170 
+  if n==0 then drawCmd "No more steps to undo!" xinfo state `thenIO` \ _ ->
171 
+               cont xinfo state
172 
+  else
173 
+  if cur_name == "computer" then cont xinfo state
174 
+  else
175 
+  (undoStep (n-1) `thenIO` \_ ->
176 
+   if (last_name == "computer" && n /= 1) then undoStep (n-2)
177 
+   else
178 
+   returnIO ()) `thenIO` \ _ ->
179 
+  playGame xinfo state
180 
+
181 
+
182 
+
183 
+
184 
+promptFile xinfo state cont =
185 
+  promptFor "File name:" xinfo state `thenIO` \ name ->
186 
+  readFile name
187 
+           (\ _ -> drawCmd ("Can't read file:" ++ name) xinfo state
188 
+                   `thenIO` \ _ ->
189 
+		   cont XNull)
190 
+           (\ content -> cont (XSome content))
191 
+
192 
+loadGame xinfo state cont =
193 
+  promptFile xinfo state $ \ file ->
194 
+  case file of
195 
+    XNull -> cont xinfo state
196 
+    XSome file_content ->
197 
+     readGameState file_content `thenIO` \ new_state ->
198 
+     let (GameState _ _ _ _ _ _ time _ _ _) = new_state
199 
+     in
200 
+     getTime `thenIO` \ curtime ->
201 
+     initArray time 2 4 curtime `thenIO` \() ->
202 
+     redraw xinfo new_state `thenIO` \ _ ->
203 
+     playGame xinfo new_state
204 
+
205 
+saveGame :: XInfo -> GameState -> IO ()
206 
+saveGame xinfo state =
207 
+  promptFor "File name:" xinfo state `thenIO` \ name ->
208 
+  showGameState state `thenIO` \ str ->
209 
+  writeFile name str
210 
+            (\ _ -> drawCmd ("Can't write file: " ++ name) xinfo state)
211 
+	    done
212 
+
213 
+quitGame :: XInfo -> GameState -> GameCont -> IO ()
214 
+quitGame xinfo state cont =
215 
+  let (XInfo display window gcontext gcontext2 gcontextp) = xinfo
216 
+  in
217 
+  promptFor "Are you sure? (y/n)" xinfo state `thenIO` \ reps ->
218 
+  if (reps == "y" || reps == "Y") then xCloseDisplay display
219 
+                                  else clearCmd xinfo state `thenIO` \ _ ->
220 
+                                       cont xinfo state
221 
+
222 
+playGame :: XInfo -> GameState -> IO ()
223 
+playGame xinfo state =
224 
+     let
225 
+        (XInfo display window gcontext gcontext2 gcontextp) = xinfo
226 
+        (GameState player1 player2 board steps weight1 weight2 time
227 
+                   numbersteps promptString next_player) = state
228 
+     in
229 
+     xMArrayLookup numbersteps 0 `thenIO` \ x ->
230 
+     (\cont -> if x == 361
231 
+               then drawCmd "It's a tie!" xinfo state `thenIO` \ _ ->
232 
+                    let loop xinfo state = waitButton xinfo state (\ _ -> loop)
233 
+                    in loop xinfo state
234 
+               else cont) $
235 
+     xMArrayLookup next_player 0 `thenIO` \ next_player_num ->
236 
+     getTime `thenIO` \ curtime ->
237 
+     xMArrayLookup time 0 `thenIO` \ lstm0 ->
238 
+     xMArrayLookup time 1 `thenIO` \ lstm1 ->
239 
+     xMArrayLookup time 2 `thenIO` \ lstm2 ->
240 
+     xMArrayLookup time 3 `thenIO` \ lstm3 ->
241 
+     drawCmd ("Waiting for player # " ++ (show next_player_num)) xinfo state
242 
+     `thenIO` \() ->
243 
+     if (next_player_num == 1)
244 
+        then xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 70)
245 
+                   '<' `thenIO` \(trash) ->
246 
+             xDrawRectangle (XDrawWindow window) gcontext2
247 
+	                    (XRect 840 180 40 40) True `thenIO` \() ->
248 
+             xMArrayUpdate time 2 curtime `thenIO` \() ->
249 
+             xMArrayUpdate time 1 (lstm1+curtime-lstm3) `thenIO` \() ->
250 
+             showtime 705 270 (lstm1+curtime-lstm3) xinfo `thenIO` \() ->
251 
+             xMArrayLookup player1 0 `thenIO` \ x ->
252 
+             if (x == "computer")
253 
+                   then computerplay xinfo state
254 
+                   else humanplay xinfo state
255 
+        else xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 210)
256 
+                    '<' `thenIO` \(trash) ->
257 
+             xDrawRectangle (XDrawWindow window) gcontext2
258 
+	                    (XRect 840 40 40 40)  True `thenIO` \() ->
259 
+             xMArrayUpdate time 3 curtime `thenIO` \() ->
260 
+             xMArrayUpdate time 0 (lstm0+curtime-lstm2) `thenIO` \() ->
261 
+             showtime 705 130 (lstm0+curtime-lstm3) xinfo `thenIO` \() ->
262 
+             xMArrayLookup player2 0 `thenIO` \ x ->
263 
+             if (x == "computer")
264 
+                   then computerplay xinfo state
265 
+                   else humanplay xinfo state
266 
+
267 
+waitButton xinfo@(XInfo display _ _ _ _) state cont =
268 
+  let
269 
+    loop xinfo state =
270 
+      xGetEvent display `thenIO` \ event ->
271 
+      case (xEventType event) of
272 
+        XExposureEvent -> may_redraw (xEventCount event == 0) xinfo state
273 
+                          `thenIO` \ _ ->
274 
+                          loop xinfo state
275 
+        XButtonPressEvent ->
276 
+                          let pos = xEventPos event
277 
+                          in
278 
+                          handleButton pos xinfo state (cont pos)
279 
+        _              -> xBell display 0 `thenIO` \ _ ->
280 
+                          loop xinfo state
281 
+  in
282 
+  loop xinfo state
283 
+
284 
+updateboard :: XInfo -> GameState -> Int -> Int -> IO ()
285 
+updateboard xinfo state x y =
286 
+            let (GameState player1 player2 board steps weight1 weight2 time
287 
+                           numbersteps promptString next_player) = state
288 
+                (XInfo display window gcontext gcontext2 gcontextp) = xinfo
289 
+            in
290 
+            xMArrayLookup next_player 0 `thenIO` \ next_player_num ->
291 
+            xMArrayUpdate next_player 0 (if next_player_num == 1 then 2 else 1)
292 
+            `thenIO` \ _ ->
293 
+            xMArrayLookup numbersteps 0 `thenIO` \ z ->
294 
+            xMArrayUpdate numbersteps 0 (z+1) `thenIO` \() ->
295 
+            xMArrayUpdate steps (2*z) x `thenIO` \() ->
296 
+            xMArrayUpdate steps (2*z+1) y `thenIO` \() ->
297 
+            xMArrayLookup player1 0 `thenIO` \ name1 ->
298 
+            xMArrayLookup player2 0 `thenIO` \ name2 ->
299 
+            xMArrayUpdate board (19*(x-1)+y-1) next_player_num
300 
+            `thenIO` \() ->
301 
+            human_unit board x y `thenIO` \ win ->
302 
+            if win
303 
+            then drawCmd ("Player " ++ (show next_player_num) ++ " has won!")
304 
+                         xinfo state `thenIO` \ _ ->
305 
+                 let loop xinfo state = waitButton xinfo state (\ _ -> loop)
306 
+                 in loop xinfo state
307 
+            else if (name1 == "computer" || name2 == "computer")
308 
+                 then draw_unit board weight1 weight2 x y `thenIO` \() ->
309 
+                      xMArrayUpdate weight1 (19*(x-1)+y-1) (-1) `thenIO` \() ->
310 
+                      xMArrayUpdate weight2 (19*(x-1)+y-1) (-1) `thenIO` \() ->
311 
+                      playGame xinfo state
312 
+                 else playGame xinfo state
313 
+
314 
+choice :: XPoint -> XInfo -> GameState -> IO ()
315 
+choice (XPoint x y) xinfo@(XInfo display _ _ _ _) state =
316 
+   let (GameState player1 player2 board steps weight1 weight2 time
317 
+                  numbersteps promptString next_player) = state
318 
+   in
319 
+   case (getposition x y) of
320 
+     XNull -> humanplay xinfo state
321 
+     XSome (x, y) ->
322 
+       xMArrayLookup board (19*(x-1)+y-1) `thenIO` \ z ->
323 
+       if (z>0)
324 
+       then xBell display 0 `thenIO` \ _ ->
325 
+            drawCmd "Wrong point, please re-enter" xinfo state `thenIO` \() ->
326 
+            humanplay xinfo state
327 
+       else xMArrayLookup next_player 0 `thenIO` \ next_player_num ->
328 
+            drawPiece x y xinfo (next_player_num == 1) `thenIO` \() ->
329 
+            updateboard xinfo state x y
330 
+
331 
+humanplay :: XInfo -> GameState -> IO ()
332 
+humanplay xinfo state =  waitButton xinfo state choice
333 
+
334 
+computerplay :: XInfo -> GameState -> IO ()
335 
+computerplay xinfo@(XInfo display window gcontext gcontext2 gcontextp)
336 
+             state =
337 
+    let process_events xinfo state cont =
338 
+          xEventListen display `thenIO` \ n_event ->
339 
+          if n_event == 0 then cont xinfo state
340 
+          else xGetEvent display `thenIO` \ event ->
341 
+               case (xEventType event) of
342 
+                 XButtonPressEvent ->
343 
+                            handleButton (xEventPos event) xinfo state cont
344 
+                 XExposureEvent    ->
345 
+                            may_redraw (xEventCount event == 0)
346 
+                                       xinfo state
347 
+                            `thenIO` \ _ ->
348 
+                            process_events xinfo state cont
349 
+                 XKeyPressEvent    ->
350 
+                            process_events xinfo state cont
351 
+    in
352 
+    process_events xinfo state $
353 
+    \ xinfo@(XInfo display window gcontext gcontext2 gcontextp)
354 
+      state@(GameState _ _ _ _ weight1 weight2 _ numbersteps _ next_player) ->
355 
+    robot numbersteps weight1 weight2 `thenIO` \pt ->
356 
+    let (XPoint x y) = pt
357 
+    in
358 
+    xMArrayLookup next_player 0 `thenIO` \ next_player_num ->
359 
+    drawPiece x y xinfo (next_player_num == 1) `thenIO` \() ->
360 
+    updateboard xinfo state x y
361 
+
362 
+
363 
+
364 
+
progs/demo/X11/gobang/gobang.hu
History View file @ 4e98702
0 365 
new file mode 100644
... ... 
@@ -0,0 +1,7 @@
1 
+:o= foldr inline constant
2 
+$HASKELL_LIBRARY/X11/xlib.hu
3 
+gobang.hs
4 
+misc.hi
5 
+utilities.hs
6 
+redraw.hs
7 
+weights.hs
progs/demo/X11/gobang/misc.hi
History View file @ 4e98702
0 8 
new file mode 100644
... ... 
@@ -0,0 +1,7 @@
1 
+interface Misc where
2 
+
3 
+random :: Int -> IO Int
4 
+
5 
+{-#
6 
+random :: LispName("lisp:random")
7 
+#-}
0 8 
\ No newline at end of file
progs/demo/X11/gobang/misc.hu
History View file @ 4e98702
1 9 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+misc.hi
2 
+
progs/demo/X11/gobang/redraw.hs
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,160 @@
1 
+module Redraw where
2 
+
3 
+import Xlib
4 
+import Utilities
5 
+
6 
+may_redraw :: Bool -> XInfo -> GameState -> IO ()
7 
+may_redraw ok xinfo state = if ok then redraw xinfo state else returnIO ()
8 
+
9 
+redraw :: XInfo -> GameState -> IO ()
10 
+
11 
+redraw xinfo state =
12 
+  let (XInfo display window gcontext gcontext2 gcontextp) = xinfo
13 
+  in
14 
+  xDrawRectangle (XDrawWindow window) gcontext2 (XRect 0 0 900 600) True
15 
+  `thenIO` \ _ ->
16 
+  drawBoard xinfo `thenIO` \ () ->
17 
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 610 65) "Player 1"
18 
+  `thenIO` \ _  ->
19 
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 620 125) "Clock 1"
20 
+  `thenIO` \ _  ->
21 
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 610 205) "Player 2"
22 
+  `thenIO` \ _  ->
23 
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 620 265) "Clock 2"
24 
+  `thenIO` \ _  ->
25 
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 700 45 130 30) False
26 
+  `thenIO` \ () ->
27 
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 700 105 90 30) False
28 
+  `thenIO` \ () ->
29 
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 700 185 130 30) False
30 
+  `thenIO` \() ->
31 
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 700 245 90 30) False
32 
+  `thenIO` \() ->
33 
+  button 700 330 "New players"  xinfo `thenIO` \() ->
34 
+  button 700 360 "New game"  xinfo `thenIO` \() ->
35 
+  button 700 390 "Undo" xinfo `thenIO` \() ->
36 
+  button 700 420 "Load" xinfo `thenIO` \() ->
37 
+  button 700 450 "Save"  xinfo `thenIO` \() ->
38 
+  button 700 480 "Quit" xinfo `thenIO` \() ->
39 
+  helpButton xinfo `thenIO` \ _ ->
40 
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 615 535 250 30) False
41 
+  `thenIO` \ _ ->
42 
+  let (GameState player1 player2 board steps weight1 weight2 time
43 
+                 numbersteps promptString next_player) = state
44 
+  in
45 
+  xMArrayLookup time 0 `thenIO` \ lstm0 ->
46 
+  xMArrayLookup time 1 `thenIO` \ lstm1 ->
47 
+  showtime 705 270 (lstm1) xinfo `thenIO` \() ->
48 
+  showtime 705 130 (lstm0) xinfo `thenIO` \() ->
49 
+  xMArrayLookup player1 0 `thenIO` \ player1_name ->
50 
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 65) player1_name
51 
+  `thenIO` \ _ ->
52 
+  xMArrayLookup player2 0 `thenIO` \ player2_name ->
53 
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 205) player2_name
54 
+  `thenIO` \ _ ->
55 
+  xMArrayLookup promptString 0 `thenIO` \ ps ->
56 
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 620 550) ps
57 
+  `thenIO` \ _ ->
58 
+  xMArrayLookup next_player 0 `thenIO` \ next_player_num ->
59 
+  (if (next_player_num == 1)
60 
+   then xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 70) '<'
61 
+   else xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 210) '<')
62 
+  `thenIO` \ _ ->
63 
+  drawPieces 1 1 board xinfo `thenIO` \ _ ->
64 
+  returnIO ()
65 
+
66 
+drawHelp (XInfo display window gcontext gcontext2 gcontextp) =
67 
+  xDrawRectangle (XDrawWindow window) gcontext2 (XRect 100 100 300 200) True
68 
+  `thenIO` \ _ ->
69 
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 100 100 300 200) False
70 
+  `thenIO` \ _ ->
71 
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 102 102 296 196) False
72 
+  `thenIO` \ _ ->
73 
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 200 230 100 60) False
74 
+  `thenIO` \ _ ->
75 
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 202 232 96 56) False
76 
+  `thenIO` \ _ ->
77 
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 240 265) "OK"
78 
+  `thenIO` \ _ ->
79 
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 120)
80 
+              "Two players in turn place black and white"
81 
+  `thenIO` \ _ ->
82 
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 135)
83 
+              "pieces on the board. The winner is the"
84 
+  `thenIO` \ _ ->
85 
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 150)
86 
+              "player who first makes five consecutive"
87 
+  `thenIO` \ _ ->
88 
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 165)
89 
+              "pieces in either vertical, horizontal or"
90 
+  `thenIO` \ _ ->
91 
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 180)
92 
+              "diagonal directions."
93 
+  `thenIO` \ _ ->
94 
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 200)
95 
+              "To play with a robot, type \"computer\" as"
96 
+  `thenIO` \ _ ->
97 
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 215)
98 
+              "the name of another player."
99 
+
100 
+
101 
+drawBoard (XInfo display window gcontext gcontext2 gcontextp) =
102 
+  drawvlines 30 30 1 `thenIO` \() ->
103 
+  drawhlines 30 30 1 `thenIO` \() ->
104 
+  drawmarks where
105 
+
106 
+  drawvlines :: Int -> Int -> Int -> IO ()
107 
+  drawvlines x y z
108 
+                | z <= 19
109 
+                   = xDrawLine (XDrawWindow window) gcontext
110 
+                     (XPoint x y) (XPoint x (y+30*18)) `thenIO` \() ->
111 
+		       drawvlines (x+30) y (z+1)
112 
+                | otherwise
113 
+                   = returnIO ()
114 
+
115 
+  drawhlines :: Int -> Int -> Int -> IO ()
116 
+  drawhlines x y z
117 
+                | z <= 19
118 
+                   = xDrawLine (XDrawWindow window) gcontext
119 
+                     (XPoint x y) (XPoint (x+30*18) y) `thenIO` \() ->
120 
+                       drawhlines x (y+30) (z+1)
121 
+                | otherwise
122 
+                   = returnIO ()
123 
+
124 
+  drawmarks :: IO ()
125 
+  drawmarks =
126 
+            map2IO (\x y ->
127 
+                     xDrawArc (XDrawWindow window) gcontext
128 
+                              (XArc x y 6 6 (-1.0) 6.283) True)
129 
+                   (map (\x -> 30 + x*30-3) [3,9,15,3,9,15,3,9,15])
130 
+                   (map (\x -> 30 + x*30-3) [3,3,3,9,9,9,15,15,15])
131 
+            `thenIO` \ _ -> returnIO ()
132 
+
133 
+map2IO :: (a -> b -> IO c) -> [a] -> [b] -> IO [c]
134 
+
135 
+map2IO f [] []         = returnIO []
136 
+map2IO f (x:xs) (z:zs) = f x z `thenIO` \ y ->
137 
+		         map2IO f xs zs `thenIO` \ ys ->
138 
+		         returnIO (y:ys)
139 
+
140 
+drawPieces 20 _ board xinfo = returnIO ()
141 
+drawPieces x 20 board xinfo = drawPieces (x+1) 1 board xinfo
142 
+drawPieces x y board xinfo =
143 
+  xMArrayLookup board ((x-1)*19 + y-1) `thenIO` \ piece ->
144 
+  (if (piece == 1 || piece == 2)
145 
+   then drawPiece x y xinfo (piece == 1)
146 
+   else returnIO ()) `thenIO` \ _ ->
147 
+  drawPieces x (y+1) board xinfo
148 
+
149 
+drawPiece x y (XInfo display window gcontext gcontext2 _ ) is_black =
150 
+  (if is_black then returnIO ()
151 
+               else xDrawArc (XDrawWindow window) gcontext2
152 
+                             (XArc (30*x-10) (30*y-10) 20 20
153 
+                             (-1.0) 6.283)
154 
+                             True) `thenIO` \ _ ->
155 
+  xDrawArc (XDrawWindow window) gcontext
156 
+           (XArc (30*x-10) (30*y-10) 20 20
157 
+  	   (-1.0) 6.283)
158 
+           is_black `thenIO` \ _ ->
159 
+  xDisplayForceOutput display
160 
+
progs/demo/X11/gobang/redraw.hu
History View file @ 4e98702
0 161 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+:o= all
2 
+$HASKELL_LIBRARY/X11/xlib.hu
3 
+redraw.hs
4 
+utilities.hs
progs/demo/X11/gobang/utilities.hs
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,305 @@
1 
+module Utilities where
2 
+
3 
+import Xlib
4 
+import Weights
5 
+import Redraw
6 
+import Misc
7 
+
8 
+data XInfo = XInfo XDisplay XWindow XGcontext XGcontext XGcontext
9 
+data GameState = GameState (XMArray String) (XMArray String) (XMArray Int)
10 
+                           (XMArray Int) (XMArray Int) (XMArray Int)
11 
+                           (XMArray Integer) (XMArray Int)
12 
+                           (XMArray String) (XMArray Int)
13 
+
14 
+type GameCont = XInfo -> GameState -> IO ()
15 
+
16 
+xMArrayToList :: XMArray a -> IO [a]
17 
+xMArrayToList a =
18 
+   let la = xMArrayLength a
19 
+       loop i a = if i == la then returnIO []
20 
+                  else xMArrayLookup a i `thenIO` \ x ->
21 
+                       loop (i+1) a `thenIO` \ xs ->
22 
+                       returnIO (x:xs)
23 
+   in
24 
+   loop 0 a
25 
+
26 
+
27 
+readGameState str =
28 
+  let
29 
+    [(board_lst, r1)] = reads str
30 
+    [(weight1_lst, r2)] = reads r1
31 
+    [(weight2_lst, r3)] = reads r2
32 
+    [(steps_lst, r4)] = reads r3
33 
+    [(player1_lst, r5)] = reads r4
34 
+    [(player2_lst, r6)] = reads r5
35 
+    [(time_lst, r7)] = reads r6
36 
+    [(numbersteps_lst, r8)] = reads r7
37 
+    [(promptString_lst, r9)] = reads r8
38 
+    [(next_player_lst, [])] = reads r9
39 
+  in
40 
+  xMArrayCreate board_lst `thenIO` \ board ->
41 
+  xMArrayCreate weight1_lst `thenIO` \ weight1 ->
42 
+  xMArrayCreate weight2_lst `thenIO` \ weight2 ->
43 
+  xMArrayCreate steps_lst `thenIO` \ steps ->
44 
+  xMArrayCreate player1_lst `thenIO` \ player1 ->
45 
+  xMArrayCreate player2_lst `thenIO` \ player2 ->
46 
+  xMArrayCreate time_lst `thenIO`  \ time ->
47 
+  xMArrayCreate numbersteps_lst `thenIO` \ numbersteps ->
48 
+  xMArrayCreate promptString_lst `thenIO` \ promptString ->
49 
+  xMArrayCreate next_player_lst `thenIO` \ next_player ->
50 
+  returnIO (GameState player1 player2 board steps weight1 weight2 time
51 
+                      numbersteps promptString next_player)
52 
+
53 
+showGameState (GameState player1 player2 board steps weight1 weight2 time
54 
+                      numbersteps promptString next_player) =
55 
+  xMArrayToList board `thenIO` \ board_lst ->
56 
+  xMArrayToList weight1 `thenIO` \ weight1_lst ->
57 
+  xMArrayToList weight2 `thenIO` \ weight2_lst ->
58 
+  xMArrayToList steps `thenIO` \ steps_lst ->
59 
+  xMArrayToList player1 `thenIO` \ player1_lst ->
60 
+  xMArrayToList player2 `thenIO` \ player2_lst ->
61 
+  xMArrayToList time `thenIO`  \ time_lst ->
62 
+  xMArrayToList numbersteps `thenIO` \ numbersteps_lst ->
63 
+  xMArrayToList promptString `thenIO` \ promptString_lst ->
64 
+  xMArrayToList next_player `thenIO` \ next_player_lst ->
65 
+  let
66 
+    str =(shows board_lst .
67 
+          shows weight1_lst .
68 
+          shows weight2_lst .
69 
+          shows steps_lst .
70 
+          shows player1_lst .
71 
+          shows player2_lst .
72 
+          shows time_lst .
73 
+          shows numbersteps_lst .
74 
+          shows promptString_lst .
75 
+          shows next_player_lst) []
76 
+  in
77 
+  returnIO str
78 
+
79 
+
80 
+xMod      :: Int -> Int -> Int
81 
+xMod x y | x >= y      = xMod (x-y) y
82 
+         | otherwise   = x
83 
+
84 
+xRes      :: Int -> Int -> Int -> Int
85 
+xRes x y z | x >= y     = xRes (x-y) y (z+1)
86 
+           | otherwise = z
87 
+
88 
+drawCmd :: String -> XInfo -> GameState -> IO ()
89 
+drawCmd a (XInfo display window gcontext gcontext2 gcontextp)
90 
+          (GameState _ _ _ _ _ _ _ _ str _)
91 
+           = xDrawRectangle (XDrawWindow window) gcontext2
92 
+                (XRect 616 536 248 28) True `thenIO` \ () ->
93 
+             xDrawGlyphs (XDrawWindow window) gcontext
94 
+                         (XPoint 620 550) a  `thenIO` \ _ ->
95 
+             xMArrayUpdate str 0 a `thenIO` \ _ ->
96 
+             xDisplayForceOutput display
97 
+
98 
+clearCmd :: XInfo -> GameState -> IO ()
99 
+clearCmd (XInfo display window gcontext gcontext2 gcontextp)
100 
+         (GameState _ _ _ _ _ _ _ _ str _)
101 
+          = xDrawRectangle (XDrawWindow window) gcontext2
102 
+                (XRect 616 536 248 28) True `thenIO` \() ->
103 
+            xMArrayUpdate str 0 "" `thenIO` \ _ ->
104 
+            xDisplayForceOutput display
105 
+
106 
+xPosition :: Int -> XPoint
107 
+xPosition  a = (XPoint (xRes a 19 1) (1+ (xMod a 19)))
108 
+
109 
+initArray :: XMArray a -> Int -> Int -> a -> IO ()
110 
+initArray mary x y z | x<y       = xMArrayUpdate mary x z `thenIO` \() ->
111 
+                                   initArray mary (x+1) y z
112 
+                     | otherwise = returnIO ()
113 
+
114 
+getposition :: Int -> Int -> XMaybe (Int, Int)
115 
+getposition x y = let x1 = round ((fromIntegral x) / 30.0)
116 
+                      y1 = round ((fromIntegral y) / 30.0)
117 
+                  in
118 
+                  if (x1 < 1 || x1 > 19 || y1 < 1 || y1 > 19) then XNull
119 
+                  else XSome (x1, y1)
120 
+
121 
+addZero :: Int -> String
122 
+addZero a | a < 10    = "0"
123 
+          | otherwise =  ""
124 
+
125 
+printTime :: Int -> Int -> [Int] -> XInfo -> IO()
126 
+printTime x y zs (XInfo display window gcontext gcontext2 gcontextp)
127 
+           = let s = head zs
128 
+                 m = head (tail zs)
129 
+                 h = head (tail (tail zs))
130 
+             in  xDrawRectangle (XDrawWindow window) gcontext2
131 
+                     (XRect (x-4) (y-24) 88 28) True `thenIO` \() ->
132 
+                 xDrawGlyphs (XDrawWindow window) gcontextp (XPoint x y)
133 
+                    ((addZero h)++(show h)++":"++(addZero m)++(show m)++
134 
+                          ":"++(addZero s)++(show s))
135 
+                    `thenIO` \(trash) ->
136 
+                 xDisplayForceOutput display
137 
+
138 
+showtime :: Int -> Int -> Integer -> XInfo -> IO()
139 
+showtime x y z a =
140 
+  let (curtm, c) = (decodeTime z (WestOfGMT 0))
141 
+  in  printTime x y curtm a
142 
+
143 
+helpButton :: XInfo -> IO ()
144 
+helpButton (XInfo display window  gcontext gcontext2 gcontextp) =
145 
+        xDrawRectangle (XDrawWindow window) gcontext (XRect 800 420 70 70)
146 
+                       False `thenIO` \ _ ->
147 
+        xDrawRectangle (XDrawWindow window) gcontext (XRect 802 422 66 66)
148 
+                       False `thenIO` \ _ ->
149 
+        xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 810 450) "About"
150 
+        `thenIO` \ _ ->
151 
+        xDrawGlyphs (XDrawWindow window) gcontext (XPoint 820 470) "Gobang"
152 
+        `thenIO` \ _ ->
153 
+        returnIO ()
154 
+
155 
+ishelp :: Int -> Int -> Bool
156 
+ishelp x y = (x > 800 && x < 870 && y > 420 && y < 490)
157 
+
158 
+button :: Int -> Int -> String -> XInfo -> IO()
159 
+button x y a (XInfo display window  gcontext gcontext2 gcontextp) =
160 
+        xDrawArc (XDrawWindow window) gcontext
161 
+          (XArc (x-40) (y-10) 20 20 1.5708 4.7124) True  `thenIO` \() ->
162 
+        xDrawRectangle (XDrawWindow window) gcontext
163 
+          (XRect (x-30) (y-10) 60 20) True  `thenIO` \() ->
164 
+        xDrawArc (XDrawWindow window) gcontext
165 
+          (XArc (x+20) (y-10) 20 20 (-1.0) 6.283) True `thenIO` \() ->
166 
+        xDrawGlyphs (XDrawWindow window) gcontext2
167 
+          (XPoint (x-(length a * 3)) (y+4)) a   `thenIO` \(trash) ->
168 
+        xDisplayForceOutput display
169 
+
170 
+-- a b are the location of the button, c d are the point where we press the
171 
+-- button.
172 
+
173 
+buttonPress :: Int -> Int -> Int -> Int -> Bool
174 
+buttonPress a b c d | (abs (c-a))<=30 && (abs (d-b))<=10   = True
175 
+                    | (c-a+30)*(c-a+30)+(d-b)*(d-b)<=100   = True
176 
+                    | (c-a-30)*(c-a-30)+(d-b)*(d-b)<=100   = True
177 
+                    | otherwise                            = False
178 
+
179 
+
180 
+
181 
+randmax :: XMArray Int -> Int -> Int -> [Int] -> IO Int
182 
+randmax a ind max mi | ind > 360  =
183 
+                       let lmi = length mi
184 
+                       in case lmi of
185 
+                          0 -> returnIO (-1)
186 
+                          1 -> returnIO (head mi)
187 
+                          _ -> random lmi `thenIO` \ i ->
188 
+                               returnIO (mi !! i)
189 
+                     | otherwise  = xMArrayLookup a ind `thenIO` \ tt3 ->
190 
+                                    if (tt3 > max)
191 
+                                    then randmax a (ind+1) tt3 [ind]
192 
+                                    else if (tt3 == max)
193 
+                                         then randmax a (ind+1) max (ind:mi)
194 
+                                         else randmax a (ind+1) max mi
195 
+
196 
+robot :: XMArray Int -> XMArray Int -> XMArray Int -> IO XPoint
197 
+robot numbersteps weight1 weight2
198 
+      = xMArrayLookup numbersteps 0 `thenIO` \(tt5) ->
199 
+        if (tt5 == 0)
200 
+           then returnIO (XPoint 10 10)
201 
+           else
202 
+		randmax weight1 0 0 [] `thenIO` \ tmp1 ->
203 
+		randmax weight2 0 0 [] `thenIO` \ tmp2 ->
204 
+		xMArrayLookup weight1 tmp1 `thenIO` \ tmp3 ->
205 
+                xMArrayLookup weight2 tmp2 `thenIO` \ tmp4 ->
206 
+                  if (tmp3 >= 200)
207 
+                      then returnIO (xPosition tmp1)
208 
+                      else if (tmp3 > tmp4)
209 
+                               then returnIO (xPosition tmp1)
210 
+                               else returnIO (xPosition tmp2)
211 
+
212 
+
213 
+promptFor prompt xinfo state =
214 
+  let (GameState player1 player2 board steps weight1 weight2 time
215 
+                 numbersteps promptString next_player) = state
216 
+      (XInfo display window gcontext gcontext2 gcontextp) = xinfo
217 
+  in
218 
+  xDrawRectangle (XDrawWindow window) gcontext2
219 
+                 (XRect 616 536 248 28) True `thenIO` \() ->
220 
+  xMArrayUpdate promptString 0 prompt `thenIO` \ _ ->
221 
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 620 550) prompt
222 
+  `thenIO` \ _ ->
223 
+  xDisplayForceOutput display `thenIO` \ _ ->
224 
+  let h_base = (length prompt + 1) * 6 + 620
225 
+      getString :: Int -> String -> IO String
226 
+      getString h_pos sofar =
227 
+        xGetEvent display `thenIO` \event ->
228 
+        case (xEventType event) of
229 
+          XButtonPressEvent ->
230 
+            let (XPoint x y) = xEventPos event
231 
+            in
232 
+            (if ishelp x y then helpGame xinfo state
233 
+             else xBell display 0)
234 
+            `thenIO` \ _ ->
235 
+            getString h_pos sofar
236 
+          XExposureEvent ->
237 
+            may_redraw (xEventCount event == 0) xinfo state `thenIO` \ _ ->
238 
+            xDrawGlyphs (XDrawWindow window) gcontext (XPoint h_base 550) sofar
239 
+            `thenIO` \ _ ->
240 
+            xDrawRectangle (XDrawWindow window) gcontext
241 
+                           (XRect (h_base + 6 * h_pos) (550-10) 6 13) True
242 
+            `thenIO` \ _ -> getString h_pos sofar
243 
+          XKeyPressEvent ->
244 
+            let code = xEventCode event
245 
+                state = xEventState event
246 
+                bs = if (sofar == "") then getString h_pos sofar
247 
+                     else xDrawRectangle (XDrawWindow window) gcontext2
248 
+                                         (XRect (h_base + 6 * h_pos)
249 
+                                                (550-10) 6 13)
250 
+                                         True `thenIO` \ _ ->
251 
+                          xDrawRectangle (XDrawWindow window) gcontext
252 
+                                         (XRect (h_base + 6 * (h_pos - 1))
253 
+                                                (550-10) 6 13)
254 
+                                         True `thenIO` \ _ ->
255 
+                          getString (h_pos-1) (take (length sofar - 1) sofar)
256 
+            in
257 
+            xKeycodeCharacter display code state `thenIO` \ char ->
258 
+            case char of
259 
+               (XSome '\r') -> returnIO sofar
260 
+               (XSome '\DEL') -> bs
261 
+               (XSome '\BS') -> bs
262 
+               XNull     -> getString h_pos sofar
263 
+               (XSome c) -> xDrawRectangle (XDrawWindow window) gcontext2
264 
+                                           (XRect (h_base + 6 * h_pos)
265 
+                                                  (550-10) 6 13)
266 
+                                           True `thenIO` \ _ ->
267 
+                            xDrawGlyph (XDrawWindow window) gcontext
268 
+                                       (XPoint (h_base + 6 * h_pos) 550) c
269 
+                            `thenIO` \ _ ->
270 
+                            xDrawRectangle (XDrawWindow window) gcontext
271 
+                                           (XRect (h_base + 6 * (h_pos + 1))
272 
+                                                  (550-10) 6 13)
273 
+                                           True `thenIO` \ _ ->
274 
+                            getString (h_pos + 1) (sofar ++ [c])
275 
+
276 
+  in
277 
+  xDrawRectangle (XDrawWindow window) gcontext
278 
+                 (XRect h_base (550-10) 6 13) True
279 
+  `thenIO` \ _ ->
280 
+  getString 0 ""
281 
+
282 
+
283 
+helpGame xinfo@(XInfo display window gcontext gcontext2 gcontextp) state =
284 
+  drawHelp xinfo `thenIO` \ _ ->
285 
+  let
286 
+    loop xinfo state =
287 
+      xGetEvent display `thenIO` \ event ->
288 
+      case (xEventType event) of
289 
+        XExposureEvent -> may_redraw (xEventCount event == 0) xinfo state
290 
+                          `thenIO` \ _ ->
291 
+                          drawHelp xinfo `thenIO` \ _ ->
292 
+                          loop xinfo state
293 
+        XButtonPressEvent ->
294 
+                          let (XPoint x y) = xEventPos event
295 
+                          in
296 
+                          if (x > 200 && x < 300 && y > 230 && y < 290)
297 
+                          then redraw xinfo state `thenIO` \ _ ->
298 
+                               returnIO ()
299 
+                          else loop xinfo state
300 
+        _              -> xBell display 0 `thenIO` \ _ ->
301 
+                          loop xinfo state
302 
+  in
303 
+  loop xinfo state
304 
+
305 
+
progs/demo/X11/gobang/utilities.hu
History View file @ 4e98702
0 306 
new file mode 100644
... ... 
@@ -0,0 +1,6 @@
1 
+:o= all
2 
+$HASKELL_LIBRARY/X11/xlib.hu
3 
+utilities.hs
4 
+weights.hs
5 
+redraw.hs
6 
+misc.hi
progs/demo/X11/gobang/weights.hs
History View file @ 4e98702
0 7 
new file mode 100644
... ... 
@@ -0,0 +1,323 @@
1 
+module Weights where
2 
+
3 
+import Xlib
4 
+import Utilities
5 
+
6 
+xlookup :: XMArray Int -> Int -> Int -> IO Int
7 
+xlookup keyboard x y =
8 
+      if (x < 1 || x > 19 || y < 1 || y > 19)
9 
+      then returnIO (-2)
10 
+      else xMArrayLookup keyboard ((x-1)*19+(y-1))
11 
+
12 
+
13 
+draw_unit :: XMArray Int -> XMArray Int -> XMArray Int -> Int -> Int  -> IO()
14 
+draw_unit keyboard weight1 weight2 x y =
15 
+  let
16 
+    update_weight :: XMArray Int->Int->Int->Int->Int->Int->Int->IO()
17 
+    update_weight weight counter player x y incr_x incr_y
18 
+      | x>=1 && x<=19 && y>=1 && y<=19 && counter<=4 =
19 
+          cpt_weight x y player `thenIO` \wt ->
20 
+            xMArrayUpdate weight ((x-1)*19+(y-1)) wt `thenIO` \() ->
21 
+              update_weight weight (counter+1) player (x+incr_x) (y+incr_y)
22 
+	                    incr_x incr_y
23 
+      | otherwise = returnIO ()
24 
+----------------------------------------------------------------------------
25 
+
26 
+    pattern0 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool
27 
+    pattern0 a b c d e p | a==p && b==p && c==p && d==p && e==p = True
28 
+	                 | otherwise                            = False
29 
+----------------------------------------------------------------------------
30 
+
31 
+    pattern1 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool
32 
+    pattern1 a b c d e f p  | (a==0) && (b==p) && (c==p) && (d==p) && (e==p) &&
33 
+                              (f==0)     = True
34 
+	       		    | otherwise  = False
35 
+----------------------------------------------------------------------------
36 
+
37 
+    pattern2 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool
38 
+    pattern2 a b c d e p | (a==0 && b==p && c==p && d==p && e==p)||
39 
+                           (a==p && b==p && c==p && d==p && e==0) = True
40 
+			 | otherwise                              = False
41 
+----------------------------------------------------------------------------
42 
+
43 
+    pattern3 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool
44 
+    pattern3 a b c d e p | (a==0 && b==p && c==p && d==p && e==0) = True
45 
+                         | otherwise                              = False
46 
+----------------------------------------------------------------------------
47 
+
48 
+    pattern4 :: Int -> Int -> Int -> Int -> Int ->  Bool
49 
+    pattern4 a b c d p | (a==0 && b==p && c==p && d==p) ||
50 
+                         (a==p && b==p && c==p && d==0) = True
51 
+                       | otherwise                      = False
52 
+----------------------------------------------------------------------------
53 
+
54 
+    pattern5 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool
55 
+    pattern5 a b c d e f p  | (a==0 && b==p && c==p && d==0 && e==p &&
56 
+                               f==0) ||
57 
+                              (a==0 && b==p && c==0 && d==p && e==p &&
58 
+                               f==0)    = True
59 
+			    | otherwise = False
60 
+----------------------------------------------------------------------------
61 
+
62 
+    pattern6 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool
63 
+    pattern6 a b c d e p | (a==0 && b==p && c==p && d==0 && e==p) ||
64 
+                           (a==0 && b==p && c==0 && d==p && e==p) ||
65 
+                           (a==p && b==p && c==0 && d==p && e==0) ||
66 
+                           (a==p && b==0 && c==p && d==p && e==0) = True
67 
+			 | otherwise = False
68 
+----------------------------------------------------------------------------
69 
+
70 
+    pattern7 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int-> Bool
71 
+    pattern7 a b c d e f g p | (a==0 && b==p && c==0 && d==p && e==0 &&
72 
+                                 f==p && g==0) = True
73 
+			     | otherwise       = False
74 
+----------------------------------------------------------------------------
75 
+
76 
+    pattern8 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool
77 
+    pattern8 a b c d e f p | (a==0 && b==p && c==0 && d==p && e==0 &&
78 
+                              f==p) ||
79 
+                             (a==p && b==0 && c==p && d==0 && e==p &&
80 
+		              f==0) = True
81 
+                           | otherwise = False
82 
+----------------------------------------------------------------------------
83 
+
84 
+    pattern9 :: Int -> Int -> Int -> Int -> Int -> Bool
85 
+    pattern9 a b c d p | (a==0 && b==p && c==p && d==0) = True
86 
+                       | otherwise                      = False
87 
+----------------------------------------------------------------------------
88 
+
89 
+    pattern10 :: Int -> Int -> Int -> Int -> Bool
90 
+    pattern10 a b c p | (a==0 && b==p && c==p) ||
91 
+                        (a==p && b==p && c==0) = True
92 
+                      | otherwise              = False
93 
+----------------------------------------------------------------------------
94 
+
95 
+    pattern11 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool
96 
+    pattern11 a b c d e p | (a==0 && b==p && c==0 && d==p && e==0) = True
97 
+                          | otherwise                              = False
98 
+----------------------------------------------------------------------------
99 
+
100 
+    pattern12 :: Int -> Int -> Int -> Int -> Int -> Bool
101 
+    pattern12 a b c d p | (a==0 && b==p && c==0 && d==p) ||
102 
+                          (a==p && b==0 && c==p && d==0) = True
103 
+                        | otherwise                      = False
104 
+----------------------------------------------------------------------------
105 
+
106 
+    direct1 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int ->
107 
+               Int -> Int -> Int -> Int -> Int -> Int
108 
+    direct1 x y pl ptN1 ptN2 ptN3 ptN4 ptN5 pt ptP1 ptP2 ptP3 ptP4 ptP5
109 
+      | (pattern0  ptN4 ptN3 ptN2 ptN1 pt pl) ||
110 
+        (pattern0  ptN3 ptN2 ptN1 pt ptP1 pl) ||
111 
+    	(pattern0  ptN2 ptN1 pt ptP1 ptP2 pl) ||
112 
+	(pattern0  ptN1 pt ptP1 ptP2 ptP3 pl) ||
113 
+        (pattern0  pt ptP1 ptP2 ptP3 ptP4 pl) = 200
114 
+      | (pattern1  ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) ||
115 
+        (pattern1  ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) ||
116 
+    	(pattern1  ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) ||
117 
+	(pattern1  ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) = 40
118 
+      | (pattern2  ptN4 ptN3 ptN2 ptN1 pt pl) ||
119 
+        (pattern2  ptN3 ptN2 ptN1 pt ptP1 pl) ||
120 
+    	(pattern2  ptN2 ptN1 pt ptP1 ptP2 pl) ||
121 
+	(pattern2  ptN1 pt ptP1 ptP2 ptP3 pl) = 13
122 
+      | (pattern3  ptN3 ptN2 ptN1 pt ptP1 pl) ||
123 
+        (pattern3  ptN2 ptN1 pt ptP1 ptP2 pl) ||
124 
+        (pattern3  ptN1 pt ptP1 ptP2 ptP3 pl) = 10
125 
+      | (pattern4  ptN3 ptN2 ptN1 pt pl) ||
126 
+        (pattern4  ptN2 ptN1 pt ptP1 pl) ||
127 
+        (pattern4  ptN1 pt ptP1 ptP2 pl) = 8
128 
+      | (pattern5  ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) ||
129 
+        (pattern5  ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) ||
130 
+        (pattern5  ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) ||
131 
+        (pattern5  ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) = 9
132 
+      | (pattern6  ptN4 ptN3 ptN2 ptN1 pt pl) ||
133 
+        (pattern6  ptN3 ptN2 ptN1 pt ptP1 pl) ||
134 
+        (pattern6  ptN2 ptN1 pt ptP1 ptP2 pl) ||
135 
+        (pattern6  ptN1 pt ptP1 ptP2 ptP3 pl) = 7
136 
+      | (pattern7  ptN5 ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) ||
137 
+        (pattern7  ptN4 ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) ||
138 
+	(pattern7  ptN3 ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) ||
139 
+        (pattern7  ptN2 ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) ||
140 
+        (pattern7  ptN1 pt ptP1 ptP2 ptP3 ptP4 ptP5 pl) = 6
141 
+      | (pattern8  ptN5 ptN4 ptN3 ptN2 ptN1 pt pl) ||
142 
+        (pattern8  ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) ||
143 
+        (pattern8  ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) ||
144 
+        (pattern8  ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) ||
145 
+        (pattern8  ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) ||
146 
+        (pattern8  pt ptP1 ptP2 ptP3 ptP4 ptP5 pl) = 5
147 
+      | (pattern9  ptN2 ptN1 pt ptP1 pl) ||
148 
+        (pattern9  ptN1 pt ptP1 ptP2 pl) = 4
149 
+      | (pattern10 ptN2 ptN1 pt pl) ||
150 
+        (pattern10 ptN1 pt ptP1 pl) ||
151 
+        (pattern10 pt ptP1 ptP2 pl) = 2
152 
+      | (pattern11 ptN3 ptN2 ptN1 pt ptP1 pl) ||
153 
+        (pattern11 ptN2 ptN1 pt ptP1 ptP2 pl) ||
154 
+        (pattern11 ptN1 pt ptP1 ptP2 ptP3 pl) = 3
155 
+      | (pattern12 ptN3 ptN2 ptN1 pt pl) ||
156 
+        (pattern12 ptN2 ptN1 pt ptP1 pl) ||
157 
+        (pattern12 ptN1 pt ptP1 ptP2 pl) ||
158 
+        (pattern12 pt ptP1 ptP2 ptP3 pl) = 1
159 
+      | otherwise = 0
160 
+----------------------------------------------------------------------------
161 
+
162 
+    direct2 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int ->
163 
+               Int -> Int -> Int -> Int -> Int -> Int
164 
+    direct2 x y pl ptN1 ptN2 ptN3 ptN4 ptN5 pt ptP1 ptP2 ptP3 ptP4 ptP5
165 
+      | (pattern0  ptN4 ptN3 ptN2 ptN1 pt pl) ||
166 
+        (pattern0  ptN3 ptN2 ptN1 pt ptP1 pl) ||
167 
+    	(pattern0  ptN2 ptN1 pt ptP1 ptP2 pl) ||
168 
+	(pattern0  ptN1 pt ptP1 ptP2 ptP3 pl) ||
169 
+        (pattern0  pt ptP1 ptP2 ptP3 ptP4 pl) = 200
170 
+      | otherwise = 0
171 
+-----------------------------------------------------------------------------
172 
+
173 
+    cpt_weight :: Int -> Int -> Int -> IO Int
174 
+    cpt_weight x y player =
175 
+      xMArrayLookup keyboard ((x-1)*19+(y-1)) `thenIO` \(unit) ->
176 
+      if (unit /= 0)
177 
+        then returnIO (-1)
178 
+        else xlookup keyboard x (y-1) `thenIO` \(xyN1) ->
179 
+             xlookup keyboard x (y-2) `thenIO` \(xyN2) ->
180 
+             xlookup keyboard x (y-3) `thenIO` \(xyN3) ->
181 
+	     xlookup keyboard x (y-4) `thenIO` \(xyN4) ->
182 
+	     xlookup keyboard x (y-5) `thenIO` \(xyN5) ->
183 
+	     xlookup keyboard x (y+1) `thenIO` \(xyP1) ->
184 
+	     xlookup keyboard x (y+2) `thenIO` \(xyP2) ->
185 
+	     xlookup keyboard x (y+3) `thenIO` \(xyP3) ->
186 
+	     xlookup keyboard x (y+4) `thenIO` \(xyP4) ->
187 
+	     xlookup keyboard x (y+5) `thenIO` \(xyP5) ->
188 
+	     xlookup keyboard (x-1) y `thenIO` \(xN1y) ->
189 
+	     xlookup keyboard (x-2) y `thenIO` \(xN2y) ->
190 
+             xlookup keyboard (x-3) y `thenIO` \(xN3y) ->
191 
+	     xlookup keyboard (x-4) y `thenIO` \(xN4y) ->
192 
+	     xlookup keyboard (x-5) y `thenIO` \(xN5y) ->
193 
+	     xlookup keyboard (x+1) y `thenIO` \(xP1y) ->
194 
+	     xlookup keyboard (x+2) y `thenIO` \(xP2y) ->
195 
+	     xlookup keyboard (x+3) y `thenIO` \(xP3y) ->
196 
+	     xlookup keyboard (x+4) y `thenIO` \(xP4y) ->
197 
+	     xlookup keyboard (x+5) y `thenIO` \(xP5y) ->
198 
+	     xlookup keyboard (x-1) (y-1) `thenIO` \(xN1yN1)->
199 
+             xlookup keyboard (x-2) (y-2) `thenIO` \(xN2yN2) ->
200 
+             xlookup keyboard (x-3) (y-3) `thenIO` \(xN3yN3) ->
201 
+             xlookup keyboard (x-4) (y-4) `thenIO` \(xN4yN4) ->
202 
+             xlookup keyboard (x-5) (y-5) `thenIO` \(xN5yN5) ->
203 
+             xlookup keyboard (x+1) (y+1) `thenIO` \(xP1yP1) ->
204 
+             xlookup keyboard (x+2) (y+2) `thenIO` \(xP2yP2) ->
205 
+             xlookup keyboard (x+3) (y+3) `thenIO` \(xP3yP3) ->
206 
+             xlookup keyboard (x+4) (y+4) `thenIO` \(xP4yP4) ->
207 
+             xlookup keyboard (x+5) (y+5) `thenIO` \(xP5yP5) ->
208 
+             xlookup keyboard (x-1) (y+1) `thenIO` \(xN1yP1) ->
209 
+             xlookup keyboard (x-2) (y+2) `thenIO` \(xN2yP2) ->
210 
+             xlookup keyboard (x-3) (y+3) `thenIO` \(xN3yP3) ->
211 
+             xlookup keyboard (x-4) (y+4) `thenIO` \(xN4yP4) ->
212 
+             xlookup keyboard (x-5) (y+5) `thenIO` \(xN5yP5) ->
213 
+             xlookup keyboard (x+1) (y-1) `thenIO` \(xP1yN1) ->
214 
+             xlookup keyboard (x+2) (y-2) `thenIO` \(xP2yN2) ->
215 
+             xlookup keyboard (x+3) (y-3) `thenIO` \(xP3yN3) ->
216 
+             xlookup keyboard (x+4) (y-4) `thenIO` \(xP4yN4) ->
217 
+             xlookup keyboard (x+5) (y-5) `thenIO` \(xP5yN5) ->
218 
+	     returnIO ( (direct1 x y player xyN1 xyN2 xyN3 xyN4 xyN5 player
219 
+	                         xyP1 xyP2 xyP3 xyP4 xyP5) +
220 
+	                (direct1 x y player xN1y xN2y xN3y xN4y xN5y player
221 
+	                         xP1y xP2y xP3y xP4y xP5y) +
222 
+                        (direct1 x y player xN1yN1 xN2yN2 xN3yN3 xN4yN4
223 
+			         xN5yN5 player xP1yP1 xP2yP2 xP3yP3 xP4yP4
224 
+				 xP5yP5) +
225 
+	                (direct1 x y player xN1yP1 xN2yP2 xN3yP3 xN4yP4
226 
+			         xN5yP5 player xP1yN1 xP2yN2 xP3yN3 xP4yN4
227 
+				 xP5yN5) )
228 
+-----------------------------------------------------------------------------
229 
+
230 
+--                        | 1111 && no_block = 20
231 
+--			  | 1111 && one_block = 13
232 
+--			  | 111 && no_block = 10
233 
+--			  | 111 && one_block = 8
234 
+--			  | 11 1 or 1 11 && no_block = 9
235 
+--			  | 11 1 or 1 11 && one_block =7
236 
+--                        | 1 1 1 && no_block = 6
237 
+--			  | 1 1 1 && one_block= 5
238 
+--			  | 11 && no_block = 4
239 
+--			  | 11 && one_block =2
240 
+--			  | 1 1 && no_block =3
241 
+--			  | 1 1 && one_block=1
242 
+
243 
+  in
244 
+    update_weight weight1 0 1 x y 1    1    `thenIO` \() ->
245 
+    update_weight weight2 0 2 x y 1    1    `thenIO` \() ->
246 
+    update_weight weight1 0 1 x y 1    (-1) `thenIO` \() ->
247 
+    update_weight weight2 0 2 x y 1    (-1) `thenIO` \() ->
248 
+    update_weight weight1 0 1 x y (-1) (-1) `thenIO` \() ->
249 
+    update_weight weight2 0 2 x y (-1) (-1) `thenIO` \() ->
250 
+    update_weight weight1 0 1 x y (-1) 1    `thenIO` \() ->
251 
+    update_weight weight2 0 2 x y (-1) 1    `thenIO` \() ->
252 
+    update_weight weight1 0 1 x y 0    1    `thenIO` \() ->
253 
+    update_weight weight2 0 2 x y 0    1    `thenIO` \() ->
254 
+    update_weight weight1 0 1 x y 0    (-1) `thenIO` \() ->
255 
+    update_weight weight2 0 2 x y 0    (-1) `thenIO` \() ->
256 
+    update_weight weight1 0 1 x y (-1) 0    `thenIO` \() ->
257 
+    update_weight weight2 0 2 x y (-1) 0    `thenIO` \() ->
258 
+    update_weight weight1 0 1 x y 1    0    `thenIO` \() ->
259 
+    update_weight weight2 0 2 x y 1    0    `thenIO` \() ->
260 
+    returnIO ()
261 
+
262 
+
263 
+human_unit :: XMArray Int -> Int -> Int  -> IO(Bool)
264 
+human_unit keyboard x y =
265 
+  let
266 
+    pattern0 :: Int -> Int -> Int -> Int -> Int -> Bool
267 
+    pattern0 a b c d e | a==b && b==c && c==d && d==e = True
268 
+	               | otherwise                    = False
269 
+
270 
+    direct3 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int ->
271 
+               Int
272 
+    direct3 ptN1 ptN2 ptN3 ptN4 pt ptP1 ptP2 ptP3 ptP4
273 
+      | (pattern0  ptN4 ptN3 ptN2 ptN1 pt) ||
274 
+        (pattern0  ptN3 ptN2 ptN1 pt ptP1) ||
275 
+    	(pattern0  ptN2 ptN1 pt ptP1 ptP2) ||
276 
+	(pattern0  ptN1 pt ptP1 ptP2 ptP3) ||
277 
+        (pattern0  pt ptP1 ptP2 ptP3 ptP4) = 200
278 
+      | otherwise = 0
279 
+  in
280 
+    xlookup keyboard x y `thenIO` \(xy) ->
281 
+    xlookup keyboard x (y-1) `thenIO` \(xyN1) ->
282 
+    xlookup keyboard x (y-2) `thenIO` \(xyN2) ->
283 
+    xlookup keyboard x (y-3) `thenIO` \(xyN3) ->
284 
+    xlookup keyboard x (y-4) `thenIO` \(xyN4) ->
285 
+    xlookup keyboard x (y+1) `thenIO` \(xyP1) ->
286 
+    xlookup keyboard x (y+2) `thenIO` \(xyP2) ->
287 
+    xlookup keyboard x (y+3) `thenIO` \(xyP3) ->
288 
+    xlookup keyboard x (y+4) `thenIO` \(xyP4) ->
289 
+    xlookup keyboard (x-1) y `thenIO` \(xN1y) ->
290 
+    xlookup keyboard (x-2) y `thenIO` \(xN2y) ->
291 
+    xlookup keyboard (x-3) y `thenIO` \(xN3y) ->
292 
+    xlookup keyboard (x-4) y `thenIO` \(xN4y) ->
293 
+    xlookup keyboard (x+1) y `thenIO` \(xP1y) ->
294 
+    xlookup keyboard (x+2) y `thenIO` \(xP2y) ->
295 
+    xlookup keyboard (x+3) y `thenIO` \(xP3y) ->
296 
+    xlookup keyboard (x+4) y `thenIO` \(xP4y) ->
297 
+    xlookup keyboard (x-1) (y-1) `thenIO` \(xN1yN1)->
298 
+    xlookup keyboard (x-2) (y-2) `thenIO` \(xN2yN2) ->
299 
+    xlookup keyboard (x-3) (y-3) `thenIO` \(xN3yN3) ->
300 
+    xlookup keyboard (x-4) (y-4) `thenIO` \(xN4yN4) ->
301 
+    xlookup keyboard (x+1) (y+1) `thenIO` \(xP1yP1) ->
302 
+    xlookup keyboard (x+2) (y+2) `thenIO` \(xP2yP2) ->
303 
+    xlookup keyboard (x+3) (y+3) `thenIO` \(xP3yP3) ->
304 
+    xlookup keyboard (x+4) (y+4) `thenIO` \(xP4yP4) ->
305 
+    xlookup keyboard (x-1) (y+1) `thenIO` \(xN1yP1) ->
306 
+    xlookup keyboard (x-2) (y+2) `thenIO` \(xN2yP2) ->
307 
+    xlookup keyboard (x-3) (y+3) `thenIO` \(xN3yP3) ->
308 
+    xlookup keyboard (x-4) (y+4) `thenIO` \(xN4yP4) ->
309 
+    xlookup keyboard (x+1) (y-1) `thenIO` \(xP1yN1) ->
310 
+    xlookup keyboard (x+2) (y-2) `thenIO` \(xP2yN2) ->
311 
+    xlookup keyboard (x+3) (y-3) `thenIO` \(xP3yN3) ->
312 
+    xlookup keyboard (x+4) (y-4) `thenIO` \(xP4yN4) ->
313 
+    xlookup keyboard (x+1) y `thenIO` \(xP1y) ->
314 
+    xlookup keyboard (x+2) y `thenIO` \(xP2y) ->
315 
+    xlookup keyboard (x+3) y `thenIO` \(xP3y) ->
316 
+    xlookup keyboard (x+4) y `thenIO` \(xP4y) ->
317 
+    if ((direct3 xyN1 xyN2 xyN3 xyN4 xy xyP1 xyP2 xyP3 xyP4) +
318 
+        (direct3 xN1y xN2y xN3y xN4y xy xP1y xP2y xP3y xP4y) +
319 
+	(direct3 xN1yN1 xN2yN2 xN3yN3 xN4yN4 xy xP1yP1 xP2yP2 xP3yP3 xP4yP4) +
320 
+        (direct3 xN1yP1 xN2yP2 xN3yP3 xN4yP4 xy xP1yN1 xP2yN2 xP3yN3 xP4yN4))
321 
+       >=200
322 
+      then returnIO (True)
323 
+      else returnIO (False)
0 324 
\ No newline at end of file
progs/demo/X11/gobang/weights.hu
History View file @ 4e98702
1 325 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+:o= all
2 
+$HASKELL_LIBRARY/X11/xlib.hu
3 
+weights.hs
4 
+utilities.hs
progs/demo/X11/graphics/README
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,31 @@
1 
+HENDERSON GRAPHICS LIBRARY
2 
+by Syam Gadde
3 
+and Bo Whong
4 
+
5 
+-------------------------------------------------
6 
+
7 
+To use the Henderson Library, run emacs with a module that
8 
+imports HendersonLib, such as "sqrlmt.hs".  For "sqrlmt.hs",
9 
+run the dialogue "final" or "skewedfinal".
10 
+
11 
+-------------------------------------------------
12 
+
13 
+henderson.hs	- Haskell source for the Henderson library.
14 
+henderson.hu
15 
+sqrlmt.hs	- Haskell source for dialogue that draws "Square Limit".
16 
+sqrlmt.hu
17 
+p.pic		- First of four pictures used to construct "Square Limit".
18 
+q.pic		- Second of four pictures used to construct "Square Limit".
19 
+r.pic		- Third of four pictures used to construct "Square Limit".
20 
+s.pic		- Four of four pictures used to construct "Square Limit".
21 
+new.pic		- Hudak's house
22 
+stop.pic	- A "hand-drawn" stop sign border
23 
+text.pic	- The word "STOP!" (hand-drawn)
24 
+strange.pic	- Overlays stop.pic and Flip of text.pic
25 
+squarebox.xwd	- A window dump of a box-like structure made of four
26 
+			square limits.  Use "xwud -in squarebox.xwd" to view.
27 
+sksl.xwd	- A window dump of "squarelimit" in a skewed bounding box.
28 
+			("skewedfinal" from sqrlmt.hs.)
29 
+sl.xwd		- A window dump of Square Limit.
30 
+			("squarelimit" from sqrlmt.hs.)
31 
+manual		- The manual in Island Write format.
progs/demo/X11/graphics/henderson.hs
History View file @ 4e98702
0 32 
new file mode 100644
... ... 
@@ -0,0 +1,465 @@
1 
+-- Peter Henderson's Recursive Geometry
2 
+-- Syam Gadde and Bo Whong
3 
+-- full set of modules
4 
+-- CS429 Project
5 
+-- 4/30/93
6 
+
7 
+module HendersonLib (Hostname(..), Filename(..), VTriple(..), HendQuartet(..),
8 
+                     Picture(..), sendToDraw, draw, create, modify, plot) where
9 
+import Xlib
10 
+
11 
+-- ADTs and Type Synonyms --------------------------------------------------
12 
+data Picture = Nil
13 
+             | Flip Picture
14 
+             | Beside Float Picture Float Picture
15 
+	     | Above Float Picture Float Picture
16 
+	     | Rot Picture
17 
+	     | File String
18 
+	     | Overlay Picture Picture
19 
+	     | Grid Int Int SegList
20 
+	     deriving Text
21 
+
22 
+data Plot = Plot Picture VTriple
23 
+          | Union Plot Plot
24 
+
25 
+type Hostname = String
26 
+type Filename = String
27 
+type IntPoint = (Int,Int)
28 
+type IntSegment = (IntPoint, IntPoint)
29 
+type IntSegList = [IntSegment]
30 
+type Point = (Float,Float)
31 
+type Segment = (Point, Point)
32 
+type SegList = [Segment]
33 
+type Vector = Point
34 
+type VTriple = (Vector, Vector, Vector)
35 
+type HendQuartet = (Int, Int, Int, Int)
36 
+type PEnv = [(Filename, Picture)]
37 
+
38 
+-- vector Functions --------------------------------------------------------
39 
+-- for adding, negating, multiplying, and dividing vectors
40 
+
41 
+addV :: Vector -> Vector -> Vector
42 
+addV (x1,y1) (x2,y2) = (x1+x2, y1+y2)
43 
+
44 
+negateV :: Vector -> Vector
45 
+negateV (x,y) = (-x,-y)
46 
+
47 
+multV ::  Float-> Vector -> Vector
48 
+multV a (x,y) = (a*x, a*y)
49 
+
50 
+divV :: Float -> Vector -> Vector
51 
+divV a (x,y) = (x/a, y/a)
52 
+
53 
+-- plot Function -----------------------------------------------------------
54 
+-- picture manipulation function
55 
+
56 
+plot :: Picture -> VTriple -> PEnv -> ((Plot, PEnv) -> IO()) -> IO()
57 
+
58 
+-- the Nil Picture is just "nothingness" so choose an abritrary representation
59 
+--  of nothingness.
60 
+plot Nil (v1, v2, v3) env cont =
61 
+  plot (Grid 1 1 []) (v1,v2,v3) env cont
62 
+
63 
+-- Flipping a Picture
64 
+plot (Flip p1) (v1, v2, v3) env cont =
65 
+  plot p1 (addV v1 v2, negateV v2, v3) env cont
66 
+
67 
+-- Rotate a Picture 90 degrees counterclockwise
68 
+plot (Rot p1) (v1, v2, v3) env cont =
69 
+  plot p1 (addV v1 v3, negateV v3, v2) env cont
70 
+
71 
+-- Overlay one Picture over another Picture
72 
+plot (Overlay p q) (a,b,c) env cont =
73 
+  plot p (a,b,c) env $ \ (plot1, env1) ->
74 
+  plot q (a,b,c) env1 $ \ (plot2, env2) ->
75 
+  cont ((Union plot1 plot2), env2)
76 
+
77 
+-- Place p1 Beside p2 with width ratio m to n
78 
+plot (Beside m p1 n p2) (v1, v2, v3) env cont =
79 
+  plot p1 (v1, multV (m/(m+n)) v2, v3) env $ \ (plot1, env1) ->
80 
+  plot p2 ((addV (multV (m/(m+n)) v2) v1),
81 
+	         (multV (n/(m+n)) v2),
82 
+                 v3) env1                  $ \ (plot2, env2) ->
83 
+  cont ((Union plot1 plot2), env2)
84 
+
85 
+-- Place p Above q with height ratio m to n
86 
+plot (Above m p n q) (a,b,c) env cont =
87 
+  plot q (addV a (multV (m/(n+m)) c), b,  multV (n/(m+n)) c) env
88 
+    $ \ (plot1, env1) ->
89 
+  plot p (a, b, multV (m/(m+n)) c) env1 $ \ (plot2, env2) ->
90 
+  cont ((Union plot1 plot2), env2)
91 
+
92 
+-- the 'real' Picture
93 
+plot (Grid x y s) (a,b,c) env cont =
94 
+  cont ((Plot (Grid x y s) (a,b,c)), env)
95 
+
96 
+-- this picture is located in a File with name name
97 
+--  lookup table: thanks to Sheng
98 
+plot (File name) (a,b,c) env cont =
99 
+  case (lookupEnv env name) of
100 
+    ((_, pic):_) -> plot pic (a,b,c) env cont
101 
+    []           ->
102 
+       readFile name (\s -> appendChan stdout ("File "++name++" not able to be read\n") exit done)
103 
+                     $ \s ->
104 
+       let
105 
+        pic = read s
106 
+        newenv = (name,pic):env
107 
+       in
108 
+       plot pic (a,b,c) newenv cont
109 
+
110 
+lookupEnv :: PEnv -> Filename -> PEnv
111 
+lookupEnv [] _ = []
112 
+lookupEnv ((a,b):es) name | a==name   = ((a,b):es)
113 
+                          | otherwise = lookupEnv es name
114 
+
115 
+-- Draw Function -----------------------------------------------------------
116 
+-- user function to draw pictures
117 
+
118 
+draw :: Hostname -> Picture -> VTriple -> HendQuartet -> IO()
119 
+
120 
+-- opens a display, screen, and window (of size specified in HendQuartet)
121 
+--  and draws Picture in the window
122 
+draw host p (a,b,c) (hm,hn,ho,hp) =
123 
+ xOpenDisplay host `thenIO` \display ->       -- opens display
124 
+  let (screen:_) = xDisplayRoots display
125 
+      fg_color = xScreenBlackPixel screen
126 
+      bg_color = xScreenWhitePixel screen
127 
+      root = xScreenRoot screen
128 
+  in
129 
+  xCreateWindow root                          -- opens window
130 
+                (XRect hm hn ho hp)
131 
+		[XWinBackground bg_color,
132 
+		 XWinEventMask (XEventMask [XKeyPress,
133 
+		                            XExposure,
134 
+                                            XButtonPress])]
135 
+  `thenIO` \window ->
136 
+  xSetWmName window "Henderson Graphics" `thenIO` \() ->
137 
+  xSetWmIconName window "Henderson Graphics" `thenIO` \() ->
138 
+  xMapWindow window `thenIO` \() ->          -- show window
139 
+  xDisplayForceOutput display `thenIO` \ () ->  -- show window NOW
140 
+  xCreateGcontext (XDrawWindow (xScreenRoot screen))   -- open a GC
141 
+                  [XGCBackground bg_color,
142 
+		   XGCForeground fg_color] `thenIO` \ gcontext ->
143 
+  plot p (a,b,c) [] $ \(plt,_) ->            -- make pic easier to work with
144 
+  let
145 
+    handleEvent =
146 
+      xGetEvent display `thenIO` \event ->
147 
+        case (xEventType event) of
148 
+	  -- Has a part of the window been uncovered?
149 
+	  XExposureEvent ->  sendToDraw window screen display gcontext plt
150 
+	                     `thenIO` \() -> handleEvent
151 
+          _              -> xCloseDisplay display
152 
+  in
153 
+  handleEvent
154 
+
155 
+-- SendToDraw Function -----------------------------------------------------
156 
+-- called by draw to actually draw the lines onto the window
157 
+
158 
+sendToDraw :: XWindow -> XScreen -> XDisplay -> XGcontext -> Plot -> IO()
159 
+
160 
+-- have a Union.  so do one, and then the other. simple.
161 
+sendToDraw win screen display gcontext (Union p1 p2) =
162 
+  sendToDraw win screen display gcontext p1 `thenIO` \() ->
163 
+  sendToDraw win screen display gcontext p2
164 
+
165 
+-- have just a Plot.  have to do some dirty work.
166 
+sendToDraw window screen display gcontext (Plot (Grid x y s) (a,b,c)) =
167 
+  let
168 
+    v2p :: Vector -> XPoint
169 
+    v2p (e,f) = XPoint (round e) (round f)  -- convert Vector to an XPoint
170 
+    fx :: Float
171 
+    fx = fromIntegral x
172 
+    fy :: Float
173 
+    fy = fromIntegral y
174 
+    drawit :: SegList -> IO()
175 
+    -- draw the Grid one line at a time
176 
+    drawit [] = done
177 
+    drawit (((x0,y0),(x1,y1)):ss) =
178 
+      xDrawLine (XDrawWindow window)
179 
+              gcontext
180 
+	      (v2p (addV (addV a (multV (x0/fx) b))
181 
+	                 (multV (y0/fy) c)))
182 
+	      (v2p (addV (addV a (multV (x1/fx) b))
183 
+	                 (multV (y1/fy) c))) `thenIO` \() ->
184 
+      drawit ss
185 
+  in
186 
+  drawit s `thenIO` \ () ->
187 
+  xDisplayForceOutput display
188 
+
189 
+-- create function ---------------------------------------------------------
190 
+-- opens up a window to allow the user to create a file
191 
+-- and save it onto a file
192 
+
193 
+create :: Hostname -> Filename -> Int -> Int -> IO()
194 
+
195 
+create host filename x y =
196 
+  xOpenDisplay host `thenIO` \ display ->
197 
+  let
198 
+   (screen:_) = xDisplayRoots display
199 
+   fg_color = xScreenWhitePixel screen
200 
+   bg_color = xScreenBlackPixel screen
201 
+   root = xScreenRoot screen
202 
+  in
203 
+  xCreateWindow root
204 
+                (XRect 0 0 (x+1) (y+1))
205 
+                [XWinBackground bg_color,
206 
+                 XWinEventMask (XEventMask [XExposure,
207 
+		                            XKeyPress,
208 
+					    XButtonPress,
209 
+					    XPointerMotion])]
210 
+  `thenIO` \window ->
211 
+  xSetWmName window filename `thenIO` \() ->
212 
+  xSetWmIconName window filename `thenIO` \() ->
213 
+  xCreateWindow root
214 
+                (XRect 0 0 100 40)
215 
+		[XWinBackground bg_color] `thenIO` \window2 ->
216 
+  xSetWmName window2 "pos" `thenIO` \() ->
217 
+  xSetWmIconName window2 "pos" `thenIO` \() ->
218 
+  xMapWindow window `thenIO` \() ->
219 
+  xMapWindow window2 `thenIO` \() ->
220 
+  xListFonts display "*times*bold*r*normal*18*" `thenIO` \fontlist ->
221 
+  xCreateGcontext (XDrawWindow root)
222 
+                  [XGCBackground bg_color,
223 
+                   XGCForeground fg_color,
224 
+		   XGCFont (head fontlist)] `thenIO` \gcontext ->
225 
+  let
226 
+   handleEvent :: IntSegList -> IO()
227 
+   handleEvent list =
228 
+     xGetEvent display `thenIO` \event ->
229 
+     let
230 
+      point = xEventPos event
231 
+      XPoint pointx pointy = point
232 
+      handleEvent' :: XPoint -> IO()
233 
+      handleEvent' last =
234 
+       xGetEvent display `thenIO` \event2 ->
235 
+       let
236 
+        pos = xEventPos event2
237 
+	XPoint posx posy = pos
238 
+       in
239 
+        case (xEventType event2) of
240 
+         XKeyPressEvent  ->
241 
+           appendChan stdout ((show (tup pos))++ "\n") abort $
242 
+           xDrawLine (XDrawWindow window) gcontext point pos
243 
+           `thenIO` \() -> handleEvent (store list point pos)
244 
+         XExposureEvent  ->
245 
+           redraw window gcontext list `thenIO` \() -> handleEvent' last
246 
+	 XMotionNotifyEvent ->
247 
+	   xDrawImageGlyphs (XDrawWindow window2)
248 
+	                    gcontext
249 
+			    (XPoint 2 18)
250 
+			    ((show posx)++", "++(show posy)++"      ")
251 
+			    `thenIO` \dummy -> handleEvent' last
252 
+         _                  ->
253 
+           handleEvent' last
254 
+     in
255 
+     case (xEventType event) of
256 
+       XButtonPressEvent     ->
257 
+         putFile display filename list x y "create"
258 
+       XKeyPressEvent  ->
259 
+         appendChan stdout (show (tup point)) abort $
260 
+         handleEvent' point
261 
+       XExposureEvent  ->
262 
+         redraw window gcontext list `thenIO` \() -> handleEvent list
263 
+       XMotionNotifyEvent ->
264 
+	 xDrawImageGlyphs (XDrawWindow window2)
265 
+	                  gcontext
266 
+			  (XPoint 2 18)
267 
+			  ((show pointx)++", "++(show pointy)++"      ")
268 
+			  `thenIO` \dummy -> handleEvent list
269 
+       _                  ->
270 
+         handleEvent list
271 
+  in
272 
+   case (checkFile filename) of
273 
+     True  -> handleEvent []
274 
+     False -> appendChan stdout picTypeError abort $
275 
+              xCloseDisplay display
276 
+
277 
+-- modify function ---------------------------------------------------------
278 
+-- allows the user to add onto an already existing picture file
279 
+
280 
+modify :: Hostname -> Filename -> IO()
281 
+
282 
+modify host filename =
283 
+  case (checkFile filename) of
284 
+   False -> appendChan stdout picTypeError abort done
285 
+   True  ->
286 
+    readFile filename (\s -> appendChan stdout
287 
+                                        readError abort done) $ \s->
288 
+    let
289 
+     dat = read s
290 
+     origlist = fFloat (getlist dat)
291 
+     x = getx dat
292 
+     y = gety dat
293 
+    in
294 
+     xOpenDisplay host `thenIO` \ display ->
295 
+     let
296 
+      (screen:_) = xDisplayRoots display
297 
+      fg_color = xScreenWhitePixel screen
298 
+      bg_color = xScreenBlackPixel screen
299 
+      root = xScreenRoot screen
300 
+     in
301 
+     xCreateWindow root
302 
+       (XRect 0 0 (x + 1) (y + 1))
303 
+        [XWinBackground bg_color,
304 
+        XWinEventMask (XEventMask [XExposure, XKeyPress,
305 
+                                   XButtonPress, XPointerMotion])]
306 
+     `thenIO` \window ->
307 
+     xSetWmName window filename `thenIO` \() ->
308 
+     xSetWmIconName window filename `thenIO` \() ->
309 
+     xCreateWindow root (XRect 0 0 100 40)
310 
+	[XWinBackground bg_color] `thenIO` \window2 ->
311 
+     xSetWmName window2 "pos" `thenIO` \() ->
312 
+     xSetWmIconName window2 "pos" `thenIO` \() ->
313 
+     xMapWindow window `thenIO` \() ->
314 
+     xMapWindow window2 `thenIO` \() ->
315 
+     xListFonts display "*times*bold*r*normal*18*" `thenIO` \fontlist ->
316 
+     xCreateGcontext (XDrawWindow root) [XGCBackground bg_color,
317 
+                                         XGCForeground fg_color,
318 
+                                         XGCFont (head fontlist)]
319 
+     `thenIO` \ gcontext ->
320 
+    let
321 
+     handleEvent :: IntSegList -> IO()
322 
+     handleEvent list =
323 
+      xGetEvent display `thenIO` \event ->
324 
+      let
325 
+       point = xEventPos event
326 
+       XPoint pointx pointy = point
327 
+       handleEvent' :: XPoint -> IO()
328 
+       handleEvent' last = xGetEvent display `thenIO` \event2 ->
329 
+        let
330 
+         pos = xEventPos event2
331 
+	 XPoint posx posy = pos
332 
+        in
333 
+         case (xEventType event2) of
334 
+          XExposureEvent  ->
335 
+            redraw window gcontext list `thenIO` \() ->
336 
+            handleEvent' last
337 
+          XKeyPressEvent  ->
338 
+            appendChan stdout ((show (tup pos))++ "\n") abort $
339 
+            xDrawLine (XDrawWindow window) gcontext point pos
340 
+            `thenIO` \() -> handleEvent (store list point pos)
341 
+     	  XMotionNotifyEvent ->
342 
+	    xDrawImageGlyphs (XDrawWindow window2) gcontext
343 
+             (XPoint 2 18) ((show posx)++", "++(show posy)++"      ")
344 
+	    `thenIO` \dummy -> handleEvent' last
345 
+	  _                  -> handleEvent' last
346 
+      in
347 
+       case (xEventType event) of
348 
+        XButtonPressEvent  ->
349 
+          putFile display filename list x y "modify"
350 
+        XKeyPressEvent     ->
351 
+          appendChan stdout (show (tup point)) abort $
352 
+          handleEvent' point
353 
+        XExposureEvent  ->
354 
+          redraw window gcontext list `thenIO` \() ->
355 
+          handleEvent list
356 
+        XMotionNotifyEvent ->
357 
+          xDrawImageGlyphs (XDrawWindow window2)
358 
+                           gcontext (XPoint 2 18)
359 
+           ((show pointx)++", "++(show pointy)++"      ")
360 
+          `thenIO` \dummy -> handleEvent list
361 
+        _                  ->
362 
+          handleEvent list
363 
+    in
364 
+     redraw window gcontext origlist `thenIO` \() ->
365 
+      handleEvent origlist
366 
+
367 
+-- Miscellaneous functions -------------------------------------------------
368 
+-- shared by the create and modify functions
369 
+
370 
+checkFile :: Filename -> Bool
371 
+checkFile name =
372 
+  case (take 4 (reverse name)) of
373 
+   "cip." -> True
374 
+   _      -> False
375 
+
376 
+store :: IntSegList -> XPoint -> XPoint -> IntSegList
377 
+store l a b =  [((xof a,yof a),(xof b,yof b))] ++ l
378 
+
379 
+xof :: XPoint -> Int
380 
+xof (XPoint x y) = x
381 
+
382 
+yof :: XPoint -> Int
383 
+yof (XPoint x y) = y
384 
+
385 
+tup :: XPoint -> IntPoint
386 
+tup (XPoint a b) = (a,b)
387 
+
388 
+ll:: IntSegment -> Int
389 
+ll ((a1,a2),(b1,b2)) = a1
390 
+
391 
+lr:: IntSegment -> Int
392 
+lr ((a1,a2),(b1,b2)) = a2
393 
+
394 
+rl:: IntSegment -> Int
395 
+rl ((a1,a2),(b1,b2)) = b1
396 
+
397 
+rr:: IntSegment -> Int
398 
+rr ((a1,a2),(b1,b2)) = b2
399 
+
400 
+getx :: Picture -> Int
401 
+getx (Grid m n o) = m
402 
+
403 
+gety :: Picture -> Int
404 
+gety(Grid m n o) = n
405 
+
406 
+getlist :: Picture -> SegList
407 
+getlist (Grid m n o) = o
408 
+
409 
+fFloat :: SegList -> IntSegList
410 
+fFloat = map (\ ((ix,iy),(jx,jy)) ->
411 
+             ((round ix,round iy), (round jx,round jy)))
412 
+
413 
+readError :: String
414 
+readError  = "Error: reading an invalid file\n"
415 
+
416 
+picTypeError :: String
417 
+picTypeError = "Error: files need to be of .pic type\n"
418 
+
419 
+deleteError :: String
420 
+deleteError = "Error: file can not be deleted\n"
421 
+
422 
+writeError :: String
423 
+writeError = "Error: file can not be written\n"
424 
+
425 
+modError :: String
426 
+modError = "Error: file can not be modified\n"
427 
+
428 
+redraw :: XWindow-> XGcontext -> IntSegList -> IO()
429 
+redraw window gcontext [] = done
430 
+redraw window gcontext (l:ls) =
431 
+ xDrawLine (XDrawWindow window) gcontext (XPoint (ll l) (lr l))
432 
+                                         (XPoint (rl l) (rr l))
433 
+ `thenIO` \() -> redraw window gcontext ls
434 
+
435 
+changeList :: IntSegList -> SegList
436 
+changeList =
437 
+  map (\ ((ix,iy),(jx,jy)) -> ((fromIntegral ix,fromIntegral iy),
438 
+                               (fromIntegral jx,fromIntegral jy)))
439 
+
440 
+putFile :: XDisplay -> Filename -> IntSegList ->
441 
+           Int -> Int -> String -> IO()
442 
+putFile display name list x y flag =
443 
+ let
444 
+  text = show (Grid x y (changeList list))
445 
+  finishMsg  = name ++ ": Done...Process completed\n"
446 
+  modMsg = name ++ ": Modifying file\n"
447 
+  createMsg = name ++ ": Creating file\n"
448 
+  continue =
449 
+   deleteFile name (\s -> appendChan stdout deleteError abort done) $
450 
+   writeFile name text (\s -> appendChan stdout writeError abort done) $
451 
+   appendChan stdout finishMsg abort $
452 
+   xCloseDisplay display
453 
+ in
454 
+  case (flag == "create") of
455 
+   False -> appendChan stdout modMsg
456 
+                       (\s -> appendChan stdout modError abort done) $
457 
+            continue
458 
+   True  -> readFile name (\s -> appendChan stdout createMsg abort $
459 
+                                 writeFile name text abort
460 
+                                   (xCloseDisplay display)) $ \s ->
461 
+            continue
462 
+
463 
+
464 
+
465 
+
progs/demo/X11/graphics/henderson.hu
History View file @ 4e98702
0 466 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= foldr inline constant
2 
+$HASKELL_LIBRARY/X11/xlib.hu
3 
+henderson.hs
progs/demo/X11/graphics/manual
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,454 @@
1 
+104 pgscriptver
2 
+
3 
+100 DefSpaceEx 100 DefCharEx 1 DefNormalHyphenationOn 100
4 
+DefTypeColor (Times-Roman) DefTypeFace ENGLISH DefLanguage 12 DefPointSize
5 
+USE_POINTSIZE DefSetSize (@default) DefTypeResource
6 
+
7 
+LEFT DefJustifyFlags 2 DefBeginParaLeadValue ABSOLUTE DefBeginParaLeadMode 2
8 
+DefEndParaLeadValue ABSOLUTE DefEndParaLeadMode 120 DefLeadValue
9 
+PROPORTIONAL DefLeadMode 1 46 0 TAB_LEFT  720 DefTab 1 46 0
10 
+TAB_LEFT  2160 DefTab 1 46 0 TAB_LEFT  3600 DefTab 1 46 0
11 
+TAB_LEFT  5040 DefTab 1 46 0 TAB_LEFT  6480 DefTab 1 46 0
12 
+TAB_LEFT  7920 DefTab 1 46 0 TAB_LEFT  9360 DefTab 0 46 0
13 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
14 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
15 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
16 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
17 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
18 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
19 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
20 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
21 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
22 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
23 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
24 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
25 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
26 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
27 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
28 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
29 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
30 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
31 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
32 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0
33 
+TAB_LEFT  24480 DefTab 80 DefWSMN 100 DefWSNM 150 DefWSMX 110
34 
+DefLSMX 100 DefLeaderEx 46 DefLeaderChar 0 DefFirstIndent 0
35 
+DefLeftIndent 0 DefRightIndent 0 DefNumberingOn 0 DefNumberingType 0
36 
+DefNumberingRestart 1 DefNumberingLevel 0 DefNumberingStyle 0
37 
+DefNumberingTabAfter 1 DefNumberingShowAllLevels 1 DefNumberingStart 1
38 
+DefNumberingIncrement () DefNumberingPrefix () DefNumberingSuffix (.)
39 
+DefNumberingSeparator (*default) DefParaResource
40 
+
41 
+0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300
42 
+DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResource
43 
+
44 
+0 DefPageDimensions 12240 DefPageWidth 15840 DefPageHeight 1440
45 
+DefInsideMargin 1080 DefOutsideMargin 1080 DefTopMargin 1080
46 
+DefBottomMargin 0 DefOrientation 0 DefPageStyle 1 DefColumns 360
47 
+DefGutter (%default) DefMasterPage ResDefEnd
48 
+
49 
+0 DefFirstLeft 0 DefDocSetup 1 DefNumPages 1 AutoPage 1
50 
+DefStartPageNum () DefPageNumPrefix 1 DefGraphicLocation document
51 
+
52 
+1 DefAutoPage
53 
+0 (%default) 1 DefPage
54 
+1 DefAutoPage
55 
+0 (%default) 2 DefPage
56 
+
57 
+POLY_OBJECT POLY_EMPTY |  DefPolyType
58 
+
59 
+0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300
60 
+DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 0
61 
+DefMasterRef
62 
+MP_CPSUCC_LINK MP_CPPRED_LINK POLY_COLUMN | |  DefSLinksFlags 0 DefStreamSucc 0
63 
+DefStreamPred
64 
+1440 1080 11160 1080 11160 14760 1440 14760 4
65 
+POLY_OBJECT POLY_EMPTY |  (%default) 0 1 TextPolygon
66 
+
67 
+POLY_OBJECT POLY_TEXT |  DefPolyType
68 
+
69 
+0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300
70 
+DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 1
71 
+DefMasterRef
72 
+
73 
+MP_CPSUCC_LINK MP_CPPRED_LINK LINK_OVERFLOW MPREF_VALID POLY_COLUMN AUTO_STREAM | | | | |
74 
+DefSLinksFlags 4 DefStreamSucc 0 DefStreamPred 3 DefTextHandle
75 
+1440 1080 11160 1080 11160 14760 1440 14760 4
76 
+POLY_OBJECT POLY_TEXT |  (1) 0 2 TextPolygon
77 
+
78 
+3 asciitextstream
79 
+<(Courier) cf ><9 cs>The Henderson Library--<eop>
80 
+by Syam Gadde<eop>
81 
+and Bo Whong<eop>
82 
+<eop>
83 
+The Henderson Library is a toolkit with which one can use Functional Geometry,
84 
+as proposed by Peter Henderson in his paper "Functional Geometry".  This is a s
85 
+cheme by which "Picture"s can be described in an abstract data type, and a numb
86 
+er of functions can be applied to it.  This results in a very elegant method to
87 
+ produce complex pictures from simple ones.  The example Henderson uses is "Squ
88 
+are Limit" by M. C. Escher,  which can be constructed with four simple pictures
89 
+.<eop>
90 
+<eop>
91 
+------------------------<eop>
92 
+ADTs and Type Synonyms<eop>
93 
+<eop>
94 
+The Picture data type is composed of eight different types of pictures.  They a
95 
+re:<eop>
96 
+<eop>
97 
+data<eop>
98 
+Picture = Nil                                 - empty picture<eop>
99 
+        | Flip Picture                        - picture flipped on the y-axis<e
100 
+op>
101 
+        | Beside Float Picture Float Picture  - two pictures placed side by sid
102 
+e <eop>
103 
+                                              - in accordance to the ratio of t
104 
+he<eop>
105 
+                                              - two floats<eop>
106 
+        | Above Float Picture Float Picture   - two pictures placed one on top
107 
+of<eop>
108 
+                                              - another in accordance to the ra
109 
+tio<eop>
110 
+                                              - of the two floats<eop>
111 
+        | Rot Picture                         - picture is rotated 90 degrees <
112 
+eop>
113 
+                                              - counterclockwise<eop>
114 
+        | File String                         - picture is stored as an externa
115 
+l<eop>
116 
+                                              - file<eop>
117 
+        | Overlay Picture Picture             - two pictures are drawn such tha
118 
+t<eop>
119 
+                                              - one lays on top of the other<eo
120 
+p>
121 
+        | Grid Int Int SegList                - picture type that contains the
122 
+list<eop>
123 
+                                              - of picture's line segments alon
124 
+g<eop>
125 
+                                              - with the size of the inital pic
126 
+ture<eop>
127 
+<eop>
128 
+The type synonyms are pretty much self explanatory.<eop>
129 
+<eop>
130 
+        Hostname<tab><tab><tab>- a string of the hostname<eop>
131 
+        Filename                              <tab>- a string of the filename<e
132 
+op>
133 
+        IntPoint                              <tab>- a tuple of integers repres
134 
+enting<eop>
135 
+                                              <tab>- the coordinates of a point
136 
+<eop>
137 
+        IntSegment                            <tab>- a tuple of Intpoints repre
138 
+senting<eop>
139 
+                                              <tab>- the endpoints of a line se
140 
+gment<eop>
141 
+        IntSegList                            <tab>- a list of IntSegments <eop
142 
+>
143 
+        Point                                 <tab>- same as IntPoint except in
144 
+ place of<eop>
145 
+<tab><tab><tab>             <tab>- intergers, they are floating points<eop>
146 
+        Segment                               <tab>- same as IntSegment except
147 
+in place<eop>
148 
+       <tab><tab>            <tab>- of intergers, they are floating <eop>
149 
+         <tab><tab><tab>- points<eop>
150 
+        SegList                               <tab>- same as IntsegList except
151 
+in place<eop>
152 
+      <tab><tab><tab><tab>- of intergers, they are floating <eop>
153 
+         <tab><tab><tab>- points<eop>
154 
+        Vector                                <tab>- a tuple of floating points
155 
+ to<eop>
156 
+        <tab><tab><tab>- to represent a vector<eop>
157 
+        Vtriple                               - a 3-tuple of Vectors<eop>
158 
+        HendQuartet                           - a 4-tuple of Integers for the s
159 
+ize<eop>
160 
+                                              - of the Henderson window<eop>
161 
+        PEnv                                  - a tuple of a Filename and a Pic
162 
+ture<eop>
163 
+                                              - for storing already opened file
164 
+s in<eop>
165 
+                                              - in order to save time and memor
166 
+y<eop>
167 
+                                              - when a file needs to be opened
168 
+more<eop>
169 
+                                              - than once<eop>
170 
+<eop>
171 
+-------------------------------------------------------------------------------
172 
+----<eop>
173 
+Function: create (an exported function from the HendersonLib)<eop>
174 
+<eop>
175 
+The purpose of the create function is to provide the user with a function to <e
176 
+op>
177 
+draw a picture from a graphics interface.  The user may choose to create a pict
178 
+ure<eop>
179 
+file by inputing the the lines and points manually into a file or (s)he may cho
180 
+ose<eop>
181 
+to use the create function.<eop>
182 
+<eop>
183 
+Functionality of create:<eop>
184 
+           create :: Hostname -<ra> Filaname -<ra> Int -<ra> Int -<ra> IO()<eop
185 
+>
186 
+<eop>
187 
+create takes as input a hostname, a filename, and two integers for the size of
188 
+the <eop>
189 
+window to be opened.  Two windows should appear, one for the input of lines and
190 
+<eop>
191 
+another showing the current position of the mouse.  These windows will be label
192 
+ed<eop>
193 
+accordingly.<eop>
194 
+To draw a line on the file window, move the cursor to the desired position, the
195 
+n<eop>
196 
+hit any key on the keybroad. This point will be the beginning of the line segme
197 
+nt.<eop>
198 
+Next move the cursor to the position of where the user wants the end of the lin
199 
+e<eop>
200 
+segment to be, then hit any key from the keyboard again.  A line should appear.
201 
+<eop>
202 
+The coordinates of the endpoints of each line drawn  will also be printed out o
203 
+nto <eop>
204 
+standard output.<eop>
205 
+To signal completion of a file, press any button on the mouse.  The user must <
206 
+eop>
207 
+remember though that this is only applicable after a completed drawing of a lin
208 
+e.<eop>
209 
+For example, pressing the mouse button will not work if one of the endpoints of
210 
+ a<eop>
211 
+line is drawn but the other endpoint is not. create will not recognize the mous
212 
+e <eop>
213 
+button press event until a second endpoint is drawn.<eop>
214 
+<eop>
215 
+Advantages of create:<eop>
216 
+ provides a quick and fun way to create a picture file.<eop>
217 
+<eop>
218 
+Disadvantages of create:<eop>
219 
+ If the file does not exist, create will create the file and then store the pic
220 
+ture<eop>
221 
+ to it.  However, if the file exists, create will automatically delete the cont
222 
+ents<eop>
223 
+ of that file before storing the new picture.<eop>
224 
+<eop>
225 
+-------------------------------------------------------------------------------
226 
+----<eop>
227 
+Function: modify (an exported function from the HendersonLib)<eop>
228 
+<eop>
229 
+The purpose of the modify function is to provide the user with a function make
230 
+<eop>
231 
+additions to an already existing picture file using a graphics interface.  The
232 
+user<eop>
233 
+may choose to modify the picture file by adding the the lines and points manual
234 
+ly <eop>
235 
+into the file or (s)he may choose to use the modify function.<eop>
236 
+<eop>
237 
+Functionality of modify:<eop>
238 
+           modify :: Hostname -<ra> Filaname -<ra> IO()<eop>
239 
+<eop>
240 
+modify takes as input a hostname and a filename. Tow windows should appear.  Th
241 
+e <eop>
242 
+size of the draw window will be the same as the x and y coordinates already in
243 
+the<eop>
244 
+file. These windows will be labeled accordingly.  The existing picture will app
245 
+ear<eop>
246 
+first before any input is allowed.<eop>
247 
+To draw a line on the file window, move the cursor to the desired position, the
248 
+n<eop>
249 
+hit any key on the keybroad. This point will be the beginning of the line segme
250 
+nt.<eop>
251 
+Next move the cursor to the position of where the user wants the end of the lin
252 
+e<eop>
253 
+segment to be, then hit any key from the keyboard again.  A line should appear.
254 
+<eop>
255 
+The coordinates of the endpoints of each line drawn  will also be printed out o
256 
+nto <eop>
257 
+standard output.<eop>
258 
+To signal completion of a file, press any button on the mouse.  The user must <
259 
+eop>
260 
+remember though that this is only applicable after a completed drawing of a lin
261 
+e.<eop>
262 
+For example, pressing the mouse button will not work if one of the endpoints of
263 
+ a<eop>
264 
+line is drawn but the other endpoint is not.  modify will not recognize the mou
265 
+se <eop>
266 
+button press event until a second endpoint is drawn.<eop>
267 
+<eop>
268 
+Advantages of modify:<eop>
269 
+ provides a quick and fun way to modify a picture file without having to go int
270 
+o<eop>
271 
+ the file and manually add on the coordinates of the additional lines<eop>
272 
+<eop>
273 
+Disadvantages of modify:<eop>
274 
+ Existing lines can not be deleted and any additional lines, whether intentiona
275 
+l or<eop>
276 
+ unintentional, will be appended to the picture and stored in the file.<eop>
277 
+<eop>
278 
+--------------------------------------------------------<eop>
279 
+Function: sendToDraw<eop>
280 
+<eop>
281 
+Type of sendToDraw:<eop>
282 
+  sendToDraw :: XWindow -<ra> XScreen -<ra> XDisplay -<ra> <eop>
283 
+              XPixel -<ra> XPixel -<ra> Plot -<ra> IO()<eop>
284 
+<eop>
285 
+Usage:<eop>
286 
+  sendToDraw win scn dis fg_color bg_color plt<eop>
287 
+<eop>
288 
+'sendToDraw' is the most primitive function in the part of the Henderson<eop>
289 
+library that deals with X windows, and therefore, can be used as a very<eop>
290 
+powerful tool.  It draws a Plot plt (see 'plot' function) in the given XWindow<
291 
+eop>
292 
+win, and on the given XScreen and XDisplay scn and dis, drawing the lines in<eo
293 
+p>
294 
+the foreground color.  This function allows the programmer to draw more than<eo
295 
+p>
296 
+one Picture to the same window.<eop>
297 
+<eop>
298 
+Arguments:<eop>
299 
+  win - the XWindow in which to draw plt<eop>
300 
+  scn - the screen which contains win<eop>
301 
+  dis - the display which contains scn<eop>
302 
+  fg_color - an XPixel the color of which the plt will be drawn in.  Note that<
303 
+eop>
304 
+<tab>this allows the programmer to draw different plt's in different colors.<eo
305 
+p>
306 
+  bg_color - unused, but required.<eop>
307 
+--------------------------------------------------------<eop>
308 
+Function: plot<eop>
309 
+<eop>
310 
+Type of 'plot':<eop>
311 
+  plot :: Picture -<ra> VTriple -<ra> PEnv -<ra> ((Plot, PEnv) -<ra> IO()) -<ra
312 
+> IO()<eop>
313 
+<eop>
314 
+Usage:<eop>
315 
+  plot pic (a,b,c) env func<eop>
316 
+<eop>
317 
+The 'plot' function is needed to create a Plot which would be normally sent to<
318 
+eop>
319 
+a function such as sendToDraw.  'plot' converts a Picture pic into a format<eop
320 
+>
321 
+that sendToDraw can deal with.<eop>
322 
+'plot' also takes three vectors which specify the bounding box in which the<eop
323 
+>
324 
+Picture is to be drawn.  The first vector (a) specifies the upper left corner<e
325 
+op>
326 
+of the bounding box.  The next two vectors specify the bounding box itself,<eop
327 
+>
328 
+with respect to the first vector.  This allows for non-rectangular bounding<eop
329 
+>
330 
+boxes.  For example, the vector triple ((50,50), (100,0), (0,100)) specifies<eo
331 
+p>
332 
+the following bounding box:<eop>
333 
+<eop>
334 
+            (0,0)----------------------------------<eop>
335 
+                 |<eop>
336 
+                 |  (50,50)<eop>
337 
+                 |     _______________ (150,0)  <eop>
338 
+                 |     |             |<eop>
339 
+                 |     |             |<eop>
340 
+                 |     |             |<eop>
341 
+                 |     |             |<eop>
342 
+                 |     |             |<eop>
343 
+                 |     |_____________| (150,150)<eop>
344 
+                 |  (0,150)<eop>
345 
+<eop>
346 
+<eop>
347 
+A vector triple of ((0,0), (100,300), (0,100)) would specify:<eop>
348 
+<eop>
349 
+            (0,0)-------------------------------------<eop>
350 
+                 ||\<eop>
351 
+                 || \<eop>
352 
+                 ||  \<eop>
353 
+          (0,100)||   \<eop>
354 
+                 |\    \<eop>
355 
+                 | \    \<eop>
356 
+                 |  \    \<eop>
357 
+                 |   \    \ (100,300)<eop>
358 
+                 |    \   | <eop>
359 
+                 |     \  |<eop>
360 
+                 |      \ |<eop>
361 
+                 |       \| (100,400)<eop>
362 
+<eop>
363 
+Arguments:                 <eop>
364 
+  pic - the Picture to be converted<eop>
365 
+  a - a vector specifying the upper left corner of the bounding box<eop>
366 
+<tab>of the picture.<eop>
367 
+  b - a vector understood to start at 'a' and specifying the upper edge of<eop>
368 
+
369 
+<tab>the bounding box.<eop>
370 
+  c - a vector understood to start at 'a' and specifying the left edge of<eop>
371 
+<tab>the bounding box.<eop>
372 
+--------------------------------------------------------<eop>
373 
+Function: draw<eop>
374 
+<eop>
375 
+Type of draw:<eop>
376 
+  draw :: Hostname -<ra> Picture -<ra> VTriple -<ra> HendQuartet -<ra> IO()<eop
377 
+>
378 
+<eop>
379 
+Usage:<eop>
380 
+  draw host pic (a,b,c) (m,n,p,q)<eop>
381 
+<eop>
382 
+'draw' is a higher-level function than sendToDraw, and is useful to use when<eo
383 
+p>
384 
+the programmer wishes only to draw one Picture on the screen.  This function<eo
385 
+p>
386 
+does most of the work that the programmer would normally have to do when using<
387 
+eop>
388 
+sendToDraw.  'draw' opens a window at host with upper left coordinates m and n<
389 
+eop>
390 
+(on an X server that lets the user position any child window of the root<eop>
391 
+window, these coordinates mean nothing), and with width p and height q.<eop>
392 
+'draw' then calls 'plot' on pic and (a,b,c) and sends the result to sendToDraw,
393 
+<eop>
394 
+which finally draws the picture to the window.<eop>
395 
+<eop>
396 
+Arguments:<eop>
397 
+  host - host on which to open a display, i.e. "tucan:0"<eop>
398 
+  pic - the Picture to be drawn<eop>
399 
+  (a,b,c) - the vector triple specifying the bounding box to be sent to<eop>
400 
+<tab>plot (see 'plot' function)<eop>
401 
+  (m,n,p,q) - upper left corner x (m), upper left corner y (n), width (p),<eop>
402 
+
403 
+<tab>and height (q), of window to be opened.<eop>
404 
+<eop>
405 
+-----------------------------------------------------------<eop>
406 
+<eop>
407 
+Module: SquareLimit<eop>
408 
+<eop>
409 
+This module is a sample user module that can be used to draw Square Limit, a wo
410 
+odcut by M. C. Escher.  To draw "SquareLimit" on your host, run the dialogue:<e
411 
+op>
412 
+<tab>final host<eop>
413 
+where 'host' is the host running X, such as "turtle:0".<eop>
414 
+<eop>
415 
+To draw a slightly more interesting picture, tun the dialogue:<eop>
416 
+<tab>skewedfinal host<eop>
417 
+and it will draw "SquareLimit" in a bounding box shaped as a diamond.<eop>
418 
+<eop>
419 
+
420 
+<textstream_end>
421 
+
422 
+POLY_OBJECT POLY_TEXT |  DefPolyType
423 
+
424 
+0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300
425 
+DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 1
426 
+DefMasterRef
427 
+
428 
+MP_CPSUCC_LINK MP_CPPRED_LINK LINK_OVERFLOW MPREF_VALID POLY_COLUMN AUTO_STREAM | | | | |
429 
+DefSLinksFlags 0 DefStreamSucc 2 DefStreamPred 3 DefTextHandle
430 
+1440 1080 11160 1080 11160 14760 1440 14760 4
431 
+POLY_OBJECT POLY_TEXT |  (2) 0 4 TextPolygon
432 
+
433 
+BeginProfile
434 
+(Number of Pages) (5)  DefProfileString
435 
+(Language) (ENGLISH)  DefProfileString
436 
+(Version) (IslandWrite Version 2.3)  DefProfileString
437 
+(Creation Date) (gadde May 7, 1993 3:55 PM)  DefProfileString
438 
+(Text Formats) (default)  DefProfileString
439 
+(Container Formats) (default)  DefProfileString
440 
+(Page Formats) (default)  DefProfileString
441 
+(Fonts) (Courier)  DefProfileString
442 
+(Fonts) (Times-Roman)  DefProfileString
443 
+(File Path) ()  DefProfileString
444 
+(External Contents) ()  DefProfileString
445 
+(Title) ()  DefProfileString
446 
+(Status) ()  DefProfileString
447 
+(Distribution List) ()  DefProfileString
448 
+(Preparer) ()  DefProfileString
449 
+(Owner) ()  DefProfileString
450 
+(Author) ()  DefProfileString
451 
+(Superseded Documents) ()  DefProfileString
452 
+EndProfile
453 
+
454 
+pgscriptdone
progs/demo/X11/graphics/p.pic
History View file @ 4e98702
0 455 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+Grid 640 640 [((560.00000000000000,560.00000000000000),(440.00000000000000,640.00000000000000)), ((640.00000000000000,560.00000000000000),(560.00000000000000,560.00000000000000)), ((520.00000000000000,440.00000000000000),(640.00000000000000,480.00000000000000)), ((400.00000000000000,480.00000000000000),(520.00000000000000,440.00000000000000)), ((480.00000000000000,360.00000000000000),(360.00000000000000,400.00000000000000)), ((480.00000000000000,360.00000000000000),(640.00000000000000,400.00000000000000)), ((480.00000000000000,280.00000000000000),(640.00000000000000,320.00000000000000)), ((320.00000000000000,320.00000000000000),(480.00000000000000,280.00000000000000)), ((280.00000000000000,400.00000000000000),(160.00000000000000,440.00000000000000)), ((160.00000000000000,240.00000000000000),(280.00000000000000,400.00000000000000)), ((160.00000000000000,440.00000000000000),(160.00000000000000,240.00000000000000)), ((120.00000000000000,480.00000000000000),(0.0000000000000000,320.00000000000000)), ((0.0000000000000000,320.00000000000000),(0.0000000000000000,520.00000000000000)), ((120.00000000000000,480.00000000000000),(0.0000000000000000,520.00000000000000)), ((240.00000000000000,640.00000000000000),(160.00000000000000,480.00000000000000)), ((400.00000000000000,480.00000000000000),(440.00000000000000,640.00000000000000)), ((320.00000000000000,320.00000000000000),(400.00000000000000,480.00000000000000)), ((160.00000000000000,120.00000000000000),(320.00000000000000,320.00000000000000)), ((0.0000000000000000,0.0000000000000000),(160.00000000000000,120.00000000000000)), ((640.00000000000000,240.00000000000000),(320.00000000000000,160.00000000000000)), ((640.00000000000000,40.000000000000000),(560.00000000000000,0.0000000000000000)), ((520.00000000000000,40.000000000000000),(640.00000000000000,80.000000000000000)), ((480.00000000000000,0.0000000000000000),(520.00000000000000,40.000000000000000)), ((480.00000000000000,80.000000000000000),(400.00000000000000,0.0000000000000000)), ((640.00000000000000,120.00000000000000),(480.00000000000000,80.000000000000000)), ((480.00000000000000,160.00000000000000),(640.00000000000000,160.00000000000000)), ((320.00000000000000,0.0000000000000000),(480.00000000000000,160.00000000000000)), ((240.00000000000000,40.000000000000000),(320.00000000000000,0.0000000000000000)), ((0.0000000000000000,0.0000000000000000),(240.00000000000000,40.000000000000000))]
0 2 
\ No newline at end of file
progs/demo/X11/graphics/q.pic
History View file @ 4e98702
1 3 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+Grid 16 16
2 
+[((10.000000000000000,6.0000000000000000),(9.0000000000000000,4.0000000000000000)), ((12.000000000000000,4.0000000000000000),(10.000000000000000,6.0000000000000000)), ((9.0000000000000000,4.0000000000000000),(12.000000000000000,4.0000000000000000)), ((0.0000000000000000,6.0000000000000000),(7.0000000000000000,5.0000000000000000)), ((0.0000000000000000,8.0000000000000000),(0.0000000000000000,16.000000000000000)), ((0.0000000000000000,0.0000000000000000),(0.0000000000000000,4.0000000000000000)), ((15.000000000000000,16.000000000000000),(16.000000000000000,14.000000000000000)), ((16.000000000000000,12.000000000000000),(14.000000000000000,16.000000000000000)), ((13.000000000000000,16.000000000000000),(16.000000000000000,10.000000000000000)), ((13.000000000000000,12.000000000000000),(12.000000000000000,16.000000000000000)), ((16.000000000000000,8.0000000000000000),(13.000000000000000,12.000000000000000)), ((15.000000000000000,6.0000000000000000),(16.000000000000000,8.0000000000000000)), ((16.000000000000000,0.0000000000000000),(15.000000000000000,6.0000000000000000)), ((10.000000000000000,16.000000000000000),(14.000000000000000,5.0000000000000000)), ((10.000000000000000,10.000000000000000),(10.000000000000000,7.0000000000000000)), ((8.0000000000000000,16.000000000000000),(10.000000000000000,10.000000000000000)), ((8.0000000000000000,11.000000000000000),(8.0000000000000000,8.0000000000000000)), ((6.0000000000000000,16.000000000000000),(8.0000000000000000,11.000000000000000)), ((6.0000000000000000,11.000000000000000),(4.0000000000000000,16.000000000000000)), ((6.0000000000000000,9.0000000000000000),(6.0000000000000000,11.000000000000000)), ((4.0000000000000000,11.000000000000000),(4.0000000000000000,9.0000000000000000)), ((2.0000000000000000,16.000000000000000),(4.0000000000000000,11.000000000000000)), ((4.0000000000000000,9.0000000000000000),(0.0000000000000000,8.0000000000000000)), ((6.0000000000000000,9.0000000000000000),(4.0000000000000000,9.0000000000000000)), ((12.000000000000000,6.0000000000000000),(6.0000000000000000,9.0000000000000000)), ((16.000000000000000,0.0000000000000000),(12.000000000000000,6.0000000000000000)), ((9.0000000000000000,3.0000000000000000),(8.0000000000000000,1.0000000000000000)), ((11.000000000000000,1.0000000000000000),(9.0000000000000000,3.0000000000000000)), ((8.0000000000000000,1.0000000000000000),(11.000000000000000,1.0000000000000000)), ((8.0000000000000000,0.0000000000000000),(7.0000000000000000,1.0000000000000000)), ((5.0000000000000000,2.0000000000000000),(7.0000000000000000,1.0000000000000000)), ((6.0000000000000000,0.0000000000000000),(7.0000000000000000,1.0000000000000000)), ((5.0000000000000000,2.0000000000000000),(4.0000000000000000,0.0000000000000000)), ((3.0000000000000000,3.0000000000000000),(5.0000000000000000,2.0000000000000000)), ((3.0000000000000000,3.0000000000000000),(0.0000000000000000,4.0000000000000000)), ((2.0000000000000000,0.0000000000000000),(3.0000000000000000,3.0000000000000000))]
0 3 
\ No newline at end of file
progs/demo/X11/graphics/r.pic
History View file @ 4e98702
1 4 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+Grid 32 32
2 
+[((32.000000000000000,0.0000000000000000),(24.000000000000000,8.0000000000000000)), ((32.000000000000000,4.0000000000000000),(30.000000000000000,2.0000000000000000)), ((28.000000000000000,4.0000000000000000),(32.000000000000000,8.0000000000000000)), ((32.000000000000000,12.000000000000000),(26.000000000000000,6.0000000000000000)), ((24.000000000000000,8.0000000000000000),(32.000000000000000,16.000000000000000)), ((22.000000000000000,0.0000000000000000),(24.000000000000000,8.0000000000000000)), ((22.000000000000000,12.000000000000000),(12.000000000000000,0.0000000000000000)), ((32.000000000000000,20.000000000000000),(22.000000000000000,12.000000000000000)), ((24.000000000000000,26.000000000000000),(10.000000000000000,22.000000000000000)), ((32.000000000000000,32.000000000000000),(24.000000000000000,26.000000000000000)), ((16.000000000000000,28.000000000000000),(24.000000000000000,32.000000000000000)), ((6.0000000000000000,26.000000000000000),(16.000000000000000,28.000000000000000)), ((16.000000000000000,32.000000000000000),(4.0000000000000000,28.000000000000000)), ((2.0000000000000000,30.000000000000000),(8.0000000000000000,32.000000000000000)), ((0.0000000000000000,32.000000000000000),(16.000000000000000,16.000000000000000)), ((0.0000000000000000,24.000000000000000),(10.000000000000000,12.000000000000000)), ((4.0000000000000000,8.0000000000000000),(0.0000000000000000,16.000000000000000)), ((28.000000000000000,20.000000000000000),(32.000000000000000,24.000000000000000)), ((16.000000000000000,16.000000000000000),(28.000000000000000,20.000000000000000)), ((4.0000000000000000,8.0000000000000000),(16.000000000000000,16.000000000000000)), ((2.0000000000000000,4.0000000000000000),(4.0000000000000000,8.0000000000000000)), ((2.0000000000000000,4.0000000000000000),(0.0000000000000000,8.0000000000000000)), ((0.0000000000000000,0.0000000000000000),(2.0000000000000000,4.0000000000000000))]
0 3 
\ No newline at end of file
progs/demo/X11/graphics/s.pic
History View file @ 4e98702
1 4 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+Grid 32 32 [((24.000000000000000,0.0000000000000000),(32.000000000000000,0.0000000000000000)), ((0.0000000000000000,0.0000000000000000),(16.000000000000000,0.0000000000000000)), ((30.000000000000000,14.000000000000000),(32.000000000000000,12.000000000000000)), ((32.000000000000000,8.0000000000000000),(28.000000000000000,10.000000000000000)), ((26.000000000000000,6.0000000000000000),(32.000000000000000,4.0000000000000000)), ((26.000000000000000,6.0000000000000000),(24.000000000000000,0.0000000000000000)), ((30.000000000000000,14.000000000000000),(26.000000000000000,6.0000000000000000)), ((32.000000000000000,16.000000000000000),(30.000000000000000,14.000000000000000)), ((30.000000000000000,16.000000000000000),(26.000000000000000,18.000000000000000)), ((30.000000000000000,22.000000000000000),(30.000000000000000,16.000000000000000)), ((26.000000000000000,18.000000000000000),(30.000000000000000,22.000000000000000)), ((24.000000000000000,24.000000000000000),(20.000000000000000,20.000000000000000)), ((24.000000000000000,18.000000000000000),(24.000000000000000,24.000000000000000)), ((20.000000000000000,20.000000000000000),(24.000000000000000,18.000000000000000)), ((20.000000000000000,0.0000000000000000),(22.000000000000000,12.000000000000000)), ((14.000000000000000,6.0000000000000000),(16.000000000000000,0.0000000000000000)), ((14.000000000000000,16.000000000000000),(16.000000000000000,20.000000000000000)), ((14.000000000000000,6.0000000000000000),(14.000000000000000,16.000000000000000)), ((20.000000000000000,24.000000000000000),(16.000000000000000,20.000000000000000)), ((32.000000000000000,32.000000000000000),(20.000000000000000,24.000000000000000)), ((16.000000000000000,28.000000000000000),(32.000000000000000,32.000000000000000)), ((8.0000000000000000,28.000000000000000),(16.000000000000000,28.000000000000000)), ((0.0000000000000000,32.000000000000000),(8.0000000000000000,28.000000000000000)), ((0.0000000000000000,24.000000000000000),(4.0000000000000000,30.000000000000000)), ((0.0000000000000000,20.000000000000000),(14.000000000000000,24.000000000000000)), ((0.0000000000000000,16.000000000000000),(16.000000000000000,20.000000000000000)), ((0.0000000000000000,12.000000000000000),(14.000000000000000,16.000000000000000)), ((0.0000000000000000,8.0000000000000000),(14.000000000000000,12.000000000000000)), ((0.0000000000000000,4.0000000000000000),(14.000000000000000,6.0000000000000000))]
0 2 
\ No newline at end of file
progs/demo/X11/graphics/sqrlmt.hs
History View file @ 4e98702
1 3 
new file mode 100644
... ... 
@@ -0,0 +1,177 @@
1 
+-- Peter Henderson's Recursive Geometry
2 
+-- Syam Gadde and Bo Whong
3 
+-- CS429 Project
4 
+-- SquareLimit User Program
5 
+
6 
+module SqrLimit where
7 
+import HendersonLib
8 
+import Xlib
9 
+{-
10 
+p = File "p.pic"
11 
+
12 
+q = File "q.pic"
13 
+
14 
+r = File "r.pic"
15 
+
16 
+s = File "s.pic"
17 
+-}
18 
+p = Grid 640 640 [((560.0,560.0),(440.0,640.0)),
19 
+              ((640.0,560.0),(560.0,560.0)),
20 
+	      ((520.0,440.0),(640.0,480.0)),
21 
+	      ((400.0,480.0),(520.0,440.0)),
22 
+	      ((480.0,360.0),(360.0,400.0)),
23 
+	      ((480.0,360.0),(640.0,400.0)),
24 
+	      ((480.0,280.0),(640.0,320.0)),
25 
+	      ((320.0,320.0),(480.0,280.0)),
26 
+	      ((280.0,400.0),(160.0,440.0)),
27 
+	      ((160.0,240.0),(280.0,400.0)),
28 
+	      ((160.0,440.0),(160.0,240.0)),
29 
+	      ((120.0,480.0),(0.0,320.0)),
30 
+	      ((0.0,320.0),(0.0,520.0)),
31 
+	      ((120.0,480.0),(0.0,520.0)),
32 
+	      ((240.0,640.0),(160.0,480.0)),
33 
+	      ((400.0,480.0),(440.0,640.0)),
34 
+	      ((320.0,320.0),(400.0,480.0)),
35 
+	      ((160.0,120.0),(320.0,320.0)),
36 
+	      ((0.0,0.0),(160.0,120.0)),
37 
+	      ((640.0,240.0),(320.0,160.0)),
38 
+	      ((640.0,40.0),(560.0,0.0)),
39 
+	      ((520.0,40.0),(640.0,80.0)),
40 
+	      ((480.0,0.0),(520.0,40.0)),
41 
+	      ((480.0,80.0),(400.0,0.0)),
42 
+	      ((640.0,120.0),(480.0,80.0)),
43 
+	      ((480.0,160.0),(640.0,160.0)),
44 
+	      ((320.0,0.0),(480.0,160.0)),
45 
+	      ((240.0,40.0),(320.0,0.0)),
46 
+	      ((0.0,0.0),(240.0,40.0))]
47 
+
48 
+q = Grid 16 16 [((10.0,6.0),(9.0,4.0)),
49 
+            ((12.0,4.0),(10.0,6.0)),
50 
+	    ((9.0,4.0),(12.0,4.0)),
51 
+	    ((0.0,6.0),(7.0,5.0)),
52 
+	    ((0.0,8.0),(0.0,16.0)),
53 
+	    ((0.0,0.0),(0.0,4.0)),
54 
+	    ((15.0,16.0),(16.0,14.0)),
55 
+	    ((16.0,12.0),(14.0,16.0)),
56 
+	    ((13.0,16.0),(16.0,10.0)),
57 
+	    ((13.0,12.0),(12.0,16.0)),
58 
+	    ((16.0,8.0),(13.0,12.0)),
59 
+	    ((15.0,6.0),(16.0,8.0)),
60 
+	    ((16.0,0.0),(15.0,6.0)),
61 
+	    ((10.0,16.0),(14.0,5.0)),
62 
+	    ((10.0,10.0),(10.0,7.0)),
63 
+	    ((8.0,16.0),(10.0,10.0)),
64 
+	    ((8.0,11.0),(8.0,8.0)),
65 
+	    ((6.0,16.0),(8.0,11.0)),
66 
+	    ((6.0,11.0),(4.0,16.0)),
67 
+	    ((6.0,9.0),(6.0,11.0)),
68 
+	    ((4.0,11.0),(4.0,9.0)),
69 
+	    ((2.0,16.0),(4.0,11.0)),
70 
+	    ((4.0,9.0),(0.0,8.0)),
71 
+	    ((6.0,9.0),(4.0,9.0)),
72 
+	    ((12.0,6.0),(6.0,9.0)),
73 
+	    ((16.0,0.0),(12.0,6.0)),
74 
+	    ((9.0,3.0),(8.0,1.0)),
75 
+	    ((11.0,1.0),(9.0,3.0)),
76 
+	    ((8.0,1.0),(11.0,1.0)),
77 
+	    ((8.0,0.0),(7.0,1.0)),
78 
+	    ((5.0,2.0),(7.0,1.0)),
79 
+	    ((6.0,0.0),(7.0,1.0)),
80 
+	    ((5.0,2.0),(4.0,0.0)),
81 
+	    ((3.0,3.0),(5.0,2.0)),
82 
+	    ((3.0,3.0),(0.0,4.0)),
83 
+	    ((2.0,0.0),(3.0,3.0))]
84 
+
85 
+r = Grid 32 32 [((32.0,0.0),(24.0,8.0)),
86 
+            ((32.0,4.0),(30.0,2.0)),
87 
+	    ((28.0,4.0),(32.0,8.0)),
88 
+	    ((32.0,12.0),(26.0,6.0)),
89 
+	    ((24.0,8.0),(32.0,16.0)),
90 
+	    ((22.0,0.0),(24.0,8.0)),
91 
+	    ((22.0,12.0),(12.0,0.0)),
92 
+	    ((32.0,20.0),(22.0,12.0)),
93 
+	    ((24.0,26.0),(10.0,22.0)),
94 
+	    ((32.0,32.0),(24.0,26.0)),
95 
+	    ((16.0,28.0),(24.0,32.0)),
96 
+	    ((6.0,26.0),(16.0,28.0)),
97 
+	    ((16.0,32.0),(4.0,28.0)),
98 
+	    ((2.0,30.0),(8.0,32.0)),
99 
+	    ((0.0,32.0),(16.0,16.0)),
100 
+	    ((0.0,24.0),(10.0,12.0)),
101 
+	    ((4.0,8.0),(0.0,16.0)),
102 
+	    ((28.0,20.0),(32.0,24.0)),
103 
+	    ((16.0,16.0),(28.0,20.0)),
104 
+	    ((4.0,8.0),(16.0,16.0)),
105 
+	    ((2.0,4.0),(4.0,8.0)),
106 
+	    ((2.0,4.0),(0.0,8.0)),
107 
+	    ((0.0,0.0),(2.0,4.0))]
108 
+
109 
+s = Grid 32 32 [((24.0,0.0),(32.0,0.0)),
110 
+            ((0.0,0.0),(16.0,0.0)),
111 
+	    ((30.0,14.0),(32.0,12.0)),
112 
+	    ((32.0,8.0),(28.0,10.0)),
113 
+	    ((26.0,6.0),(32.0,4.0)),
114 
+	    ((26.0,6.0),(24.0,0.0)),
115 
+	    ((30.0,14.0),(26.0,6.0)),
116 
+	    ((32.0,16.0),(30.0,14.0)),
117 
+	    ((30.0,16.0),(26.0,18.0)),
118 
+	    ((30.0,22.0),(30.0,16.0)),
119 
+	    ((26.0,18.0),(30.0,22.0)),
120 
+	    ((24.0,24.0),(20.0,20.0)),
121 
+	    ((24.0,18.0),(24.0,24.0)),
122 
+	    ((20.0,20.0),(24.0,18.0)),
123 
+	    ((20.0,0.0),(22.0,12.0)),
124 
+	    ((14.0,6.0),(16.0,0.0)),
125 
+	    ((14.0,16.0),(16.0,20.0)),
126 
+	    ((14.0,6.0),(14.0,16.0)),
127 
+	    ((20.0,24.0),(16.0,20.0)),
128 
+	    ((32.0,32.0),(20.0,24.0)),
129 
+	    ((16.0,28.0),(32.0,32.0)),
130 
+	    ((8.0,28.0),(16.0,28.0)),
131 
+	    ((0.0,32.0),(8.0,28.0)),
132 
+	    ((0.0,24.0),(4.0,30.0)),
133 
+	    ((0.0,20.0),(14.0,24.0)),
134 
+	    ((0.0,16.0),(16.0,20.0)),
135 
+	    ((0.0,12.0),(14.0,16.0)),
136 
+	    ((0.0,8.0),(14.0,12.0)),
137 
+	    ((0.0,4.0),(14.0,6.0))]
138 
+
139 
+quartet p1 p2 p3 p4 =
140 
+  Above 1 (Beside 1 p1 1 p2) 1 (Beside 1 p3 1 p4)
141 
+
142 
+cyc p1 =
143 
+  quartet p1 (Rot (Rot (Rot p1))) (Rot p1) (Rot (Rot p1))
144 
+
145 
+t = quartet p q r s
146 
+
147 
+u = cyc (Rot q)
148 
+
149 
+side1 = quartet Nil Nil (Rot t) t
150 
+
151 
+side2 = quartet side1 side1 (Rot t) t
152 
+
153 
+corner1 = quartet Nil Nil Nil u
154 
+
155 
+corner2 = quartet corner1 side1 (Rot side1) u
156 
+
157 
+pseudocorner = quartet corner2 side2 (Rot side2) (Rot t)
158 
+
159 
+pseudolimit = cyc pseudocorner
160 
+
161 
+nonet p1 p2 p3 p4 p5 p6 p7 p8 p9 =
162 
+  Above 1 (Beside 1 p1 2 (Beside 1 p2 1 p3))
163 
+        2 (Above 1 (Beside 1 p4 2 (Beside 1 p5 1 p6))
164 
+	         1 (Beside 1 p7 2 (Beside 1 p8 1 p9)))
165 
+
166 
+corner = nonet corner2 side2 side2
167 
+               (Rot side2) u (Rot t)
168 
+	       (Rot side2) (Rot t) (Rot q)
169 
+
170 
+squarelimit = cyc corner
171 
+
172 
+final host = draw host corner ((0,0),(500,0),(0,500)) (0,0,500,500)
173 
+skewedfinal host = draw host squarelimit ((0,0),(600,200),(200,600)) (0,0,800,800)
174 
+
175 
+main = getEnv "DISPLAY" exit $ \ host ->
176 
+       xHandleError ( \ (XError msg) -> appendChan stdout msg exit done) $
177 
+       final host
progs/demo/X11/graphics/sqrlmt.hu
History View file @ 4e98702
0 178 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= foldr inline constant
2 
+henderson.hu
3 
+sqrlmt.hs
progs/demo/X11/graphics/stop.pic
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+Grid 200 200 [((110.00000000000000,28.000000000000000),(48.000000000000000,39.000000000000000)), ((143.00000000000000,45.000000000000000),(118.00000000000000,32.000000000000000)), ((165.00000000000000,97.000000000000000),(143.00000000000000,45.000000000000000)), ((149.00000000000000,142.00000000000000),(166.00000000000000,98.000000000000000)), ((80.000000000000000,155.00000000000000),(153.00000000000000,146.00000000000000)), ((31.000000000000000,124.00000000000000),(80.000000000000000,156.00000000000000)), ((24.000000000000000,64.000000000000000),(31.000000000000000,124.00000000000000)), ((52.000000000000000,34.000000000000000),(24.000000000000000,64.000000000000000))]
0 2 
\ No newline at end of file
progs/demo/X11/graphics/strange.pic
History View file @ 4e98702
1 3 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+Overlay (Grid 200 200 [((110.00000000000000,28.000000000000000),(48.000000000000000,39.000000000000000)), ((143.00000000000000,45.000000000000000),(118.00000000000000,32.000000000000000)), ((165.00000000000000,97.000000000000000),(143.00000000000000,45.000000000000000)), ((149.00000000000000,142.00000000000000),(166.00000000000000,98.000000000000000)), ((80.000000000000000,155.00000000000000),(153.00000000000000,146.00000000000000)), ((31.000000000000000,124.00000000000000),(80.000000000000000,156.00000000000000)), ((24.000000000000000,64.000000000000000),(31.000000000000000,124.00000000000000)), ((52.000000000000000,34.000000000000000),(24.000000000000000,64.000000000000000))]) (Flip (File "text.pic"))
2 
+
progs/demo/X11/graphics/text.pic
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+Grid 200 200 [((177.00000000000000,91.000000000000000),(177.00000000000000,91.000000000000000)), ((172.00000000000000,63.000000000000000),(175.00000000000000,79.000000000000000)), ((164.00000000000000,73.000000000000000),(148.00000000000000,77.000000000000000)), ((159.00000000000000,63.000000000000000),(164.00000000000000,71.000000000000000)), ((148.00000000000000,63.000000000000000),(159.00000000000000,62.000000000000000)), ((146.00000000000000,61.000000000000000),(149.00000000000000,92.000000000000000)), ((122.00000000000000,61.000000000000000),(115.00000000000000,61.000000000000000)), ((130.00000000000000,62.000000000000000),(122.00000000000000,61.000000000000000)), ((133.00000000000000,75.000000000000000),(130.00000000000000,63.000000000000000)), ((124.00000000000000,89.000000000000000),(131.00000000000000,79.000000000000000)), ((111.00000000000000,81.000000000000000),(124.00000000000000,89.000000000000000)), ((114.00000000000000,61.000000000000000),(108.00000000000000,78.000000000000000)), ((88.000000000000000,64.000000000000000),(91.000000000000000,91.000000000000000)), ((73.000000000000000,62.000000000000000),(96.000000000000000,60.000000000000000)), ((65.000000000000000,97.000000000000000),(49.000000000000000,100.00000000000000)), ((61.000000000000000,80.000000000000000),(65.000000000000000,97.000000000000000)), ((46.000000000000000,79.000000000000000),(61.000000000000000,80.000000000000000)), ((45.000000000000000,61.000000000000000),(46.000000000000000,79.000000000000000)), ((61.000000000000000,63.000000000000000),(41.000000000000000,62.000000000000000))]
0 2 
\ No newline at end of file
progs/demo/X11/logo/EXAMPLES.LOGO
History View file @ 4e98702
1 3 
new file mode 100644
... ... 
@@ -0,0 +1,70 @@
1 
+(to nth :index :lst
2 
+  (if (equal :index 1)
3 
+     then (first :lst)
4 
+     else (nth (difference :index 1) (butfirst :lst))))
5 
+
6 
+(to makelist :begin :end
7 
+  (fput :begin (if (equal :begin :end)
8 
+                   then [[]]
9 
+                   else (makelist (sum :begin 1) :end))))
10 
+
11 
+(to wheel :centerright
12 
+  [(hideturtle)
13 
+   (pendown)
14 
+   (setangle 90)
15 
+   (setxy :centerright 350)
16 
+   (repeat 72 times
17 
+     [(forward 2)
18 
+      (left 5)])])
19 
+
20 
+(to car
21 
+  [(pendown)
22 
+   (hideturtle)
23 
+   (setxy 400 350)
24 
+   (setangle 90)
25 
+   (forward 70)
26 
+   (left 90)
27 
+   (forward 100)
28 
+   (right 60)
29 
+   (forward 80)
30 
+   (left 60)
31 
+   (forward 100)
32 
+   (left 60)
33 
+   (forward 80)
34 
+   (right 60)
35 
+   (forward 70)
36 
+   (left 90)
37 
+   (forward 70)
38 
+   (left 90)
39 
+   (forward 350)
40 
+   (wheel 350)
41 
+   (wheel 150)])
42 
+
43 
+(to docar?
44 
+  [(local "ans)
45 
+   (print [do you want a car?])
46 
+   (make "ans (read))
47 
+   (if (equal (first ans) "yes)
48 
+      then (car)
49 
+      else [[oh well]])])
50 
+
51 
+(to poly :size :angles
52 
+    [(hideturtle)
53 
+     (pendown)
54 
+     (setangle 90)
55 
+     (repeat :angles times
56 
+             [(forward :size)
57 
+              (right (div 360 :angles))])])
58 
+
59 
+(make "x (makelist 3 12))
60 
+
61 
+(while (less (first x) 12)
62 
+ [(make "x (butfirst x))
63 
+  (print x)])
64 
+
65 
+(clean)
66 
+
67 
+(car)
68 
+
69 
+(poly 100 5)
70 
+
progs/demo/X11/logo/README
History View file @ 4e98702
0 71 
new file mode 100644
... ... 
@@ -0,0 +1,104 @@
1 
+Ki-Wing Ho and Eric Fox
2 
+Computer Science 429b
3 
+Professor Hudak
4 
+Final Project:  User Manual
5 
+
6 
+
7 
+Control Commands:
8 
+
9 
+
10 
+(DO <clause> WHILE <cond>)
11 
+
12 
+   Loop, executing a list of commands, then checking a condition and
13 
+looping again if the condition is true.
14 
+
15 
+
16 
+(REPEAT n TIMES)
17 
+  WHILE cn cl
18 
+  IF cn THEN cl1 [ELSE cl2]
19 
+
20 
+Load a file:
21 
+  USE "filename
22 
+
23 
+Environment Commands:
24 
+  MAKE "nm v
25 
+  LOCAL "nm
26 
+  TO :nm1 :nm2 :nm3 ... cl
27 
+
28 
+Text I/O:
29 
+  PRINT v
30 
+  READ
31 
+
32 
+Graphics Commands:
33 
+  FORWARD n
34 
+  BACKWARD n
35 
+  SETXY n1 n2
36 
+  LEFT n
37 
+  RIGHT n
38 
+  PENUP
39 
+  PENDOWN
40 
+  HIDETURTLE
41 
+  SHOWTURTLE
42 
+  CLEARSCREEN
43 
+  CLEAN
44 
+
45 
+Graphics Functions:
46 
+  XCOR
47 
+  YCOR
48 
+  GETANGLE
49 
+  GETPEN
50 
+  GETTURTLE
51 
+
52 
+Mathematical:
53 
+  SUM n1 n2
54 
+  DIFFERENCE n1 n2
55 
+  PRODUCT n1 n2
56 
+  MOD n1 n2
57 
+  DIV n1 n2
58 
+  POWER n1 n2
59 
+
60 
+Boolean:
61 
+  AND b1 b2
62 
+  OR b1 b2
63 
+  NOT b
64 
+
65 
+Predicates:
66 
+  WORDP v
67 
+  LISTP v
68 
+  NUMBERP v
69 
+  GREATER n1 n2
70 
+  LESS n1 n2
71 
+  EQUAL v1 v2
72 
+
73 
+Word/List:
74 
+  FIRST t
75 
+  LAST t
76 
+  FPUT t l
77 
+  BUTFIRST l
78 
+  WORD w1 w2 w3 ...
79 
+  LIST t1 t2 t3 ...
80 
+  CONCAT l1 l2
81 
+  SENTENCE t1 t2 t3 ...
82 
+
83 
+
84 
+Our Logo interpreter will only support one of the three windowing
85 
+modes: window mode, where the turtle, if it walks off the end of the
86 
+screen, just continues going and does not wrap.  The two (unsupported)
87 
+modes are fence mode where the turtle cannot walk off the end, and
88 
+wrap mode.  The initial turtle state will be with the turtle hidden,
89 
+the pen down, and the turtle in the center of the screen facing
90 
+upwards.
91 
+
92 
+All input (both for commands as well as user-input) will be
93 
+case-insensitive, and the interpreter needs to handle lists, words,
94 
+integers, and boolean values.  Also, typing "GoodBye" at the LOGO>
95 
+prompt exits the interpreter.
96 
+
97 
+All commands will be enclosed in parentheses, and all lists of
98 
+commands will be enclosed in square brackets, so that there is no
99 
+longer any need for the keyword "End". Also, all procedures will
100 
+return the value of their last command, so that there are no Stop or
101 
+Output commands.  IF statements should return the value of the last
102 
+statement executed, but all looping constructs should return no value.
103 
+
104 
+
progs/demo/X11/logo/logo.hs
History View file @ 4e98702
0 105 
new file mode 100644
... ... 
@@ -0,0 +1,1345 @@
1 
+{-
2 
+
3 
+Ki-Wing Ho and Eric Fox
4 
+Computer Science 429b
5 
+Professor Hudak
6 
+Final Project:  LOGO Interpreter
7 
+
8 
+-}
9 
+
10 
+
11 
+
12 
+-------------------------------------------------------------------------------
13 
+module REPLoop where
14 
+
15 
+{-
16 
+
17 
+REPLoop has two main parts: the first part (function logo) sets up the
18 
+graphics window, prints a welcome message, initializes the variable
19 
+and procedure environments and the turtle, accepts and lines's the
20 
+user input, runs the read-eval-print loop (part two), and then closes
21 
+the graphics window and exists; the second part (function repLoop)
22 
+lexes and parses each command, prints an error message if there was a
23 
+syntax error and evaluates (or tries to) if there wasn't, and then
24 
+either prints the value or an error message or exits if the value
25 
+returnd by the evaluator is "GoodBye".
26 
+
27 
+-}
28 
+
29 
+import Lexer
30 
+import Parser
31 
+import Evaluator
32 
+import Xlib
33 
+
34 
+demo = main
35 
+
36 
+main = getEnv "DISPLAY" exit $ \ host ->
37 
+       xHandleError ( \ (XError msg) -> appendChan stdout msg exit done) $
38 
+       logo host
39 
+
40 
+logo :: String -> IO ()
41 
+
42 
+logo host =
43 
+  xOpenDisplay host `thenIO` \ display ->
44 
+
45 
+  let (screen:_) = xDisplayRoots display
46 
+      fg_color = xScreenWhitePixel screen
47 
+      bg_color = xScreenBlackPixel screen
48 
+      root = xScreenRoot screen
49 
+  in
50 
+  xCreateWindow root
51 
+                (XRect 100 100 500 500)
52 
+                [XWinBackground bg_color,
53 
+                 XWinBackingStore XAlwaysBackStore]
54 
+  `thenIO` \ graphWindow ->
55 
+  xSetWmName graphWindow "Logo" `thenIO` \ () ->
56 
+  xSetWmIconName graphWindow "Logo" `thenIO` \ () ->
57 
+  xMapWindow graphWindow `thenIO` \ () ->
58 
+
59 
+  xCreateGcontext (XDrawWindow root)
60 
+                  [XGCBackground bg_color,
61 
+                   XGCForeground fg_color] `thenIO` \ graphContext ->
62 
+
63 
+  xDisplayForceOutput display `thenIO` \ () ->
64 
+
65 
+  appendChan stdout ("Welcome to LOGO!\n" ++ prompt) exit $
66 
+  readChan stdin exit $ \userInput ->
67 
+  repLoop
68 
+    (varEnvsInit,procEnvsInit,turtleInit)
69 
+    ((lines userInput,Lexer),
70 
+     (graphWindow,display,graphContext,bg_color,fg_color)) $
71 
+  xCloseDisplay display
72 
+
73 
+-- Initial Environments --
74 
+
75 
+varEnvsInit :: VarsType
76 
+varEnvsInit  = [[("GOODBYE",GoodBye)]]
77 
+
78 
+-- all user-defined commands must have dummy entries
79 
+procEnvsInit :: ProcsType
80 
+procEnvsInit = (map (makeFakeProc)
81 
+                    [("XCOR",0),("YCOR",0),("GETANGLE",0),("GETPEN",0),
82 
+                     ("GETTURTLE",0),
83 
+                     ("SUM",2),("DIFFERENCE",2),("PRODUCT",2),("MOD",2),
84 
+                     ("DIV",2),("POWER",2),
85 
+                     ("AND",2),("OR",2),("NOT",1),
86 
+                     ("WORDP",1),("LISTP",1),("NUMBERP",1),("GREATER",2),
87 
+                     ("EQUAL",2),("LESS",2),
88 
+                     ("BUTFIRST",1),("FPUT",2),("CONCAT",2),
89 
+                     ("FIRST",1),("LAST",1),("WORD",-2),("LIST",-2),
90 
+                     ("SENTENCE",-2), ("USE",1)]):[]
91 
+
92 
+turtleInit :: TurtleType
93 
+turtleInit   = (500 `div` 2,500 `div` 2,90,True,False)
94 
+
95 
+-- makes a dummy procedure
96 
+makeFakeProc :: (NameType , Int) -> (NameType , ProcType)
97 
+makeFakeProc (name,num) = (name,(makeArgs num,[]))
98 
+
99 
+makeArgs :: Int -> [NameType]
100 
+makeArgs n | n > 0     = "" : makeArgs (n-1)
101 
+           | otherwise = []
102 
+
103 
+-- keep running Read-Eval-Print Loop until user types GoodBye
104 
+-- repLoop keeps running until user types "GoodBye", alternately
105 
+--   lexing, parsing, and evaluating each command
106 
+-- after a syntax error, the lex state is reset
107 
+repLoop :: EnvsType -> StateType -> IO () -> IO ()
108 
+repLoop e1 (inS1,gs1) end =
109 
+  let fail1 msg (is1,ls1) = errorOutput msg $
110 
+                            repLoop e1 ((is1,Lexer),gs1) end
111 
+        -- parser fail continuation doesn't contain graphics state
112 
+      fail2 msg ((is2,ls2),gs2) = errorOutput msg $
113 
+                                  repLoop e1 ((is2,Lexer),gs1) end
114 
+        -- evaluator fail continuation does contain graphics state
115 
+  in
116 
+    parse [] inS1 fail1 $ \a ts inS2 ->
117 
+    if (null ts)
118 
+      then
119 
+        evaluate e1 a (inS2,gs1) fail2 $ \v e2 ((is3,ls3),gs3) ->
120 
+        output v end $
121 
+        repLoop e2 ((is3,Lexer),gs3) end
122 
+      else
123 
+        fail1 "Syntax error:  expected end of line" inS2
124 
+        -- repLoop will still be rerun
125 
+
126 
+-- print error message
127 
+errorOutput :: String -> IO () -> IO ()
128 
+errorOutput error = appendChan stdout (error ++ prompt) abort
129 
+
130 
+-- print expression value, exiting if GoodBye
131 
+output :: Value -> IO () -> IO () -> IO ()
132 
+output GoodBye end succ
133 
+  = appendChan stdout "\nGoodbye!\n"abort end
134 
+output v       end succ
135 
+  = appendChan stdout ((valueToString v) ++ prompt) abort succ
136 
+
137 
+prompt :: String
138 
+prompt = "\nLOGO> "
139 
+
140 
+
141 
+
142 
+-------------------------------------------------------------------------------
143 
+module Evaluator where
144 
+
145 
+{-
146 
+
147 
+Evaluator takes an Abstract Syntax Tree and evaluates it in the
148 
+current environment, returning both the resultant value and the new
149 
+environment (as well as the updated state, of which only the user
150 
+input can actually be changed in the evaluator).
151 
+
152 
+A value can be of one of six types:  integer, string, list, and
153 
+boolean, as well as null (for commands which don't return anything and
154 
+newly-declared local variables), and goodbye, which allows logo to
155 
+quit.
156 
+
157 
+The environment consists of three parts.  The variable environment and
158 
+the procedure environment are separate (so that a name can refer both
159 
+to a variable and a procedure:  Logo syntax is such that there is
160 
+never any ambiguity) are both lists of name-value association lists.
161 
+Each association list representes a "local environment", with each
162 
+successive one being more "global", so that the last environment in
163 
+the list is the global environment.  Local environments are produced
164 
+by user-function invocations and removed at the end of those
165 
+invocations.
166 
+
167 
+-}
168 
+
169 
+import Lexer
170 
+import Parser
171 
+import Xlib
172 
+
173 
+type NameType      = [Char]
174 
+type WordType      = [Char]
175 
+type Error         = [Char]
176 
+
177 
+type StateType     = (InputState , GraphicsState)
178 
+type GraphicsState = (XWindow , XDisplay , XGcontext , XPixel , XPixel)
179 
+type EnvsType      = (VarsType,ProcsType,TurtleType)
180 
+type VarsType      = [[(NameType , Value)]]
181 
+type ProcsType     = [[(NameType , ProcType)]]
182 
+type TurtleType    = (Int , Int , Int , Bool , Bool)
183 
+type ProcType      = ([NameType] , ClauseType)
184 
+
185 
+data Value         = Null
186 
+                   | Num Int
187 
+                   | Word WordType
188 
+                   | List ListType
189 
+                   | Boolean Bool
190 
+                   | GoodBye
191 
+                     deriving Text
192 
+
193 
+data ListType      = NullList | Value :* ListType
194 
+                     deriving Text
195 
+
196 
+
197 
+type EvalFailType  = Error -> StateType -> IO ()
198 
+type EvalSuccType  = Value -> EnvsType -> StateType -> IO ()
199 
+type EvalResType   = StateType -> EvalFailType -> EvalSuccType -> IO ()
200 
+type EvaluateType  = EnvsType -> AST -> EvalResType
201 
+
202 
+
203 
+evaluate :: EvaluateType
204 
+
205 
+evaluate (vs,p:ps,ttl) (To newName newProc)         ss fail succ
206 
+  = succ Null (vs,((newName,newProc):p):ps,ttl) ss
207 
+  -- procedures
208 
+
209 
+evaluate e             (Read)                       ((i:is,ls),gs) fail succ
210 
+  = succ (List (makeReadList (lexerReadLine i))) e ((is,ls),gs)
211 
+  -- user input
212 
+
213 
+evaluate e1            (Print [a])                  ss fail succ
214 
+  = evaluate e1 a ss fail $ \v e2 ss2 ->
215 
+    appendChan stdout ((valueToString v)++"\n") abort $
216 
+    succ Null e2 ss2
217 
+  -- user output
218 
+
219 
+evaluate e             (Argument (Val (Word n)))    ss fail succ
220 
+  = lookup e n ss fail $ \v ->
221 
+    succ v e ss
222 
+  -- variable reference
223 
+
224 
+evaluate e             (Argument (Val v))           ss fail succ
225 
+  = succ v e ss
226 
+  -- constant
227 
+
228 
+evaluate e             (Argument (QuotedWordArg n)) ss fail succ
229 
+  = succ (Word n) e ss
230 
+  -- string constant
231 
+
232 
+evaluate (v:vs,ps,ttl) (Local n)                    ss fail succ
233 
+  = succ Null (((n,Null):v):vs,ps,ttl) ss
234 
+  -- local variable declaraion
235 
+  -- local returns null, and sets the new local variable to null also
236 
+
237 
+evaluate e             (ParseList l)                ss fail succ
238 
+  = succ (List l) e ss
239 
+  -- lists (also constant)
240 
+
241 
+evaluate e             (Loop l cond insts)          ss fail succ
242 
+  = evalLoop l e cond insts ss fail succ
243 
+  -- loops
244 
+
245 
+evaluate e             (If cond thens elses)        ss fail succ
246 
+  = evalIf e cond thens elses ss fail succ
247 
+  -- if-then[-eles] conditionals
248 
+
249 
+evaluate e1            (Command name as1)           ss fail succ
250 
+  | ((na == length as1) || (na == -2))
251 
+    = evalArgs e1 as1 ss fail $ \e2 as2 ss2 ->
252 
+      apply name as2 e2 ss2 fail $ \v e3 ss3 ->
253 
+      succ v e3 ss3
254 
+  | na == -1
255 
+    = fail ("Function does not exist:  " ++ name) ss
256 
+  | otherwise
257 
+    = fail ("Wrong number of arguments to " ++ name) ss
258 
+  where na = numArgs e1 name
259 
+  -- function applications
260 
+
261 
+evaluate e1            (Make n a)                   ss fail succ
262 
+  = evaluate e1 a ss fail $ \v e2 ss2 ->
263 
+    update e2 n v $ \e3 ->
264 
+    succ v e3 ss2
265 
+  -- assignment statements, which return the assigned value
266 
+
267 
+evaluate e1            (Graphics name as1)          ss fail succ
268 
+  = evalArgs e1 as1 ss fail $ \e2 as2 ss2 ->
269 
+    doGraphics name as2 e2 ss2 fail $ \e3 ss3 ->
270 
+    succ Null e3 ss3
271 
+  -- side-effecting graphics statements, which all return null
272 
+-- end evaluate
273 
+
274 
+
275 
+-- evaluate a list of actual parameters, returning the corresponding
276 
+--   list of values
277 
+evalArgs :: EnvsType -> ParseArgs -> StateType -> EvalFailType ->
278 
+            (EnvsType -> EvalArgs -> StateType -> IO ()) -> IO ()
279 
+evalArgs e  []      ss fail succ
280 
+  = succ e [] ss
281 
+evalArgs e1 (a:as1) ss fail succ
282 
+  = evaluate e1 a ss fail $ \v e2 ss2 ->
283 
+    evalArgs e2 as1 ss2 fail $ \e3 as2 ss3 ->
284 
+    succ e3 (v:as2) ss3
285 
+
286 
+
287 
+-- evaluate a list of commands, returning the value of the last one
288 
+evalClause :: EnvsType -> ClauseType -> EvalResType
289 
+evalClause e  []     ss fail succ
290 
+  = succ Null e ss
291 
+evalClause e  (a:[]) ss fail succ
292 
+  = evaluate e a ss fail succ
293 
+evalClause e1 (a:as) ss fail succ
294 
+  = evaluate e1 a ss fail $ \v e2 ss2 ->
295 
+    evalClause e2 as ss2 fail succ
296 
+
297 
+-- convert a lexed user-input list to a list constant
298 
+makeReadList :: [WordType] -> ListType
299 
+makeReadList []              = NullList
300 
+makeReadList (w:ws) = (Word w) :* (makeReadList ws)
301 
+
302 
+
303 
+-- Variable routines --
304 
+
305 
+-- look up a variable reference in the variable environment
306 
+-- search the most-local environments first
307 
+-- return an error if not found
308 
+lookup :: EnvsType -> NameType -> StateType -> EvalFailType ->
309 
+          (Value -> IO ()) -> IO ()
310 
+lookup ([],ps,ttl)             name ss fail succ
311 
+  = fail ("Unbound variable:  " ++ name) ss
312 
+lookup ([]:vss,ps,ttl)         name ss fail succ
313 
+  = lookup (vss,ps,ttl) name ss fail succ
314 
+lookup (((n,v):vs):vss,ps,ttl) name ss fail succ
315 
+  | n == name = succ v
316 
+  | otherwise = lookup (vs:vss,ps,ttl) name ss fail succ
317 
+
318 
+-- update the variable environment
319 
+-- replace the most-local occurrance  first; if none are found,
320 
+--   create a new variable and place it in the most-global environment
321 
+update :: EnvsType -> NameType -> Value -> (EnvsType -> IO ()) -> IO ()
322 
+update ([]:[],ps,ttl) name value succ
323 
+  = succ (((name,value):[]):[],ps,ttl)
324 
+update ([]:vss,ps,ttl) name value succ
325 
+  = update (vss,ps,ttl) name value $ \(vss2,ps2,ttl2) ->
326 
+    succ ([]:vss2,ps2,ttl2)
327 
+update (((n,v):vs):vss,ps,ttl) name value succ
328 
+  | n == name = succ (((n,value):vs):vss,ps,ttl)
329 
+  | otherwise = update (vs:vss,ps,ttl) name value $ \(vs2:vss2,ps2,ttl2) ->
330 
+                succ (((n,v):vs2):vss2,ps2,ttl2)
331 
+
332 
+
333 
+-- Control structures --
334 
+
335 
+-- evaluate loops
336 
+evalLoop :: LoopType -> EnvsType -> ConditionType -> ClauseType ->
337 
+            EvalResType
338 
+evalLoop Do     = evalDo
339 
+evalLoop While  = evalWhile
340 
+evalLoop Repeat = evalRepeat
341 
+
342 
+-- evaluate while statements
343 
+-- loop semantics:  evaluate condition; if true, evaluate clause, then loop
344 
+-- while returns null
345 
+evalWhile :: EnvsType -> ConditionType -> ClauseType -> EvalResType
346 
+evalWhile e1 cond insts ss fail succ
347 
+  = evalCond e1 cond ss fail $ \b e2 ss2 ->
348 
+    if b
349 
+      then
350 
+        evalClause e2 insts ss2 fail $ \v e3 ss3 ->
351 
+        evalWhile e3 cond insts ss3 fail succ
352 
+      else
353 
+        succ Null e2 ss2
354 
+
355 
+-- evaluate do-while statements
356 
+-- loop semantics:  evaluate clause then evaluate condition; if true, loop
357 
+evalDo :: EnvsType -> ConditionType -> ClauseType -> EvalResType
358 
+evalDo e1 cond insts ss fail succ
359 
+  = evalClause e1 insts ss fail $ \v e2 ss2 ->
360 
+    evalCond e2 cond ss2 fail $ \b e3 ss3 ->
361 
+    if b
362 
+      then
363 
+        evalDo e3 cond insts ss3 fail succ
364 
+      else
365 
+        succ Null e3 ss3
366 
+
367 
+-- evaluate repeat statements
368 
+-- loop semantics:  evaluate loop number as n; evaluate clause n times
369 
+-- evaluate loop number and print error if it is negative or not an integer
370 
+evalRepeat :: EnvsType -> ConditionType -> ClauseType -> EvalResType
371 
+evalRepeat e1 cond insts ss fail succ
372 
+  = evaluate e1 cond ss fail $ \v e2 ss2 ->
373 
+    case v of
374 
+      Num n     -> if (n >= 0)
375 
+                     then doIterations e2 n insts ss2 fail succ
376 
+                     else fail "Repeat: Iteration count cannot be negative" ss2
377 
+      otherwise -> fail "Repeat:  Invalid iteration count" ss2
378 
+
379 
+-- perform loop interations:  evaluate "insts" "n" times
380 
+doIterations :: EnvsType -> Int -> ClauseType -> EvalResType
381 
+doIterations e  0     insts ss fail succ
382 
+  = succ Null e ss
383 
+doIterations e1 (n+1) insts ss fail succ
384 
+  = evalClause e1 insts ss fail $ \v e2 ss2 ->
385 
+    doIterations e2 n insts ss2 fail succ
386 
+
387 
+-- evaluates conditions and returns either true, false, or an error
388 
+evalCond :: EnvsType -> ConditionType -> StateType -> EvalFailType ->
389 
+            (Bool -> EnvsType -> StateType -> IO ()) -> IO ()
390 
+evalCond e1 cond ss fail succ
391 
+  = evaluate e1 cond ss fail $ \v e2 ss2 ->
392 
+    case v of
393 
+      Boolean b -> succ b e2 ss2
394 
+      otherwise -> fail "Invalid condition" ss2
395 
+
396 
+-- evaluate if-then[-else] statements
397 
+evalIf :: EnvsType -> ConditionType -> ClauseType -> ClauseType -> EvalResType
398 
+evalIf e1 cond thens elses ss fail succ
399 
+  = evalCond e1 cond ss fail $ \b e2 ss2 ->
400 
+    if b
401 
+      then evalClause e2 thens ss2 fail succ
402 
+      else evalClause e2 elses ss2 fail succ
403 
+
404 
+
405 
+-- Function application --
406 
+
407 
+-- returns the number of arguments to a user-defined or built-in function
408 
+-- -1 means the function wasn't found
409 
+-- -2 means the function can take any number of arguments
410 
+numArgs :: EnvsType -> CommandName -> Int
411 
+numArgs (vs,[],ttl)     name
412 
+  = -1
413 
+numArgs (vs,[]:pss,ttl) name
414 
+  = numArgs (vs,pss,ttl) name
415 
+numArgs (vs,((n,(formals,body)):ps):pss,ttl) name
416 
+  | inList ["WORD","SENTENCE","LIST"] name = -2
417 
+  | n == name                              = length formals
418 
+  | otherwise                              = numArgs (vs,ps:pss,ttl) name
419 
+
420 
+-- apply a function to its arguments
421 
+-- mostly just decides if it's user-defined or built-in, then dispatches
422 
+apply :: CommandName -> EvalArgs -> EnvsType -> EvalResType
423 
+apply n as e ss fail succ
424 
+  | isBuiltIn n = applyPrimProc n as e ss fail succ
425 
+  | otherwise   = applyUserProc (getProc e n) as e ss fail succ
426 
+
427 
+
428 
+
429 
+-- returns procedure "name" from the procedure environment
430 
+-- searches most-local environments first
431 
+-- precondition:  procedure does exist somewhere
432 
+getProc :: EnvsType -> CommandName -> ProcType
433 
+getProc (vss,[]:pss,ttl)        name
434 
+  = getProc (vss,pss,ttl) name
435 
+getProc (vs,((n,p):ps):pss,ttl) name
436 
+  | n == name = p
437 
+  | otherwise = getProc (vs,ps:pss,ttl) name
438 
+
439 
+-- apply user function:
440 
+--   bind formal parameters
441 
+--   create local enviroments
442 
+--   evaluate body of function
443 
+--   destroy local environments
444 
+--   return value of body
445 
+applyUserProc :: ProcType -> EvalArgs -> EnvsType -> EvalResType
446 
+applyUserProc (formals,body) actuals e1 ss fail succ
447 
+  = bind formals actuals e1 $ \e2 ->
448 
+    evalClause e2 body ss fail $ \v (vs:vss,ps:pss,ts) ss2 ->
449 
+    succ v (vss,pss,ts) ss2
450 
+
451 
+-- bind formal parameters to actuals in local environment
452 
+bind :: [NameType] -> EvalArgs -> EnvsType -> (EnvsType -> IO ()) -> IO ()
453 
+bind formals actuals (vss,pss,ttl) succ
454 
+  = succ ((zip formals actuals):vss,[]:pss,ttl)
455 
+
456 
+
457 
+-- Built-in functions --
458 
+
459 
+-- returns true for built-in functions
460 
+isBuiltIn :: CommandName -> Bool
461 
+isBuiltIn = inList ["XCOR","YCOR","GETANGLE","GETPEN","GETTURTLE",
462 
+                    "SUM","DIFFERENCE","PRODUCT","MOD","DIV","POWER",
463 
+                    "AND","OR","NOT",
464 
+                    "WORDP","LISTP","NUMBERP","GREATER","EQUAL","LESS",
465 
+                    "BUTFIRST","FPUT","CONCAT",
466 
+                    "FIRST","LAST","WORD","LIST","SENTENCE", "USE"]
467 
+
468 
+
469 
+-- applies a built-in function to its arguments
470 
+applyPrimProc :: CommandName -> [Value] -> EnvsType -> EvalResType
471 
+
472 
+applyPrimProc "XCOR"      [] (vs,ps,(x,y,a,p,t)) ss fail succ
473 
+  = succ (Num x) (vs,ps,(x,y,a,p,t)) ss
474 
+applyPrimProc "YCOR"      [] (vs,ps,(x,y,a,p,t)) ss fail succ
475 
+  = succ (Num y) (vs,ps,(x,y,a,p,t)) ss
476 
+applyPrimProc "GETANGLE"  [] (vs,ps,(x,y,a,p,t)) ss fail succ
477 
+  = succ (Num a) (vs,ps,(x,y,a,p,t)) ss
478 
+applyPrimProc "GETPEN"    [] (vs,ps,(x,y,a,p,t)) ss fail succ
479 
+  = succ (Boolean p) (vs,ps,(x,y,a,p,t)) ss
480 
+applyPrimProc "GETTURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ
481 
+  = succ (Boolean t) (vs,ps,(x,y,a,p,t)) ss
482 
+
483 
+applyPrimProc "SUM"        [Num a , Num b] e ss fail succ
484 
+  = succ (Num (a+b)) e ss
485 
+applyPrimProc "DIFFERENCE" [Num a , Num b] e ss fail succ
486 
+  = succ (Num (a-b)) e ss
487 
+applyPrimProc "PRODUCT"    [Num a , Num b] e ss fail succ
488 
+  = succ (Num (a*b)) e ss
489 
+applyPrimProc "MOD"        [Num a , Num b] e ss fail succ
490 
+  = succ (Num (a `mod` b)) e ss
491 
+applyPrimProc "DIV"        [Num a , Num b] e ss fail succ
492 
+  = succ (Num (a `div` b)) e ss
493 
+applyPrimProc "POWER"      [Num a , Num b] e ss fail succ
494 
+  | b >= 0 = succ (Num (a^b)) e ss
495 
+  | otherwise = fail ("Negative exponent:  " ++ (show b)) ss
496 
+
497 
+applyPrimProc "AND" [Boolean a , Boolean b] e ss fail succ
498 
+  = succ (Boolean (a && b)) e ss
499 
+applyPrimProc "OR"  [Boolean a , Boolean b] e ss fail succ
500 
+  = succ (Boolean (a || b)) e ss
501 
+applyPrimProc "NOT" [Boolean a]             e ss fail succ
502 
+  = succ (Boolean (not a)) e ss
503 
+
504 
+applyPrimProc "WORDP"   [Word w]                e ss fail succ
505 
+  = succ (Boolean True) e ss
506 
+applyPrimProc "WORDP"   [v]                     e ss fail succ
507 
+  = succ (Boolean False) e ss
508 
+applyPrimProc "NUMBERP" [Num n]                 e ss fail succ
509 
+  = succ (Boolean True) e ss
510 
+applyPrimProc "NUMBERP" [v]                     e ss fail succ
511 
+  = succ (Boolean False) e ss
512 
+applyPrimProc "LISTP"   [List l]                e ss fail succ
513 
+  = succ (Boolean True) e ss
514 
+applyPrimProc "LISTP"   [v]                     e ss fail succ
515 
+  = succ (Boolean False) e ss
516 
+applyPrimProc "GREATER" [Num a , Num b]         e ss fail succ
517 
+  = succ (Boolean (a > b)) e ss
518 
+applyPrimProc "EQUAL"   [Num a , Num b]         e ss fail succ
519 
+  = succ (Boolean (a == b)) e ss
520 
+applyPrimProc "EQUAL"   [Word a , Word b]       e ss fail succ
521 
+  = succ (Boolean (a == b)) e ss
522 
+applyPrimProc "EQUAL"   [Boolean a , Boolean b] e ss fail succ
523 
+  = succ (Boolean (a == b)) e ss
524 
+applyPrimProc "LESS"    [Num a , Num b]         e ss fail succ
525 
+  = succ (Boolean (a < b)) e ss
526 
+
527 
+applyPrimProc "BUTFIRST" [Word ""]                     e ss fail succ
528 
+  = succ (Word "") e ss
529 
+applyPrimProc "BUTFIRST" [Word (c:cs)]                 e ss fail succ
530 
+  = succ (Word cs) e ss
531 
+applyPrimProc "BUTFIRST" [List NullList]               e ss fail succ
532 
+  = succ (List NullList) e ss
533 
+applyPrimProc "BUTFIRST" [List (v :* vs)]              e ss fail succ
534 
+  = succ (List vs) e ss
535 
+applyPrimProc "FPUT"     [v , List l]                  e ss fail succ
536 
+  = succ (List (v :* l)) e ss
537 
+applyPrimProc "CONCAT"   [List l1 , List l2]           e ss fail succ
538 
+  = succ (List (listConcatenate l1 l2)) e ss
539 
+applyPrimProc "FIRST"    [Word (c:cs)]                 e ss fail succ
540 
+  = succ (Word (c:[])) e ss
541 
+applyPrimProc "FIRST"    [List (v :* vs)]              e ss fail succ
542 
+  = succ v e ss
543 
+applyPrimProc "LAST"     [Word (c:[])]                 e ss fail succ
544 
+  = succ (Word (c:[])) e ss
545 
+applyPrimProc "LAST"     [Word ""]                     e ss fail succ
546 
+  = succ Null e ss
547 
+applyPrimProc "LAST"     [Word (c:cs)]                 e ss fail succ
548 
+  = applyPrimProc "LAST" [(Word cs)] e ss fail succ
549 
+applyPrimProc "LAST"     [List (v :* NullList)]        e ss fail succ
550 
+  = succ v e ss
551 
+applyPrimProc "LAST"     [List (v :* vs)]              e ss fail succ
552 
+  = applyPrimProc "LAST" [(List vs)] e ss fail succ
553 
+applyPrimProc "WORD"     []                            e ss fail succ
554 
+  = succ (Word "") e ss
555 
+applyPrimProc "WORD"     ((Word w):ws)                 e ss fail succ
556 
+  = applyPrimProc "WORD" ws e ss fail $ \(Word wsc) e2 ss2 ->
557 
+    succ (Word (w ++ wsc)) e2 ss2
558 
+applyPrimProc "LIST"     (v:vs)                        e ss fail succ
559 
+  = applyPrimProc "LIST" vs e ss fail $ \(List l) e2 ss2 ->
560 
+    succ (List (v :* l)) e2 ss2
561 
+applyPrimProc "LIST"     []                            e ss fail succ
562 
+  = succ (List NullList) e ss
563 
+applyPrimProc "SENTENCE" []                            e ss fail succ
564 
+  = succ (List NullList) e ss
565 
+applyPrimProc "SENTENCE" ((List l):[])                 e ss fail succ
566 
+  = succ (List l) e ss
567 
+applyPrimProc "SENTENCE" ((List l):vs)                 e ss fail succ
568 
+  = applyPrimProc "SENTENCE" [List l] e  ss  fail $ \(List s1) e2 ss2 ->
569 
+    applyPrimProc "SENTENCE" vs       e2 ss2 fail $ \(List s2) e3 ss3 ->
570 
+    succ (List (listConcatenate s1 s2)) e3 ss3
571 
+applyPrimProc "SENTENCE" (v:vs)                        e ss fail succ
572 
+  = applyPrimProc "SENTENCE" vs e ss fail $ \(List ws) e2 ss2 ->
573 
+    succ (List (v :* ws)) e2 ss2
574 
+
575 
+applyPrimProc "USE" [Word filename]
576 
+              e
577 
+              ss@((ins, ls), gs)
578 
+              fail succ
579 
+  = readFile filename (\ _ -> fail ("Can't read file: " ++ filename) ss)
580 
+    $ \filecontents ->
581 
+    useRepLoop e ((lines filecontents, Lexer), gs)
582 
+               (\ msg s -> fail msg ss) $ \ v e s ->
583 
+    succ v e ss
584 
+
585 
+applyPrimProc n          _                             _ ss fail _
586 
+  = fail ("Incorrect arguments:  " ++ n) ss
587 
+
588 
+useRepLoop :: EnvsType -> EvalResType
589 
+useRepLoop e  s@(([], ls), gs) fail succ = succ (Word "OK") e s
590 
+useRepLoop e1 s1@(inS1,gs1) fail succ =
591 
+    parse [] inS1 (\ msg ins -> fail msg (ins, gs1)) $ \a ts inS2 ->
592 
+    if (null ts)
593 
+      then
594 
+        evaluate e1 a (inS2,gs1) fail $ \v e2 s3 ->
595 
+        useRepLoop e2 s3 fail succ
596 
+      else
597 
+        fail "Syntax error:  expected end of line" (inS2, gs1)
598 
+
599 
+
600 
+
601 
+-- concatenates two lists
602 
+listConcatenate :: ListType -> ListType -> ListType
603 
+listConcatenate NullList  l2 = l2
604 
+listConcatenate (v :* l1) l2 = (v :* (listConcatenate l1 l2))
605 
+
606 
+
607 
+-- Graphics --
608 
+
609 
+type EvalArgs = [Value]
610 
+type GraphEnv = (Int,Int,Int,Bool)
611 
+
612 
+-- evaluates side-effecting graphics functions
613 
+-- note:  none of them return values
614 
+doGraphics :: CommandName -> EvalArgs -> EnvsType -> StateType ->
615 
+              EvalFailType -> (EnvsType -> StateType -> IO ()) -> IO ()
616 
+
617 
+doGraphics "HIDETURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ
618 
+  = hideTurtle x y a ss $
619 
+    succ (vs,ps,(x,y,a,p,False)) ss
620 
+  -- hide turtle, appropriately adjust environment
621 
+
622 
+doGraphics "SHOWTURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ
623 
+  = showTurtle x y a ss $
624 
+    succ (vs,ps,(x,y,a,p,True)) ss
625 
+  -- show turtle, appropriately adjust environment
626 
+
627 
+doGraphics name as (vs,ps,(x,y,a,p,True)) ss fail succ
628 
+  = hideTurtle x y a ss $
629 
+    moveTurtle name as (x,y,a,p) ss $ \(x2,y2,a2,p2) ->
630 
+    showTurtle x2 y2 a2 ss $
631 
+    succ (vs,ps,(x2,y2,a2,p2,True)) ss
632 
+  -- executes graphics commands if turtle is shownn
633 
+
634 
+doGraphics name as (vs,ps,(x,y,a,p,False)) ss fail succ
635 
+  = moveTurtle name as (x,y,a,p) ss $ \(x2,y2,a2,p2) ->
636 
+    succ (vs,ps,(x2,y2,a2,p2,False)) ss
637 
+  -- executes graphics commands if turtle is not shown
638 
+
639 
+-- converts an integer to a float
640 
+toFloat :: Int -> Float
641 
+toFloat = fromInteger . toInteger
642 
+
643 
+newmod a b = let c = a `mod` b
644 
+             in if (c < 0) then (c + b) else c
645 
+
646 
+-- shows the turtle, but returns nothing
647 
+showTurtle :: Int -> Int -> Int -> StateType -> IO () -> IO ()
648 
+showTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) succ
649 
+  = let dx1 = round (12 * cos (toFloat a * pi/180))
650 
+        dx2 = round (4  * sin (toFloat a * pi/180))
651 
+	dy1 = round (12 * sin (toFloat a * pi/180))
652 
+	dy2 = round (4  * cos (toFloat a * pi/180))
653 
+    in
654 
+    xDrawLine (XDrawWindow graphWindow)
655 
+              graphContext
656 
+	      (XPoint x y)
657 
+	      (XPoint (x-dx1-dx2) (y+dy1-dy2))
658 
+    `thenIO` \ () ->
659 
+    xDrawLine (XDrawWindow graphWindow)
660 
+              graphContext
661 
+	      (XPoint x y)
662 
+	      (XPoint (x-dx1+dx2) (y+dy1+dy2))
663 
+    `thenIO` \ () ->
664 
+    xDrawLine (XDrawWindow graphWindow)
665 
+              graphContext
666 
+	      (XPoint (x-dx1-dx2) (y+dy1-dy2))
667 
+	      (XPoint (x-dx1+dx2) (y+dy1+dy2))
668 
+    `thenIO` \ () ->
669 
+    xDisplayForceOutput display
670 
+    `thenIO_`
671 
+    succ
672 
+
673 
+-- hides the turtle, but returns nothing
674 
+hideTurtle :: Int -> Int -> Int -> StateType -> IO () -> IO ()
675 
+hideTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) succ
676 
+  = xUpdateGcontext graphContext [XGCForeground bg]
677 
+    `thenIO_`
678 
+    (showTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) $
679 
+    (xUpdateGcontext graphContext [XGCForeground fg]
680 
+    `thenIO_`
681 
+    succ))
682 
+
683 
+-- performs all graphics commands that don't involve hiding/showing
684 
+--   the turtle
685 
+moveTurtle :: CommandName -> EvalArgs -> GraphEnv -> StateType ->
686 
+              (GraphEnv -> IO ()) -> IO ()
687 
+moveTurtle "SETXY"       [Num xp,Num yp] (x,y,a,p) ss succ
688 
+  = succ (xp,yp,a,p)
689 
+
690 
+-- move the turtle forward "d" times, drawing a line if pen is down
691 
+moveTurtle "FORWARD"     [Num d]         (x,y,a,p)
692 
+           (is,(graphWindow,display,graphContext,fg,bg)) succ
693 
+  = let xp = x + round (toFloat d * cos (toFloat a * pi/180))
694 
+        yp = y - round (toFloat d * sin (toFloat a * pi/180)) in
695 
+     (if p
696 
+        then (xDrawLine (XDrawWindow graphWindow)
697 
+	                graphContext
698 
+			(XPoint x y)
699 
+			(XPoint xp yp))
700 
+        else returnIO ()) `thenIO` \ () ->
701 
+     xDisplayForceOutput display `thenIO` \ () ->
702 
+     succ (xp,yp,a,p)
703 
+
704 
+-- move the turtle backward "d" pixels, drawing a line if pen is down
705 
+moveTurtle "BACKWARD"    [Num d]         (x,y,a,p) ss succ
706 
+  = moveTurtle "FORWARD" [Num (-d)] (x,y,a,p) ss succ
707 
+
708 
+-- rotate turtle to "ap" degrees from facing due east
709 
+moveTurtle "SETANGLE"    [Num ap]        (x,y,a,p) ss succ
710 
+  = succ (x,y,ap,p)
711 
+
712 
+-- rotate turtle counterclockwise "ap" degrees
713 
+moveTurtle "LEFT"        [Num ap]        (x,y,a,p) ss succ
714 
+  = succ (x,y, (a + ap) `newmod` 360 ,p)
715 
+
716 
+-- rotate turtle clockwise "ap" degrees
717 
+moveTurtle "RIGHT"       [Num ap]        (x,y,a,p) ss succ
718 
+  = succ (x,y, (a - ap) `newmod` 360 ,p)
719 
+
720 
+-- pick pen up
721 
+moveTurtle "PENUP"       []              (x,y,a,p) ss succ
722 
+  = succ (x,y,a,False)
723 
+
724 
+-- put pen down
725 
+moveTurtle "PENDOWN"     []              (x,y,a,p) ss succ
726 
+  = succ (x,y,a,True)
727 
+
728 
+-- clear screen but don't otherwise alter turtle state
729 
+moveTurtle "CLEARSCREEN" []              (x,y,a,p)
730 
+           (is,(graphWindow,display,graphContext,bg,fg)) succ
731 
+  = xClearArea graphWindow (XRect 0 0 500 500) True
732 
+    `thenIO` \() ->
733 
+    xDisplayForceOutput display
734 
+    `thenIO` \() ->
735 
+    succ (x,y,a,p)
736 
+
737 
+-- pick pen up and reset turtle
738 
+moveTurtle "CLEAN"       []              (x,y,a,p)
739 
+           (is,(graphWindow,display,graphContext,bg,fg)) succ
740 
+  = xClearArea graphWindow (XRect 0 0 500 500) True
741 
+    `thenIO` \() ->
742 
+    xDisplayForceOutput display
743 
+    `thenIO` \() ->
744 
+    succ (500 `div` 2,500 `div` 2,90,True)
745 
+
746 
+-- do nothing if arguments are incorrect
747 
+moveTurtle _ _ e _ succ = succ e
748 
+
749 
+
750 
+-- valueToString, etc. --
751 
+
752 
+-- convert a value to a string
753 
+valueToString :: Value -> String
754 
+valueToString (Word w)        = w
755 
+valueToString (Num n)         = show n
756 
+valueToString (Boolean True)  = "TRUE"
757 
+valueToString (Boolean False) = "FALSE"
758 
+valueToString Null            = ""
759 
+valueToString (List l)        = "[" ++ (listToString l) ++ "]"
760 
+valueToString GoodBye         = "Don't play around with this variable!"
761 
+
762 
+-- convert a list to a string
763 
+listToString :: ListType -> String
764 
+listToString NullList        = ""
765 
+listToString (v :* NullList) = valueToString v
766 
+listToString (v :* l)        = (valueToString v) ++ " " ++ (listToString l)
767 
+
768 
+
769 
+
770 
+-------------------------------------------------------------------------------
771 
+module Lexer where
772 
+
773 
+{-
774 
+
775 
+Lexer takes as input a line from standard input and returns an ordered
776 
+pair containing the translation of that list into tokens as well as
777 
+the current state of the lexer (how many parentheses and brackets are
778 
+still open).  The state is necessary because some commands may take
779 
+multiple lines, so a bracket (say) may be left open on one line to be
780 
+closed later on.
781 
+
782 
+All unmatched close brackets and parentheses are treated as spaces
783 
+(and therefore ignored).
784 
+
785 
+The method for tokenizing commands is:
786 
+
787 
+  All words are delimited by spaces, parenthesis, or brackets.
788 
+
789 
+  All words beginning with a double quote are returned as quoted words
790 
+  rather than normal words.
791 
+
792 
+  Any character preceded by a backslash is taken as is, rather than
793 
+  tokenized normally.
794 
+
795 
+  All words are translated to upper case..
796 
+
797 
+The method for tokenizing user input is:
798 
+
799 
+  All words are delimited by spaces and translated to upper case.
800 
+
801 
+-}
802 
+
803 
+import Parser
804 
+import Evaluator
805 
+
806 
+
807 
+data LexState = Lexer | LexerBracket Int LexState | LexerParen Int LexState
808 
+                deriving Text
809 
+
810 
+type LexerType = [Char] -> ([Token] , LexState)
811 
+
812 
+data Token   = OpenBracket
813 
+             | CloseBracket
814 
+             | OpenParen
815 
+             | CloseParen
816 
+             | QuotedWord WordType
817 
+             | Normal WordType     deriving (Text,Eq)
818 
+
819 
+
820 
+-- call appropriate lex procedure depending upon the current lex state
821 
+lexDispatch :: LexState -> LexerType
822 
+lexDispatch (Lexer)            = lexer
823 
+lexDispatch (LexerBracket n s) = lexerBracket n s
824 
+lexDispatch (LexerParen n s)   = lexerParen n s
825 
+
826 
+
827 
+-- handle commands
828 
+lexer :: LexerType
829 
+lexer []       = ([] , Lexer)
830 
+lexer (' ':cs) = lexer cs
831 
+lexer ('[':cs) = let (ts , s) = lexerBracket 1 (Lexer) cs
832 
+                 in (OpenBracket : ts , s)
833 
+lexer ('(':cs) = let (ts , s) = lexerParen 1 (Lexer) cs
834 
+                 in (OpenParen : ts , s)
835 
+lexer (')':cs) = lexer cs
836 
+lexer (']':cs) = lexer cs
837 
+lexer ('"':cs) = let (t , cs2) = lexerWord (isDelimiter) cs
838 
+                     (ts , s)  = lexer cs2
839 
+                 in ((QuotedWord (upWord t)):ts , s)
840 
+lexer cs       = let (t , cs2) = lexerWord (isDelimiter) cs
841 
+                     (ts , s)  = lexer cs2
842 
+                 in ((Normal (upWord t)):ts , s)
843 
+
844 
+lexerWord :: (Char -> Bool) -> [Char] -> (WordType , [Char])
845 
+lexerWord endCond []
846 
+  = ([] , [])
847 
+lexerWord endCond (c:cs)
848 
+  | c == '\\' = if cs == []
849 
+                  then ("\\" , cs)
850 
+                  else
851 
+                    let (t , cs2) = lexerWord endCond (tail cs)
852 
+                    in ((head cs):t , cs2)
853 
+  | endCond c = ([] , (c:cs))
854 
+  | otherwise = let (t , cs2) = lexerWord endCond cs
855 
+                in ((toUpper c):t , cs2)
856 
+
857 
+
858 
+-- performs lexing inside brackets
859 
+lexerBracket :: Int -> LexState -> LexerType
860 
+lexerBracket n s []
861 
+  = ([] , LexerBracket n s)
862 
+lexerBracket n s (' ':cs)
863 
+  = lexerBracket n s cs
864 
+lexerBracket 1 s (']':cs)
865 
+  = let (ts , s2) = lexDispatch s cs
866 
+    in (CloseBracket:ts , s2)
867 
+lexerBracket n s (']':cs)
868 
+  = let (ts , s2) = lexerBracket (n-1) s cs
869 
+    in (CloseBracket:ts , s2)
870 
+lexerBracket n s ('[':cs)
871 
+  = let (ts , s2) = lexerBracket (n+1) s cs
872 
+    in (OpenBracket:ts , s2)
873 
+lexerBracket n s ('(':cs)
874 
+  = let (ts , s2) = lexerParen 1 (LexerBracket n s) cs
875 
+    in (OpenParen:ts , s2)
876 
+lexerBracket n s (')':cs)
877 
+  = lexerBracket n s cs
878 
+lexerBracket n s cs
879 
+  = let (t , cs2) = lexerWord (isDelimiter) cs
880 
+        (ts , s2) = lexerBracket n s cs2
881 
+    in ((Normal (upWord t)):ts , s2)
882 
+
883 
+
884 
+-- performs lexing inside parentheses
885 
+lexerParen :: Int -> LexState -> LexerType
886 
+lexerParen n s []
887 
+  = ([] , LexerParen n s)
888 
+lexerParen n s (' ':cs)
889 
+  = lexerParen n s cs
890 
+lexerParen 1 s (')':cs)
891 
+  = let (ts , s2) = lexDispatch s cs
892 
+    in (CloseParen:ts , s2)
893 
+lexerParen n s (')':cs)
894 
+  = let (ts , s2) = lexerParen (n-1) s cs
895 
+    in (CloseParen:ts , s2)
896 
+lexerParen n s ('(':cs)
897 
+  = let (ts , s2) = lexerParen (n+1) s cs
898 
+    in (OpenParen:ts , s2)
899 
+lexerParen n s ('[':cs)
900 
+  = let (ts , s2) = lexerBracket 1 (LexerParen n s) cs
901 
+    in (OpenBracket:ts , s2)
902 
+lexerParen n s (']':cs)
903 
+  = lexerParen n s cs
904 
+lexerParen n s ('"':cs)
905 
+  = let (t , cs2) = lexerWord (isDelimiter) cs
906 
+        (ts , s2) = lexerParen n s cs2
907 
+    in ((QuotedWord (upWord t)):ts , s2)
908 
+lexerParen n s cs
909 
+  = let (t , cs2) = lexerWord (isDelimiter) cs
910 
+        (ts , s2) = lexerParen n s cs2
911 
+    in ((Normal (upWord t)):ts , s2)
912 
+
913 
+
914 
+-- returns true for delimiters
915 
+isDelimiter :: Char -> Bool
916 
+isDelimiter = inList " []()"
917 
+
918 
+-- returns true of p is in cs
919 
+inList :: (Eq a) => [a] -> a -> Bool
920 
+inList [] p     = False
921 
+inList (c:cs) p = (c == p) || (inList cs p)
922 
+
923 
+
924 
+-- handle user input
925 
+lexerReadLine :: [Char] -> [WordType]
926 
+lexerReadLine []
927 
+  = []
928 
+lexerReadLine (' ':cs)
929 
+  = lexerReadLine cs
930 
+lexerReadLine cs
931 
+  = let (firstWord,restOfWords) = span (/= ' ') cs
932 
+    in (upWord firstWord) : lexerReadLine restOfWords
933 
+
934 
+-- translate a word to upper case
935 
+upWord :: WordType -> WordType
936 
+upWord = map (toUpper)
937 
+
938 
+
939 
+
940 
+-------------------------------------------------------------------------------
941 
+module Parser where
942 
+
943 
+{-
944 
+
945 
+Parser takes a list of tokens, the input state, and fail and success
946 
+continuations and returns an Abstract Syntax Tree, the remaining
947 
+tokens (hopefully none), and the new input state.  The input state
948 
+will be changed every time Parser runs out of tokens:  it simply grabs
949 
+(and lexes) the next line of user-input.  It therefore doesn't return
950 
+anything until the entire AST has been be read in, even if it spans
951 
+several lines, though parse may catch some errors before all lines
952 
+have been input.  In this case, it ceases taking input and returns the
953 
+error.
954 
+
955 
+An Abstract Syntax Tree represents one command, and breaks those
956 
+commands into Ifs, Loops, Tos, Locals, Makes, Reads, Prints,
957 
+Constants, List constants, Graphics commands (which produce
958 
+side-effects), and function applications.  All built-in commands that
959 
+don't fit into one of those categories are lumped into function
960 
+applications along with user-defined functions.  Each type of AST is
961 
+parsed into subcommands, subclauses (lists of commands), command
962 
+arguments (also subcommands), and any other values that will be
963 
+immediately-evaluatable (such as function names).
964 
+
965 
+-}
966 
+
967 
+
968 
+import Lexer
969 
+import Evaluator
970 
+
971 
+
972 
+type CommandName     = [Char]
973 
+type ClauseType      = [AST]
974 
+type ConditionType   = AST
975 
+
976 
+type ParseArgs       = [AST]
977 
+
978 
+data ArgType         = Val Value | QuotedWordArg WordType
979 
+                       deriving Text
980 
+
981 
+data AST             = ParseList ListType
982 
+                     | If ConditionType ClauseType ClauseType
983 
+                     | Loop LoopType ConditionType ClauseType
984 
+                     | To NameType ProcType
985 
+                     | Make NameType AST
986 
+                     | Local NameType
987 
+                     | Read
988 
+                     | Print ParseArgs
989 
+                     | Argument ArgType
990 
+                     | Graphics CommandName ParseArgs
991 
+                     | Command CommandName ParseArgs      deriving Text
992 
+
993 
+data LoopType        = Do | While | Repeat
994 
+                       deriving Text
995 
+
996 
+type ParseFailType   = Error -> InputState -> IO ()
997 
+type ParseType       = [Token] -> InputState -> ParseFailType ->
998 
+                       (AST -> [Token] -> InputState -> IO ()) -> IO ()
999 
+type ParseClauseType = [Token] -> InputState -> ParseFailType ->
1000 
+                       (ClauseType -> [Token] -> InputState -> IO ()) -> IO ()
1001 
+
1002 
+type InputState      = ([[Char]] , LexState)
1003 
+
1004 
+parse :: ParseType
1005 
+
1006 
+parse [] (i:is , ls) fail succ
1007 
+  = let (ts , ls2) = lexDispatch ls i
1008 
+    in parse ts (is , ls2) fail succ
1009 
+
1010 
+parse ((QuotedWord s) : ts) inS fail succ
1011 
+  = succ (Argument (QuotedWordArg s)) ts inS
1012 
+
1013 
+parse ((Normal s) : ts) inS fail succ
1014 
+  = succ (Argument (Val (process s))) ts inS
1015 
+
1016 
+parse (OpenParen : []) (i:is,ls) fail succ
1017 
+  = let (ts,ls2) = lexDispatch ls i
1018 
+    in parse (OpenParen:ts) (is,ls2) fail succ
1019 
+
1020 
+parse (OpenParen : (Normal t) : ts) inS fail succ
1021 
+  | t == "TO"    = makeProc ts inS fail succ
1022 
+  | t == "MAKE"  = makeMake ts inS fail succ
1023 
+  | t == "LOCAL" = makeLocal ts inS fail succ
1024 
+  | t == "READ"  = makeRead ts inS fail succ
1025 
+  | t == "PRINT" = makePrint ts inS fail succ
1026 
+  | t == "IF"    = makeIf ts inS fail succ
1027 
+  | isLoop t     = makeLoop t ts inS fail succ
1028 
+  | isGraphics t = makeGraphics t ts inS fail succ
1029 
+  | otherwise    = makeCommand t ts inS fail succ
1030 
+
1031 
+parse (OpenBracket : ts) inS fail succ
1032 
+  = parseList ts inS fail succ
1033 
+
1034 
+parse ts inS@([], _) _ succ = succ (Argument (Val (Word "GOODBYE"))) ts inS
1035 
+
1036 
+parse _ inS fail _
1037 
+  = fail "Syntax error" inS
1038 
+
1039 
+
1040 
+-- returns true for all loop names
1041 
+isLoop :: CommandName -> Bool
1042 
+isLoop = inList ["DO","WHILE","REPEAT"]
1043 
+
1044 
+-- returns true for all side-effecting graphics command names
1045 
+isGraphics :: CommandName -> Bool
1046 
+isGraphics = inList ["FORWARD","BACKWARD","LEFT","RIGHT",
1047 
+                     "SETXY","SETANGLE","PENUP","PENDOWN",
1048 
+                     "HIDETURTLE","SHOWTURTLE","CLEARSCREEN","CLEAN"]
1049 
+
1050 
+-- Parse lists --
1051 
+
1052 
+-- parses a list constant
1053 
+parseList :: ParseType
1054 
+parseList []                  (i:is,ls) fail succ
1055 
+  = let (ts,ls2) = lexDispatch ls i
1056 
+    in parseList ts (is,ls2) fail succ
1057 
+parseList (CloseBracket:ts)   inS fail succ
1058 
+  = succ (ParseList NullList) ts inS
1059 
+parseList (OpenBracket:ts)    inS fail succ
1060 
+  = parseList ts inS fail $ \(ParseList l1) ts2 inS2 ->
1061 
+    parseList ts2 inS2 fail $ \(ParseList l2) ts3 inS3 ->
1062 
+    succ (ParseList ((List l1) :* l2)) ts3 inS3
1063 
+parseList ((Normal w):ts)     inS fail succ
1064 
+  = parseList ts inS fail $ \(ParseList l) ts2 inS2 ->
1065 
+    succ (ParseList ((process w) :* l)) ts2 inS2
1066 
+parseList (OpenParen:ts)      inS fail succ
1067 
+  = parseList ts inS fail $ \(ParseList l) ts2 inS2 ->
1068 
+    succ (ParseList ((Word "(") :* l)) ts2 inS2
1069 
+parseList (CloseParen:ts)     inS fail succ
1070 
+  = parseList ts inS fail $ \(ParseList l) ts2 inS2 ->
1071 
+    succ (ParseList ((Word ")") :* l)) ts2 inS2
1072 
+parseList ((QuotedWord w):ts) inS fail succ
1073 
+  = parseList ts inS fail $ \(ParseList l) ts2 inS2 ->
1074 
+    succ (ParseList ((Word w) :* l)) ts2 inS2
1075 
+
1076 
+
1077 
+-- parses constant values, distinguishing words from integers and booleans
1078 
+process :: WordType -> Value
1079 
+process "TRUE"  = Boolean True
1080 
+process "FALSE" = Boolean False
1081 
+process ('-':w)
1082 
+  | all isDigit w = Num (- (stringToNum (reverse w)))
1083 
+  | otherwise     = Word ('-':w)
1084 
+process w
1085 
+  | all isDigit w = Num (stringToNum (reverse w))
1086 
+  | otherwise     = Word w
1087 
+
1088 
+-- converts a string to a positive integer
1089 
+stringToNum :: String -> Int
1090 
+stringToNum (d:[]) = charToDigit d
1091 
+stringToNum (d:ds) = (charToDigit d) + 10 * stringToNum ds
1092 
+
1093 
+-- converts a character to a digit
1094 
+charToDigit :: Char -> Int
1095 
+charToDigit c = ord c - ord '0'
1096 
+
1097 
+
1098 
+-- Parse command statements --
1099 
+
1100 
+-- parses commands
1101 
+-- format:  (<name> <arg1> <arg2> ...)
1102 
+makeCommand :: CommandName -> ParseType
1103 
+makeCommand n ts inS fail succ
1104 
+  = parseArgs CloseParen ts inS fail $ \as ts2 inS2 ->
1105 
+    succ (Command n as) ts2 inS2
1106 
+
1107 
+
1108 
+-- parses a list of commands that are terminated by token "term""
1109 
+parseArgs :: Token -> ParseClauseType
1110 
+parseArgs term [] (i:is,ls) fail succ
1111 
+  = let (ts,ls2) = lexDispatch ls i
1112 
+    in parseArgs term ts (is,ls2) fail succ
1113 
+parseArgs term (t:ts) inS fail succ
1114 
+  | t == term = succ [] ts inS
1115 
+  | otherwise = parse (t:ts) inS fail $ \a ts2 inS2 ->
1116 
+                parseArgs term ts2 inS2 fail $ \as ts3 inS3 ->
1117 
+                succ (a:as) ts3 inS3
1118 
+
1119 
+
1120 
+-- Parse I/O statements --
1121 
+
1122 
+-- parses read statements
1123 
+-- format:  (READ)
1124 
+makeRead :: ParseType
1125 
+makeRead (CloseParen:ts) inS fail succ
1126 
+  = succ Read ts inS
1127 
+makeRead _ inS fail _
1128 
+  = fail "Read:  too many arguments" inS
1129 
+
1130 
+-- parses print statements
1131 
+-- format:  (PRINT <arg1>)
1132 
+makePrint :: ParseType
1133 
+makePrint ts inS fail succ
1134 
+  = parseArgs CloseParen ts inS fail $ \as ts2 inS2 ->
1135 
+    if (length as) == 1
1136 
+      then succ (Print as) ts2 inS2
1137 
+      else fail "Print:  too many arguments" inS
1138 
+
1139 
+
1140 
+
1141 
+-- Parse TO statements --
1142 
+
1143 
+
1144 
+-- parses to statements
1145 
+-- format:  (TO <name> <fpname1> <fpname2> ... <clause>)
1146 
+-- note:  all formal parameter names must begin with a colon
1147 
+makeProc :: ParseType
1148 
+makeProc [] (i:is,ls) fail succ
1149 
+  = let (ts,ls2) = lexDispatch ls i
1150 
+    in makeProc ts (is,ls2) fail succ
1151 
+makeProc ((Normal t):ts) inS fail succ
1152 
+  = parseFormals ts inS fail $ \p ts2 inS2 ->
1153 
+    getParen ts2 inS2 fail $ \ts3 inS3 ->
1154 
+    succ (To t p) ts3 inS3
1155 
+makeProc _ inS fail _
1156 
+  = fail "Invalid procedure name" inS
1157 
+
1158 
+-- parses the formal parameters
1159 
+-- takes all words beginning with a colon, and assumes everything
1160 
+--   after that is part of the body
1161 
+parseFormals :: [Token] -> InputState -> ParseFailType ->
1162 
+                (([NameType] , ClauseType) -> [Token] -> InputState -> IO ())
1163 
+                -> IO ()
1164 
+parseFormals [] (i:is,ls) fail succ
1165 
+  = let (ts,ls2) = lexDispatch ls i
1166 
+    in parseFormals ts (is,ls2) fail succ
1167 
+parseFormals (OpenBracket:ts) inS fail succ
1168 
+  = parseClause (OpenBracket:ts) inS fail $ \pb ts2 inS2 ->
1169 
+    succ ([],pb) ts2 inS2
1170 
+parseFormals ((Normal (':':c:cs)):ts) inS fail succ
1171 
+  = parseFormals ts inS fail $ \(formals,pb) ts2 inS2 ->
1172 
+    succ ((':':c:cs):formals , pb) ts2 inS2
1173 
+parseFormals ts inS fail succ
1174 
+  = parseClause ts inS fail $ \pb ts2 inS2 ->
1175 
+    succ ([],pb) ts2 inS2
1176 
+
1177 
+
1178 
+-- Parse MAKE statements --
1179 
+
1180 
+-- parses make statements
1181 
+-- format:  (MAKE <name> <arg>)
1182 
+-- note:  <name> must be quoted
1183 
+makeMake :: ParseType
1184 
+makeMake [] (i:is,ls) fail succ
1185 
+  = let (ts,ls2) = lexDispatch ls i
1186 
+    in makeMake ts (is,ls2) fail succ
1187 
+makeMake ((QuotedWord s):ts) inS fail succ
1188 
+  = parse ts inS fail $ \a ts2 inS2 ->
1189 
+    getParen ts2 inS2 fail $ \ts3 inS3 ->
1190 
+    succ (Make s a) ts3 inS3
1191 
+makeMake _ inS fail _
1192 
+  = fail "Make:  Improper variable name" inS
1193 
+
1194 
+
1195 
+-- Parse LOCAL statements --
1196 
+
1197 
+-- parses local statements
1198 
+-- format:  (LOCAL <name>)
1199 
+-- note:  <name> must be quoted
1200 
+makeLocal :: ParseType
1201 
+makeLocal [] (i:is,ls) fail succ
1202 
+  = let (ts,ls2) = lexDispatch ls i
1203 
+    in makeLocal ts (is,ls2) fail succ
1204 
+makeLocal (t:[]) (i:is,ls) fail succ
1205 
+  = let (ts,ls2) = lexDispatch ls i
1206 
+    in makeLocal (t:ts) (is,ls2) fail succ
1207 
+makeLocal ((QuotedWord s):CloseParen:ts) inS fail succ
1208 
+  = succ (Local s) ts inS
1209 
+makeLocal _ inS fail _
1210 
+  = fail "Local:  improper variable name" inS
1211 
+
1212 
+
1213 
+-- Parse IF statements --
1214 
+
1215 
+-- parses if-then and if-then-else statements
1216 
+-- format:  (IF <cond> then <clause> [else <clause>])
1217 
+makeIf :: ParseType
1218 
+makeIf [] (i:is,ls) fail succ
1219 
+  = let (ts,ls2) = lexDispatch ls i
1220 
+    in makeIf ts (is,ls2) fail succ
1221 
+makeIf ts inS fail succ
1222 
+  = parse ts inS fail $ \cond ts2 inS2 ->
1223 
+    parseThen ts2 inS2 fail $ \thens elses ts3 inS3 ->
1224 
+    getParen ts3 inS3 fail $ \ts4 inS4 ->
1225 
+    succ (If cond thens elses) ts4 inS4
1226 
+
1227 
+
1228 
+-- parses then clauses
1229 
+parseThen :: [Token] -> InputState -> ParseFailType ->
1230 
+             (ClauseType -> ClauseType -> [Token] -> InputState -> IO ()) ->
1231 
+             IO ()
1232 
+parseThen [] (i:is,ls) fail succ
1233 
+  = let (ts,ls2) = lexDispatch ls i
1234 
+    in parseThen ts (is,ls2) fail succ
1235 
+parseThen ((Normal "THEN"):ts) inS fail succ
1236 
+  = parseClause ts inS fail $ \thens ts2 inS2 ->
1237 
+    parseElse ts2 inS2 fail $ \elses ts3 inS3 ->
1238 
+    succ thens elses ts3 inS3
1239 
+parseThen _ inS fail _
1240 
+  = fail "IF:  improper THEN clause" inS
1241 
+
1242 
+-- parses (optional) else clauses
1243 
+parseElse :: ParseClauseType
1244 
+parseElse [] (i:is,ls) fail succ
1245 
+  = let (ts,ls2) = lexDispatch ls i
1246 
+    in parseElse ts (is,ls2) fail succ
1247 
+parseElse (CloseParen:ts) inS fail succ
1248 
+  = succ [] (CloseParen:ts) inS
1249 
+parseElse ((Normal "ELSE"):ts) inS fail succ
1250 
+  = parseClause ts inS fail succ
1251 
+parseElse _ inS fail _
1252 
+  = fail "IF:  improper ELSE clause" inS
1253 
+
1254 
+-- parses clauses
1255 
+-- a clause is either a list of commands enclosed in brackets, or a
1256 
+--   single command
1257 
+parseClause :: ParseClauseType
1258 
+parseClause [] (i:is,ls) fail succ
1259 
+  = let (ts,ls2) = lexDispatch ls i
1260 
+    in parseClause ts (is,ls2) fail succ
1261 
+parseClause (OpenBracket:ts) inS fail succ
1262 
+  = parseArgs CloseBracket ts inS fail succ
1263 
+parseClause ts inS fail succ
1264 
+  = parse ts inS fail $ \a ts2 inS2 ->
1265 
+    succ [a] ts2 inS2
1266 
+
1267 
+
1268 
+-- Parse Loop Statements --
1269 
+
1270 
+-- parses loop statements
1271 
+-- basically a dispatcher for other parse functions
1272 
+makeLoop :: NameType -> ParseType
1273 
+makeLoop "DO"     = makeDo
1274 
+makeLoop "WHILE"  = makeWhile
1275 
+makeLoop "REPEAT" = makeRepeat
1276 
+
1277 
+-- parses do statements
1278 
+-- format:  (DO <clause> WHILE <cond>)
1279 
+makeDo :: ParseType
1280 
+makeDo ts inS fail succ
1281 
+  = parseClause ts inS fail $ \insts ts2 inS2 ->
1282 
+    parseWhileCond ts2 inS2 fail $ \cond ts3 inS3 ->
1283 
+    getParen ts3 inS3 fail $ \ts4 inS4 ->
1284 
+    succ (Loop Do cond insts) ts4 inS4
1285 
+
1286 
+-- parses while conditions (both in while and do-while loops)
1287 
+-- a condition is simply a command that (hopefully) returns a boolean
1288 
+parseWhileCond :: ParseType
1289 
+parseWhileCond [] (i:is,ls) fail succ
1290 
+  = let (ts,ls2) = lexDispatch ls i
1291 
+    in parseWhileCond ts (is,ls2) fail succ
1292 
+parseWhileCond ((Normal "WHILE"):ts) inS fail succ
1293 
+  = parse ts inS fail succ
1294 
+
1295 
+-- parses while statements
1296 
+-- format:  (WHILE <cond> <clause>)
1297 
+makeWhile :: ParseType
1298 
+makeWhile ts inS fail succ
1299 
+  = parse ts inS fail $ \cond ts2 inS2 ->
1300 
+    parseClause ts2 inS fail $ \insts ts3 inS3 ->
1301 
+    getParen ts3 inS3 fail $ \ts4 inS4 ->
1302 
+    succ (Loop While cond insts) ts4 inS4
1303 
+
1304 
+-- parses repeat statements
1305 
+-- format:  (REPEAT <num> TIMES <clause>)
1306 
+-- note:  <num> is simply a command that (hopefully) returns an integer
1307 
+makeRepeat :: ParseType
1308 
+makeRepeat ts inS fail succ
1309 
+  = parse ts inS fail $ \num ts2 inS2 ->
1310 
+    parseRepeatBody ts2 inS fail $ \insts ts3 inS3 ->
1311 
+    getParen ts3 inS3 fail $ \ts4 inS4 ->
1312 
+    succ (Loop Repeat num insts) ts4 inS4
1313 
+
1314 
+-- parses repeat body (just a clause)
1315 
+parseRepeatBody :: ParseClauseType
1316 
+parseRepeatBody [] (i:is,ls) fail succ
1317 
+  = let (ts,ls2) = lexDispatch ls i
1318 
+    in parseRepeatBody ts (is,ls2) fail succ
1319 
+parseRepeatBody ((Normal "TIMES"):ts) inS fail succ
1320 
+  = parseClause ts inS fail succ
1321 
+parseRepeatBody _ inS fail _
1322 
+  = fail "Repeat:  invalid format" inS
1323 
+
1324 
+
1325 
+-- Parse Graphics Statements --
1326 
+
1327 
+-- parses all side-effecting graphics statements
1328 
+makeGraphics :: CommandName -> ParseType
1329 
+makeGraphics n ts inS fail succ
1330 
+  = parseArgs CloseParen ts inS fail $ \as ts2 inS2 ->
1331 
+    succ (Graphics n as) ts2 inS2
1332 
+
1333 
+-- Parse Trailing Parenthesis --
1334 
+
1335 
+-- parses the closing paren terminating most commands
1336 
+getParen :: [Token] -> InputState -> ParseFailType ->
1337 
+            ([Token] -> InputState -> IO ()) -> IO ()
1338 
+getParen [] (i:is,ls) fail succ
1339 
+  = let (ts,ls2) = lexDispatch ls i
1340 
+    in getParen ts (is,ls) fail succ
1341 
+getParen (CloseParen:ts) inS fail succ
1342 
+  = succ ts inS
1343 
+getParen _ inS fail _
1344 
+  = fail "Expected )" inS
1345 
+
progs/demo/X11/logo/logo.hu
History View file @ 4e98702
0 1346 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= foldr inline constant
2 
+$HASKELL_LIBRARY/X11/xlib.hu
3 
+logo.hs
progs/demo/X11/mdraw/README
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+This is a multiple screen version of the draw program.
progs/demo/X11/mdraw/mdraw.hs
History View file @ 4e98702
0 2 
new file mode 100644
... ... 
@@ -0,0 +1,83 @@
1 
+module MDraw where
2 
+
3 
+import Xlib
4 
+
5 
+mapIO :: (a -> IO b) -> [a] -> IO [b]
6 
+
7 
+mapIO f []     = returnIO []
8 
+mapIO f (x:xs) = f x `thenIO` \ y ->
9 
+                 mapIO f xs `thenIO` \ ys ->
10 
+		 returnIO (y:ys)
11 
+
12 
+map2IO :: (a -> b -> IO c) -> [a] -> [b] -> IO [c]
13 
+
14 
+map2IO f [] []         = returnIO []
15 
+map2IO f (x:xs) (z:zs) = f x z `thenIO` \ y ->
16 
+		         map2IO f xs zs `thenIO` \ ys ->
17 
+		         returnIO (y:ys)
18 
+
19 
+xGetEventMul              :: XMArray XDisplay -> IO (Int, XEvent)
20 
+xGetEventMul displays =
21 
+  let n_displays = xMArrayLength displays
22 
+      loop :: Int -> IO (Int, XEvent)
23 
+      loop i = if i == n_displays then loop 0
24 
+               else xMArrayLookup displays i `thenIO` \ display ->
25 
+                    xDisplayForceOutput display `thenIO` \ _ ->
26 
+                    xEventListen display `thenIO` \ n_events ->
27 
+                    if n_events == 0 then loop (i + 1)
28 
+                    else xGetEvent display `thenIO` \ event ->
29 
+                         returnIO (i, event)
30 
+  in loop 0
31 
+
32 
+-- takes a list of host names
33 
+
34 
+mdraw :: [String] -> IO ()
35 
+mdraw hosts =
36 
+  xHandleError (\ (XError msg) -> appendChan stdout msg exit done) $
37 
+  mapIO xOpenDisplay hosts `thenIO` \ displays ->
38 
+  let screens = map (head . xDisplayRoots) displays
39 
+      fg_colors = map xScreenBlackPixel screens
40 
+      bg_colors = map xScreenWhitePixel screens
41 
+      roots = map xScreenRoot screens
42 
+  in
43 
+  map2IO (\ root color ->
44 
+              xCreateWindow root
45 
+                            (XRect 100 100 400 400)
46 
+                            [XWinBackground color,
47 
+		             XWinEventMask (XEventMask [XButtonMotion,
48 
+                                                        XButtonPress])])
49 
+         roots
50 
+         bg_colors
51 
+  `thenIO` \windows ->
52 
+  mapIO xMapWindow windows `thenIO` \ _ ->
53 
+  map2IO xCreateGcontext
54 
+        (map XDrawWindow roots)
55 
+        (map (\ color -> [XGCForeground color]) fg_colors)
56 
+  `thenIO` \ gcontexts ->
57 
+  xMArrayCreate displays `thenIO` \ displayArr ->
58 
+  let
59 
+    handleEvent lasts =
60 
+      xGetEventMul displayArr `thenIO` \ (idx, event) ->
61 
+        let pos = xEventPos event
62 
+	in
63 
+	case (xEventType event) of
64 
+          XButtonPressEvent  ->
65 
+            xMArrayUpdate lasts idx pos `thenIO` \ () ->
66 
+            handleEvent lasts
67 
+          XMotionNotifyEvent ->
68 
+            xMArrayLookup lasts idx `thenIO` \ last ->
69 
+            map2IO (\ window gcontext -> xDrawLine (XDrawWindow window)
70 
+                                                    gcontext
71 
+                                                    last
72 
+                                                    pos)
73 
+                   windows
74 
+                   gcontexts
75 
+            `thenIO` \ _ ->
76 
+            xMArrayUpdate lasts idx pos `thenIO` \ () ->
77 
+            handleEvent lasts
78 
+          _                  -> handleEvent lasts
79 
+  in
80 
+  xMArrayCreate (map (\ _ -> XPoint 0 0) hosts) `thenIO` \ lasts ->
81 
+  handleEvent lasts `thenIO` \ _ ->
82 
+  returnIO ()
83 
+
progs/demo/X11/mdraw/mdraw.hu
History View file @ 4e98702
0 84 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+$HASKELL_LIBRARY/X11/xlib.hu
3 
+mdraw.hs
progs/demo/X11/mdraw/t.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,16 @@
1 
+module Test where
2 
+import Xlib
3 
+
4 
+xGetEventMul :: XMArray XDisplay -> IO (Int, XEvent)
5 
+xGetEventMul displays =
6 
+  let n_displays = xMArrayLength displays
7 
+      loop :: Int -> IO (Int, XEvent)
8 
+      loop i = if i == n_displays then loop 0
9 
+               else xMArrayLookup displays i `thenIO` \ display ->
10 
+                    xDisplayForceOutput display `thenIO` \ _ ->
11 
+                    xEventListen display `thenIO` \ n_events ->
12 
+                    if n_events == 0 then loop (i + 1)
13 
+                    else xGetEvent display `thenIO` \ event ->
14 
+                         returnIO (i, event)
15 
+  in loop 0
16 
+
progs/demo/X11/mdraw/t.hu
History View file @ 4e98702
0 17 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:o= all
2 
+$HASKELL_LIBRARY/X11/xlib.hu
3 
+t.hs
progs/demo/add.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+-- this is an interactive program to read in two numbers and print their sum.
2 
+
3 
+module Main where
4 
+
5 
+main = readChan stdin abort $ \userInput ->
6 
+       let inputLines = lines userInput in
7 
+        readInt "Enter first number: " inputLines $ \num1 inputLines1 ->
8 
+        readInt "Enter second number: " inputLines1 $ \ num2 _ ->
9 
+        appendChan stdout ("Their sum is: " ++ show (num1 + num2)) abort done
10 
+
11 
+readInt :: String -> [String] -> (Integer -> [String] -> Dialogue) -> Dialogue
12 
+
13 
+readInt prompt inputLines succ =
14 
+  appendChan stdout prompt abort $
15 
+  case inputLines of
16 
+     (l1 : rest) -> case (reads l1) of
17 
+                       [(x,"")] -> succ x rest
18 
+                       _        -> appendChan stdout
19 
+	                              "Error - retype the number\n" abort $
20 
+	                           readInt prompt rest succ
21 
+     _          -> appendChan stdout "Early EOF" abort done
progs/demo/eliza.hs
History View file @ 4e98702
0 22 
new file mode 100644
... ... 
@@ -0,0 +1,267 @@
1 
+-- Eliza: an implementation of the classic pseudo-psychoanalyst ---------------
2 
+--
3 
+-- Gofer version by Mark P. Jones, January 12 1992
4 
+--
5 
+-- Adapted from a pascal implementation provided as part of an experimental
6 
+-- package from James Risner (risner@ms.uky.edu), Univ. of KY. with original
7 
+-- pascal code apparently provided by Robert Migliaccio (mig@ms.uky.edu).
8 
+-------------------------------------------------------------------------------
9 
+
10 
+import Prelude hiding (conjugate)
11 
+
12 
+main  :: Dialogue
13 
+main   = interact (("\n\
14 
+		    \Hi! I'm Eliza. I am your personal therapy computer.\n\
15 
+		    \Please tell me your problem.\n\
16 
+		    \\n" ++)
17 
+                   . session initial []
18 
+                   . filter (not.null)
19 
+                   . map (words . trim)
20 
+                   . lines)
21 
+
22 
+trim  :: String -> String                     -- strip punctuation characters
23 
+trim   = foldr cons "" . dropWhile (`elem` punct)
24 
+         where x `cons` xs | x `elem` punct && null xs = []
25 
+                           | otherwise                 = x : xs
26 
+               punct = [' ', '.', '!', '?', ',']
27 
+
28 
+-- Read a line at a time, and produce some kind of response -------------------
29 
+
30 
+session               :: State -> Words -> [Words] -> String
31 
+session rs prev []     = []
32 
+session rs prev (l:ls) = response ++ "\n\n" ++ session rs' l ls
33 
+                         where (response, rs') | prev == l = repeated rs
34 
+                                               | otherwise = answer rs l
35 
+
36 
+answer                :: State -> Words -> (String, State)
37 
+answer st l            = (response, newKeyTab kt st)
38 
+ where (response, kt)         = ans (keyTabOf st)
39 
+       e `cons` (r, es)       = (r, e:es)
40 
+       ans (e:es) | null rs   = e `cons` ans es
41 
+                  | otherwise = (makeResponse a (head rs), (key,as):es)
42 
+                         where rs           = replies key l
43 
+                               (key,(a:as)) = e
44 
+
45 
+-- Find all possible replies (without leading string for given key ------------
46 
+
47 
+replies                 :: Words -> Words -> [String]
48 
+replies key l            = ( map (conjugate l . drop (length key))
49 
+                           . filter (prefix key . map ucase)
50 
+                           . tails) l
51 
+
52 
+prefix                  :: Eq a => [a] -> [a] -> Bool
53 
+[]     `prefix` xs       = True
54 
+(x:xs) `prefix` []       = False
55 
+(x:xs) `prefix` (y:ys)   = x==y && (xs `prefix` ys)
56 
+
57 
+tails                   :: [a] -> [[a]]          -- non-empty tails of list
58 
+tails []                 = []
59 
+tails xs                 = xs : tails (tail xs)
60 
+
61 
+ucase                   :: String -> String      -- map string to upper case
62 
+ucase                    = map toUpper
63 
+
64 
+-- Replace keywords in a list of words with appropriate conjugations ----------
65 
+
66 
+conjugate  :: Words -> Words -> String
67 
+conjugate d = unwords . trailingI . map conj . maybe d  -- d is default input
68 
+              where maybe d xs = if null xs then d else xs
69 
+                    conj  w    = head ([m | (w',m)<-conjugates, uw==w'] ++ [w])
70 
+                                 where uw = ucase w
71 
+                    trailingI  = foldr cons []
72 
+                                 where x `cons` xs | x=="I" && null xs = ["me"]
73 
+                                                   | otherwise         = x:xs
74 
+
75 
+conjugates :: [(Word, Word)]
76 
+conjugates  = prepare (oneways ++ concat [[(x,y), (y,x)] | (x,y) <- bothways])
77 
+              where oneways  = [ ("me",   "you") ]
78 
+                    bothways = [ ("are",  "am"),     ("we're", "was"),
79 
+				("you",  "I"),      ("your",  "my"),
80 
+				("I've", "you've"), ("I'm",   "you're") ]
81 
+                    prepare  = map (\(w,r) -> (ucase w, r))
82 
+
83 
+-- Response data --------------------------------------------------------------
84 
+
85 
+type Word     = String
86 
+type Words    = [Word]
87 
+type KeyTable = [(Key, Replies)]
88 
+type Replies  = [String]
89 
+type State    = (KeyTable, Replies)
90 
+type Key      = Words
91 
+
92 
+repeated		  :: State -> (String, State)
93 
+repeated (kt, (r:rp))      = (r, (kt, rp))
94 
+
95 
+newKeyTab                 :: KeyTable -> State -> State
96 
+newKeyTab kt' (kt, rp)     = (kt', rp)
97 
+
98 
+keyTabOf                  :: State -> KeyTable
99 
+keyTabOf (kt, rp)          = kt
100 
+
101 
+makeResponse             :: String -> String -> String
102 
+makeResponse ('?':cs) us  = cs ++ " " ++ us ++ "?"
103 
+makeResponse ('.':cs) us  = cs ++ " " ++ us ++ "."
104 
+makeResponse cs       us  = cs
105 
+
106 
+initial     :: State
107 
+initial      = ([(words k, cycle rs) | (k,rs) <-respMsgs], cycle repeatMsgs)
108 
+
109 
+respMsgs     = [ ("CAN YOU",		canYou),
110 
+		 ("CAN I",		canI),
111 
+		 ("YOU ARE",		youAre),
112 
+		 ("YOU'RE",		youAre),
113 
+		 ("I DON'T",		iDont),
114 
+		 ("I FEEL",		iFeel),
115 
+		 ("WHY DON'T YOU",	whyDont),
116 
+		 ("WHY CAN'T I",	whyCant),
117 
+		 ("ARE YOU",		areYou),
118 
+		 ("I CAN'T",		iCant),
119 
+		 ("I AM",		iAm),
120 
+		 ("I'M",		iAm),
121 
+		 ("YOU", 		you),
122 
+		 ("YES",		yes),
123 
+		 ("NO",			no),
124 
+		 ("COMPUTER",		computer),
125 
+		 ("COMPUTERS",		computer),
126 
+		 ("I WANT",		iWant),
127 
+		 ("WHAT",		question),
128 
+		 ("HOW",		question),
129 
+		 ("WHO",		question),
130 
+		 ("WHERE",		question),
131 
+		 ("WHEN",		question),
132 
+		 ("WHY",		question),
133 
+		 ("NAME",		name),
134 
+		 ("BECAUSE",		because),
135 
+		 ("CAUSE",		because),
136 
+		 ("SORRY",		sorry),
137 
+		 ("DREAM",		dream),
138 
+		 ("DREAMS",		dream),
139 
+		 ("HI",			hello),
140 
+		 ("HELLO",		hello),
141 
+		 ("MAYBE",		maybe),
142 
+		 ("YOUR",		your),
143 
+		 ("ALWAYS",		always),
144 
+		 ("THINK",		think),
145 
+		 ("ALIKE",		alike),
146 
+		 ("FRIEND",		friend),
147 
+		 ("FRIENDS",		friend),
148 
+		 ("",			nokeyMsgs) ]
149 
+
150 
+canYou	     = [ "?Don't you believe that I can",
151 
+		 "?Perhaps you would like to be able to",
152 
+		 "?You want me to be able to" ]
153 
+canI	     = [ "?Perhaps you don't want to",
154 
+		 "?Do you want to be able to" ]
155 
+youAre	     = [ "?What makes you think I am",
156 
+		 "?Does it please you to believe I am",
157 
+		 "?Perhaps you would like to be",
158 
+		 "?Do you sometimes wish you were" ]
159 
+iDont	     = [ "?Don't you really",
160 
+		 "?Why don't you",
161 
+		 "?Do you wish to be able to",
162 
+		 "Does that trouble you?" ]
163 
+iFeel	     = [ "Tell me more about such feelings.",
164 
+		 "?Do you often feel",
165 
+		 "?Do you enjoy feeling" ]
166 
+whyDont	     = [ "?Do you really believe I don't",
167 
+		 ".Perhaps in good time I will",
168 
+		 "?Do you want me to" ]
169 
+whyCant	     = [ "?Do you think you should be able to",
170 
+		 "?Why can't you" ]
171 
+areYou	     = [ "?Why are you interested in whether or not I am",
172 
+		 "?Would you prefer if I were not",
173 
+		 "?Perhaps in your fantasies I am" ]
174 
+iCant	     = [ "?How do you know you can't",
175 
+		 "Have you tried?",
176 
+		 "?Perhaps you can now" ]
177 
+iAm	     = [ "?Did you come to me because you are",
178 
+		 "?How long have you been",
179 
+		 "?Do you believe it is normal to be",
180 
+		 "?Do you enjoy being" ]
181 
+you	     = [ "We were discussing you --not me.",
182 
+		 "?Oh,",
183 
+		 "You're not really talking about me, are you?" ]
184 
+yes	     = [ "You seem quite positive.",
185 
+		 "Are you Sure?",
186 
+		 "I see.",
187 
+		 "I understand." ]
188 
+no	     = [ "Are you saying no just to be negative?",
189 
+		 "You are being a bit negative.",
190 
+		 "Why not?",
191 
+		 "Are you sure?",
192 
+		 "Why no?" ]
193 
+computer     = [ "Do computers worry you?",
194 
+		 "Are you talking about me in particular?",
195 
+		 "Are you frightened by machines?",
196 
+		 "Why do you mention computers?",
197 
+		 "What do you think machines have to do with your problems?",
198 
+		 "Don't you think computers can help people?",
199 
+		 "What is it about machines that worries you?" ]
200 
+iWant	     = [ "?Why do you want",
201 
+		 "?What would it mean to you if you got",
202 
+		 "?Suppose you got",
203 
+		 "?What if you never got",
204 
+		 ".I sometimes also want" ]
205 
+question     = [ "Why do you ask?",
206 
+		 "Does that question interest you?",
207 
+		 "What answer would please you the most?",
208 
+		 "What do you think?",
209 
+		 "Are such questions on your mind often?",
210 
+		 "What is it that you really want to know?",
211 
+		 "Have you asked anyone else?",
212 
+		 "Have you asked such questions before?",
213 
+		 "What else comes to mind when you ask that?" ]
214 
+name	     = [ "Names don't interest me.",
215 
+		 "I don't care about names --please go on." ]
216 
+because	     = [ "Is that the real reason?",
217 
+		 "Don't any other reasons come to mind?",
218 
+		 "Does that reason explain anything else?",
219 
+		 "What other reasons might there be?" ]
220 
+sorry	     = [ "Please don't apologise!",
221 
+		 "Apologies are not necessary.",
222 
+		 "What feelings do you have when you apologise?",
223 
+		 "Don't be so defensive!" ]
224 
+dream	     = [ "What does that dream suggest to you?",
225 
+		 "Do you dream often?",
226 
+		 "What persons appear in your dreams?",
227 
+		 "Are you disturbed by your dreams?" ]
228 
+hello	     = [ "How do you...please state your problem." ]
229 
+maybe	     = [ "You don't seem quite certain.",
230 
+		 "Why the uncertain tone?",
231 
+		 "Can't you be more positive?",
232 
+		 "You aren't sure?",
233 
+		 "Don't you know?" ]
234 
+your	     = [ "?Why are you concerned about my",
235 
+		 "?What about your own" ]
236 
+always	     = [ "Can you think of a specific example?",
237 
+		 "When?",
238 
+		 "What are you thinking of?",
239 
+		 "Really, always?" ]
240 
+think	     = [ "Do you really think so?",
241 
+		 "?But you are not sure you",
242 
+		 "?Do you doubt you" ]
243 
+alike	     = [ "In what way?",
244 
+		 "What resemblence do you see?",
245 
+		 "What does the similarity suggest to you?",
246 
+		 "What other connections do you see?",
247 
+		 "Cound there really be some connection?",
248 
+		 "How?" ]
249 
+friend	     = [ "Why do you bring up the topic of friends?",
250 
+		 "Do your friends worry you?",
251 
+		 "Do your friends pick on you?",
252 
+		 "Are you sure you have any friends?",
253 
+		 "Do you impose on your friends?",
254 
+		 "Perhaps your love for friends worries you." ]
255 
+
256 
+repeatMsgs   = [ "Why did you repeat yourself?",
257 
+		 "Do you expect a different answer by repeating yourself?",
258 
+		 "Come, come, elucidate your thoughts.",
259 
+		 "Please don't repeat yourself!" ]
260 
+
261 
+nokeyMsgs    = [ "I'm not sure I understand you fully.",
262 
+		 "What does that suggest to you?",
263 
+		 "I see.",
264 
+		 "Can you elaborate on that?",
265 
+		 "Say, do you have any psychological problems?" ]
266 
+
267 
+-------------------------------------------------------------------------------
progs/demo/fact.hs
History View file @ 4e98702
0 268 
new file mode 100755
... ... 
@@ -0,0 +1,14 @@
1 
+{- This is a simple factorial program which uses the I/O system
2 
+   to read the input and print the result -}
3 
+
4 
+module Main where
5 
+
6 
+fact :: Integer -> Integer
7 
+fact 0 = 1
8 
+fact (n+1) = (n+1)*fact n
9 
+fact _ = error "Negative argument to factorial"
10 
+
11 
+main = appendChan stdout "Type in N: " abort $
12 
+       readChan stdin abort $ \ input ->
13 
+       appendChan stdout (show (fact (read (head (lines input))))) abort done
14 
+
progs/demo/improved-add.hs
History View file @ 4e98702
0 15 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+-- this is an interactive program to read in two numbers and print their sum.
2 
+
3 
+module Main where
4 
+
5 
+main = readChan stdin abort $ \userInput ->
6 
+       let inputLines = lines userInput in
7 
+        readInt "Enter first number: " inputLines $ \num1 inputLines1 ->
8 
+        readInt "Enter second number: " inputLines1 $ \ num2 _ ->
9 
+        appendChan stdout ("Their sum is: " ++ show (num1 + num2)) abort done
10 
+
11 
+readInt :: String -> [String] -> (Integer -> [String] -> Dialogue) -> Dialogue
12 
+
13 
+readInt prompt inputLines succ =
14 
+  appendChan stdout prompt abort $
15 
+  case inputLines of
16 
+     (l1 : rest) -> case (reads l1) of
17 
+                       [(x,"")] -> succ x rest
18 
+                       _        -> appendChan stdout
19 
+	                              "Error - retype the number\n" abort $
20 
+	                           readInt prompt rest succ
21 
+     _          -> appendChan stdout "Early EOF" abort done
progs/demo/merge.hs
History View file @ 4e98702
0 22 
new file mode 100755
... ... 
@@ -0,0 +1,26 @@
1 
+{- This is a simple merge sort -}
2 
+
3 
+module Merge where
4 
+
5 
+merge :: [Int] -> [Int] -> [Int]
6 
+merge [] x = x
7 
+merge x [] = x
8 
+merge l1@(a:b) l2@(c:d) | a < c     = a:(merge b l2)
9 
+			| otherwise = c:(merge l1 d)
10 
+
11 
+half [] = []
12 
+half [x] = [x]
13 
+half (x:y:z) = x:r where r = half z
14 
+
15 
+sort [] = []
16 
+sort [x] = [x]
17 
+sort l = merge (sort odds) (sort evens) where
18 
+	     odds = half l
19 
+	     evens = half (tail l)
20 
+
21 
+main =
22 
+  appendChan stdout "Enter a list of integers separated by \",\"\n" abort $
23 
+  readChan stdin abort $ \ input ->
24 
+  appendChan stdout
25 
+      (show (sort (read ("[" ++ (head (lines input)) ++ "]"))))
26 
+      abort done
progs/demo/pascal.hs
History View file @ 4e98702
0 27 
new file mode 100644
... ... 
@@ -0,0 +1,24 @@
1 
+{- This uses lazy evaluation to define Pascals triangle -}
2 
+
3 
+module Main where
4 
+
5 
+pascal :: [[Int]]
6 
+pascal = [1] : [[x+y | (x,y) <- zip ([0]++r) (r++[0])] | r <- pascal]
7 
+
8 
+tab :: Int -> ShowS
9 
+tab 0     = id
10 
+tab (n+1) = showChar ' ' . tab n
11 
+
12 
+showRow :: [Int] -> ShowS
13 
+showRow []     = showChar '\n'
14 
+showRow (n:ns) = shows n . showChar ' ' . showRow ns
15 
+
16 
+showTriangle 1     (t:_)  = showRow t
17 
+showTriangle (n+1) (t:ts) = tab n . showRow t . showTriangle n ts
18 
+
19 
+main = appendChan stdout "Number of rows: " abort $
20 
+       readChan stdin abort $ \input ->
21 
+       appendChan stdout
22 
+         (showTriangle (read (head (lines input))) pascal "")
23 
+         abort done
24 
+
progs/demo/pfac.hs
History View file @ 4e98702
0 25 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+
2 
+-- This is a parallel varient of factorial
3 
+
4 
+module Main where
5 
+
6 
+fac :: Int -> Int
7 
+fac 0 = 1
8 
+fac n = pfac 1 n
9 
+
10 
+pfac :: Int -> Int -> Int
11 
+pfac low high | low == high     = low
12 
+              | low + 1 == high = (low * high)
13 
+              | otherwise       = pfac low mid * pfac (mid + 1) high
14 
+    where
15 
+       mid = (high + low) `div` 2
16 
+
17 
+main = appendChan stdout "Type in N: " abort $
18 
+       readChan stdin abort $ \ input ->
19 
+       appendChan stdout (show (fac (read (head (lines input))))) abort done
20 
+
21 
+
progs/demo/primes.hs
History View file @ 4e98702
0 22 
new file mode 100755
... ... 
@@ -0,0 +1,16 @@
1 
+-- This program implements Eratosthenes Sieve
2 
+-- to generate prime numbers.
3 
+
4 
+module Main where
5 
+
6 
+primes :: [Int]
7 
+primes = map head (iterate sieve [2 ..])
8 
+
9 
+sieve :: [Int] -> [Int]
10 
+sieve (p:ps) = [x | x <- ps, (x `mod` p) /= 0]
11 
+
12 
+main = appendChan stdout "How many primes? " abort $
13 
+       readChan stdin abort $ \ input ->
14 
+       appendChan stdout (show (take (read (head (lines input))) primes))
15 
+	                 abort done
16 
+
progs/demo/prolog/Engine.hs
History View file @ 4e98702
0 17 
new file mode 100644
... ... 
@@ -0,0 +1,61 @@
1 
+--
2 
+-- Stack based Prolog inference engine
3 
+-- Mark P. Jones November 1990
4 
+--
5 
+-- uses Haskell B. version 0.99.3
6 
+--
7 
+module Engine(prove) where
8 
+
9 
+import PrologData
10 
+import Subst
11 
+
12 
+--- Calculation of solutions:
13 
+
14 
+-- the stack based engine maintains a stack of triples (s,goal,alts)
15 
+-- corresponding to backtrack points, where s is the substitution at that
16 
+-- point, goal is the outstanding goal and alts is a list of possible ways
17 
+-- of extending the current proof to find a solution.  Each member of alts
18 
+-- is a pair (tp,u) where tp is a new subgoal that must be proved and u is
19 
+-- a unifying substitution that must be combined with the substitution s.
20 
+--
21 
+-- the list of relevant clauses at each step in the execution is produced
22 
+-- by attempting to unify the head of the current goal with a suitably
23 
+-- renamed clause from the database.
24 
+
25 
+type Stack = [ (Subst, [Term], [Alt]) ]
26 
+type Alt   = ([Term], Subst)
27 
+
28 
+alts       :: Database -> Int -> Term -> [Alt]
29 
+alts db n g = [ (tp,u) | (tm:*tp) <- renClauses db n g, u <- unify g tm ]
30 
+
31 
+-- The use of a stack enables backtracking to be described explicitly,
32 
+-- in the following `state-based' definition of prove:
33 
+
34 
+prove      :: Database -> [Term] -> [Subst]
35 
+prove db gl = solve 1 nullSubst gl []
36 
+ where
37 
+   solve :: Int -> Subst -> [Term] -> Stack -> [Subst]
38 
+   solve n s []     ow          = s : backtrack n ow
39 
+   solve n s (g:gs) ow
40 
+                    | g==theCut = solve n s gs (cut ow)
41 
+                    | otherwise = choose n s gs (alts db n (apply s g)) ow
42 
+
43 
+   choose :: Int -> Subst -> [Term] -> [Alt] -> Stack -> [Subst]
44 
+   choose n s gs []          ow = backtrack n ow
45 
+   choose n s gs ((tp,u):rs) ow = solve (n+1) (u@@s) (tp++gs) ((s,gs,rs):ow)
46 
+
47 
+   backtrack                   :: Int -> Stack -> [Subst]
48 
+   backtrack n []               = []
49 
+   backtrack n ((s,gs,rs):ow)   = choose (n-1) s gs rs ow
50 
+
51 
+
52 
+--- Special definitions for the cut predicate:
53 
+
54 
+theCut    :: Term
55 
+theCut     = Struct "!" []
56 
+
57 
+cut                  :: Stack -> Stack
58 
+cut (top:(s,gl,_):ss) = top:(s,gl,[]):ss
59 
+cut ss                = ss
60 
+
61 
+--- End of Engine.hs
progs/demo/prolog/Engine.hu
History View file @ 4e98702
0 62 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+Engine.hs
2 
+PrologData.hu
3 
+Subst.hu
progs/demo/prolog/Interact.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,76 @@
1 
+--
2 
+-- Interactive utility functions
3 
+-- Mark P. Jones November 1990
4 
+--
5 
+-- uses Haskell B. version 0.99.3
6 
+--
7 
+module Interact(Interactive(..), skip, end, readln, writeln, readch) where
8 
+
9 
+-- The functions defined in this module provide basic facilities for
10 
+-- writing line-oriented interactive programs (i.e. a function mapping
11 
+-- an input string to an appropriate output string).  These definitions
12 
+-- are an enhancement of thos in B+W 7.8
13 
+--
14 
+-- skip p         is an interactive program which consumes no input, produces
15 
+--                no output and then behaves like the interactive program p.
16 
+-- end            is an interactive program which ignores the input and
17 
+--                produces no output.
18 
+-- writeln txt p  is an interactive program which outputs the message txt
19 
+--                and then behaves like the interactive program p
20 
+-- readch act def is an interactive program which reads the first character c
21 
+--                from the input stream and behaves like the interactive
22 
+--                program act c.  If the input character stream is empty,
23 
+--                readch act def prints the default string def and terminates.
24 
+--
25 
+-- readln p g     is an interactive program which prints the prompt p and
26 
+--                reads a line (upto the first carriage return, or end of
27 
+--                input) from the input stream.  It then behaves like g line.
28 
+--                Backspace characters included in the input stream are
29 
+--                interpretted in the usual way.
30 
+
31 
+type Interactive = String -> String
32 
+
33 
+--- Interactive program combining forms:
34 
+
35 
+skip                 :: Interactive -> Interactive
36 
+skip p inn             = p inn    -- a dressed up identity function
37 
+
38 
+end                  :: Interactive
39 
+end inn                = ""
40 
+
41 
+writeln              :: String -> Interactive -> Interactive
42 
+writeln txt p inn      = txt ++ p inn
43 
+
44 
+readch               :: (Char -> Interactive) -> String -> Interactive
45 
+readch act def ""     = def
46 
+readch act def (c:cs) = act c cs
47 
+
48 
+readln               :: String -> (String -> Interactive) -> Interactive
49 
+readln prompt g inn    = prompt ++ lineOut 0 line ++ "\n"
50 
+                               ++ g (noBackSpaces line) input'
51 
+                        where line     = before '\n' inn
52 
+                              input'   = after  '\n' inn
53 
+                              after x  = tail . dropWhile (x/=)
54 
+                              before x = takeWhile (x/=)
55 
+
56 
+--- Filter out backspaces etc:
57 
+
58 
+rubout  :: Char -> Bool
59 
+rubout c = (c=='\DEL' || c=='\BS')
60 
+
61 
+lineOut                      :: Int -> String -> String
62 
+lineOut n ""                  = ""
63 
+lineOut n (c:cs)
64 
+          | n>0  && rubout c  = "\BS \BS" ++ lineOut (n-1) cs
65 
+          | n==0 && rubout c  = lineOut 0 cs
66 
+          | otherwise         = c:lineOut (n+1) cs
67 
+
68 
+noBackSpaces :: String -> String
69 
+noBackSpaces  = reverse . delete 0 . reverse
70 
+                where delete n ""          = ""
71 
+                      delete n (c:cs)
72 
+                               | rubout c  = delete (n+1) cs
73 
+                               | n>0       = delete (n-1) cs
74 
+                               | otherwise = c:delete 0 cs
75 
+
76 
+--- End of Interact.hs
progs/demo/prolog/Interact.hu
History View file @ 4e98702
0 77 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+Interact.hs
2 
+
progs/demo/prolog/Main.hs
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,87 @@
1 
+--
2 
+-- Prolog interpreter top level module
3 
+-- Mark P. Jones November 1990
4 
+--
5 
+-- uses Haskell B. version 0.99.3
6 
+--
7 
+module Main(main) where
8 
+
9 
+import PrologData
10 
+import Parse
11 
+import Interact
12 
+import Subst
13 
+import Engine
14 
+import Version
15 
+
16 
+--- Command structure and parsing:
17 
+
18 
+data Command = Fact Clause | Query [Term] | Show | Error | Quit | NoChange
19 
+
20 
+command :: Parser Command
21 
+command  = just (sptok "bye" `orelse` sptok "quit") `do` (\quit->Quit)
22 
+               `orelse`
23 
+           just (okay NoChange)
24 
+               `orelse`
25 
+           just (sptok "??") `do` (\show->Show)
26 
+               `orelse`
27 
+           just clause `do` Fact
28 
+               `orelse`
29 
+           just (sptok "?-" `seq` termlist) `do` (\(q,ts)->Query ts)
30 
+               `orelse`
31 
+           okay Error
32 
+
33 
+--- Main program read-solve-print loop:
34 
+
35 
+signOn           :: String
36 
+signOn            = "Mini Prolog Version 1.5 (" ++ version ++ ")\n\n"
37 
+
38 
+main             :: Dialogue
39 
+main              = --echo False abort
40 
+                    (appendChan stdout signOn abort
41 
+                    (appendChan stdout ("Reading " ++ stdlib ++ "...") abort
42 
+                    (readFile stdlib
43 
+                      (\fail -> appendChan stdout "not found\n" abort
44 
+                                (interpreter ""))
45 
+                      (\lib  -> appendChan stdout "done\n"      abort
46 
+                                (interpreter lib))
47 
+                    )))
48 
+
49 
+stdlib           :: String
50 
+stdlib            = "$HASKELL/progs/demo/prolog/stdlib"
51 
+
52 
+interpreter      :: String -> Dialogue
53 
+interpreter lib   = readChan stdin abort
54 
+                    (\inn -> appendChan stdout (loop startDb inn) abort done)
55 
+                    where startDb = foldl addClause emptyDb clauses
56 
+                          clauses = [r | ((r,""):_)<-map clause (lines lib)]
57 
+
58 
+loop             :: Database -> String -> String
59 
+loop db           = readln "> " (exec db . fst . head . command)
60 
+
61 
+exec             :: Database -> Command -> String -> String
62 
+exec db (Fact r)  = skip                              (loop (addClause db r))
63 
+exec db (Query q) = demonstrate db q
64 
+exec db Show      = writeln (show db)                 (loop db)
65 
+exec db Error     = writeln "I don't understand\n"    (loop db)
66 
+exec db Quit      = writeln "Thank you and goodbye\n" end
67 
+exec db NoChange  = skip                              (loop db)
68 
+
69 
+--- Handle printing of solutions etc...
70 
+
71 
+solution      :: [Id] -> Subst -> [String]
72 
+solution vs s  = [ show (Var i) ++ " = " ++ show v
73 
+                                | (i,v) <- [ (i,s i) | i<-vs ], v /= Var i ]
74 
+
75 
+demonstrate     :: Database -> [Term] -> Interactive
76 
+demonstrate db q = printOut (map (solution vs) (prove db q))
77 
+ where vs               = (nub . concat . map varsIn) q
78 
+       printOut []      = writeln "no.\n"     (loop db)
79 
+       printOut ([]:bs) = writeln "yes.\n"    (loop db)
80 
+       printOut (b:bs)  = writeln (doLines b) (nextReqd bs)
81 
+       doLines          = foldr1 (\xs ys -> xs ++ "\n" ++ ys)
82 
+       nextReqd bs      = writeln " "
83 
+                            (readch (\c->if c==';'
84 
+                                           then writeln ";\n" (printOut bs)
85 
+                                           else writeln "\n"  (loop db)) "")
86 
+
87 
+--- End of Main.hs
progs/demo/prolog/Main.hu
History View file @ 4e98702
0 88 
new file mode 100644
... ... 
@@ -0,0 +1,6 @@
1 
+Main.hs
2 
+Parse.hu
3 
+PrologData.hu
4 
+Interact.hu
5 
+Engine.hu
6 
+Version.hu
progs/demo/prolog/Parse.hs
History View file @ 4e98702
0 7 
new file mode 100644
... ... 
@@ -0,0 +1,116 @@
1 
+--
2 
+-- General parsing library, based on Richard Bird's parselib.orw for Orwell
3 
+-- (with a number of extensions)
4 
+-- Mark P. Jones November 1990
5 
+--
6 
+-- uses Haskell B. version 0.99.3
7 
+--
8 
+module Parse(Parser(..), fail, okay, tok, sat, orelse, seq, do,
9 
+             sptok, just, listOf, many, sp, many1) where
10 
+
11 
+infixr 6 `seq`
12 
+infixl 5 `do`
13 
+infixr 4 `orelse`
14 
+
15 
+--- Type definition:
16 
+
17 
+type Parser a = [Char] -> [(a,[Char])]
18 
+
19 
+-- A parser is a function which maps an input stream of characters into
20 
+-- a list of pairs each containing a parsed value and the remainder of the
21 
+-- unused input stream.  This approach allows us to use the list of
22 
+-- successes technique to detect errors (i.e. empty list ==> syntax error).
23 
+-- it also permits the use of ambiguous grammars in which there may be more
24 
+-- than one valid parse of an input string.
25 
+
26 
+--- Primitive parsers:
27 
+
28 
+-- fail     is a parser which always fails.
29 
+-- okay v   is a parser which always succeeds without consuming any characters
30 
+--          from the input string, with parsed value v.
31 
+-- tok w    is a parser which succeeds if the input stream begins with the
32 
+--          string (token) w, returning the matching string and the following
33 
+--          input.  If the input does not begin with w then the parser fails.
34 
+-- sat p    is a parser which succeeds with value c if c is the first input
35 
+--          character and c satisfies the predicate p.
36 
+
37 
+fail        :: Parser a
38 
+fail inn      = []
39 
+
40 
+okay        :: a -> Parser a
41 
+okay v inn    = [(v,inn)]
42 
+
43 
+tok         :: [Char] -> Parser [Char]
44 
+tok w inn     = [(w, drop n inn) | w == take n inn]
45 
+               where n = length w
46 
+
47 
+sat         :: (Char -> Bool) -> Parser Char
48 
+sat p []     = []
49 
+sat p (c:inn) = [ (c,inn) | p c ]
50 
+
51 
+--- Parser combinators:
52 
+
53 
+-- p1 `orelse` p2 is a parser which returns all possible parses of the input
54 
+--                string, first using the parser p1, then using parser p2.
55 
+-- p1 `seq` p2    is a parser which returns pairs of values (v1,v2) where
56 
+--                v1 is the result of parsing the input string using p1 and
57 
+--                v2 is the result of parsing the remaining input using p2.
58 
+-- p `do` f       is a parser which behaves like the parser p, but returns
59 
+--                the value f v wherever p would have returned the value v.
60 
+--
61 
+-- just p         is a parser which behaves like the parser p, but rejects any
62 
+--                parses in which the remaining input string is not blank.
63 
+-- sp p           behaves like the parser p, but ignores leading spaces.
64 
+-- sptok w        behaves like the parser tok w, but ignores leading spaces.
65 
+--
66 
+-- many p         returns a list of values, each parsed using the parser p.
67 
+-- many1 p        parses a non-empty list of values, each parsed using p.
68 
+-- listOf p s     parses a list of input values using the parser p, with
69 
+--                separators parsed using the parser s.
70 
+
71 
+orelse             :: Parser a -> Parser a -> Parser a
72 
+p1 `orelse` p2     = \inn->p1 inn ++ p2 inn
73 
+
74 
+seq                :: Parser a -> Parser b -> Parser (a,b)
75 
+p1 `seq` p2        = \inn->[((v1,v2),inn2) | (v1,inn1) <- p1 inn, (v2,inn2) <- p2 inn1]
76 
+
77 
+do                 :: Parser a -> (a -> b) -> Parser b
78 
+p `do` f           = \inn->[(f v, inn1) | (v,inn1) <- p inn]
79 
+
80 
+just               :: Parser a -> Parser a
81 
+just p inn           = [ (v,"") | (v,inn')<- p inn, dropWhile (' '==) inn' == "" ]
82 
+
83 
+sp                 :: Parser a -> Parser a
84 
+sp p                = p . dropWhile (' '==)
85 
+
86 
+sptok              :: [Char] -> Parser [Char]
87 
+sptok               =  sp . tok
88 
+
89 
+many               :: Parser a  -> Parser [a]
90 
+many p              = q
91 
+                      where q = ((p `seq` q) `do` makeList) `orelse` (okay [])
92 
+
93 
+many1              :: Parser a -> Parser [a]
94 
+many1 p             = p `seq` many p `do` makeList
95 
+
96 
+listOf             :: Parser a -> Parser b -> Parser [a]
97 
+listOf p s          = p `seq` many (s `seq` p) `do` nonempty
98 
+                      `orelse` okay []
99 
+                      where nonempty (x,xs) = x:(map snd xs)
100 
+
101 
+--- Internals:
102 
+
103 
+makeList       :: (a,[a]) -> [a]
104 
+makeList (x,xs) = x:xs
105 
+
106 
+{-
107 
+-- an attempt to optimise the performance of the standard prelude function
108 
+-- `take' in Haskell B 0.99.3 gives the wrong semantics.  The original
109 
+-- definition, given below works correctly and is used in the above.
110 
+
111 
+safetake              :: (Integral a) => a -> [b] -> [b]
112 
+safetake  _     []     =  []
113 
+safetake  0     _      =  []
114 
+safetake (n+1) (x:xs)  =  x : safetake n xs
115 
+-}
116 
+--- End of Parse.hs
progs/demo/prolog/Parse.hu
History View file @ 4e98702
0 117 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+Parse.hs
progs/demo/prolog/PrologData.hs
History View file @ 4e98702
0 2 
new file mode 100644
... ... 
@@ -0,0 +1,121 @@
1 
+--
2 
+-- Representation of Prolog Terms, Clauses and Databases
3 
+-- Mark P. Jones November 1990
4 
+--
5 
+-- uses Haskell B. version 0.99.3
6 
+--
7 
+module PrologData(Id(..), Atom(..), Term(..), term, termlist, varsIn,
8 
+                  Clause((:*)), clause,
9 
+                  Database, emptyDb, renClauses, addClause) where
10 
+
11 
+import Parse
12 
+
13 
+infix 6 :*
14 
+
15 
+--- Prolog Terms:
16 
+
17 
+type Id       = (Int,String)
18 
+type Atom     = String
19 
+data Term     = Var Id | Struct Atom [Term]
20 
+                deriving Eq
21 
+data Clause   = Term :* [Term]
22 
+data Database = Db [(Atom,[Clause])]
23 
+
24 
+--- Determine the list of variables in a term:
25 
+
26 
+varsIn              :: Term -> [Id]
27 
+varsIn (Var i)       = [i]
28 
+varsIn (Struct i ts) = (nub . concat . map varsIn) ts
29 
+
30 
+renameVars                  :: Int -> Term -> Term
31 
+renameVars lev (Var (n,s))   = Var (lev,s)
32 
+renameVars lev (Struct s ts) = Struct s (map (renameVars lev) ts)
33 
+
34 
+--- Functions for manipulating databases (as an abstract datatype)
35 
+
36 
+emptyDb      :: Database
37 
+emptyDb       = Db []
38 
+
39 
+renClauses                  :: Database -> Int -> Term -> [Clause]
40 
+renClauses db n (Var _)      = []
41 
+renClauses db n (Struct a _) = [ r tm:*map r tp | (tm:*tp)<-clausesFor a db ]
42 
+                               where r = renameVars n
43 
+
44 
+clausesFor           :: Atom -> Database -> [Clause]
45 
+clausesFor a (Db rss) = case dropWhile (\(n,rs) -> n<a) rss of
46 
+                         []         -> []
47 
+                         ((n,rs):_) -> if a==n then rs else []
48 
+
49 
+addClause :: Database -> Clause -> Database
50 
+addClause (Db rss) r@(Struct a _ :* _)
51 
+         = Db (initialPart ++
52 
+               case lastPart of
53 
+                 []            -> [(a,[r])]
54 
+                 ((n,rs):rss') -> if a==n then (n,rs++[r]):rss'
55 
+                                          else (a,[r]):lastPart)
56 
+           where (initialPart,lastPart) = span (\(n,rs) -> n<a) rss
57 
+
58 
+--- Output functions (defined as instances of Text):
59 
+
60 
+instance Text Term where
61 
+  showsPrec p (Var (n,s))
62 
+              | n==0        = showString s
63 
+              | otherwise   = showString s . showChar '_' . shows n
64 
+  showsPrec p (Struct a []) = showString a
65 
+  showsPrec p (Struct a ts) = showString a . showChar '('
66 
+                                           . showWithSep "," ts
67 
+                                           . showChar ')'
68 
+
69 
+instance Text Clause where
70 
+   showsPrec p (t:*[]) = shows t . showChar '.'
71 
+   showsPrec p (t:*gs) = shows t . showString ":-"
72 
+                                 . showWithSep "," gs
73 
+                                 . showChar '.'
74 
+
75 
+instance Text Database where
76 
+    showsPrec p (Db [])  = showString "-- Empty Database --\n"
77 
+    showsPrec p (Db rss) = foldr1 (\u v-> u . showChar '\n' . v)
78 
+                                  [ showWithTerm "\n" rs | (i,rs)<-rss ]
79 
+
80 
+--- Local functions for use in defining instances of Text:
81 
+
82 
+showWithSep          :: Text a => String -> [a] -> ShowS
83 
+showWithSep s [x]     = shows x
84 
+showWithSep s (x:xs)  = shows x . showString s . showWithSep s xs
85 
+
86 
+showWithTerm         :: Text a => String -> [a] -> ShowS
87 
+showWithTerm s xs     = foldr1 (.) [shows x . showString s | x<-xs]
88 
+
89 
+--- String parsing functions for Terms and Clauses:
90 
+--- Local definitions:
91 
+
92 
+letter       :: Parser Char
93 
+letter        = sat (\c -> isAlpha c || isDigit c || c `elem` ":;+=-*&%$#@?/.~!")
94 
+
95 
+variable     :: Parser Term
96 
+variable      = sat isUpper `seq` many letter `do` makeVar
97 
+                where makeVar (initial,rest) = Var (0,(initial:rest))
98 
+
99 
+struct       :: Parser Term
100 
+struct        = many letter `seq` (sptok "(" `seq` termlist `seq` sptok ")"
101 
+                                       `do` (\(o,(ts,c))->ts)
102 
+                                  `orelse`
103 
+                                   okay [])
104 
+                `do` (\(name,terms)->Struct name terms)
105 
+
106 
+--- Exports:
107 
+
108 
+term         :: Parser Term
109 
+term          = sp (variable `orelse` struct)
110 
+
111 
+termlist     :: Parser [Term]
112 
+termlist      = listOf term (sptok ",")
113 
+
114 
+clause       :: Parser Clause
115 
+clause        = sp struct `seq` (sptok ":-" `seq` listOf term (sptok ",")
116 
+                                 `do` (\(from,body)->body)
117 
+                                `orelse` okay [])
118 
+                          `seq` sptok "."
119 
+                     `do` (\(head,(goals,dot))->head:*goals)
120 
+
121 
+--- End of PrologData.hs
progs/demo/prolog/PrologData.hu
History View file @ 4e98702
0 122 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+PrologData.hs
2 
+Parse.hu
progs/demo/prolog/README
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+This is a mini prolog interpreter written my Mark Jones.  It
2 
+was slightly adapted from version in the hbc release.
3 
+
progs/demo/prolog/Subst.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,65 @@
1 
+--
2 
+-- Substitutions and Unification of Prolog Terms
3 
+-- Mark P. Jones November 1990
4 
+--
5 
+-- uses Haskell B. version 0.99.3
6 
+--
7 
+module Subst(Subst(..), nullSubst, (>!), (@@), apply, unify) where
8 
+
9 
+import PrologData
10 
+
11 
+infixr 3 @@
12 
+infix  4 >!
13 
+
14 
+--- Substitutions:
15 
+
16 
+type Subst = Id -> Term
17 
+
18 
+-- substitutions are represented by functions mapping identifiers to terms.
19 
+--
20 
+-- apply s   extends the substitution s to a function mapping terms to terms
21 
+-- nullSubst is the empty substitution which maps every identifier to the
22 
+--           same identifier (as a term).
23 
+-- i >! t   is the substitution which maps the identifier i to the term t,
24 
+--           but otherwise behaves like nullSubst.
25 
+-- s1 @@ s2  is the composition of substitutions s1 and s2
26 
+--           N.B.  apply is a monoid homomorphism from (Subst,nullSubst,(@@))
27 
+--           to (Term -> Term, id, (.)) in the sense that:
28 
+--                  apply (s1 @@ s2) = apply s1 . apply s2
29 
+--                    s @@ nullSubst = s = nullSubst @@ s
30 
+
31 
+apply                   :: Subst -> Term -> Term
32 
+apply s (Var i)          = s i
33 
+apply s (Struct a ts)    = Struct a (map (apply s) ts)
34 
+
35 
+nullSubst               :: Subst
36 
+nullSubst i              = Var i
37 
+
38 
+(>!)                  :: Id -> Term -> Subst
39 
+(>!) i t j | j==i       = t
40 
+            | otherwise  = Var j
41 
+
42 
+(@@)                    :: Subst -> Subst -> Subst
43 
+s1 @@ s2                 = apply s1 . s2
44 
+
45 
+--- Unification:
46 
+
47 
+-- unify t1 t2 returns a list containing a single substitution s which is
48 
+--             the most general unifier of terms t1 t2.  If no unifier
49 
+--             exists, the list returned is empty.
50 
+
51 
+unify :: Term -> Term -> [Subst]
52 
+unify (Var x)       (Var y)       = if x==y then [nullSubst] else [x>!Var y]
53 
+unify (Var x)       t2            = [ x >! t2 | not (x `elem` varsIn t2) ]
54 
+unify t1            (Var y)       = [ y >! t1 | not (y `elem` varsIn t1) ]
55 
+unify (Struct a ts) (Struct b ss) = [ u | a==b, u<-listUnify ts ss ]
56 
+
57 
+listUnify :: [Term] -> [Term] -> [Subst]
58 
+listUnify []     []     = [nullSubst]
59 
+listUnify []     (r:rs) = []
60 
+listUnify (t:ts) []     = []
61 
+listUnify (t:ts) (r:rs) = [ u2 @@ u1 | u1<-unify t r,
62 
+                                       u2<-listUnify (map (apply u1) ts)
63 
+                                                     (map (apply u1) rs) ]
64 
+
65 
+--- End of Subst.hs
progs/demo/prolog/Subst.hu
History View file @ 4e98702
0 66 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+Subst.hs
2 
+PrologData.hu
progs/demo/prolog/Version.hs
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+module Version where version="tree based"
progs/demo/prolog/Version.hu
History View file @ 4e98702
0 2 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+Version.hs
progs/demo/prolog/stdlib
History View file @ 4e98702
0 2 
new file mode 100644
... ... 
@@ -0,0 +1,38 @@
1 
+This file contains a list of predicate definitions that will automatically
2 
+be read into Mini Prolog at the beginning of a session.  Each clause in this
3 
+file must be entered on a single line and lines containing syntax errors are
4 
+always ignored.  This includes the first few lines of this file and provides
5 
+a simple way to include comments.
6 
+
7 
+append(nil,X,X).
8 
+append(cons(X,Y),Z,cons(X,W)):-append(Y,Z,W).
9 
+
10 
+equals(X,X).
11 
+
12 
+not(X):-X,!,false.
13 
+not(X).
14 
+
15 
+or(X,Y):-X.
16 
+or(X,Y):-Y.
17 
+
18 
+and(X,Y):-X,Y.
19 
+
20 
+reverse(nil,nil).
21 
+reverse(cons(A,X),Y):-and(reverse(X,Z),append(Z,cons(A,nil),Y)).
22 
+
23 
+palindromes(X):-and(reverse(X,Y),equals(X,Y)).
24 
+
25 
+mul2(A,B):-append(A,A,B).
26 
+mul4(A,B):-and(mul2(A,C),mul2(C,B)).
27 
+mul8(A,B):-and(mul4(A,C),mul2(C,B)).
28 
+mul16(A,B):-and(mul8(A,C),mul2(C,B)).
29 
+mul32(A,B):-and(mul16(A,C),mul2(C,B)).
30 
+mul64(A,B):-and(mul32(A,C),mul2(C,B)).
31 
+mul128(A,B):-and(mul64(A,C),mul2(C,B)).
32 
+mul256(A,B):-and(mul128(A,C),mul2(C,B)).
33 
+mul512(A,B):-and(mul256(A,C),mul2(C,B)).
34 
+mul1024(A,B):-and(mul512(A,C),mul2(C,B)).
35 
+
36 
+true.
37 
+
38 
+End of stdlib
progs/demo/queens.hs
History View file @ 4e98702
0 39 
new file mode 100755
... ... 
@@ -0,0 +1,40 @@
1 
+{- This is the n Queens problem. -}
2 
+
3 
+module Main where
4 
+
5 
+queens :: Int -> [[Int]]
6 
+queens size  = queens' size size
7 
+
8 
+queens' :: Int -> Int -> [[Int]]
9 
+queens' 0     _    = [[]]
10 
+queens' (n+1) size = [q:qs | qs <- queens' n size, q <- [1..size],
11 
+			     not (threatens q qs)]
12 
+
13 
+threatens :: Int -> [Int] -> Bool
14 
+threatens q qs = q `elem` qs || q `elem` (diagonals 1 qs)
15 
+
16 
+diagonals :: Int -> [Int] -> [Int]
17 
+diagonals _  []    = []
18 
+diagonals n (q:qs) = (q+n) : (q-n) : diagonals (n+1) qs
19 
+
20 
+main = appendChan stdout "Enter board size: " abort $
21 
+       readChan stdin abort $ \input ->
22 
+       let line1 : ~(line2 : _) = lines input
23 
+	   size = read line1
24 
+           solns = read line2
25 
+       in if size == 0 then done else  -- This causes the size to actually read
26 
+         appendChan stdout "Number of solutions: " abort $
27 
+         appendChan stdout (concat (map (\x -> showBoard size x)
28 
+                                        (take solns (queens size))))
29 
+  	 abort done
30 
+
31 
+showBoard :: Int -> [Int] -> String
32 
+
33 
+showBoard size pos =
34 
+  concat (map showRow pos) ++ "\n"
35 
+    where
36 
+      showRow n = concat [if i == n then "Q " else ". " | i <- [1..size]]
37 
+                  ++ "\n"
38 
+
39 
+
40 
+
progs/demo/quicksort.hs
History View file @ 4e98702
0 41 
new file mode 100644
... ... 
@@ -0,0 +1,13 @@
1 
+-- Quick sort for Haskell.
2 
+
3 
+module Main where
4 
+
5 
+qs :: [Int] -> [Int]
6 
+qs []     = []
7 
+qs (a:as) = qs [x | x <- as, x <= a] ++ [a] ++ qs [x | x <- as, x > a]
8 
+
9 
+main =
10 
+  appendChan stdout "Enter a list of integers separated by \",\"\n" abort $
11 
+  readChan stdin abort $ \ input ->
12 
+  appendChan stdout (show (qs (read ("[" ++ (head (lines input)) ++ "]"))))
13 
+             abort done
progs/lib/README
History View file @ 4e98702
0 14 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+This directory contains supported libraries for Yale Haskell.
progs/lib/X11/README
History View file @ 4e98702
0 2 
new file mode 100644
... ... 
@@ -0,0 +1,11 @@
1 
+This directory contains the Haskell->CLX support code.
2 
+
3 
+If you see errors like "ID 42 is a :WM_RESIZE_HINTS, not a window",
4 
+you can get rid of them by loading clx-patch.lisp.  This seems to be a
5 
+bug where CLX is not consistent with the protocol in some way; we've
6 
+seen it on some machines and not others.  The line
7 
+
8 
+(load "$HASKELL/progs/lib/X11/clx-patch.lisp")
9 
+
10 
+can be placed in your .yhaskell file to load the patch on startup.
11 
+
progs/lib/X11/clx-patch.lisp
History View file @ 4e98702
0 12 
new file mode 100644
... ... 
@@ -0,0 +1,39 @@
1 
+(lisp:in-package 'xlib)
2 
+(defmacro generate-lookup-functions (useless-name &body types)
3 
+            `(within-definition (,useless-name generate-lookup-functions)
4 
+               ,@(mapcar
5 
+                   #'(lambda (type)
6 
+                       `(defun ,(xintern 'lookup- type)
7 
+                               (display id)
8 
+                          (declare (type display display)
9 
+                                   (type resource-id id))
10 
+                          (declare (values ,type))
11 
+                          ,(if (member type *clx-cached-types*)
12 
+                               `(let ((,type (lookup-resource-id display id)))
13 
+                                  (cond ((null ,type) ;; Not found, create and s
14 
+ave it.
15 
+                                         (setq ,type (,(xintern 'make- type)
16 
+                                                      :display display :id id))
17 
+                                         (save-id display id ,type))
18 
+                                        ;; Found.  Check the type
19 
+                                        ,(cond ((null '()) ;*type-check?*)
20 
+                                                `(t ,type))
21 
+                                               ((member type '(window pixmap))
22 
+                                                `((type? ,type 'drawable) ,type)
23 
+)
24 
+                                               (t `((type? ,type ',type) ,type))
25 
+)
26 
+                                        ,@(when '() ;*type-check?*
27 
+                                            `((t (x-error 'lookup-error
28 
+                                                          :id id
29 
+                                                          :display display
30 
+                                                          :type ',type
31 
+                                                          :object ,type))))))
32 
+                               ;; Not being cached.  Create a new one each time.
33 
+                               `(,(xintern 'make- type)
34 
+                                 :display display :id id))))
35 
+                   types)))
36 
+(macroexpand
37 
+  (generate-lookup-functions ignore
38 
+    window))
39 
+
progs/lib/X11/xlib.hs
History View file @ 4e98702
0 40 
new file mode 100644
... ... 
@@ -0,0 +1,877 @@
1 
+module Xlib(XLibTypes..,XLibPrims..) where
2 
+import XLibTypes
3 
+import XLibPrims
4 
+
5 
+module XLibTypes(XDisplay, XScreen, XWindow, XGcontext, XPixmap,
6 
+                 XColormap, XCursor, XFont, XImage, XMaybe(..), XError(..),
7 
+                 XBitmap(..), XKeysymTable(..), XBitVec(..),
8 
+                 XPixarray(..), XByteVec(..), XAtom(..), XProperty(..),
9 
+                 XPixel(..), XDrawable(..), XTime(..), XSwitch(..),
10 
+		 XWindowPlace(..), XEventMode(..), XEventKind(..),
11 
+		 XWindowVisibility(..), XWindowStackMode(..),
12 
+		 XPropertyState(..), XMapReqType(..), XGraphFun(..),
13 
+		 XEvent(..), XEventType(..), XEventSlot(..), XEventMask(..),
14 
+		 XEventMaskKey(..), XStateMask(..), XStateMaskKey(..),
15 
+		 XWinAttribute(..),XGCAttribute(..), XImAttribute(..),
16 
+		 XGrabAttribute(..), XArcMode(..), XCapStyle(..),
17 
+		 XClipMask(..), XFillRule(..), XFillStyle(..),
18 
+		 XFunction(..), XJoinStyle(..), XLineStyle(..),
19 
+		 XSubwindowMode(..), XPoint(..), XSize(..), XRect(..),
20 
+		 XArc(..), XBitmapFormat(..), XByteOrder(..),
21 
+		 XPixmapFormat(..), XVisualInfo(..), XVisualClass(..),
22 
+		 XFillContent(..), XBackingStore(..), XGravity(..),
23 
+		 XWindowClass(..), XMapState(..), XImageData(..),
24 
+		 XImageFormat(..), XImageType(..), XDrawDirection(..),
25 
+		 XColor(..), XInputFocus(..), XGrabStatus(..),
26 
+		 XKeysym(..), XCloseDownMode(..), XScreenSaver(..))
27 
+    where
28 
+
29 
+data XMaybe a {-# STRICT #-} = XSome a
30 
+                 	     | XNull
31 
+	      --deriving (Printers)
32 
+
33 
+data XDisplay 		= XDisplay 	 --deriving (Printers)
34 
+data XScreen 		= XScreen	 --deriving (Printers)
35 
+data XWindow 		= XWindow	 --deriving (Printers)
36 
+data XGcontext 		= XGcontext	 --deriving (Printers)
37 
+data XPixmap 		= XPixmap	 --deriving (Printers)
38 
+data XColormap 		= XColormap	 --deriving (Printers)
39 
+data XCursor 		= XCursor	 --deriving (Printers)
40 
+data XFont 		= XFont		 --deriving (Printers)
41 
+data XImage 		= XImage	 --deriving (Printers)
42 
+
43 
+data XError {-# STRICT #-}
44 
+              = XError String
45 
+                --deriving Printers
46 
+data XBitmap {-# STRICT #-}
47 
+             = XBitmap [[Int]]
48 
+instance Text(XBitmap) where
49 
+  showsPrec p x = showString "<<XBitMap>>"
50 
+
51 
+data XKeysymTable {-# STRICT #-}
52 
+             = XKeysymTable [[Integer]]
53 
+instance Text(XKeysymTable) where
54 
+  showsPrec p x = showString "<<XKeysymTable>>"
55 
+
56 
+data XBitVec {-# STRICT #-}
57 
+             = XBitVec [Int]
58 
+instance Text(XBitVec) where
59 
+  showsPrec p x = showString "<<XBitVec>>"
60 
+
61 
+data XPixarray {-# STRICT #-}
62 
+   	     = XPixarray [[Integer]]
63 
+instance Text(XPixarray) where
64 
+  showsPrec p x = showString "<<XPixarray>>"
65 
+
66 
+data XByteVec {-# STRICT #-}
67 
+             = XByteVec [Int]
68 
+instance Text(XByteVec) where
69 
+  showsPrec p x = showString "<<XByteVec>>"
70 
+
71 
+
72 
+data XAtom {-# STRICT #-}
73 
+             = XAtom String
74 
+	--deriving (Printers)
75 
+
76 
+data XProperty {-#STRICT #-}
77 
+             = XProperty [Integer]  	-- data
78 
+	                 XAtom  	-- type
79 
+                         Int    	-- format
80 
+       --deriving (Printers)
81 
+
82 
+data XPixel {-# STRICT #-}
83 
+            = XPixel Integer
84 
+       --deriving (Printers)
85 
+
86 
+data XDrawable {-# STRICT #-}
87 
+            = XDrawWindow XWindow
88 
+            | XDrawPixmap XPixmap
89 
+	--deriving (Printers)
90 
+
91 
+data XTime {-# STRICT #-}
92 
+            = XTime Integer
93 
+	--deriving (Printers)
94 
+
95 
+data XSwitch    = XOn
96 
+                | XOff
97 
+        --deriving (Printers)
98 
+
99 
+data XWindowPlace 	= XTopPlace
100 
+			| XBottomPlace
101 
+	--deriving (Printers)
102 
+
103 
+data XEventMode		= XNormalMode
104 
+			| XGrabMode
105 
+			| XUngrabMode
106 
+			| XWhileGrabbedMode
107 
+	--deriving (Printers)
108 
+
109 
+data XEventKind		= XAncestorKind
110 
+			| XVirtualKind
111 
+			| XInferiorKind
112 
+			| XNonlinearKind
113 
+			| XNonlinearVirtualKind
114 
+			| XPointerKind
115 
+			| XPointerRootKind
116 
+			| XNoneKind
117 
+	--deriving (Printers)
118 
+
119 
+data XWindowVisibility	= XUnobscured
120 
+			| XPartiallyObscured
121 
+			| XFullyObscured
122 
+	--deriving (Printers)
123 
+
124 
+data XWindowStackMode	= XStackAbove
125 
+			| XStackBelow
126 
+			| XStackTopIf
127 
+			| XStackBottomIf
128 
+			| XStackOpposite
129 
+	--deriving (Printers)
130 
+
131 
+data XPropertyState	= XNewValueProperty
132 
+			| XDeletedProperty
133 
+	--deriving (Printers)
134 
+
135 
+data XMapReqType	= XModifierMapping
136 
+			| XKeyboardMapping
137 
+			| XPointerMapping
138 
+	--deriving (Printers)
139 
+
140 
+data XGraphFun {-# STRICT #-}
141 
+        	= XGraphFun Int  -- major opcode
142 
+	         	    Int  -- minor opcode
143 
+	--deriving (Printers)
144 
+
145 
+data XEvent {-# STRICT #-}
146 
+        	= XEvent XEventType
147 
+		         [XEventSlot]
148 
+
149 
+data XEventType = 	  XKeyPressEvent
150 
+		        | XKeyReleaseEvent
151 
+	        	| XButtonPressEvent
152 
+	        	| XButtonReleaseEvent
153 
+		        | XMotionNotifyEvent
154 
+		        | XEnterNotifyEvent
155 
+		        | XLeaveNotifyEvent
156 
+		        | XFocusInEvent
157 
+			| XFocusOutEvent
158 
+            		| XKeymapNotifyEvent
159 
+            		| XMappingNotifyEvent
160 
+            		| XExposureEvent
161 
+            		| XGraphicsExposureEvent
162 
+            		| XNoExposureEvent
163 
+            		| XCirculateNotifyEvent
164 
+            		| XConfigureNotifyEvent
165 
+            		| XCreateNotifyEvent
166 
+            		| XDestroyNotifyEvent
167 
+            		| XGravityNotifyEvent
168 
+            		| XMapNotifyEvent
169 
+            		| XReparentNotifyEvent
170 
+            		| XUnmapNotifyEvent
171 
+            		| XVisibilityNotifyEvent
172 
+            		| XCirculateRequestEvent
173 
+            		| XColormapNotifyEvent
174 
+            		| XConfigureRequestEvent
175 
+            		| XMapRequestEvent
176 
+            		| XResizeRequestEvent
177 
+            		| XClientMessageEvent
178 
+            		| XPropertyNotifyEvent
179 
+            		| XSelectionClearEvent
180 
+            		| XSelectionNotifyEvent
181 
+            		| XSelectionRequestEvent
182 
+            		| XOtherEvents
183 
+       --deriving Printers
184 
+
185 
+data XEventSlot {-# STRICT #-}
186 
+                = XEventWindow XWindow
187 
+		| XEventEventWindow XWindow
188 
+		| XEventCode Int
189 
+		| XEventPos XPoint
190 
+		| XEventState XStateMask
191 
+		| XEventTime XTime
192 
+		| XEventRoot XWindow
193 
+		| XEventRootPos XPoint
194 
+		| XEventChild (XMaybe XWindow)
195 
+		| XEventSameScreenP Bool
196 
+		| XEventHintP Bool
197 
+		| XEventMode XEventMode
198 
+		| XEventKind XEventKind
199 
+		| XEventFocusP Bool
200 
+		| XEventKeymap XBitVec
201 
+		| XEventRequest XMapReqType
202 
+		| XEventStart Int
203 
+		| XEventCount Int
204 
+		| XEventRect XRect
205 
+		| XEventDrawable XDrawable
206 
+		| XEventXGraphFun XGraphFun
207 
+		| XEventPlace XWindowPlace
208 
+		| XEventBorderWidth Int
209 
+		| XEventAboveSibling (XMaybe XWindow)
210 
+		| XEventOverrideRedirectP Bool
211 
+		| XEventParent XWindow
212 
+		| XEventConfigureP Bool
213 
+		| XEventVisibility XWindowVisibility
214 
+		| XEventNewP Bool
215 
+		| XEventInstalledP Bool
216 
+		| XEventStackMode XWindowStackMode
217 
+		| XEventValueMask Int
218 
+		| XEventSize XSize
219 
+		| XEventMessage XProperty
220 
+		| XEventPropertyState XPropertyState
221 
+		| XEventAtom XAtom
222 
+		| XEventSelection XAtom
223 
+		| XEventTarget XAtom
224 
+		| XEventProperty (XMaybe XAtom)
225 
+		| XEventRequestor XWindow
226 
+       --deriving Printers
227 
+
228 
+data XEventMask {-# STRICT #-}
229 
+             = XEventMask [XEventMaskKey]
230 
+       --deriving (Printers)
231 
+
232 
+data XEventMaskKey
233 
+		= XButton1Motion
234 
+		| XButton2Motion
235 
+		| XButton3Motion
236 
+		| XButton4Motion
237 
+		| XButton5Motion
238 
+		| XButtonMotion
239 
+                | XButtonPress
240 
+		| XButtonRelease
241 
+		| XColormapChange
242 
+		| XEnterWindow
243 
+		| XExposure
244 
+		| XFocusChange
245 
+		| XKeyPress
246 
+		| XKeyRelease
247 
+		| XKeymapState
248 
+		| XLeaveWindow
249 
+		| XOwnerGrabButton
250 
+		| XPointerMotion
251 
+		| XPointerMotionHint
252 
+		| XPropertyChange
253 
+		| XResizeRedirect
254 
+		| XStructureNotify
255 
+		| XSubstructureRedirect
256 
+		| XVisibilityChange
257 
+	  --deriving (Printers)
258 
+
259 
+data XStateMask	{-# STRICT #-}
260 
+            = XStateMask [XStateMaskKey]
261 
+        --deriving (Printers)
262 
+
263 
+data XStateMaskKey
264 
+		= XShift
265 
+		| XLock
266 
+		| XControl
267 
+		| XMod1
268 
+		| XMod2
269 
+		| XMod3
270 
+		| XMod4
271 
+		| XMod5
272 
+		| XButton1
273 
+		| XButton2
274 
+		| XButton3
275 
+		| XButton4
276 
+		| XButton5
277 
+	--deriving (Printers)
278 
+
279 
+data XWinAttribute {-# STRICT #-}
280 
+		= XWinBackground XPixel
281 
+                | XWinEventMask XEventMask
282 
+                | XWinDepth Int
283 
+		| XWinBorderWidth Int
284 
+		| XWinClass XWindowClass
285 
+		| XWinVisual Int
286 
+		| XWinBorder XFillContent
287 
+		| XWinBackingStore XBackingStore
288 
+		| XWinBackingPlanes XPixel
289 
+		| XWinBackingPixel XPixel
290 
+		| XWinSaveUnder XSwitch
291 
+		| XWinDoNotPropagateMask XEventMask
292 
+		| XWinOverrideRedirect XSwitch
293 
+		| XWinColormap XColormap
294 
+		| XWinCursor XCursor
295 
+     --deriving (Printers)
296 
+
297 
+data XGCAttribute {-# STRICT #-}
298 
+		= XGCArcMode XArcMode
299 
+		| XGCBackground XPixel
300 
+		| XGCCapStyle XCapStyle
301 
+		| XGCClipMask XClipMask
302 
+		| XGCClipOrigin XPoint
303 
+		| XGCDashOffset Int
304 
+		| XGCDashes [Int]
305 
+		| XGCExposures XSwitch
306 
+		| XGCFillRule XFillRule
307 
+		| XGCFillStyle XFillStyle
308 
+		| XGCFont XFont
309 
+		| XGCForeground XPixel
310 
+		| XGCFunction XFunction
311 
+		| XGCJoinStyle XJoinStyle
312 
+		| XGCLineStyle XLineStyle
313 
+		| XGCLineWidth Int
314 
+		| XGCPlaneMask XPixel
315 
+		| XGCStipple XPixmap
316 
+		| XGCSubwindowMode XSubwindowMode
317 
+		| XGCTile XPixmap
318 
+		| XGCTileOrigin XPoint
319 
+        --deriving (Printers)
320 
+
321 
+data XImAttribute {-# STRICT #-}
322 
+		= XImBitLsbFirstP Bool
323 
+		| XImBitsPerPixel Int
324 
+		| XImBlueMask XPixel
325 
+		| XImByteLsbFirstP Bool
326 
+		| XImBytesPerLine Int
327 
+		| XImData XImageData
328 
+		| XImDepth Int
329 
+		| XImFormat XImageFormat
330 
+		| XImGreenMask XPixel
331 
+		| XImSize XSize
332 
+		| XImName String
333 
+		| XImRedMask XPixel
334 
+		| XImHotSpot XPoint
335 
+	   --deriving (Printers)
336 
+
337 
+data XGrabAttribute {-# STRICT #-}
338 
+		= XGrabOwnerP Bool
339 
+		| XGrabSyncPointerP Bool
340 
+		| XGrabSyncKeyboardP Bool
341 
+		| XGrabConfineTo XWindow
342 
+		| XGrabCursor XCursor
343 
+	   --deriving (Printers)
344 
+
345 
+data XArcMode	= XChord
346 
+		| XPieSlice
347 
+          --deriving (Printers)
348 
+
349 
+data XCapStyle	= XButt
350 
+		| XNotLast
351 
+		| XProjecting
352 
+		| XRound
353 
+	   --deriving (Printers)
354 
+
355 
+data XClipMask {-# STRICT #-}
356 
+        	= XClipMaskPixmap XPixmap
357 
+		| XClipMaskRects [XRect]
358 
+		| XClipMaskNone
359 
+	   --deriving (Printers)
360 
+
361 
+data XFillRule  = XFillEvenOdd
362 
+		| XFillWinding
363 
+	   --deriving (Printers)
364 
+
365 
+data XFillStyle = XFillOpaqueStippled
366 
+		| XFillSolid
367 
+		| XFillStippled
368 
+		| XFillTiled
369 
+	   --deriving (Printers)
370 
+
371 
+data XFunction	= XBoole1
372 
+		| XBoole2
373 
+		| XBooleAndC1
374 
+		| XBooleAndC2
375 
+		| XBooleAnd
376 
+		| XBooleC1
377 
+		| XBooleC2
378 
+		| XBooleClr
379 
+		| XBooleEqv
380 
+		| XBooleIor
381 
+		| XBooleNand
382 
+		| XBooleNor
383 
+		| XBooleOrc1
384 
+		| XBooleOrc2
385 
+		| XBooleSet
386 
+		| XBooleXor
387 
+	   --deriving (Printers)
388 
+
389 
+data XJoinStyle	= XJoinBevel
390 
+		| XJoinMiter
391 
+		| XJoinRound
392 
+	   --deriving (Printers)
393 
+
394 
+data XLineStyle = XLineSolid
395 
+		| XLineDoubleDash
396 
+		| XLineOnOffDash
397 
+	   --deriving (Printers)
398 
+
399 
+data XSubwindowMode	= XClipByChildren
400 
+			| XIncludeInferiors
401 
+	   --deriving (Printers)
402 
+
403 
+-- BASIC GEOMETRY
404 
+
405 
+data XPoint {-# STRICT #-} = XPoint Int Int		-- x,y
406 
+	   --deriving (Printers)
407 
+
408 
+data XSize {-# STRICT #-} = XSize Int Int               -- width, height
409 
+	   --deriving (Printers)
410 
+
411 
+data XRect {-# STRICT #-} = XRect Int Int Int Int       -- x, y, width, height
412 
+	   --deriving (Printers)
413 
+
414 
+data XArc {-# STRICT #-} = XArc Int Int Int Int Float Float
415 
+	   --deriving (Printers)  -- x, y, width, height, angle1, angle2
416 
+
417 
+data XBitmapFormat {-# STRICT #-} = XBitmapFormat Int Int Bool
418 
+          --deriving (Printers) -- unit, pad, lsb-first-p
419 
+
420 
+data XByteOrder = XLsbFirst
421 
+                | XMsbFirst
422 
+		   --deriving (Printers)
423 
+
424 
+data XPixmapFormat {-# STRICT #-} = XPixmapFormat Int Int Int
425 
+         --deriving (Printers) -- depth, bits-per-pixel, scanline-pad
426 
+
427 
+data XVisualInfo {-# STRICT #-} = XVisualInfo
428 
+			Int 		-- id
429 
+                        XVisualClass 	-- class
430 
+                        XPixel 		-- red-mask
431 
+                        XPixel 		-- green-mask
432 
+                        XPixel 		-- blue-mask
433 
+                        Int 		-- bits-per-rgb
434 
+			Int 		-- colormap-entries
435 
+        --deriving (Printers)
436 
+
437 
+data XVisualClass	= XDirectColor
438 
+			| XGrayScale
439 
+			| XPseudoColor
440 
+			| XStaticColor
441 
+			| XStaticGray
442 
+			| XTrueColor
443 
+        --deriving (Printers)
444 
+
445 
+data XFillContent {-# STRICT #-}
446 
+	                = XFillPixel XPixel
447 
+			| XFillPixmap XPixmap
448 
+			| XFillNone
449 
+			| XFillParentRelative
450 
+			| XFillCopy
451 
+        --deriving (Printers)
452 
+
453 
+data XBackingStore 	= XAlwaysBackStore
454 
+			| XNeverBackStore
455 
+			| XBackStoreWhenMapped
456 
+			| XBackStoreNotUseful
457 
+        --deriving (Printers)
458 
+
459 
+data XGravity	= XForget
460 
+		| XStatic
461 
+		| XCenter
462 
+		| XEast
463 
+		| XNorth
464 
+		| XNorthEast
465 
+		| XNorthWest
466 
+		| XSouth
467 
+		| XSouthEast
468 
+		| XSouthWest
469 
+		| XWest
470 
+        --deriving (Printers)
471 
+
472 
+data XWindowClass 	= XInputOutput
473 
+			| XInputOnly
474 
+        --deriving (Printers)
475 
+
476 
+data XMapState		= XUnmapped
477 
+			| XUnviewable
478 
+			| XViewable
479 
+        --deriving (Printers)
480 
+
481 
+data XImageData	{-# STRICT #-}
482 
+                = XBitmapData [XBitmap]
483 
+		| XPixarrayData XPixarray
484 
+		| XByteVecData XByteVec
485 
+        --deriving (Printers)
486 
+
487 
+data XImageFormat 	= XXyPixmapImage
488 
+			| XZPixmapImage
489 
+			| XBitmapImage
490 
+        --deriving (Printers)
491 
+
492 
+data XImageType	= XImageX
493 
+		| XImageXy
494 
+		| XImageZ
495 
+        --deriving (Printers)
496 
+
497 
+data XDrawDirection	= XLeftToRight
498 
+			| XRightToLeft
499 
+        --deriving (Printers)
500 
+
501 
+data XColor {-# STRICT #-} = XColor Float Float Float
502 
+        --deriving (Printers)
503 
+
504 
+data XInputFocus {-# STRICT #-}
505 
+                	= XFocusWindow XWindow
506 
+			| XFocusNone
507 
+			| XFocusPointerRoot
508 
+			| XFocusParent
509 
+        --deriving (Printers)
510 
+
511 
+data XGrabStatus	= XAlreadyGrabbed
512 
+			| XFrozen
513 
+			| XInvalidTime
514 
+			| XNotViewable
515 
+			| XSuccess
516 
+        --deriving (Printers)
517 
+
518 
+
519 
+data XKeysym {-# STRICT #-} = XKeysym Integer
520 
+        --deriving (Printers)
521 
+
522 
+
523 
+data XCloseDownMode	= XDestroy
524 
+			| XRetainPermanent
525 
+			| XRetainTemporary
526 
+        --deriving (Printers)
527 
+
528 
+data XScreenSaver {-# STRICT #-} = XScreenSaver Int Int Bool Bool
529 
+       --deriving (Printers)
530 
+
531 
+{-#
532 
+ImportLispType (
533 
+   XMaybe (XSome ("not-null?", "identity", "identity"),
534 
+           XNull ("null?", "'()")),
535 
+   XError (XError ("cons-xerror", "x-error-string")),
536 
+   XBitmap (XBitmap ("mk-bitmap", "sel-bitmap")),
537 
+   XKeysymTable (XKeysymTable ("mk-keysym-table", "sel-keysym-table")),
538 
+   XBitVec (XBitVec ("mk-bitvec", "sel-bitvec")),
539 
+   XPixarray (XPixarray ("mk-pixarray", "sel-pixarray")),
540 
+   XByteVec (XByteVec ("mk-bytevec", "sel-bytevec")),
541 
+   XAtom (XAtom ("mk-atom", "sel-atom")),
542 
+   XProperty (XProperty ("mk-xproperty", "sel-xproperty-data",
543 
+	                 "sel-xproperty-type", "sel-xproperty-format")),
544 
+   XDrawable (XDrawWindow ("xlib:window-p", "identity", "identity"),
545 
+ 	      XDrawPixmap ("xlib:pixmap-p", "identity", "identity")),
546 
+   XSwitch ( XOn(":on"), XOff(":off")),
547 
+   XWindowPlace (XTopPlace (":top"), XBottomPlace (":bottom")),
548 
+   XEventMode (XNormalMode (":normal"),
549 
+               XGrabMode (":grab"),
550 
+	       XUngrabMode (":ungrab"),
551 
+	       XWhileGrabbedMode (":while-grabbed")),
552 
+   XEventKind (XAncestorKind (":ancestor"),
553 
+               XVirtualKind (":virtual"),
554 
+               XInferiorKind (":inferior"),
555 
+               XNonlinearKind (":nonlinear"),
556 
+               XNonlinearVirtualKind (":nonlinear-virtual"),
557 
+               XPointerKind (":pointer"),
558 
+               XPointerRootKind (":pointer-root"),
559 
+               XNoneKind (":none")),
560 
+   XWindowVisibility (XUnobscured (":unobscured"),
561 
+                      XPartiallyObscured (":partially-obscured"),
562 
+                      XFullyObscured (":fully-obscured")),
563 
+   XWindowStackMode (XStackAbove (":above"),
564 
+                     XStackBelow (":below"),
565 
+		     XStackTopIf (":top-if"),
566 
+		     XStackBottomIf (":bottom-if"),
567 
+		     XStackOpposite (":opposite")),
568 
+   XPropertyState (XNewValueProperty (":new-value"),
569 
+                   XDeletedProperty (":deleted")),
570 
+   XMapReqType (XModifierMapping (":modifier"),
571 
+                XKeyboardMapping (":keyboard"),
572 
+		XPointerMapping (":pointer")),
573 
+   XGraphFun (XGraphFun ("cons", "car", "cdr")),
574 
+   XEvent (XEvent ("mk-event", "sel-event-type", "sel-event-slots")),
575 
+   XEventType (XKeyPressEvent (":key-press"),
576 
+               XKeyReleaseEvent (":key-release"),
577 
+	       XButtonPressEvent (":button-press"),
578 
+	       XButtonReleaseEvent (":button-release"),
579 
+	       XMotionNotifyEvent (":motion-notify"),
580 
+	       XEnterNotifyEvent (":enter-notify"),
581 
+	       XLeaveNotifyEvent (":leave-notify"),
582 
+	       XFocusInEvent (":focus-in"),
583 
+	       XFocusOutEvent (":focus-out"),
584 
+	       XKeymapNotifyEvent (":keymap-notify"),
585 
+	       XMappingNotifyEvent (":mapping-notify"),
586 
+	       XExposureEvent (":exposure"),
587 
+	       XGraphicsExposureEvent (":graphics-exposure"),
588 
+	       XNoExposureEvent (":no-exposure"),
589 
+	       XCirculateNotifyEvent (":circulate-notify"),
590 
+	       XConfigureNotifyEvent (":configure-notify"),
591 
+	       XCreateNotifyEvent (":create-notify"),
592 
+	       XDestroyNotifyEvent (":destroy-notify"),
593 
+	       XGravityNotifyEvent (":gravity-notify"),
594 
+	       XMapNotifyEvent (":map-notify"),
595 
+	       XReparentNotifyEvent (":reparent-notify"),
596 
+	       XUnmapNotifyEvent (":unmap-notify"),
597 
+	       XVisibilityNotifyEvent (":visibility-notify"),
598 
+	       XCirculateRequestEvent (":circulate-notify"),
599 
+	       XColormapNotifyEvent (":colormap-notify"),
600 
+	       XConfigureRequestEvent (":configure-request"),
601 
+	       XMapRequestEvent (":map-request"),
602 
+	       XResizeRequestEvent (":resize-request"),
603 
+	       XClientMessageEvent (":client-message"),
604 
+	       XPropertyNotifyEvent (":property-notify"),
605 
+	       XSelectionClearEvent (":selection-clear"),
606 
+	       XSelectionNotifyEvent (":selection-notify"),
607 
+	       XSelectionRequestEvent (":selection-request"),
608 
+	       XOtherEvents (":others")),
609 
+   XEventSlot (XEventWindow ("is-window", "mk-window", "keyword-val"),
610 
+               XEventEventWindow
611 
+                  ("is-event-window", "mk-event-window", "keyword-val"),
612 
+	       XEventCode ("is-code", "mk-code", "keyword-val"),
613 
+	       XEventPos ("is-pos", "mk-pos", "keyword-val"),
614 
+	       XEventState ("is-state", "mk-state", "keyword-val"),
615 
+	       XEventTime ("is-time", "mk-time", "keyword-val"),
616 
+	       XEventRoot ("is-root", "mk-root", "keyword-val"),
617 
+	       XEventRootPos ("is-root-pos", "mk-root-pos", "keyword-val"),
618 
+	       XEventChild ("is-child", "mk-child", "keyword-val"),
619 
+	       XEventSameScreenP
620 
+                  ("is-same-screen-p", "mk-same-screen-p", "keyword-val"),
621 
+	       XEventHintP ("is-hint-p", "mk-hint-p", "keyword-val"),
622 
+	       XEventMode ("is-mode", "mk-mode", "keyword-val"),
623 
+	       XEventKind ("is-kind", "mk-kind", "keyword-val"),
624 
+	       XEventFocusP ("is-focus-p", "mk-focus-p", "keyword-val"),
625 
+	       XEventKeymap ("is-keymap", "mk-keymap", "keyword-val"),
626 
+	       XEventRequest ("is-request", "mk-request", "keyword-val"),
627 
+	       XEventStart ("is-start", "mk-start", "keyword-val"),
628 
+	       XEventCount ("is-count", "mk-count", "keyword-val"),
629 
+	       XEventRect ("is-rect", "mk-rect", "keyword-val"),
630 
+	       XEventDrawable ("is-drawable", "mk-drawable", "keyword-val"),
631 
+	       XEventXGraphFun ("is-graph-fun", "mk-graph-fun", "keyword-val"),
632 
+	       XEventPlace ("is-place", "mk-place", "keyword-val"),
633 
+	       XEventBorderWidth
634 
+                ("is-border-width", "mk-border-width", "keyword-val"),
635 
+	       XEventAboveSibling
636 
+                ("is-above-sibling", "mk-above-sibling", "keyword-val"),
637 
+	       XEventOverrideRedirectP
638 
+                ("is-override-redirect-p", "mk-override-redirect-p", "keyword-val"),
639 
+	       XEventParent ("is-parent", "mk-parent", "keyword-val"),
640 
+	       XEventConfigureP ("is-configure-p", "mk-configure-p", "keyword-val"),
641 
+	       XEventVisibility ("is-visibility", "mk-visibility", "keyword-val"),
642 
+	       XEventNewP ("is-new-p", "mk-new-p", "keyword-val"),
643 
+	       XEventInstalledP ("is-installed-p", "mk-installed-p", "keyword-val"),
644 
+	       XEventStackMode ("is-stack-mode", "mk-stack-mode", "keyword-val"),
645 
+	       XEventValueMask ("is-value-mask", "mk-value-mask", "keyword-val"),
646 
+	       XEventSize ("is-size", "mk-size", "keyword-val"),
647 
+	       XEventMessage ("is-message", "mk-message", "keyword-val"),
648 
+	       XEventPropertyState
649 
+                 ("is-property-state", "mk-property-state", "keyword-val"),
650 
+	       XEventAtom ("is-atom", "mk-atom", "keyword-val"),
651 
+	       XEventSelection ("is-selection", "mk-selection", "keyword-val"),
652 
+	       XEventTarget ("is-target", "mk-target", "keyword-val"),
653 
+	       XEventProperty ("is-property", "mk-property", "keyword-val"),
654 
+	       XEventRequestor ("is-requestor", "mk-requestor", "keyword-val")),
655 
+   XEventMask (XEventMask ("x-make-event-mask", "x-event-mask-key-list")),
656 
+   XEventMaskKey (XButton1Motion (":button-1-motion"),
657 
+                  XButton2Motion (":button-2-motion"),
658 
+		  XButton3Motion (":button-3-motion"),
659 
+		  XButton4Motion (":button-4-motion"),
660 
+		  XButton5Motion (":button-5-motion"),
661 
+		  XButtonMotion (":button-motion"),
662 
+		  XButtonPress (":button-press"),
663 
+		  XButtonRelease (":button-release"),
664 
+		  XColormapChange (":colormap-change"),
665 
+		  XEnterWindow (":enter-window"),
666 
+		  XExposure (":exposure"),
667 
+		  XFocusChange (":focus-change"),
668 
+		  XKeyPress (":key-press"),
669 
+		  XKeyRelease (":key-release"),
670 
+		  XKeymapState (":keymap-state"),
671 
+		  XLeaveWindow (":leave-window"),
672 
+		  XOwnerGrabButton (":owner-grab-button"),
673 
+		  XPointerMotion (":pointer-motion"),
674 
+		  XPointerMotionHint (":pointer-motion-hint"),
675 
+		  XPropertyChange (":property-change"),
676 
+		  XResizeRedirect (":resize-redirect"),
677 
+		  XStructureNotify (":structure-notify"),
678 
+		  XSubstructureRedirect (":substructure-notify"),
679 
+		  XVisibilityChange (":visibility-change")),
680 
+   XStateMask (XStateMask ("x-make-state-mask", "x-state-mask-key-list")),
681 
+   XStateMaskKey (XShift (":shift"),
682 
+                  XLock (":lock"),
683 
+		  XControl (":control"),
684 
+		  XMod1 (":mod-1"),
685 
+		  XMod2 (":mod-2"),
686 
+		  XMod3 (":mod-3"),
687 
+		  XMod4 (":mod-4"),
688 
+		  XMod5 (":mod-5"),
689 
+		  XButton1 (":button-1"),
690 
+		  XButton2 (":button-2"),
691 
+		  XButton3 (":button-3"),
692 
+		  XButton4 (":button-4"),
693 
+		  XButton5 (":button-5")),
694 
+  XWinAttribute
695 
+    (XWinBackground ("is-background","mk-background","keyword-val"),
696 
+     XWinEventMask ("is-event-mask","mk-event-mask","keyword-val"),
697 
+     XWinDepth ("is-depth","mk-depth","keyword-val"),
698 
+     XWinBorderWidth ("is-border-width","mk-border-width","keyword-val"),
699 
+     XWinClass ("is-class","mk-class","keyword-val"),
700 
+     XWinVisual ("is-visual","mk-visual","keyword-val"),
701 
+     XWinBorder ("is-border","mk-border","keyword-val"),
702 
+     XWinBackingStore ("is-backing-store","mk-backing-store","keyword-val"),
703 
+     XWinBackingPlanes ("is-backing-planes","mk-backing-planes","keyword-val"),
704 
+     XWinBackingPixel ("is-backing-pixel","mk-backing-pixel","keyword-val"),
705 
+     XWinSaveUnder ("is-save-under","mk-save-under","keyword-val"),
706 
+     XWinDoNotPropagateMask ("is-do-not-propagate-mask",
707 
+	  	             "mk-do-not-propagate-mask","keyword-val"),
708 
+     XWinOverrideRedirect("is-override-redirect",
709 
+                          "mk-override-redirect","keyword-val"),
710 
+     XWinColormap ("is-colormap","mk-colormap","keyword-val"),
711 
+     XWinCursor ("is-cursor","mk-cursor","keyword-val")),
712 
+   XGCAttribute(
713 
+     XGCArcMode ("is-arc-mode","mk-arc-mode","keyword-val"),
714 
+     XGCBackground ("is-background","mk-background","keyword-val"),
715 
+     XGCCapStyle ("is-cap-style","mk-cap-style","keyword-val"),
716 
+     XGCClipMask ("is-clip-mask","mk-clip-mask","keyword-val"),
717 
+     XGCClipOrigin ("is-clip-origin","mk-clip-origin","keyword-val"),
718 
+     XGCDashOffset ("is-dash-offset","mk-dash-offset","keyword-val"),
719 
+     XGCDashes ("is-dashes","mk-dashes","keyword-val"),
720 
+     XGCExposures ("is-exposures","mk-exposures","keyword-val"),
721 
+     XGCFillRule ("is-fill-rule","mk-fill-rule","keyword-val"),
722 
+     XGCFillStyle ("is-fill-style","mk-fill-style","keyword-val"),
723 
+     XGCFont ("is-font","mk-font","keyword-val"),
724 
+     XGCForeground ("is-foreground","mk-foreground","keyword-val"),
725 
+     XGCFunction ("is-function","mk-function","keyword-val"),
726 
+     XGCJoinStyle ("is-join-style","mk-join-style","keyword-val"),
727 
+     XGCLineStyle ("is-line-style","mk-line-style","keyword-val"),
728 
+     XGCLineWidth ("is-line-width","mk-line-width","keyword-val"),
729 
+     XGCPlaneMask ("is-plane-mask","mk-plane-mask","keyword-val"),
730 
+     XGCStipple ("is-stipple","mk-stipple","keyword-val"),
731 
+     XGCSubwindowMode ("is-subwindow-mode","mk-subwindow-mode","keyword-val"),
732 
+     XGCTile ("is-tile","mk-tile","keyword-val"),
733 
+     XGCTileOrigin ("is-tile-origin","mk-tile-origin","keyword-val")),
734 
+   XImAttribute (
735 
+     XImBitLsbFirstP ("is-bit-lsb-first-p","mk-bit-lsb-first-p","keyword-val"),
736 
+     XImBitsPerPixel ("is-bits-per-pixel","mk-bits-per-pixel","keyword-val"),
737 
+     XImBlueMask ("is-blue-mask","mk-blue-mask","keyword-val"),
738 
+     XImByteLsbFirstP ("is-byte-lsb-first-p","mk-byte-lsb-first-p","keyword-val"),
739 
+     XImBytesPerLine ("is-bytes-per-line","mk-bytes-per-line","keyword-val"),
740 
+     XImData ("is-data","mk-data","keyword-val"),
741 
+     XImDepth ("is-depth","mk-depth","keyword-val"),
742 
+     XImFormat ("is-format","mk-format","keyword-val"),
743 
+     XImGreenMask ("is-green-mask","mk-green-mask","keyword-val"),
744 
+     XImSize ("is-size","mk-size","keyword-val"),
745 
+     XImName ("is-name","mk-name","keyword-val"),
746 
+     XImRedMask ("is-red-mask","mk-red-mask","keyword-val"),
747 
+     XImHotSpot ("is-hot-spot","mk-hot-spot","keyword-val")),
748 
+   XGrabAttribute (
749 
+     XGrabOwnerP ("is-owner-p", "mk-owner-p", "keyword-val"),
750 
+     XGrabSyncPointerP ("is-sync-pointer-p", "mk-sync-pointer-p", "keyword-val"),
751 
+     XGrabSyncKeyboardP ("is-sync-keyboard-p", "mk-sync-keyboard-p", "keyword-val"),
752 
+     XGrabConfineTo ("is-confine-to", "mk-confine-to", "keyword-val"),
753 
+     XGrabCursor ("is-cursor", "mk-cursor", "keyword-val")),
754 
+   XArcMode (XChord (":chord"),
755 
+             XPieSlice (":pie-slice")),
756 
+   XCapStyle (XButt (":butt"),
757 
+              XNotLast (":not-last"),
758 
+	      XProjecting (":projecting"),
759 
+	      XRound (":round")),
760 
+   XClipMask (XClipMaskPixmap ("xlib:pixmap-p","identity","identity"),
761 
+	      XClipMaskRects ("not-pixmap-and-list-p","mk-clip-mask-rects",
762 
+	                      "sel-clip-mask-rects"),
763 
+	      XClipMaskNone ("null?", "()")),
764 
+   XFillRule (XFillEvenOdd (":even-odd"),
765 
+              XFillWinding (":winding")),
766 
+   XFillStyle (XFillOpaqueStippled (":opaque-stippled"),
767 
+               XFillSolid (":solid"),
768 
+	       XFillStippled (":stippled"),
769 
+	       XFillTiled (":tiled")),
770 
+   XFunction (XBoole1 ("xlib::boole-1"),
771 
+              XBoole2 ("xlib::boole-2"),
772 
+	      XBooleAndC1 ("xlib::boole-andc1"),
773 
+	      XBooleAndC2 ("xlib::boole-andc2"),
774 
+	      XBooleAnd ("xlib::boole-and"),
775 
+	      XBooleC1 ("xlib::boole-c1"),
776 
+	      XBooleC2 ("xlib::boole-c2"),
777 
+	      XBooleClr ("xlib::boole-clr"),
778 
+	      XBooleEqv ("xlib::boole-eqv"),
779 
+	      XBooleIor ("xlib::boole-ior"),
780 
+	      XBooleNand ("xlib::boole-nand"),
781 
+	      XBooleNor ("xlib::boole-nor"),
782 
+	      XBooleOrc1 ("xlib::boole-orc1"),
783 
+	      XBooleOrc2 ("xlib::boole-orc2"),
784 
+	      XBooleSet ("xlib::boole-set"),
785 
+	      XBooleXor ("xlib::boole-xor")),
786 
+   XJoinStyle (XJoinBevel (":bevel"),
787 
+               XJoinMiter (":miter"),
788 
+	       XJoinRound (":round")),
789 
+   XLineStyle (XLineSolid (":solid"),
790 
+               XLineDoubleDash (":double-dash"),
791 
+	       XLineOnOffDash (":on-off-dash")),
792 
+   XSubwindowMode (XClipByChildren (":clip-by-children"),
793 
+   	           XIncludeInferiors (":include-inferiors")),
794 
+   XPoint(XPoint("mk-xpoint", "xpoint-x", "xpoint-y")),
795 
+   XSize (XSize ("mk-xsize", "xsize-w", "xsize-h")),
796 
+   XRect (XRect ("mk-xrect", "xrect-x", "xrect-y", "xrect-w", "xrect-h")),
797 
+   XArc	(XArc ("mk-xarc", "xarc-x", "xarc-y", "xarc-w", "xarc-h",
798 
+	       "xarc-a1", "xarc-a2")),
799 
+   XBitmapFormat
800 
+	(XBitmapFormat ("bitmap-format-p", "mk-bitmap-format",
801 
+			"xlib:bitmap-format-unit",
802 
+			"xlib:bitmap-format-pad",
803 
+			"xlib:bitmap-format-lsb-first-p")),
804 
+   XByteOrder (XLsbFirst (":lsbfirst"),
805 
+               XMsbFirst (":msbfirst")),
806 
+   XPixmapFormat (XPixmapFormat ("pixmap-format-p", "mk-pixmap-format",
807 
+			         "xlib:pixmap-format-depth",
808 
+			         "xlib:pixmap-format-bits-per-pixel",
809 
+			         "xlib:pixmap-format-scanline-pad")),
810 
+   XVisualInfo
811 
+	(XVisualInfo (	"visual-info-p", "mk-xvisual-info",
812 
+		      	"xlib:visual-info-id",
813 
+		      	"xlib:visual-info-class",
814 
+		      	"xlib:visual-info-red-mask",
815 
+			"xlib:visual-info-green-mask",
816 
+			"xlib:visual-info-blue-mask",
817 
+ 			"xlib:visual-info-bits-per-rgb",
818 
+			"xlib:visual-info-colormap-entries")),
819 
+   XVisualClass (XDirectColor (":direct-color"),
820 
+	         XGrayScale (":gray-scale"),
821 
+		 XPseudoColor (":pseudo-color"),
822 
+		 XStaticColor (":static-color"),
823 
+		 XStaticGray  (":static-gray"),
824 
+		 XTrueColor   (":true-color")),
825 
+   XFillContent (XFillPixel  ("is-fill-pixel", "identity","identity"),
826 
+   	         XFillPixmap ("xlib:pixmap-p", "identity","identity"),
827 
+		 XFillNone (":none"),
828 
+		 XFillParentRelative (":parent-relative"),
829 
+		 XFillCopy (":copy")),
830 
+   XBackingStore (XAlwaysBackStore (":always"),
831 
+                  XNeverBackStore (":never"),
832 
+                  XBackStoreWhenMapped (":when-mapped"),
833 
+		  XBackStoreNotUseful (":not-useful")),
834 
+   XGravity (XForget (":forget"),
835 
+             XStatic (":static"),
836 
+	     XCenter (":center"),
837 
+	     XEast (":east"),
838 
+	     XNorth (":north"),
839 
+	     XNorthEast (":north-east"),
840 
+	     XNorthWest (":north-west"),
841 
+	     XSouth (":south"),
842 
+	     XSouthEast (":south-east"),
843 
+	     XSouthWest (":south-west"),
844 
+	     XWest ("west")),
845 
+   XWindowClass (XInputOutput (":input-output"),
846 
+                 XInputOnly (":input-only")),
847 
+   XMapState (XUnmapped (":unmapped"),
848 
+              XUnviewable (":unviewable"),
849 
+	      XViewable (":viewable")),
850 
+   XImageData (XBitmapData ("bitmap-list-p", "haskell-list->list/identity", "list->haskell-list/identity"),
851 
+	       XPixarrayData ("pixarray-p", "identity", "identity"),
852 
+	       XByteVecData ("bytevec-p", "identity", "identity")),
853 
+   XImageFormat (XXyPixmapImage (":xy-pixmap"),
854 
+                 XZPixmapImage (":z-pixmap"),
855 
+		 XBitmapImage (":bitmap")),
856 
+   XImageType (XImageX ("'xlib:image-x"),
857 
+               XImageXy ("'xlib:image-xy"),
858 
+	       XImageZ ("'xlib:image-z")),
859 
+   XDrawDirection (XLeftToRight (":left-to-right"),
860 
+	           XRightToLeft (":right-to-left")),
861 
+   XColor (XColor ("xlib:color-p", "mk-color",
862 
+                   "xlib:color-red", "xlib:color-green", "xlib:color-blue")),
863 
+   XInputFocus (XFocusWindow ("xlib:window-p", "identity", "identity"),
864 
+                XFocusNone (":none"),
865 
+		XFocusPointerRoot (":pointer-root"),
866 
+		XFocusParent (":parent")),
867 
+   XGrabStatus (XAlreadyGrabbed (":already-grabbed"),
868 
+                XFrozen (":frozen"),
869 
+                XInvalidTime (":invalid-time"),
870 
+		XSuccess (":success")),
871 
+   XCloseDownMode (XDestroy (":destroy"),
872 
+	           XRetainPermanent (":retain-permanent"),
873 
+		   XRetainTemporary (":retain-temporary")),
874 
+   XScreenSaver (XScreenSaver ("list", "car", "cadr", "caddr", "cadddr")))
875 
+
876 
+#-}
877 
+
progs/lib/X11/xlib.hu
History View file @ 4e98702
0 878 
new file mode 100644
... ... 
@@ -0,0 +1,5 @@
1 
+:output $LIBRARYBIN/
2 
+:stable
3 
+:o= all
4 
+xlib.hs
5 
+xlibprims.hu
progs/lib/X11/xlibclx.scm
History View file @ 4e98702
0 6 
new file mode 100644
... ... 
@@ -0,0 +1,1262 @@
1 
+;;; xlibclx.scm -- Lisp support for Haskell/CLX interface
2 
+
3 
+;; general
4 
+
5 
+(define-syntax (nth-value n form)
6 
+  (cond ((eqv? n 0)
7 
+	 `(values ,form))
8 
+	((number? n)
9 
+	 (let ((temps  '()))
10 
+	   (dotimes (i n)
11 
+	     (declare (ignorable i))
12 
+	     (push (gensym) temps))
13 
+	   `(multiple-value-bind ,(reverse temps) ,form
14 
+	      (declare (ignore ,@(reverse (cdr temps))))
15 
+	      ,(car temps))))
16 
+	(else
17 
+	 `(lisp:nth ,n (lisp:multiple-value-list ,form)))
18 
+	))
19 
+
20 
+
21 
+(define-local-syntax (keywordify string)
22 
+  `(lisp:intern ,string (lisp:find-package "KEYWORD")))
23 
+
24 
+(define-local-syntax (xlibify string)
25 
+  `(lisp:intern ,string (lisp:find-package "XLIB")))
26 
+
27 
+
28 
+
29 
+;;; This is stuff to support slots that consist of a keyword/value
30 
+;;; pair.  Note that the value is always unboxed.
31 
+
32 
+(define-syntax (make-keyword key value)
33 
+  `(cons ,key ,value))
34 
+
35 
+(define-syntax (is-keyword? x key)
36 
+  `(eq? (car ,x) ,key))
37 
+
38 
+(define-syntax (keyword-key x) `(car ,x))
39 
+(define-syntax (keyword-val x) `(cdr ,x))
40 
+
41 
+(define-syntax (define-keyword-constructor name)
42 
+  (let* ((name-str (symbol->string name))
43 
+	 (key      (keywordify name-str))
44 
+	 (is-name  (string->symbol (string-append "IS-" name-str)))
45 
+	 (mk-name  (string->symbol (string-append "MK-" name-str))))
46 
+    `(begin
47 
+       (define (,mk-name x) (make-keyword ,key x))
48 
+       (define (,is-name x) (is-keyword? x ,key)))
49 
+    ))
50 
+
51 
+(define-syntax (define-event-slot-finder slot)
52 
+  (let* ((slot-str (symbol->string slot))
53 
+	 (slot-key (keywordify slot-str))
54 
+	 (fun      (string->symbol (string-append "X-EVENT-" slot-str))))
55 
+    `(define (,fun event) (lookup-event-slot (cdr event) ,slot-key))))
56 
+
57 
+(define (lookup-event-slot event key)
58 
+  (if (null? event)
59 
+      (error "non-existent event slot: ~A" key)
60 
+      (if (eq? key (car event))
61 
+	  (cadr event)
62 
+	  (lookup-event-slot (cddr event) key))))
63 
+
64 
+
65 
+(define-syntax (define-attribute-setter entity attribute)
66 
+  (let* ((entity-attr (string-append (symbol->string entity)
67 
+				     "-"
68 
+				     (symbol->string attribute)))
69 
+	 (fun-name    (string->symbol (string-append "X-SET-" entity-attr)))
70 
+	 (xfun-name   (xlibify entity-attr)))
71 
+    `(define (,fun-name ,entity ,attribute)
72 
+       (setf (,xfun-name ,entity) ,attribute))))
73 
+
74 
+(define-syntax (make-h-tuple . args)
75 
+  (let ((nargs (map (lambda (arg) `(box ,arg)) args)))
76 
+    `(make-tuple ,@nargs)))
77 
+
78 
+;; type XError
79 
+
80 
+(define (cons-xerror x)
81 
+  (declare (ignore x))
82 
+  (error "can't construct XError"))
83 
+
84 
+(define (x-error-string c)
85 
+  (make-haskell-string (format '#f "~A" c)))
86 
+
87 
+
88 
+;;; The forces here are necessary because the thing being funcalled
89 
+;;; returns a data structure of type (IO a), and we need to do
90 
+;;; an  IO a -> a transformation.
91 
+
92 
+#+lucid
93 
+(define (x-handle-error handler body)
94 
+  (lisp:catch 'x-error-handle
95 
+	      (lcl:handler-bind ((lisp:error (mk-handler handler)))
96 
+				(force (funcall body (box 'state))))))
97 
+
98 
+#+(or cmu allegro lispworks)
99 
+(define (x-handle-error handler body)
100 
+  (lisp:catch 'x-error-handle
101 
+	      (lisp:handler-bind ((lisp:error (mk-handler handler)))
102 
+				 (force (funcall body (box 'state))))))
103 
+
104 
+#+akcl
105 
+(define (x-handle-error handler body)
106 
+  (error "AKCL does not support HANDLER-BIND!"))
107 
+
108 
+(define (mk-handler handler)
109 
+  (lambda (c)
110 
+    (lisp:throw 'x-error-handle
111 
+		(force (funcall handler
112 
+				(box c)
113 
+				(box 'state))))))
114 
+
115 
+;; for type XMaybe
116 
+
117 
+(define (not-null? x) (not (null? x)))
118 
+
119 
+
120 
+;; For Bitmap, Pixarray, KeysymTable
121 
+
122 
+(define (array2->haskell-list a)
123 
+  (let* ((dims    (lisp:array-dimensions a))
124 
+	 (i1max   (car dims))
125 
+	 (i2max   (cadr dims)))
126 
+    (declare (type fixnum i1max i2max))
127 
+    (do ((i1     (the fixnum (1- i1max)) (the fixnum (1- i1)))
128 
+	 (outer  '()))
129 
+	((< i1 0) outer)
130 
+	(declare (type fixnum i1))
131 
+	(setf outer
132 
+	      (cons
133 
+	        (box
134 
+		  (do ((i2    (the fixnum (1- i2max)) (the fixnum (1- i2)))
135 
+		       (inner '()))
136 
+		      ((< i2 0) inner)
137 
+		      (declare (type fixnum i2))
138 
+		      (setf inner
139 
+			    (cons (box (lisp:aref a i1 i2))
140 
+				  (box inner)))))
141 
+		(box outer))))
142 
+    ))
143 
+
144 
+
145 
+;; Bitmap
146 
+
147 
+(define (mk-bitmap ll)
148 
+  (let ((l (haskell-list->list #'haskell-list->list/identity ll)))
149 
+    (lisp:make-array `(,(length l) , (length (car l)))
150 
+		     :element-type 'lisp:bit
151 
+		     :initial-contents l)))
152 
+
153 
+(define (sel-bitmap l)
154 
+  (array2->haskell-list l))
155 
+
156 
+
157 
+;; XKeysymTable
158 
+
159 
+(define (mk-keysym-table ll)
160 
+  (let ((l (haskell-list->list #'haskell-list->list/identity ll)))
161 
+    (lisp:make-array `(,(length l) , (length (car l)))
162 
+		     :element-type 'xlib:card32
163 
+		     :initial-contents l)))
164 
+
165 
+(define (sel-keysym-table l)
166 
+  (array2->haskell-list l))
167 
+
168 
+;; XPixarray
169 
+
170 
+(define (mk-pixarray ll)
171 
+  (let ((l (haskell-list->list #'haskell-list->list/identity ll)))
172 
+    (let* ((max-num  (find-max l))
173 
+	   (pix-type (cond ((<= max-num 1) 'lisp:bit)
174 
+			   ((<= max-num 15) '(lisp:unsigned-byte 4))
175 
+			   ((<= max-num 255) 'xlib:card8)
176 
+			   ((<= max-num 65535) 'xlib:card16)
177 
+			   (else 'xlib:card32))))
178 
+      (declare (type integer max-num))
179 
+      (lisp:make-array `(,(length l) , (length (car l)))
180 
+		       :element-type pix-type
181 
+		       :initial-contents l))))
182 
+
183 
+(define (find-max l)
184 
+  (let ((max  0))
185 
+    (dolist (ll l)
186 
+      (dolist (lll ll)
187 
+	(when (> (the integer lll) (the integer max))
188 
+	  (setf max lll))))
189 
+    max))
190 
+
191 
+(define (sel-pixarray l)
192 
+  (array2->haskell-list l))
193 
+
194 
+
195 
+
196 
+
197 
+;;; Can't use mumble vector primitives on arrays of specialized types!
198 
+
199 
+(define (array1->haskell-list a)
200 
+  (declare (type lisp:vector a))
201 
+  (let ((imax  (lisp:length a)))
202 
+    (declare (type fixnum imax))
203 
+    (do ((i      (the fixnum (1- imax)) (the fixnum (1- i)))
204 
+	 (result '()))
205 
+	((< i 0) result)
206 
+	(declare (type fixnum i))
207 
+	(setf result
208 
+	      (cons (box (lisp:aref a i))
209 
+		    (box result))))))
210 
+
211 
+;; BitVec
212 
+
213 
+(define (mk-bitvec ll)
214 
+  (let ((l (haskell-list->list/identity ll)))
215 
+    (lisp:make-array `(,(length l)) :element-type 'lisp:bit
216 
+		     :initial-contents l)))
217 
+
218 
+(define (sel-bitvec l)
219 
+  (array1->haskell-list l))
220 
+
221 
+;; ByteVec
222 
+
223 
+(define (mk-bytevec ll)
224 
+  (let ((l (haskell-list->list/identity ll)))
225 
+    (lisp:make-array `(,(length l)) :element-type 'xlib:card8
226 
+		     :initial-contents l)))
227 
+
228 
+(define (sel-bytevec l)
229 
+  (array1->haskell-list l))
230 
+
231 
+
232 
+;; XAtom
233 
+(define (mk-atom name)
234 
+  (keywordify (haskell-string->string name)))
235 
+
236 
+(define (sel-atom atom)
237 
+  (make-haskell-string (symbol->string atom)))
238 
+
239 
+;; XProperty
240 
+;;; watch out for name conflict with :property keyword stuff
241 
+(define (mk-xproperty d ty f) (list (haskell-list->list/identity d) ty f))
242 
+(define (sel-xproperty-data p) (list->haskell-list/identity (car p)))
243 
+(define (sel-xproperty-type p) (cadr p))
244 
+(define (sel-xproperty-format p) (caddr p))
245 
+
246 
+(define (mk-event type slots)
247 
+  (cons type (slots->keywords (haskell-list->list/identity slots))))
248 
+
249 
+(define (sel-event-type event) (car event))
250 
+
251 
+(define (sel-event-slots event)
252 
+  (list->haskell-list/identity (keywords->slots (car event) (cdr event) event)))
253 
+
254 
+;; XEventSlot
255 
+
256 
+(define-keyword-constructor window)
257 
+(define-keyword-constructor event-window)
258 
+(define-keyword-constructor code)
259 
+(define-keyword-constructor pos)
260 
+(define-keyword-constructor state)
261 
+(define-keyword-constructor time)
262 
+(define-keyword-constructor root)
263 
+(define-keyword-constructor root-pos)
264 
+(define-keyword-constructor child)
265 
+(define-keyword-constructor same-screen-p)
266 
+(define-keyword-constructor hint-p)
267 
+(define-keyword-constructor mode)
268 
+(define-keyword-constructor kind)
269 
+(define-keyword-constructor focus-p)
270 
+(define-keyword-constructor keymap)
271 
+(define-keyword-constructor request)
272 
+(define-keyword-constructor start)
273 
+(define-keyword-constructor count)
274 
+(define-keyword-constructor rect)
275 
+(define-keyword-constructor drawable)
276 
+(define-keyword-constructor graph-fun)
277 
+(define-keyword-constructor place)
278 
+(define-keyword-constructor border-width)
279 
+(define-keyword-constructor above-sibling)
280 
+(define-keyword-constructor override-redirect-p)
281 
+(define-keyword-constructor parent)
282 
+(define-keyword-constructor configure-p)
283 
+(define-keyword-constructor visibility)
284 
+(define-keyword-constructor new-p)
285 
+(define-keyword-constructor installed-p)
286 
+(define-keyword-constructor stack-mode)
287 
+(define-keyword-constructor value-mask)
288 
+(define-keyword-constructor size)
289 
+(define-keyword-constructor message)
290 
+(define-keyword-constructor property-state)
291 
+(define-keyword-constructor atom)
292 
+(define-keyword-constructor selection)
293 
+(define-keyword-constructor target)
294 
+(define-keyword-constructor property)
295 
+(define-keyword-constructor requestor)
296 
+
297 
+(define-event-slot-finder window)
298 
+(define-event-slot-finder event-window)
299 
+(define-event-slot-finder code)
300 
+(define-event-slot-finder x)
301 
+(define-event-slot-finder y)
302 
+(define-event-slot-finder state)
303 
+(define-event-slot-finder time)
304 
+(define-event-slot-finder root)
305 
+(define-event-slot-finder root-x)
306 
+(define-event-slot-finder root-y)
307 
+(define-event-slot-finder child)
308 
+(define-event-slot-finder same-screen-p)
309 
+(define-event-slot-finder hint-p)
310 
+(define-event-slot-finder mode)
311 
+(define-event-slot-finder kind)
312 
+(define-event-slot-finder focus-p)
313 
+(define-event-slot-finder keymap)
314 
+(define-event-slot-finder request)
315 
+(define-event-slot-finder start)
316 
+(define-event-slot-finder count)
317 
+(define-event-slot-finder width)
318 
+(define-event-slot-finder height)
319 
+(define-event-slot-finder drawable)
320 
+(define-event-slot-finder major)
321 
+(define-event-slot-finder minor)
322 
+(define-event-slot-finder place)
323 
+(define-event-slot-finder border-width)
324 
+(define-event-slot-finder above-sibling)
325 
+(define-event-slot-finder override-redirect-p)
326 
+(define-event-slot-finder parent)
327 
+(define-event-slot-finder configure-p)
328 
+(define-event-slot-finder new-p)
329 
+(define-event-slot-finder installed-p)
330 
+(define-event-slot-finder stack-mode)
331 
+(define-event-slot-finder value-mask)
332 
+(define-event-slot-finder data)
333 
+(define-event-slot-finder type)
334 
+(define-event-slot-finder format)
335 
+(define-event-slot-finder atom)
336 
+(define-event-slot-finder selection)
337 
+(define-event-slot-finder target)
338 
+(define-event-slot-finder property)
339 
+(define-event-slot-finder requestor)
340 
+
341 
+(define (x-event-pos event) (mk-xpoint (x-event-x event) (x-event-y event)))
342 
+
343 
+(define (x-event-root-pos event)
344 
+  (mk-xpoint (x-event-root-x event) (x-event-root-y event)))
345 
+
346 
+(define (x-event-size event)
347 
+  (mk-xsize (x-event-width event) (x-event-height event)))
348 
+
349 
+(define (x-event-rect event)
350 
+  (mk-xrect (x-event-x event) (x-event-y event)
351 
+	    (x-event-width event) (x-event-height event)))
352 
+
353 
+(define (x-event-graph-fun event)
354 
+  (cons (x-event-major event) (x-event-minor event)))
355 
+
356 
+(define (x-event-message event)
357 
+  (list (sequence->list (x-event-data event))
358 
+	(x-event-type event)
359 
+	(x-event-format event)))
360 
+
361 
+
362 
+;; XEventMask
363 
+
364 
+(define (x-make-event-mask keys)
365 
+  (apply (function xlib:make-event-mask) (haskell-list->list/identity keys)))
366 
+
367 
+(define (x-event-mask-key-list mask)
368 
+  (list->haskell-list/identity (xlib:make-event-keys mask)))
369 
+
370 
+;; XStateMask
371 
+
372 
+(define (x-make-state-mask keys)
373 
+  (apply (function xlib:make-state-mask) (haskell-list->list/identity keys)))
374 
+
375 
+(define (x-state-mask-key-list mask)
376 
+  (list->haskell-list/identity (xlib:make-state-keys mask)))
377 
+
378 
+
379 
+(define-keyword-constructor background)
380 
+(define-keyword-constructor foreground)
381 
+(define-keyword-constructor event-mask)
382 
+(define-keyword-constructor depth)
383 
+(define-keyword-constructor border-width)
384 
+(define-keyword-constructor class)
385 
+(define-keyword-constructor visual)
386 
+(define-keyword-constructor border)
387 
+(define-keyword-constructor backing-store)
388 
+(define-keyword-constructor backing-planes)
389 
+(define-keyword-constructor backing-pixel)
390 
+(define-keyword-constructor save-under)
391 
+(define-keyword-constructor do-not-propagate-mask)
392 
+(define-keyword-constructor override-redirect)
393 
+(define-keyword-constructor colormap)
394 
+(define-keyword-constructor cursor)
395 
+
396 
+(define-keyword-constructor arc-mode)
397 
+(define-keyword-constructor cap-style)
398 
+(define-keyword-constructor clip-mask)
399 
+(define-keyword-constructor clip-origin)
400 
+(define-keyword-constructor dash-offset)
401 
+(define-keyword-constructor dashes)
402 
+(define-keyword-constructor exposures)
403 
+(define-keyword-constructor fill-rule)
404 
+(define-keyword-constructor fill-style)
405 
+(define-keyword-constructor font)
406 
+(define-keyword-constructor function)
407 
+(define-keyword-constructor join-style)
408 
+(define-keyword-constructor line-style)
409 
+(define-keyword-constructor line-width)
410 
+(define-keyword-constructor plane-mask)
411 
+(define-keyword-constructor stipple)
412 
+(define-keyword-constructor subwindow-mode)
413 
+(define-keyword-constructor tile)
414 
+(define-keyword-constructor tile-origin)
415 
+
416 
+(define-keyword-constructor bit-lsb-first-p)
417 
+(define-keyword-constructor bits-per-pixel)
418 
+(define-keyword-constructor blue-mask)
419 
+(define-keyword-constructor byte-lsb-first-p)
420 
+(define-keyword-constructor bytes-per-line)
421 
+(define-keyword-constructor data)
422 
+(define-keyword-constructor format)
423 
+(define-keyword-constructor green-mask)
424 
+(define-keyword-constructor size)
425 
+(define-keyword-constructor name)
426 
+(define-keyword-constructor red-mask)
427 
+(define-keyword-constructor hot-spot)
428 
+
429 
+
430 
+(define-keyword-constructor owner-p)
431 
+(define-keyword-constructor sync-pointer-p)
432 
+(define-keyword-constructor sync-keyboard-p)
433 
+(define-keyword-constructor confine-to)
434 
+
435 
+
436 
+;; XClipMask
437 
+
438 
+(define (not-pixmap-and-list-p x)
439 
+  (and (pair? x) (not (xlib:pixmap-p x))))
440 
+(define (mk-clip-mask-rects rects)
441 
+  (rects->point-seq (haskell-list->list/identity rects)))
442 
+(define (sel-clip-mask-rects point-seq)
443 
+  (list->haskell-list/identity (point-seq->rects point-seq)))
444 
+
445 
+;; XPoint
446 
+
447 
+(define (mk-xpoint x y) (cons x y))
448 
+(define (xpoint-x x) (car x))
449 
+(define (xpoint-y x) (cdr x))
450 
+
451 
+;; XSize
452 
+
453 
+(define (mk-xsize x y) (cons x y))
454 
+(define (xsize-w x) (car x))
455 
+(define (xsize-h x) (cdr x))
456 
+
457 
+;; XRect
458 
+(define (mk-xrect x y w h) (vector x y w h))
459 
+(define (xrect-x x) (vector-ref x 0))
460 
+(define (xrect-y x) (vector-ref x 1))
461 
+(define (xrect-w x) (vector-ref x 2))
462 
+(define (xrect-h x) (vector-ref x 3))
463 
+
464 
+;; XArc
465 
+
466 
+(define (mk-xarc x y w h a1 a2) (vector x y w h a1 a2))
467 
+
468 
+(define (xarc-x x) (vector-ref x 0))
469 
+(define (xarc-y x) (vector-ref x 1))
470 
+(define (xarc-w x) (vector-ref x 2))
471 
+(define (xarc-h x) (vector-ref x 3))
472 
+(define (xarc-a1 x) (vector-ref x 4))
473 
+(define (xarc-a2 x) (vector-ref x 5))
474 
+
475 
+;; BitmapFormat
476 
+
477 
+(define (mk-bitmap-format u p l)
478 
+  (xlib::make-bitmap-format :unit u :pad p :lsb-first-p l))
479 
+
480 
+;; PixmapFormat
481 
+
482 
+(define (mk-pixmap-format u p l)
483 
+  (xlib::make-pixmap-format :depth u :bits-per-pixel p :scanline-pad l))
484 
+
485 
+;; XVisualInfo
486 
+
487 
+(define (mk-xvisual-info id cl rm gm bm bs es)
488 
+  (xlib::make-visual-info :id id :class cl :red-mask rm :green-mask gm
489 
+			  :blue-mask bm :bits-per-rgb bs :colormap-entries es))
490 
+
491 
+;; XFillContent
492 
+
493 
+(define (is-fill-pixel x) (not (or (xlib:pixmap-p x) (symbol? x))))
494 
+
495 
+;; XBackingStore
496 
+
497 
+;; XImageData
498 
+
499 
+(define (bitmap-list-p x) (pair? x))
500 
+(define (pixarray-p x) (and (not (pair? x)) (eq? (lisp:array-rank x) 2)))
501 
+(define (bytevec-p x) (and (not (pair? x)) (eq? (lisp:array-rank x) 1)))
502 
+
503 
+;; XColor
504 
+(define (mk-color r g b)
505 
+  (xlib:make-color :red r :green g :blue b))
506 
+
507 
+
508 
+(define (x-print x)
509 
+  (print x))
510 
+
511 
+(define (x-set-event-mask-key mask key-sym)
512 
+  (lisp:logior mask (xlib:make-event-mask key-sym)))
513 
+
514 
+(define (x-clear-event-mask-key mask key-sym)
515 
+  (lisp:logand mask (lisp:lognot (xlib:make-event-mask key-sym))))
516 
+
517 
+
518 
+(define (x-test-event-mask-key mask key-sym)
519 
+  (if (eqv? 0 (lisp:logand mask (xlib:make-event-mask key-sym))) '#f '#t))
520 
+
521 
+(define (x-set-state-mask-key mask key-sym)
522 
+  (lisp:logior mask (xlib:make-state-mask key-sym)))
523 
+
524 
+(define (x-clear-state-mask-key mask key-sym)
525 
+  (lisp:logand mask (lisp:lognot (xlib:make-state-mask key-sym))))
526 
+
527 
+(define (x-test-state-mask-key mask key-sym)
528 
+  (if (eqv? 0 (lisp:logand mask (xlib:make-state-mask key-sym))) '#f '#t))
529 
+
530 
+
531 
+;;; Display is a string of the format name:d.s
532 
+;;; ignore s; if d is omitted, default it to zero.
533 
+
534 
+(define (x-open-display display)
535 
+  (let* ((end    (string-length display))
536 
+	 (colon  (or (string-position #\: display 0 end) end))
537 
+	 (dot    (or (string-position #\. display colon end) end)))
538 
+    (declare (type fixnum end colon dot))
539 
+    (xlib:open-display
540 
+      (substring display 0 colon)
541 
+      :display (if (eqv? colon dot)
542 
+		   0
543 
+		   (string->number (substring display (1+ colon) dot))))))
544 
+
545 
+(define (x-set-display-error-handler display error-fun)
546 
+  (declare (ignore display error-fun))
547 
+  (error "not implemented"))
548 
+
549 
+(define (x-set-display-after-function display after-fun)
550 
+  (declare (ignore display after-fun))
551 
+  (error "not implemented"))
552 
+
553 
+(define (x-screen-depths screen)
554 
+  (let ((depths (xlib:screen-depths screen)))
555 
+    (map (lambda (l) (make-h-tuple (car l) (list->haskell-list/identity (cdr l))))
556 
+	 depths)))
557 
+
558 
+(define (x-screen-size screen)
559 
+  (mk-xsize (xlib:screen-width screen) (xlib:screen-height screen)))
560 
+
561 
+(define (x-screen-mmsize screen)
562 
+  (mk-xsize (xlib:screen-width-in-millimeters screen)
563 
+	    (xlib:screen-height-in-millimeters screen)))
564 
+
565 
+(define (x-create-window parent rect attrs)
566 
+  (apply (function XLIB:CREATE-WINDOW)
567 
+	 `(:parent ,parent :x ,(xrect-x rect) :y ,(xrect-y rect)
568 
+	   :width ,(xrect-w rect) :height ,(xrect-h rect)
569 
+	   ,@(attrs->keywords attrs))))
570 
+
571 
+(define-attribute-setter drawable border-width)
572 
+
573 
+(define (x-drawable-size drawable)
574 
+  (mk-xsize (xlib:drawable-width drawable) (xlib:drawable-height drawable)))
575 
+
576 
+(define (x-drawable-resize drawable size)
577 
+  (setf (xlib:drawable-width drawable) (xsize-w size))
578 
+  (setf (xlib:drawable-height drawable) (xsize-h size)))
579 
+
580 
+(define (x-window-pos window)
581 
+  (mk-xpoint (xlib:drawable-x window) (xlib:drawable-y window)))
582 
+
583 
+(define (x-window-move window point)
584 
+  (setf (xlib:drawable-x window) (xpoint-x point))
585 
+  (setf (xlib:drawable-y window) (xpoint-y point)))
586 
+
587 
+(define-attribute-setter window background)
588 
+(define-attribute-setter window backing-pixel)
589 
+(define-attribute-setter window backing-planes)
590 
+(define-attribute-setter window backing-store)
591 
+(define-attribute-setter window bit-gravity)
592 
+(define-attribute-setter window border)
593 
+(define-attribute-setter window colormap)
594 
+
595 
+(define (x-set-window-cursor window cursor)
596 
+  (let ((val (if (null? cursor) :none cursor)))
597 
+    (setf (xlib:window-cursor window) val)))
598 
+
599 
+(define-attribute-setter window do-not-propagate-mask)
600 
+(define-attribute-setter window event-mask)
601 
+(define-attribute-setter window gravity)
602 
+(define-attribute-setter window override-redirect)
603 
+(define-attribute-setter window priority)
604 
+(define-attribute-setter window save-under)
605 
+
606 
+(define (x-query-tree window)
607 
+  (multiple-value-bind (children parent root)
608 
+		       (xlib:query-tree window)
609 
+     (make-h-tuple (list->haskell-list/identity children) parent root)))
610 
+
611 
+(define (x-reparent-window window parent point)
612 
+  (xlib:reparent-window window parent (xpoint-x point) (xpoint-y point)))
613 
+
614 
+(define (x-translate-coordinates source point dest)
615 
+  (xlib:translate-coordinates source (xpoint-x point) (xpoint-y point) dest))
616 
+
617 
+(define (x-create-pixmap size depth drawable)
618 
+  (xlib:create-pixmap :width (xsize-w size)
619 
+		      :height (xsize-h size)
620 
+		      :depth depth
621 
+		      :drawable drawable))
622 
+
623 
+(define (x-create-gcontext drawable attrs)
624 
+  (apply (function XLIB:CREATE-GCONTEXT)
625 
+	 `(:drawable ,drawable ,@(attrs->keywords attrs))))
626 
+
627 
+(define (x-update-gcontext gcontext attrs)
628 
+  (do ((keys (attrs->keywords attrs) (cddr keys)))
629 
+      ((null? keys))
630 
+    (x-update-gcontext-attr gcontext (car keys) (cadr keys))))
631 
+
632 
+(define (x-update-gcontext-attr gcontext key attr)
633 
+  (case key
634 
+    (:arc-mode (setf (xlib:gcontext-arc-mode gcontext) attr))
635 
+    (:background (setf (xlib:gcontext-background gcontext) attr))
636 
+    (:cap-style (setf (xlib:gcontext-cap-style gcontext) attr))
637 
+    (:fill-style (setf (xlib:gcontext-fill-style gcontext) attr))
638 
+    (:clip-mask (setf (xlib:gcontext-clip-mask gcontext) attr))
639 
+    (:clip-x (setf (xlib:gcontext-clip-x gcontext) attr))
640 
+    (:clip-y (setf (xlib:gcontext-clip-y gcontext) attr))
641 
+    (:dash-offset (setf (xlib:gcontext-dash-offset gcontext) attr))
642 
+    (:dashes (setf (xlib:gcontext-dashes gcontext) attr))
643 
+    (:exposures (setf (xlib:gcontext-exposures gcontext) attr))
644 
+    (:fill-rule (setf (xlib:gcontext-fill-rule gcontext) attr))
645 
+    (:font (setf (xlib:gcontext-font gcontext) attr))
646 
+    (:foreground (setf (xlib:gcontext-foreground gcontext) attr))
647 
+;    (:function (setf (xlib:gcontext-function gcontext) attr))
648 
+    (:join-style (setf (xlib:gcontext-join-style gcontext) attr))
649 
+    (:line-style (setf (xlib:gcontext-line-style gcontext) attr))
650 
+;    (:line-width (setf (xlib:gcontext-line-width gcontext) attr))
651 
+;    (:plane-mask (setf (xlib:gcontext-plane-mask gcontext) attr))
652 
+;    (:stipple (setf (xlib:gcontext-stipple gcontext) attr))
653 
+    (:subwindow-mode (setf (xlib:gcontext-subwindow-mode gcontext) attr))
654 
+;    (:tile (setf (xlib:gcontext-tile gcontext) attr))
655 
+;    (:ts-x (setf (xlib:gcontext-ts-x gcontext) attr))
656 
+;    (:ts-y (setf (xlib:gcontext-ts-y gcontext) attr))
657 
+    (else (format '#t "Graphics context attribute ~A is not settable.~%"
658 
+		  key))))
659 
+
660 
+(define (x-query-best-stipple dsize drawable)
661 
+  (multiple-value-bind (w h)
662 
+        (xlib:query-best-stipple (xsize-w dsize) (xsize-h dsize) drawable)
663 
+     (mk-xsize w h)))
664 
+
665 
+(define (x-query-best-tile dsize drawable)
666 
+  (multiple-value-bind (w h)
667 
+        (xlib:query-best-tile (xsize-w dsize) (xsize-h dsize) drawable)
668 
+     (mk-xsize w h)))
669 
+
670 
+(define (x-clear-area window rect exposures-p)
671 
+  (xlib:clear-area window
672 
+		   :x (xrect-x rect)
673 
+		   :y (xrect-y rect)
674 
+		   :width (xrect-w rect)
675 
+		   :height (xrect-h rect)
676 
+		   :exposures-p exposures-p))
677 
+
678 
+(define (x-copy-area src gcontext rect dest point)
679 
+  (xlib:copy-area src
680 
+		  gcontext
681 
+		  (xrect-x rect) (xrect-y rect)
682 
+		  (xrect-w rect) (xrect-h rect)
683 
+		  dest
684 
+		  (xpoint-x point) (xpoint-y point)))
685 
+
686 
+(define (x-copy-plane src gcontext plane rect dest point)
687 
+  (xlib:copy-plane src
688 
+		   gcontext
689 
+		   plane
690 
+		   (xrect-x rect) (xrect-y rect)
691 
+		   (xrect-w rect) (xrect-h rect)
692 
+		   dest
693 
+		   (xpoint-x point) (xpoint-y point)))
694 
+
695 
+(define (x-draw-point drawable gcontext point)
696 
+  (xlib:draw-point drawable gcontext (xpoint-x point) (xpoint-y point)))
697 
+
698 
+(define (x-draw-points drawable gcontext points)
699 
+  (xlib:draw-points drawable gcontext (points->point-seq points)))
700 
+
701 
+(define (points->point-seq points)
702 
+  (if (null? points)
703 
+      '()
704 
+      (let ((point (car points)))
705 
+	(lisp:list* (xpoint-x point)
706 
+		    (xpoint-y point)
707 
+		    (points->point-seq (cdr points))))))
708 
+
709 
+(define (segments->point-seq segments)
710 
+  (if (null? segments)
711 
+      '()
712 
+      (let* ((first-pair (car segments))
713 
+	     (point-1 (force (tuple-select 2 0 first-pair)))
714 
+	     (point-2 (force (tuple-select 2 1 first-pair))))
715 
+	(lisp:list* (xpoint-x point-1)
716 
+		    (xpoint-y point-1)
717 
+		    (xpoint-x point-2)
718 
+		    (xpoint-y point-2)
719 
+		    (segments->point-seq (cdr segments))))))
720 
+
721 
+(define (rects->point-seq rects)
722 
+  (if (null? rects)
723 
+      '()
724 
+      (let ((rect (car rects)))
725 
+	(lisp:list* (xrect-x rect)
726 
+		    (xrect-y rect)
727 
+		    (xrect-w rect)
728 
+		    (xrect-h rect)
729 
+		    (rects->point-seq (cdr rects))))))
730 
+
731 
+(define (point-seq->rects point-seq)
732 
+  (if (null? point-seq)
733 
+      '()
734 
+      (cons (mk-xrect (car point-seq) (cadr point-seq)
735 
+		      (caddr point-seq) (cadddr point-seq))
736 
+	    (point-seq->rects (cddddr point-seq)))))
737 
+
738 
+(define (arcs->point-seq arcs)
739 
+  (if (null? arcs)
740 
+      '()
741 
+      (let ((arc (car arcs)))
742 
+	(lisp:list* (xarc-x arc)
743 
+		    (xarc-y arc)
744 
+		    (xarc-w arc)
745 
+		    (xarc-h arc)
746 
+		    (xarc-a1 arc)
747 
+		    (xarc-a2 arc)
748 
+		    (arcs->point-seq (cdr arcs))))))
749 
+
750 
+(define (x-draw-line drawable gcontext point-1 point-2)
751 
+  (xlib:draw-line drawable gcontext (xpoint-x point-1) (xpoint-y point-1)
752 
+		  (xpoint-x point-2) (xpoint-y point-2)))
753 
+
754 
+(define (x-draw-lines drawable gcontext points fill-p)
755 
+  (xlib:draw-lines drawable gcontext
756 
+		   (points->point-seq points) :fill-p fill-p))
757 
+
758 
+(define (x-draw-segments drawable gcontext segments)
759 
+  (xlib:draw-segments drawable gcontext (segments->point-seq segments)))
760 
+
761 
+(define (x-draw-rectangle drawable gcontext rect fill-p)
762 
+  (xlib:draw-rectangle drawable gcontext
763 
+		       (xrect-x rect) (xrect-y rect)
764 
+		       (xrect-w rect) (xrect-h rect)
765 
+		       fill-p))
766 
+
767 
+(define (x-draw-rectangles drawable gcontext rects fill-p)
768 
+  (xlib:draw-rectangles drawable gcontext
769 
+			(rects->point-seq rects)
770 
+			fill-p))
771 
+
772 
+(define (x-draw-arc drawable gcontext arc fill-p)
773 
+  (xlib:draw-arc drawable gcontext
774 
+		 (xarc-x arc) (xarc-y arc)
775 
+		 (xarc-w arc) (xarc-h arc)
776 
+		 (xarc-a1 arc) (xarc-a2 arc)
777 
+		 fill-p))
778 
+
779 
+(define (x-draw-arcs drawable gcontext arcs fill-p)
780 
+  (xlib:draw-arcs drawable gcontext
781 
+		  (arcs->point-seq arcs)
782 
+		  fill-p))
783 
+
784 
+(define (x-draw-glyph drawable gcontext point element)
785 
+  (nth-value 1
786 
+	     (xlib:draw-glyph drawable gcontext (xpoint-x point)
787 
+			      (xpoint-y point) element)))
788 
+
789 
+(define (x-draw-glyphs drawable gcontext point element)
790 
+  (nth-value 1 (xlib:draw-glyphs drawable gcontext (xpoint-x point)
791 
+				 (xpoint-y point) element)))
792 
+
793 
+(define (x-draw-image-glyph drawable gcontext point element)
794 
+  (nth-value 1 (xlib:draw-image-glyph drawable gcontext (xpoint-x point)
795 
+				      (xpoint-y point) element)))
796 
+
797 
+(define (x-draw-image-glyphs drawable gcontext point element)
798 
+  (nth-value 1 (xlib:draw-image-glyphs drawable gcontext (xpoint-x point)
799 
+				       (xpoint-y point) element)))
800 
+
801 
+(define (x-image-size image)
802 
+  (mk-xsize (xlib:image-width image) (xlib:image-height image)))
803 
+
804 
+(define (x-image-name image)
805 
+  (let ((lisp-name (xlib:image-name image)))
806 
+    (cond ((null? lisp-name) "")
807 
+	  ((symbol? lisp-name) (symbol->string lisp-name))
808 
+	  (else lisp-name))))
809 
+
810 
+(define-attribute-setter image name)
811 
+
812 
+(define (x-image-hot-spot image)
813 
+  (mk-xpoint (xlib:image-x-hot image) (xlib:image-y-hot image)))
814 
+
815 
+(define (x-set-image-hot-spot image point)
816 
+  (setf (xlib:image-x-hot image) (xpoint-x point))
817 
+  (setf (xlib:image-y-hot image) (xpoint-y point)))
818 
+
819 
+(define-attribute-setter image xy-bitmap-list)
820 
+(define-attribute-setter image z-bits-per-pixel)
821 
+(define-attribute-setter image z-pixarray)
822 
+
823 
+(define (x-create-image attrs)
824 
+  (apply (function xlib:create-image) (attrs->keywords attrs)))
825 
+
826 
+(define (x-copy-image image rect type)
827 
+  (xlib:copy-image image :x (xrect-x rect) :y (xrect-y rect)
828 
+		   :width (xrect-w rect) :height (xrect-h rect)
829 
+		   :result-type type))
830 
+
831 
+(define (x-get-image drawable rect pmask format type)
832 
+  (xlib:get-image drawable :x (xrect-x rect) :y (xrect-y rect)
833 
+		  :width (xrect-w rect) :height (xrect-h rect)
834 
+		  :plane-mask pmask :format format :result-type type))
835 
+
836 
+(define (x-put-image drawable gcontext image point rect)
837 
+  (xlib:put-image drawable gcontext image
838 
+		  :src-x (xpoint-x point) :src-y (xpoint-y point)
839 
+		  :x (xrect-x rect) :y (xrect-y rect)
840 
+		  :width (xrect-w rect) :height (xrect-h rect)))
841 
+
842 
+(define (x-get-raw-image drawable rect pmask format)
843 
+  (xlib:get-raw-image drawable
844 
+		      :x (xrect-x rect) :y (xrect-y rect)
845 
+		      :width (xrect-w rect) :height (xrect-h rect)
846 
+		      :plane-mask pmask :format format))
847 
+
848 
+(define (x-put-raw-image drawable gcontext data depth rect left-pad format)
849 
+  (xlib:put-raw-image drawable gcontext data
850 
+		      :depth depth
851 
+		      :x (xrect-x rect) :y (xrect-y rect)
852 
+		      :width (xrect-w rect) :height (xrect-h rect)
853 
+		      :left-pad left-pad :format format))
854 
+
855 
+(define (x-font-name font)
856 
+  (let ((lisp-name (xlib:font-name font)))
857 
+    (cond ((null? lisp-name) "")
858 
+	  ((symbol? lisp-name) (symbol->string lisp-name))
859 
+	  (else lisp-name))))
860 
+
861 
+(define (x-alloc-color colormap color)
862 
+  (multiple-value-bind (pixel screen-color exact-color)
863 
+       (xlib:alloc-color colormap color)
864 
+     (make-h-tuple pixel screen-color exact-color)))
865 
+
866 
+(define (x-alloc-color-cells colormap colors planes contiguous-p)
867 
+  (multiple-value-bind (pixels mask)
868 
+       (xlib:alloc-color-cells colormap colors :planes planes
869 
+			       :contiguous-p contiguous-p)
870 
+     (make-h-tuple (list->haskell-list/identity pixels) (list->haskell-list/identity mask))))
871 
+
872 
+(define (x-alloc-color-planes colormap colors reds greens blues contiguous-p)
873 
+  (multiple-value-bind (pixels red-mask green-mask blue-mask)
874 
+       (xlib:alloc-color-planes colormap colors :reds reds :greens greens
875 
+				:blues blues :contiguous-p contiguous-p)
876 
+     (make-h-tuple (list->haskell-list/identity pixels)
877 
+		   red-mask
878 
+		   green-mask
879 
+		   blue-mask)))
880 
+
881 
+(define (x-lookup-color colormap name)
882 
+  (multiple-value-bind (screen-color exact-color)
883 
+      (xlib:lookup-color colormap name)
884 
+    (make-h-tuple screen-color exact-color)))
885 
+
886 
+(define (unzip l)
887 
+  (if (null? l)
888 
+      '()
889 
+      (let ((h (car l)))
890 
+	(lisp:list* (force (tuple-select 2 0 h))
891 
+		    (force (tuple-select 2 1 h))
892 
+		    (unzip (cdr l))))))
893 
+
894 
+(define (x-store-colors colormap pixel-colors)
895 
+  (xlib:store-colors colormap (unzip pixel-colors)))
896 
+
897 
+(define (x-create-cursor source mask point foreground background)
898 
+  (apply (function xlib:create-cursor)
899 
+	 `(:source ,source
900 
+	   ,@(if mask `(:mask ,mask) '())
901 
+	   :x ,(xpoint-x point) :y ,(xpoint-y point)
902 
+	   :foreground ,foreground :background ,background)))
903 
+
904 
+(define (x-create-glyph-cursor src mask foreground background)
905 
+  (apply (function xlib:create-glyph-cursor)
906 
+	 `(:source-font ,(force (tuple-select 2 0 src))
907 
+	   :source-char ,(integer->char (force (tuple-select 2 1 src)))
908 
+	   ,@(if mask
909 
+		 `(:mask-font ,(force (tuple-select 2 0 mask))
910 
+		 :mask-char ,(integer->char (force (tuple-select 2 1 mask))))
911 
+		 '())
912 
+	   :foreground ,foreground :background ,background)))
913 
+
914 
+(define (x-query-best-cursor size display)
915 
+  (multiple-value-bind (w h)
916 
+      (xlib:query-best-cursor (xsize-w size) (xsize-h size) display)
917 
+    (mk-xsize w h)))
918 
+
919 
+(define (x-change-property window property content)
920 
+  (xlib:change-property window property
921 
+			(car content) (cadr content)
922 
+			(caddr content)))
923 
+
924 
+(define (x-get-property window property)
925 
+  (lisp:multiple-value-bind (data type format)
926 
+			    (xlib:get-property window property)
927 
+	 (list (sequence->list data) type format)))
928 
+
929 
+(define (x-convert-selection selection type requestor property time)
930 
+  (apply (function xlib:convert-selection)
931 
+	 `(,selection ,type ,requestor ,property ,@(if time `(,time) '()))))
932 
+
933 
+(define (x-set-selection-owner display selection time owner)
934 
+  (if time
935 
+      (setf (xlib:selection-owner display selection time) owner)
936 
+      (setf (xlib:selection-owner display selection) owner)))
937 
+
938 
+(define (sequence->list seq)
939 
+  (if (list? seq) seq
940 
+      (do ((i (1- (lisp:length seq)) (1- i))
941 
+	   (res '() (cons (lisp:elt seq i) res)))
942 
+	  ((< i 0) res))))
943 
+
944 
+(define *this-event* '())
945 
+
946 
+(define (translate-event lisp:&rest event-slots lisp:&key event-key
947 
+			 lisp:&allow-other-keys)
948 
+  (setf *this-event* (cons event-key event-slots))
949 
+  '#t)
950 
+
951 
+
952 
+(define (x-get-event display)
953 
+  (xlib:process-event display :handler #'translate-event :force-output-p '#t)
954 
+  *this-event*)
955 
+
956 
+(define (x-queue-event display event append-p)
957 
+  (apply (function xlib:queue-event)
958 
+	 `(,display ,(car event) ,@(cdr event) :append-p ,append-p)))
959 
+
960 
+(define (x-event-listen display)
961 
+  (let ((res (xlib:event-listen display)))
962 
+    (if (null? res) 0 res)))
963 
+
964 
+(define (x-send-event window event mask)
965 
+  (apply (function xlib:send-event)
966 
+	 `(,window ,(car event) ,mask ,@(cdr event))))
967 
+
968 
+(define (x-global-pointer-position display)
969 
+  (multiple-value-bind (x y) (xlib:global-pointer-position display)
970 
+    (mk-xpoint x y)))
971 
+
972 
+(define (x-pointer-position window)
973 
+  (multiple-value-bind (x y same) (xlib:pointer-position window)
974 
+    (if same (mk-xpoint x y) '())))
975 
+
976 
+(define (x-motion-events window start stop)
977 
+  (do ((npos '() (cons (mk-xpoint (car pos) (cadr pos)) npos))
978 
+       (pos (xlib:motion-events window :start start :stop stop)
979 
+	    (cdddr pos)))
980 
+      ((null? pos) (nreverse npos))))
981 
+
982 
+(define (x-warp-pointer dest-win point)
983 
+  (xlib:warp-pointer dest-win (xpoint-x point) (xpoint-y point)))
984 
+
985 
+(define (x-set-input-focus display focus revert-to time)
986 
+  (apply (function xlib:set-input-focus)
987 
+	 `(,display ,focus ,revert-to ,@(if time `(,time) '()))))
988 
+
989 
+(define (x-input-focus display)
990 
+  (multiple-value-bind (focus revert-to) (xlib:input-focus display)
991 
+    (make-h-tuple focus revert-to)))
992 
+
993 
+(define (x-grab-pointer window event-mask attrs time)
994 
+  (apply (function xlib:grab-pointer)
995 
+	 `(,window ,event-mask
996 
+           ,@(attrs->keywords attrs)
997 
+	   ,@(if time `(:time ,time) '()))))
998 
+
999 
+(define (x-ungrab-pointer display time)
1000 
+  (if time
1001 
+      (xlib:ungrab-pointer display :time time)
1002 
+      (xlib:ungrab-pointer display)))
1003 
+
1004 
+(define (x-change-active-pointer-grab display event-mask attrs time)
1005 
+  (apply (function xlib:change-active-pointer-grab)
1006 
+	 `(,display ,event-mask
1007 
+           ,@(attrs->keywords attrs)
1008 
+	   ,@(if time `(,time) '()))))
1009 
+
1010 
+(define (x-grab-button window button event-mask state-mask attrs)
1011 
+  (apply (function xlib:grab-button)
1012 
+	 `(,window ,button ,event-mask :modifiers ,state-mask
1013 
+	   ,@(attrs->keywords attrs))))
1014 
+
1015 
+(define (x-ungrab-button window button modifiers)
1016 
+  (xlib:ungrab-button window button :modifiers modifiers))
1017 
+
1018 
+(define (x-grab-keyboard window attrs time)
1019 
+  (apply (function xlib:grab-keyboard)
1020 
+	 `(,window ,@(attrs->keywords attrs)
1021 
+	   ,@(if time `(:time ,time) '()))))
1022 
+
1023 
+(define (x-ungrab-keyboard display time)
1024 
+  (if time
1025 
+      (xlib:ungrab-keyboard display :time time)
1026 
+      (xlib:ungrab-keyboard display)))
1027 
+
1028 
+(define (x-grab-key window key state-mask attrs)
1029 
+  (apply (function xlib:grab-key)
1030 
+	 `(,window ,key :modifiers ,state-mask ,@(attrs->keywords attrs))))
1031 
+
1032 
+(define (x-ungrab-key window key modifiers)
1033 
+  (xlib:ungrab-button window key :modifiers modifiers))
1034 
+
1035 
+(define (x-set-pointer-acceleration display val)
1036 
+  (xlib:change-pointer-control display :acceleration val))
1037 
+
1038 
+(define (x-set-pointer-threshold display val)
1039 
+  (xlib:change-pointer-control display :threshold val))
1040 
+
1041 
+(define (x-pointer-acceleration display)
1042 
+  (lisp:coerce (nth-value 0 (xlib:pointer-control display))
1043 
+	       'lisp:single-float))
1044 
+
1045 
+(define (x-pointer-threshold display)
1046 
+  (lisp:coerce (nth-value 1 (xlib:pointer-control display))
1047 
+	       'lisp:single-float))
1048 
+
1049 
+(define-attribute-setter pointer mapping)
1050 
+
1051 
+(define (x-set-keyboard-key-click-percent display v)
1052 
+  (xlib:change-keyboard-control display :key-click-percent v))
1053 
+
1054 
+(define (x-set-keyboard-bell-percent display v)
1055 
+  (xlib:change-keyboard-control display :bell-percent v))
1056 
+
1057 
+(define (x-set-keyboard-bell-pitch display v)
1058 
+  (xlib:change-keyboard-control display :bell-pitch v))
1059 
+
1060 
+(define (x-set-keyboard-bell-duration display v)
1061 
+  (xlib:change-keyboard-control display :bell-duration v))
1062 
+
1063 
+
1064 
+;;; Yes, leds are really counted from 1 rather than 0.
1065 
+
1066 
+(define (x-set-keyboard-led display v)
1067 
+  (declare (type integer v))
1068 
+  (do ((led 1 (1+ led))
1069 
+       (vv v (lisp:ash vv -1)))
1070 
+      ((> led 32))
1071 
+      (declare (type fixnum led) (type integer vv))
1072 
+      (xlib:change-keyboard-control display
1073 
+        :led led
1074 
+	:led-mode (if (lisp:logand vv 1) :on :off))))
1075 
+
1076 
+(define (x-set-keyboard-auto-repeat-mode display v)
1077 
+  (do ((key 0 (1+ key)))
1078 
+      ((>= key (lisp:length v)))
1079 
+      (declare (type fixnum key))
1080 
+      (xlib:change-keyboard-control display
1081 
+        :key key
1082 
+	:auto-repeat-mode (if (eqv? (the fixnum (lisp:aref v key)) 1) :on :off)
1083 
+	)))
1084 
+
1085 
+(define (x-keyboard-key-click-percent display)
1086 
+  (nth-value 0 (xlib:keyboard-control display)))
1087 
+
1088 
+(define (x-keyboard-bell-percent display)
1089 
+  (nth-value 1 (xlib:keyboard-control display)))
1090 
+
1091 
+(define (x-keyboard-bell-pitch display)
1092 
+  (nth-value 2 (xlib:keyboard-control display)))
1093 
+
1094 
+(define (x-keyboard-bell-duration display)
1095 
+  (nth-value 3 (xlib:keyboard-control display)))
1096 
+
1097 
+(define (x-keyboard-led display)
1098 
+  (nth-value 4 (xlib:keyboard-control display)))
1099 
+
1100 
+(define (x-keyboard-auto-repeat-mode display)
1101 
+  (nth-value 6 (xlib:keyboard-control display)))
1102 
+
1103 
+(define (x-modifier-mapping display)
1104 
+  (lisp:multiple-value-list (xlib:modifier-mapping display)))
1105 
+
1106 
+(define (x-set-modifier-mapping display l)
1107 
+  (let ((l1 (cddddr l)))
1108 
+    (xlib:set-modifier-mapping display
1109 
+			       :shift (car l)
1110 
+			       :lock (cadr l)
1111 
+			       :control (caddr l)
1112 
+			       :mod1 (cadddr l)
1113 
+			       :mod2 (car l1)
1114 
+			       :mod3 (cadr l1)
1115 
+			       :mod4 (caddr l1)
1116 
+			       :mod5 (cadddr l1))))
1117 
+
1118 
+(define (x-keysym-character display keysym state)
1119 
+  (let ((res (xlib:keysym->character display keysym state)))
1120 
+    (if (char? res) (char->integer res) '())))
1121 
+
1122 
+(define (x-keycode-character display keycode state)
1123 
+  (let ((res (xlib:keycode->character display keycode state)))
1124 
+    (if (char? res) (char->integer res) '())))
1125 
+
1126 
+(define-attribute-setter close-down mode)
1127 
+
1128 
+(define-attribute-setter access control)
1129 
+
1130 
+(define (x-screen-saver display)
1131 
+  (lisp:multiple-value-list (xlib:screen-saver display)))
1132 
+
1133 
+(define (x-set-screen-saver display ss)
1134 
+  (xlib:set-screen-saver display (car ss) (cadr ss) (caddr ss) (cadddr ss)))
1135 
+
1136 
+(define (slots->keywords slots)
1137 
+  (if (null slots) '()
1138 
+      `(,@(slot->keyword (car slots)) ,@(slots->keywords (cdr slots)))))
1139 
+
1140 
+(define (slot->keyword slot)
1141 
+  (let* ((tag (keyword-key slot))
1142 
+	 (val (keyword-val slot)))
1143 
+    (case tag
1144 
+      (:pos `(:x ,(xpoint-x val) :y ,(xpoint-y val)))
1145 
+      (:root-pos `(:root-x ,(xpoint-x val) :root-y ,(xpoint-y val)))
1146 
+      (:size `(:width ,(xsize-w val) :height ,(xsize-h val)))
1147 
+      (:rect `(:x ,(xrect-x val) :y ,(xrect-y val)
1148 
+	       :width ,(xrect-w val) :height ,(xrect-h val)))
1149 
+      (:graph-fun `(:major ,(car val) :minor ,(cdr val)))
1150 
+      (:visibility `(:state ,val))
1151 
+      (:property-state `(:state ,val))
1152 
+      (:message `(:data ,(car val) :type ,(cadr val) :format ,(caddr val)))
1153 
+      (else `(,tag ,val)))))
1154 
+
1155 
+(define (keywords->slots type keywords event)
1156 
+  (let* ((slots (keywords->slots1 type keywords))
1157 
+	 (has-root-xy (memq type '(:key-press :key-release :button-press
1158 
+					      :button-release :motion-notify
1159 
+					      :enter-notify :leave-notify)))
1160 
+	 (has-xy (or has-root-xy
1161 
+		     (memq type '(:gravity-notify :reparent-notify))))
1162 
+	 (has-graph-fun (memq type '(:graphics-exposure :no-exposure)))
1163 
+	 (has-rect (memq type '(:exposure :graphics-exposure
1164 
+					  :configure-notify
1165 
+					  :create-notify :configure-request)))
1166 
+	 (has-size (memq type '(:resize-request)))
1167 
+	 (has-message (memq type '(:client-message))))
1168 
+    (when has-xy
1169 
+      (push (make-keyword :pos (x-event-pos event)) slots))
1170 
+    (when has-root-xy
1171 
+      (push (make-keyword :root-pos (x-event-root-pos event))	slots))
1172 
+    (when has-graph-fun
1173 
+      (push (make-keyword :graph-fun (x-event-graph-fun event)) slots))
1174 
+    (when has-rect
1175 
+      (push (make-keyword :rect (x-event-rect event))	slots))
1176 
+    (when has-size
1177 
+      (push (make-keyword :size (x-event-size event))	slots))
1178 
+    (when has-message
1179 
+      (push (make-keyword :message (x-event-message event)) slots))
1180 
+    slots))
1181 
+
1182 
+(define (keywords->slots1 type keywords)
1183 
+  (if (null? keywords)
1184 
+      '()
1185 
+      (if (memq (car keywords)
1186 
+		'(:x :y :width :height :root-x :root-y
1187 
+		     :major :minor :type :data :format))
1188 
+	  (keywords->slots1 type (cddr keywords))
1189 
+	  (cons (keyword->slot type (car keywords) (cadr keywords))
1190 
+		(keywords->slots1 type (cddr keywords))))))
1191 
+
1192 
+(define (keyword->slot type slot val)
1193 
+  (if (eq? slot :state)
1194 
+      (case type
1195 
+	(:property-state (make-keyword :property-state val))
1196 
+	(:visibility (make-keyword :visibility val))
1197 
+	(else (make-keyword :state val)))
1198 
+      (make-keyword slot val)))
1199 
+
1200 
+(define (attrs->keywords attrs)
1201 
+  (if (null attrs)
1202 
+      '()
1203 
+      (nconc (attr->keyword (car attrs))
1204 
+	     (attrs->keywords (cdr attrs)))))
1205 
+
1206 
+(define (attr->keyword attr)
1207 
+  (let* ((tag (keyword-key attr))
1208 
+	 (val (keyword-val attr)))
1209 
+    (case tag
1210 
+      (:clip-origin `(:clip-x ,(xpoint-x val) :clip-y ,(xpoint-y val)))
1211 
+      (:dashes `(,tag ,(haskell-list->list/identity val)))
1212 
+      (:tile-origin `(:ts-x ,(xpoint-x val) :ts-y ,(xpoint-y val)))
1213 
+      (:size `(:width ,(xsize-w val) :height ,(xsize-h val)))
1214 
+      (:name `(:name ,(haskell-string->string val)))
1215 
+      (:hot-spot `(:x-hot ,(xpoint-x val) :y-hot ,(xpoint-y val)))
1216 
+      (else `(,tag ,val)))))
1217 
+
1218 
+(define (x-mutable-array-create inits)
1219 
+  (list->vector inits))
1220 
+
1221 
+(define (x-mutable-array-lookup a i)
1222 
+  (vector-ref a i))
1223 
+
1224 
+(define (x-mutable-array-update a i x)
1225 
+  (setf (vector-ref a i) x))
1226 
+
1227 
+(define (x-mutable-array-length a)
1228 
+  (vector-length a))
1229 
+
1230 
+(define (get-time-zone)
1231 
+  (nth-value 8 (lisp:get-decoded-time)))
1232 
+
1233 
+(define (decode-time time zone)
1234 
+  (multiple-value-bind (sec min hour date mon year week ds-p)
1235 
+		       (if zone
1236 
+			   (lisp:decode-universal-time time zone)
1237 
+			   (lisp:decode-universal-time time))
1238 
+    (make-h-tuple
1239 
+      (list->haskell-list/identity (list sec min hour date mon year week))
1240 
+      ds-p)))
1241 
+
1242 
+(define (encode-time time zone)
1243 
+  (apply (function lisp:encode-universal-time)
1244 
+	 (if (null? zone) time (append time (list zone)))))
1245 
+
1246 
+(define (get-run-time)
1247 
+  (/ (lisp:coerce (lisp:get-internal-run-time) 'lisp:single-float)
1248 
+     (lisp:coerce lisp:internal-time-units-per-second 'lisp:single-float)))
1249 
+
1250 
+(define (get-elapsed-time)
1251 
+  (/ (lisp:coerce (lisp:get-internal-real-time) 'lisp:single-float)
1252 
+     (lisp:coerce lisp:internal-time-units-per-second 'lisp:single-float)))
1253 
+
1254 
+(define (prim.thenio---1 x fn)
1255 
+  (lambda (state)
1256 
+    (declare (ignore state))
1257 
+    (let ((res (funcall x (box 'state))))
1258 
+      (format '#t "~A~%" res)
1259 
+      (funcall fn res (box 'state)))))
1260 
+
1261 
+(define-attribute-setter wm name)
1262 
+(define-attribute-setter wm icon-name)
progs/lib/X11/xlibprims.hi
History View file @ 4e98702
0 1263 
new file mode 100644
... ... 
@@ -0,0 +1,1465 @@
1 
+-- 4/13/93 add xTestEventMask, xTestStateMask
2 
+-- 4/14/93 add xMArrayLength,
3 
+--             xGetEventN
4 
+-- 4/15/93 change xKeycodeCharacter
5 
+--         add xKeysymCharacter
6 
+--         add xHandleError
7 
+--         add xError
8 
+-- 4/27/93 Change Bool to XSwitch in XWinAttribute, XGCAttribute
9 
+
10 
+interface XLibPrims where
11 
+
12 
+import XLibTypes(
13 
+                 XDisplay, XScreen, XWindow, XGcontext, XPixmap,
14 
+                 XColormap, XCursor, XFont, XImage, XMaybe, XError,
15 
+                 XBitmap, XKeysymTable, XBitVec,
16 
+                 XPixarray, XByteVec, XAtom, XProperty,
17 
+                 XPixel, XDrawable, XTime, XSwitch,
18 
+		 XWindowPlace, XEventMode, XEventKind,
19 
+		 XWindowVisibility, XWindowStackMode,
20 
+		 XPropertyState, XMapReqType, XGraphFun,
21 
+		 XEvent, XEventType, XEventSlot, XEventMask,
22 
+		 XEventMaskKey, XStateMask, XStateMaskKey,
23 
+		 XWinAttribute,XGCAttribute, XImAttribute,
24 
+		 XGrabAttribute, XArcMode, XCapStyle,
25 
+		 XClipMask, XFillRule, XFillStyle,
26 
+		 XFunction, XJoinStyle, XLineStyle,
27 
+		 XSubwindowMode, XPoint, XSize, XRect,
28 
+		 XArc, XBitmapFormat, XByteOrder,
29 
+		 XPixmapFormat, XVisualInfo, XVisualClass,
30 
+		 XFillContent, XBackingStore, XGravity,
31 
+		 XWindowClass, XMapState, XImageData,
32 
+		 XImageFormat, XImageType, XDrawDirection,
33 
+		 XColor, XInputFocus, XGrabStatus,
34 
+		 XKeysym, XCloseDownMode, XScreenSaver)
35 
+
36 
+xHandleError		:: (XError -> IO a) -> IO a -> IO a
37 
+xError			:: String -> IO a
38 
+
39 
+xEventType		:: XEvent -> XEventType
40 
+xEventWindow 		:: XEvent -> XWindow
41 
+xEventEventWindow	:: XEvent -> XWindow
42 
+xEventCode		:: XEvent -> Int
43 
+xEventPos		:: XEvent -> XPoint
44 
+xEventState		:: XEvent -> XStateMask
45 
+xEventTime		:: XEvent -> XTime
46 
+xEventRoot		:: XEvent -> XWindow
47 
+xEventRootPos		:: XEvent -> XPoint
48 
+xEventChild		:: XEvent -> (XMaybe XWindow)
49 
+xEventSameScreenP	:: XEvent -> Bool
50 
+xEventHintP		:: XEvent -> Bool
51 
+xEventMode		:: XEvent -> XEventMode
52 
+xEventKind		:: XEvent -> XEventKind
53 
+xEventFocusP		:: XEvent -> Bool
54 
+xEventKeymap		:: XEvent -> XBitVec
55 
+xEventRequest		:: XEvent -> XMapReqType
56 
+xEventStart		:: XEvent -> Int
57 
+xEventCount		:: XEvent -> Int
58 
+xEventRect		:: XEvent -> XRect
59 
+xEventDrawable		:: XEvent -> XDrawable
60 
+xEventXGraphFun		:: XEvent -> XGraphFun
61 
+xEventPlace		:: XEvent -> XWindowPlace
62 
+xEventBorderWidth	:: XEvent -> Int
63 
+xEventAboveSibling	:: XEvent -> (XMaybe XWindow)
64 
+xEventOverrideRedirectP	:: XEvent -> Bool
65 
+xEventParent		:: XEvent -> XWindow
66 
+xEventConfigureP	:: XEvent -> Bool
67 
+xEventVisibility	:: XEvent -> XWindowVisibility
68 
+xEventNewP		:: XEvent -> Bool
69 
+xEventInstalledP	:: XEvent -> Bool
70 
+xEventStackMode		:: XEvent -> XWindowStackMode
71 
+xEventValueMask		:: XEvent -> Int
72 
+xEventSize		:: XEvent -> XSize
73 
+xEventMessage		:: XEvent -> XProperty
74 
+xEventPropertyState	:: XEvent -> XPropertyState
75 
+xEventAtom		:: XEvent -> XAtom
76 
+xEventSelection		:: XEvent -> XAtom
77 
+xEventTarget		:: XEvent -> XAtom
78 
+xEventProperty		:: XEvent -> (XMaybe XAtom)
79 
+xEventRequestor		:: XEvent -> XWindow
80 
+
81 
+xSetEventMaskKey 	:: XEventMask -> XEventMaskKey -> XEventMask
82 
+xClearEventMaskKey 	:: XEventMask -> XEventMaskKey -> XEventMask
83 
+xTestEventMaskKey 	:: XEventMask -> XEventMaskKey -> Bool
84 
+
85 
+xSetStateMaskKey 	:: XStateMask -> XStateMaskKey -> XStateMask
86 
+xClearStateMaskKey 	:: XStateMask -> XStateMaskKey -> XStateMask
87 
+xTestStateMaskKey 	:: XStateMask -> XStateMaskKey -> Bool
88 
+
89 
+
90 
+-- DISPLAYS
91 
+
92 
+-- open
93 
+
94 
+xOpenDisplay 			:: String 		-- host:display
95 
+				-> IO XDisplay
96 
+
97 
+-- display attributes
98 
+
99 
+xDisplayAuthorizationData	:: XDisplay -> String
100 
+xDisplayAuthorizationName	:: XDisplay -> String
101 
+xDisplayBitmapFormat		:: XDisplay -> XBitmapFormat
102 
+xDisplayByteOrder		:: XDisplay -> XByteOrder
103 
+xDisplayDisplay 		:: XDisplay -> Int
104 
+xSetDisplayErrorHandler		:: XDisplay -> (XError -> IO ()) -> IO ()
105 
+xDisplayImageLsbFirstP		:: XDisplay -> Bool
106 
+xDisplayMaxKeycode		:: XDisplay -> Int
107 
+xDisplayMaxRequestLength	:: XDisplay -> Int
108 
+xDisplayMinKeycode		:: XDisplay -> Int
109 
+xDisplayMotionBufferSize	:: XDisplay -> Int
110 
+xDisplayPixmapFormats		:: XDisplay -> [XPixmapFormat]
111 
+xDisplayProtocolMajorVersion	:: XDisplay -> Int
112 
+xDisplayProtocolMinorVersion	:: XDisplay -> Int
113 
+xDisplayResourceIdBase		:: XDisplay -> Int
114 
+xDisplayResourceIdMask		:: XDisplay -> Int
115 
+xDisplayRoots 			:: XDisplay -> [XScreen]
116 
+xDisplayVendorName		:: XDisplay -> String
117 
+xDisplayReleaseNumber		:: XDisplay -> Int
118 
+
119 
+-- output buffer
120 
+
121 
+xDisplayAfterFunction		:: XDisplay -> XMaybe (IO ())
122 
+xSetDisplayAfterFunction 	:: XDisplay -> XMaybe (IO ()) -> IO ()
123 
+xDisplayForceOutput 		:: XDisplay -> IO ()
124 
+xDisplayFinishOutput		:: XDisplay -> IO ()
125 
+
126 
+-- close
127 
+
128 
+xCloseDisplay 			:: XDisplay -> IO ()
129 
+
130 
+-- SCREENS
131 
+
132 
+xScreenBackingStores		:: XScreen -> XBackingStore
133 
+xScreenBlackPixel		:: XScreen -> XPixel
134 
+xScreenDefaultColormap		:: XScreen -> XColormap
135 
+xScreenDepths			:: XScreen -> [(Int, [XVisualInfo])]
136 
+xScreenEventMaskAtOpen		:: XScreen -> XEventMask
137 
+xScreenSize			:: XScreen -> XSize
138 
+xScreenMMSize 			:: XScreen -> XSize
139 
+xScreenMaxInstalledMaps		:: XScreen -> Int
140 
+xScreenMinInstalledMaps		:: XScreen -> Int
141 
+xScreenRoot			:: XScreen -> XWindow
142 
+xScreenRootDepth		:: XScreen -> Int
143 
+xScreenRootVisual		:: XScreen -> Int
144 
+xScreenSaveUndersP		:: XScreen -> Bool
145 
+xScreenWhitePixel		:: XScreen -> XPixel
146 
+
147 
+-- WINDOWS AND PIXMAPS
148 
+
149 
+-- drawables
150 
+
151 
+xDrawableDisplay	:: XDrawable -> XDisplay
152 
+xDrawableEqual		:: XDrawable -> XDrawable -> Bool
153 
+xDrawableId		:: XDrawable -> Int
154 
+
155 
+-- creating windows
156 
+
157 
+xCreateWindow 		:: XWindow 		-- parent
158 
+			-> XRect		-- (x,y,width,height)
159 
+			-> [XWinAttribute] 	-- optional arguments
160 
+			-> IO XWindow
161 
+
162 
+-- window attributes
163 
+
164 
+xWindowBorderWidth 	:: XWindow -> IO Int
165 
+xSetWindowBorderWidth 	:: XWindow -> Int -> IO ()
166 
+
167 
+xDrawableDepth		:: XDrawable -> Int
168 
+
169 
+xDrawableSize 		:: XDrawable -> IO XSize
170 
+xDrawableResize 	:: XDrawable -> XSize -> IO ()
171 
+
172 
+xWindowPos 		:: XWindow -> IO XPoint
173 
+xWindowMove 		:: XWindow -> XPoint -> IO ()
174 
+
175 
+xWindowAllEventMasks	:: XWindow -> IO XEventMask
176 
+xSetWindowBackground 	:: XWindow -> XFillContent -> IO ()
177 
+
178 
+xWindowBackingPixel 	:: XWindow -> IO XPixel
179 
+xSetWindowBackingPixel 	:: XWindow -> XPixel -> IO ()
180 
+
181 
+xWindowBackingPlanes 	:: XWindow -> IO XPixel
182 
+xSetWindowBackingPlanes	:: XWindow -> XPixel -> IO ()
183 
+
184 
+xWindowBackingStore 	:: XWindow -> IO XBackingStore
185 
+xSetWindowBackingStore 	:: XWindow -> XBackingStore -> IO ()
186 
+
187 
+xWindowBitGravity	:: XWindow -> IO XGravity
188 
+xSetWindowBitGravity	:: XWindow -> XGravity -> IO ()
189 
+
190 
+xSetWindowBorder 	:: XWindow -> XFillContent -> IO ()
191 
+
192 
+xWindowClass 		:: XWindow -> XWindowClass
193 
+
194 
+xWindowColorMap 	:: XWindow -> IO (XMaybe XColormap)
195 
+xSetWindowColorMap 	:: XWindow -> XColormap -> IO ()
196 
+xWindowColormapInstalledP :: XWindow -> IO Bool
197 
+
198 
+xSetWindowCursor 	:: XWindow -> (XMaybe XCursor) -> IO ()
199 
+
200 
+xWindowDisplay 		:: XWindow -> XDisplay
201 
+
202 
+xWindowDoNotPropagateMask	:: XWindow -> IO XEventMask
203 
+xSetWindowDoNotPropagateMask	:: XWindow -> XEventMask -> IO ()
204 
+
205 
+xWindowEqual		:: XWindow -> XWindow -> Bool
206 
+
207 
+xWindowEventMask	:: XWindow -> IO XEventMask
208 
+xSetWindowEventMask	:: XWindow -> XEventMask -> IO ()
209 
+
210 
+xWindowGravity		:: XWindow -> IO XGravity
211 
+xSetWindowGravity	:: XWindow -> XGravity -> IO ()
212 
+
213 
+xWindowId		:: XWindow -> Int
214 
+
215 
+xWindowMapState		:: XWindow -> IO XMapState
216 
+
217 
+xWindowOverrideRedirect		:: XWindow -> IO XSwitch
218 
+xSetWindowOverrideRedirect	:: XWindow -> XSwitch -> IO ()
219 
+
220 
+xSetWindowPriority	:: XWindow -> XWindowStackMode -> IO ()
221 
+
222 
+xWindowSaveUnder	:: XWindow -> IO XSwitch
223 
+xSetWindowSaveUnder	:: XWindow -> XSwitch -> IO ()
224 
+
225 
+xWindowVisual		:: XWindow -> Int
226 
+
227 
+-- stacking order
228 
+
229 
+xCirculateWindowDown	:: XWindow -> IO ()
230 
+xCirculateWindowUp	:: XWindow -> IO ()
231 
+
232 
+-- window hierarchy
233 
+
234 
+xDrawableRoot		:: XDrawable -> IO XWindow
235 
+xQueryTree		:: XWindow -> IO ([XWindow], 	-- children
236 
+				         XMaybe XWindow,-- parent
237 
+				         XWindow) 	-- root
238 
+
239 
+xReparentWindow		:: XWindow 			-- window
240 
+			-> XWindow 			-- parent
241 
+			-> XPoint 			-- (x,y)
242 
+			-> IO ()
243 
+
244 
+xTranslateCoordinates	:: XWindow 			-- source
245 
+			-> XPoint 			-- (source-x,source-y)
246 
+			-> XWindow 			-- destination
247 
+			-> IO (XMaybe XPoint)		-- (dest-x,dest-y)
248 
+
249 
+-- mapping windows
250 
+
251 
+xMapWindow 		:: XWindow -> IO ()
252 
+xMapSubwindows 		:: XWindow -> IO ()
253 
+xUnmapWindow		:: XWindow -> IO ()
254 
+xUnmapSubwindows	:: XWindow -> IO ()
255 
+
256 
+-- destroying windows
257 
+
258 
+xDestroyWindow		:: XWindow -> IO ()
259 
+xDestroySubwindows	:: XWindow -> IO ()
260 
+
261 
+-- pixmaps
262 
+
263 
+xCreatePixmap 		:: XSize 			-- (width,height)
264 
+			-> Int 				-- depth
265 
+			-> XDrawable 			-- drawable
266 
+			-> IO XPixmap
267 
+
268 
+xFreePixmap 		:: XPixmap -> IO ()
269 
+
270 
+xPixmapDisplay		:: XPixmap -> XDisplay
271 
+xPixmapEqual		:: XPixmap -> XPixmap -> Bool
272 
+
273 
+-- GRAPHICS CONTEXTS
274 
+
275 
+xCreateGcontext		:: XDrawable 			-- drawable
276 
+			-> [XGCAttribute] 		-- optional arguments
277 
+			-> IO XGcontext
278 
+
279 
+xUpdateGcontext 	:: XGcontext 			-- old gcontext
280 
+			-> [XGCAttribute] 		-- changes
281 
+			-> IO ()			-- new gcontext
282 
+
283 
+xFreeGcontext		:: XGcontext -> IO ()
284 
+
285 
+xGcontextDisplay	:: XGcontext -> XDisplay
286 
+xGcontextEqual		:: XGcontext -> XGcontext -> Bool
287 
+
288 
+xGcontextId		:: XGcontext -> Int
289 
+
290 
+xQueryBestStipple	:: XSize -> XDrawable -> XSize
291 
+xQueryBestTile		:: XSize -> XDrawable -> XSize
292 
+
293 
+xCopyGcontext		:: XGcontext 			-- source
294 
+			-> XGcontext			-- destination
295 
+			-> IO ()
296 
+
297 
+-- GRAPHICS OPERATIONS
298 
+
299 
+xClearArea 		:: XWindow 			-- window
300 
+			-> XRect 			-- (x,y,width,height)
301 
+			-> Bool 			-- exposure-p
302 
+			-> IO ()
303 
+
304 
+xCopyArea		:: XDrawable 			-- source
305 
+			-> XGcontext 			-- gcontext
306 
+			-> XRect 			-- (src-x,src-y,w,h)
307 
+			-> XDrawable			-- destination
308 
+			-> XPoint 			-- (dest-x,dest-y)
309 
+			-> IO ()
310 
+
311 
+xCopyPlane		:: XDrawable 			-- source
312 
+			-> XGcontext 			-- gcontext
313 
+			-> XPixel 			-- plane
314 
+			-> XRect			-- (src-x,src-y,w,h)
315 
+                        -> XDrawable 			-- destination
316 
+			-> XPoint 			-- (dest-x,dest-y)
317 
+			-> IO ()
318 
+
319 
+xDrawPoint		:: XDrawable 			-- drawable
320 
+			-> XGcontext 			-- gcontext
321 
+			-> XPoint 			-- (x,y)
322 
+			-> IO ()
323 
+
324 
+xDrawPoints		:: XDrawable 			-- drawable
325 
+			-> XGcontext 			-- gcontext
326 
+			-> [XPoint]			-- points
327 
+			-> IO ()
328 
+
329 
+xDrawLine 		:: XDrawable 			-- drawable
330 
+			-> XGcontext 			-- gcontext
331 
+			-> XPoint 			-- (x1,y1)
332 
+			-> XPoint 			-- (x2,y2)
333 
+			-> IO ()
334 
+
335 
+xDrawLines 		:: XDrawable 			-- drawable
336 
+			-> XGcontext 			-- gcontext
337 
+			-> [XPoint] 			-- points
338 
+			-> Bool 			-- fill-p
339 
+			-> IO ()
340 
+
341 
+xDrawSegments		:: XDrawable 			-- drawable
342 
+			-> XGcontext 			-- gcontext
343 
+			-> [(XPoint,XPoint)]		-- segments
344 
+			-> IO ()
345 
+
346 
+xDrawRectangle 		:: XDrawable 			-- drawable
347 
+			-> XGcontext			-- gcontext
348 
+			-> XRect 			-- (x,y,width,height)
349 
+			-> Bool 			-- fill-p
350 
+			-> IO ()
351 
+
352 
+xDrawRectangles 	:: XDrawable 			-- drawable
353 
+			-> XGcontext 			-- gcontext
354 
+			-> [XRect] 			-- rectangles
355 
+			-> Bool 			-- fill-p
356 
+			-> IO ()
357 
+
358 
+xDrawArc		:: XDrawable 			-- drawable
359 
+			-> XGcontext 			-- gcontext
360 
+			-> XArc 			-- (x,y,w,h,a1,a2)
361 
+			-> Bool 			-- fill-p
362 
+			-> IO ()
363 
+
364 
+xDrawArcs		:: XDrawable 			-- drawable
365 
+			-> XGcontext 			-- gcontext
366 
+			-> [XArc] 			-- arcs
367 
+			-> Bool 			-- fill-p
368 
+			-> IO ()
369 
+
370 
+xDrawGlyph		:: XDrawable 			-- drawable
371 
+			-> XGcontext 			-- gcontext
372 
+			-> XPoint 			-- (x,y)
373 
+			-> Char 			-- element
374 
+			-> IO (XMaybe Int)		-- width
375 
+
376 
+xDrawGlyphs		:: XDrawable 			-- drawable
377 
+			-> XGcontext 			-- gcontext
378 
+			-> XPoint 			-- (x,y)
379 
+			-> String			-- sequence
380 
+			-> IO (XMaybe Int)		-- width
381 
+
382 
+xDrawImageGlyph		:: XDrawable 			-- drawable
383 
+			-> XGcontext 			-- gcontext
384 
+			-> XPoint 			-- (x,y)
385 
+			-> Char 			-- element
386 
+			-> IO (XMaybe Int)		-- width
387 
+
388 
+xDrawImageGlyphs	:: XDrawable 			-- drawable
389 
+			-> XGcontext 			-- gcontext
390 
+			-> XPoint 			-- (x,y)
391 
+			-> String 			-- sequence
392 
+			-> IO (XMaybe Int)		-- width
393 
+
394 
+-- IMAGES
395 
+
396 
+xImageBlueMask		:: XImage -> XMaybe XPixel
397 
+xImageDepth 		:: XImage -> Int
398 
+xImageGreenMask		:: XImage -> XMaybe XPixel
399 
+xImageSize		:: XImage -> XSize
400 
+xImageName		:: XImage -> String
401 
+xSetImageName		:: XImage -> String -> IO ()
402 
+xImageRedMask		:: XImage -> XMaybe XPixel
403 
+xImageHotSpot		:: XImage -> XMaybe XPoint
404 
+xSetImageHotSpot	:: XImage -> XPoint -> IO ()
405 
+
406 
+-- XY-format images
407 
+
408 
+xImageXYBitmaps		:: XImage -> IO [XBitmap]
409 
+xSetImageXYBitmaps	:: XImage -> [XBitmap] -> IO ()
410 
+
411 
+-- Z-format images
412 
+
413 
+xImageZBitsPerPixel	:: XImage -> IO Int
414 
+xsetImageZBitsPerPixel	:: XImage -> Int -> IO ()
415 
+xImageZPixarray		:: XImage -> IO XPixarray
416 
+xSetImageZPixarray	:: XImage -> XPixarray -> IO ()
417 
+
418 
+-- image functions
419 
+
420 
+xCreateImage		:: [XImAttribute] -> IO XImage
421 
+xCopyImage		:: XImage 			-- image
422 
+			-> XRect 			-- (x,y,width,height)
423 
+			-> XImageType 			-- result-type
424 
+			-> XImage			-- new-image
425 
+
426 
+xGetImage		:: XDrawable 			-- drawable
427 
+			-> XRect 			-- (x,y,width,height)
428 
+			-> XPixel 			-- plane-mask
429 
+			-> XImageFormat 		-- format
430 
+			-> XImageType 			-- result-type
431 
+			-> IO XImage			-- image
432 
+
433 
+xPutImage		:: XDrawable 			-- drawable
434 
+			-> XGcontext 			-- gcontext
435 
+			-> XImage 			-- ximage
436 
+			-> XPoint 			-- (src-x,src-y)
437 
+			-> XRect			-- (x,y,width,height)
438 
+                        -> IO ()
439 
+
440 
+-- image files
441 
+
442 
+xReadBitmapFile		:: String 			-- pathname
443 
+			-> IO XImage
444 
+
445 
+xWriteBitmapFile	:: String 			-- pathname
446 
+			-> XImage -> IO ()
447 
+
448 
+-- direct image transfer
449 
+
450 
+xGetRawImage		:: XDrawable 			-- drawable
451 
+			-> XRect 			-- (x,y,width,height)
452 
+			-> XPixel 			-- plane-mask
453 
+			-> XImageFormat 		-- format
454 
+			-> IO XImageData		-- data
455 
+
456 
+xPutRawImage		:: XDrawable 			-- drawable
457 
+			-> XGcontext 			-- gcontext
458 
+			-> XImageData 			-- data
459 
+			-> Int 				-- depth
460 
+			-> XRect			-- (x,y,width,height)
461 
+			-> Int 				-- left-pad
462 
+			-> XImageFormat 		-- format
463 
+			-> IO ()
464 
+
465 
+-- FONTS
466 
+
467 
+-- opening fonts
468 
+
469 
+xOpenFont		:: XDisplay -> String -> IO XFont
470 
+xCloseFont		:: XFont -> IO ()
471 
+xDiscardFontInfo	:: XFont -> IO ()
472 
+
473 
+-- listing fonts
474 
+
475 
+xFontPath		:: XDisplay -> IO [String]
476 
+xListFontNames		:: XDisplay -> String 		-- pattern
477 
+			-> IO [String]
478 
+xListFonts		:: XDisplay -> String 		-- pattern
479 
+			-> IO [XFont]
480 
+
481 
+-- font attriburtes
482 
+
483 
+xFontAllCharExistsP	:: XFont -> Bool
484 
+xFontAscent		:: XFont -> Int
485 
+xFontDefaultChar	:: XFont -> Int
486 
+xFontDescent		:: XFont -> Int
487 
+xFontDirection		:: XFont -> XDrawDirection
488 
+xFontDisplay		:: XFont -> XDisplay
489 
+xFontEqual		:: XFont -> XFont -> Int
490 
+xFontId			:: XFont -> Int
491 
+
492 
+xFontMaxByte1		:: XFont -> Int
493 
+xFontMaxByte2		:: XFont -> Int
494 
+xFontMaxChar		:: XFont -> Int
495 
+xFontMinByte1		:: XFont -> Int
496 
+xFontMinByte2		:: XFont -> Int
497 
+xFontMinChar		:: XFont -> Int
498 
+
499 
+xFontName		:: XFont -> String
500 
+
501 
+xFontMaxCharAscent	:: XFont -> Int
502 
+xFontMaxCharAttributes	:: XFont -> Int
503 
+xFontMaxCharDescent	:: XFont -> Int
504 
+xFontMaxCharLeftBearing	:: XFont -> Int
505 
+xFontMaxCharRightBearing	:: XFont -> Int
506 
+xFontMaxCharWidth	:: XFont -> Int
507 
+xFontMinCharAscent	:: XFont -> Int
508 
+xFontMinCharAttributes	:: XFont -> Int
509 
+xFontMinCharDescent	:: XFont -> Int
510 
+xFontMinCharLeftBearing	:: XFont -> Int
511 
+xFontMinCharRightBearing	:: XFont -> Int
512 
+xFontMinCharWidth	:: XFont -> Int
513 
+
514 
+-- char attributes
515 
+
516 
+xCharAscent		:: XFont -> Int -> XMaybe Int
517 
+xCharAttributes		:: XFont -> Int -> XMaybe Int
518 
+xCharDescent		:: XFont -> Int -> XMaybe Int
519 
+xCharLeftBearing	:: XFont -> Int -> XMaybe Int
520 
+xCharRightBearing	:: XFont -> Int -> XMaybe Int
521 
+xCharWidth		:: XFont -> Int -> XMaybe Int
522 
+
523 
+-- querying text size
524 
+
525 
+xTextWidth		:: XFont 			-- font
526 
+			-> String 			-- sequence
527 
+			-> Int				-- width
528 
+
529 
+-- COLORS
530 
+
531 
+-- creating colormaps
532 
+
533 
+xCreateColormap		:: XVisualInfo 			-- visual
534 
+			-> XWindow 			-- window
535 
+			-> Bool 			-- alloc-p
536 
+			-> IO XColormap
537 
+
538 
+xCopyColormapAndFree	:: XColormap -> IO XColormap
539 
+xFreeColormap		:: XColormap -> IO ()
540 
+
541 
+-- installing colormaps
542 
+
543 
+xInstallColormap	:: XColormap -> IO ()
544 
+xInstalledColormaps	:: XWindow -> IO [XColormap]
545 
+xUnInstallColormap	:: XColormap -> IO ()
546 
+
547 
+-- allocating colors
548 
+
549 
+xAllocColor		:: XColormap -> XColor
550 
+			-> IO (XPixel, 			-- pixel
551 
+			       XColor, 			-- screen-color
552 
+			       XColor)			-- exact-color
553 
+
554 
+xAllocColorCells	:: XColormap 			-- pixel
555 
+			-> Int 				-- colors
556 
+			-> Int 				-- planes
557 
+			-> Bool 			-- contiguous
558 
+			-> IO ([XPixel], 		-- pixels
559 
+			       [XPixel])		-- mask
560 
+
561 
+xAllocColorPlanes	:: XColormap 			-- colormap
562 
+			-> Int 				-- colors
563 
+			-> Int 				-- reds
564 
+			-> Int 				-- greens
565 
+			-> Int 				-- blues
566 
+			-> Bool 			-- contiguous-p
567 
+			-> IO ([XPixel], 		-- pixel
568 
+			       XPixel, 			-- red-mask
569 
+			       XPixel, 			-- green-mask
570 
+			       XPixel)			-- blue-mask
571 
+
572 
+xFreeColors		:: XColormap -> [XPixel] 	-- pixels
573 
+			-> XPixel 			-- plane-mask
574 
+			-> IO ()
575 
+
576 
+-- finding colors
577 
+
578 
+xLookupColor		:: XColormap -> String 		-- name
579 
+			-> IO (XColor, 			-- screen-color
580 
+			       XColor)			-- exact-color
581 
+
582 
+xQueryColors		:: XColormap -> [XPixel] 	-- pixels
583 
+			-> IO [XColor]
584 
+
585 
+-- changing colors
586 
+
587 
+xStoreColor		:: XColormap -> XPixel 		-- pixel
588 
+			-> XColor 			-- color
589 
+			-> IO ()
590 
+
591 
+xStoreColors		:: XColormap 			-- colormap
592 
+			-> [(XPixel, XColor)] 		-- pixel-colors
593 
+			-> IO ()
594 
+
595 
+-- colormap attributes
596 
+
597 
+xColormapDisplay	:: XColormap -> XDisplay
598 
+xColormapEqual		:: XColormap -> XColormap -> Bool
599 
+
600 
+-- CURSORS
601 
+
602 
+xCreateCursor		:: XPixmap 			-- source
603 
+			-> (XMaybe XPixmap) 		-- mask
604 
+			-> XPoint 			-- (x,y)
605 
+			-> XColor 			-- foreground
606 
+			-> XColor 			-- background
607 
+			-> IO XCursor
608 
+
609 
+xCreateGlyphCursor	:: (XFont, char) 		-- (src-font,src-char)
610 
+			-> (XMaybe (XFont, Char)) 	-- (mask-font,mask-char)
611 
+			-> XColor			-- foreground
612 
+			-> XColor 			-- background
613 
+			-> IO XCursor
614 
+
615 
+xFreeCursor		:: XCursor -> IO ()
616 
+
617 
+xQueryBestCursor	:: XSize 			-- (width,height)
618 
+			-> XDisplay -> IO XSize
619 
+
620 
+xRecolorCursor		:: XCursor -> XColor 		-- foreground
621 
+			-> XColor 			-- background
622 
+			-> IO ()
623 
+
624 
+xCursorDisplay		:: XCursor -> XDisplay
625 
+xCursorEqual		:: XCursor -> XCursor -> Bool
626 
+
627 
+-- ATOMS, PROPERTIES, AND SELECTIONS
628 
+
629 
+-- atoms
630 
+
631 
+xAtomName		:: XDisplay -> Int 		-- atom-id
632 
+			-> XAtom
633 
+
634 
+xFindAtom		:: XDisplay -> XAtom 		-- atom-name
635 
+			-> IO (XMaybe Int)
636 
+
637 
+xInternAtom		:: XDisplay -> XAtom 		-- atom-name
638 
+			-> IO (XMaybe Int)
639 
+
640 
+-- properties
641 
+
642 
+xChangeProperty		:: XWindow 			-- window
643 
+			-> XAtom 			-- property
644 
+			-> XProperty 			-- (data,type,format)
645 
+			-> IO ()
646 
+
647 
+xDeleteProperty		:: XWindow -> XAtom -> IO ()
648 
+xGetProperty		:: XWindow			-- window
649 
+			-> XAtom 			-- property
650 
+			-> IO XProperty			-- (data,type,format)
651 
+
652 
+xListProperties		:: XWindow -> IO [XAtom]
653 
+xRotateProperties	:: XWindow 			-- window
654 
+			-> [XAtom] 			-- properties
655 
+			-> Int 				-- delta
656 
+			-> IO ()
657 
+
658 
+-- selections
659 
+
660 
+xConvertSelection	:: XAtom 			-- selection
661 
+			-> XAtom 			-- type
662 
+			-> XWindow 			-- requester
663 
+			-> XAtom			-- property
664 
+			-> (XMaybe XTime) 		-- time
665 
+			-> IO ()
666 
+
667 
+xSelectionOwner		:: XDisplay 			-- display
668 
+			-> XAtom 			-- selection
669 
+			-> IO (XMaybe XWindow)
670 
+
671 
+xSetSelectionOwner	:: XDisplay 			-- display
672 
+			-> XAtom 			-- selection
673 
+			-> (XMaybe XTime) 		-- time
674 
+			-> XWindow 			-- owner
675 
+			-> IO ()
676 
+
677 
+-- EVENT
678 
+
679 
+-- Wait for the next event
680 
+
681 
+xGetEvent		:: XDisplay -> IO XEvent
682 
+
683 
+-- managing the event queue
684 
+
685 
+xQueueEvent		:: XDisplay -> XEvent -> Bool	-- append-p
686 
+			-> IO ()
687 
+
688 
+xEventListen		:: XDisplay -> IO Int 		-- # of events in queue
689 
+
690 
+-- sending events
691 
+
692 
+xSendEvent		:: XWindow 			-- window
693 
+			-> XEvent 			-- event key and slots
694 
+			-> XEventMask 			-- event-mask
695 
+			-> IO ()
696 
+
697 
+-- pointer position
698 
+
699 
+xGlobalPointerPosition	:: XDisplay -> IO XPoint
700 
+xPointerPosition	:: XWindow -> IO (XMaybe XPoint)
701 
+xMotionEvents		:: XWindow -> XTime -> XTime -> IO [XPoint]
702 
+xWarpPointer		:: XWindow -> XPoint -> IO ()
703 
+
704 
+-- keyboard input focus
705 
+
706 
+xSetInputFocus		:: XDisplay 			-- display
707 
+			-> XInputFocus 			-- focus
708 
+			-> XInputFocus			-- revert-to
709 
+			-> (XMaybe XTime) 		-- time
710 
+			-> IO ()
711 
+
712 
+xInputFucus		:: XDisplay -> IO (XInputFocus,	-- focus
713 
+					   XInputFocus)	-- revert-to
714 
+
715 
+-- grabbing the pointer
716 
+
717 
+xGrabPointer		:: XWindow 			-- window
718 
+			-> XEventMask			-- event-mask
719 
+			-> [XGrabAttribute] 		-- optional attributes
720 
+			-> XMaybe XTime 		-- time
721 
+			-> IO XGrabStatus
722 
+
723 
+xUngrabPointer		:: XDisplay -> XMaybe XTime -> IO ()
724 
+
725 
+xChangeActivePointerGrab :: XDisplay -> XEventMask 	-- event-mask
726 
+			 -> [XGrabAttribute] 		-- cursor
727 
+			 -> XMaybe XTime -> IO ()
728 
+
729 
+-- grabbing a button
730 
+
731 
+xGrabButton		:: XWindow 			-- window
732 
+			-> Int 				-- button
733 
+			-> XEventMask 			-- event-mask
734 
+			-> XStateMask 			-- modifiers
735 
+			-> [XGrabAttribute]		-- optional attributes
736 
+			-> IO ()
737 
+
738 
+xUngrabButton		:: XWindow -> Int 		-- button
739 
+			-> XStateMask 			-- modifiers
740 
+			-> IO ()
741 
+
742 
+-- grabbing the keyboard
743 
+
744 
+xGrabKeyboard		:: XWindow 			-- window
745 
+			-> [XGrabAttribute] 		-- optional attributes
746 
+			-> XMaybe XTime			-- time
747 
+			-> IO XGrabStatus
748 
+
749 
+xUngrabkeyboard		:: XDisplay -> XMaybe XTime -> IO ()
750 
+
751 
+-- grabbing a key
752 
+
753 
+xGrabKey		:: XWindow 			-- window
754 
+			-> Int 				-- key
755 
+			-> XStateMask			-- modifiers
756 
+			-> [XGrabAttribute] 		-- optional attributes
757 
+			-> IO ()
758 
+
759 
+xUngrabKey		:: XWindow -> Int -> XStateMask -- modifiers
760 
+			-> IO ()
761 
+
762 
+-- CONTROL FUNCTIONS
763 
+
764 
+-- grabbing the server
765 
+
766 
+xGrabServer		:: XDisplay -> IO ()
767 
+xUngrabServer		:: XDisplay -> IO ()
768 
+
769 
+-- pointer control
770 
+
771 
+xSetPointerAcceleration	:: XDisplay -> Float -> IO ()
772 
+xSetPointerThreshold	:: XDisplay -> Float -> IO ()
773 
+xPointerAcceleration	:: XDisplay -> IO Float
774 
+xPointerThreshold	:: XDisplay -> IO Float
775 
+xSetPointerMapping	:: XDisplay -> [Int] -> IO ()
776 
+xPointerMapping		:: XDisplay -> IO [Int]
777 
+
778 
+-- keyboard control
779 
+
780 
+xBell			:: XDisplay -> Int -> IO ()
781 
+
782 
+xSetKeyboardKeyClickPercent	:: XDisplay -> Int -> IO ()
783 
+xSetKeyboardBellPercent		:: XDisplay -> Int -> IO ()
784 
+xSetKeyboardBellPitch		:: XDisplay -> Int -> IO ()
785 
+xSetKeyboardBellDuration	:: XDisplay -> Int -> IO ()
786 
+xSetKeyboardLed			:: XDisplay -> Integer -> IO ()
787 
+xSetKeyboardAutoRepeatMode	:: XDisplay -> XBitVec -> IO ()
788 
+
789 
+xKeyboardKeyClickPercent	:: XDisplay -> IO Int
790 
+xKeyboardBellPercent		:: XDisplay -> IO Int
791 
+xKeyboardBellPitch		:: XDisplay -> IO Int
792 
+xKeyboardBellDuration		:: XDisplay -> IO Int
793 
+
794 
+xKeyboardLed			:: XDisplay -> IO Integer
795 
+xKeyboardAutoRepeatMode		:: XDisplay -> IO XBitVec
796 
+
797 
+xModifierMapping		:: XDisplay -> IO [[Int]]
798 
+xSetModifierMapping		:: XDisplay -> [[Int]] -> IO (XMaybe ())
799 
+xQueryKeymap			:: XDisplay -> IO XBitVec
800 
+
801 
+-- keyboard mapping
802 
+
803 
+xChangeKeyboardMapping 		:: XDisplay 		-- display
804 
+				-> XKeysymTable 	-- keysyms
805 
+				-> IO ()
806 
+
807 
+xKeyboardMapping		:: XDisplay 		-- display
808 
+				-> IO XKeysymTable	-- mappings
809 
+
810 
+xKeycodeKeysym			:: XDisplay 		-- display
811 
+				-> Int 			-- keycode
812 
+				-> Int 			-- keysym-index
813 
+				-> IO XKeysym
814 
+
815 
+xKeysymCharacter		:: XDisplay 		-- display
816 
+				-> XKeysym               -- keysym
817 
+				-> XStateMask		-- state
818 
+				-> IO (XMaybe Char)
819 
+
820 
+xKeycodeCharacter		:: XDisplay 		-- display
821 
+				-> Int                  -- keycode
822 
+				-> XStateMask		-- state
823 
+				-> IO (XMaybe Char)
824 
+
825 
+-- client termination
826 
+
827 
+xAddToSaveSet		:: XWindow -> IO ()
828 
+xCloseDownMode		:: XDisplay -> IO XCloseDownMode
829 
+xSetCloseDownMode	:: XDisplay -> XCloseDownMode -> IO ()
830 
+xKillClient		:: XDisplay -> Int -> IO ()
831 
+xKillTemporaryClients	:: XDisplay -> IO ()
832 
+xRemoveFromSaveSet	:: XWindow -> IO ()
833 
+
834 
+-- managing host access
835 
+
836 
+xAccessControl		:: XDisplay -> IO Bool
837 
+xSetAccessControl	:: XDisplay -> Bool -> IO ()
838 
+xAccessHosts		:: XDisplay -> IO [String]
839 
+xAddAccessHost		:: XDisplay -> String -> IO ()
840 
+xRemoveAccessHost	:: XDisplay -> String -> IO ()
841 
+
842 
+-- screen saver
843 
+
844 
+xActivateScreenSaver	:: XDisplay -> IO ()
845 
+xResetScreenSaver	:: XDisplay -> IO ()
846 
+
847 
+xScreenSaver		:: XDisplay -> IO XScreenSaver
848 
+xSetScreenSaver		:: XDisplay -> XScreenSaver -> IO ()
849 
+
850 
+{-#
851 
+
852 
+
853 
+xHandleError		:: LispName("x-handle-error")
854 
+xError			:: LispName("xlib::x-error")
855 
+
856 
+xEventType 		:: LispName("sel-event-type")
857 
+
858 
+xEventWindow 		:: LispName ("x-event-window")
859 
+xEventEventWindow	:: LispName ("x-event-event-window")
860 
+xEventCode		:: LispName ("x-event-code")
861 
+xEventPos		:: LispName ("x-event-pos")
862 
+xEventState		:: LispName ("x-event-state")
863 
+xEventTime		:: LispName ("x-event-time")
864 
+xEventRoot		:: LispName ("x-event-root")
865 
+xEventRootPos		:: LispName ("x-event-root-pos")
866 
+xEventChild		:: LispName ("x-event-child")
867 
+xEventSameScreenP	:: LispName ("x-event-same-screen-p")
868 
+xEventHintP		:: LispName ("x-event-hint-p")
869 
+xEventMode		:: LispName ("x-event-mode")
870 
+xEventKind		:: LispName ("x-event-kind")
871 
+xEventFocusP		:: LispName ("x-event-focus-p")
872 
+xEventKeymap		:: LispName ("x-event-keymap")
873 
+xEventRequest		:: LispName ("x-event-request")
874 
+xEventStart		:: LispName ("x-event-start")
875 
+xEventCount		:: LispName ("x-event-count")
876 
+xEventRect		:: LispName ("x-event-rect")
877 
+xEventDrawable		:: LispName ("x-event-drawable")
878 
+xEventXGraphFun		:: LispName ("x-event-graph-fun")
879 
+xEventPlace		:: LispName ("x-event-place")
880 
+xEventBorderWidth	:: LispName ("x-event-border-width")
881 
+xEventAboveSibling	:: LispName ("x-event-above-sibling")
882 
+xEventOverrideRedirectP	:: LispName ("x-event-override-redirect-p")
883 
+xEventParent		:: LispName ("x-event-parent")
884 
+xEventConfigureP	:: LispName ("x-event-configure-p")
885 
+xEventVisibility	:: LispName ("x-event-state")
886 
+xEventNewP		:: LispName ("x-event-new-p")
887 
+xEventInstalledP	:: LispName ("x-event-installed-p")
888 
+xEventStackMode		:: LispName ("x-event-stack-mode")
889 
+xEventValueMask		:: LispName ("x-event-value-mask")
890 
+xEventSize		:: LispName ("x-event-size")
891 
+xEventMessage		:: LispName ("x-event-message")
892 
+xEventPropertyState	:: LispName ("x-event-state")
893 
+xEventAtom		:: LispName ("x-event-atom")
894 
+xEventSelection		:: LispName ("x-event-selection")
895 
+xEventTarget		:: LispName ("x-event-target")
896 
+xEventProperty		:: LispName ("x-event-property")
897 
+xEventRequestor		:: LispName ("x-event-requestor")
898 
+
899 
+
900 
+xSetEventMaskKey 	:: LispName ("x-set-event-mask-key")
901 
+xClearEventMaskKey 	:: LispName ("x-clear-event-mask-key")
902 
+xTestEventMaskKey 	:: LispName ("x-test-event-mask-key")
903 
+
904 
+xSetStateMaskKey 	:: LispName ("x-set-state-mask-key")
905 
+xClearStateMaskKey 	:: LispName ("x-clear-state-mask-key")
906 
+xTestStateMaskKey 	:: LispName ("x-test-state-mask-key")
907 
+
908 
+-- DISPLAYS
909 
+
910 
+-- open
911 
+
912 
+xOpenDisplay      		:: LispName("x-open-display")
913 
+
914 
+-- display attributes
915 
+
916 
+xDisplayAuthorizationData	:: LispName("xlib:display-authorization-data")
917 
+xDisplayAuthorizationName	:: LispName("xlib:display-authorization-name")
918 
+xDisplayBitmapFormat		:: LispName("xlib:display-bitmap-format")
919 
+xDisplayByteOrder		:: LispName("xlib:display-byte-order")
920 
+xDisplayDisplay           	:: LispName("xlib:display-display")
921 
+xSetDisplayErrorHandler		:: LispName("x-set-display-error-handler")
922 
+xDisplayImageLsbFirstP		:: LispName("xlib:display-image-lsb-first-p")
923 
+xDisplayMaxKeycode		:: LispName("xlib:display-max-keycode")
924 
+xDisplayMaxRequestLength	:: LispName("xlib:display-max-request-length")
925 
+xDisplayMinKeycode		:: LispName("xlib:display-min-keycode")
926 
+xDisplayMotionBufferSize	:: LispName("xlib:display-motion-buffer-size")
927 
+xDisplayPixmapFormats		:: LispName("xlib:display-pixmap-formats")
928 
+xDisplayProtocolMajorVersion :: LispName("xlib:display-protocol-major-version")
929 
+xDisplayProtocolMinorVersion :: LispName("xlib:display-protocol-minor-version")
930 
+xDisplayResourceIdBase		:: LispName("xlib:display-resource-id-base")
931 
+xDisplayResourceIdMask		:: LispName("xlib:display-resource-id-mask")
932 
+xDisplayRoots     		:: LispName("xlib:display-roots")
933 
+xDisplayVendorName		:: LispName("xlib:display-vendor-name")
934 
+xDisplayReleaseNumber		:: LispName("xlib:display-release-number")
935 
+
936 
+-- output buffer
937 
+
938 
+xDisplayAfterFunction    	:: LispName("xlib:display-after-function")
939 
+xSetDisplayAfterFunction    	:: LispName("x-set-display-after-function")
940 
+xDisplayForceOutput      	:: LispName("xlib:display-force-output")
941 
+xDisplayFinishOutput      	:: LispName("xlib:display-finish-output")
942 
+
943 
+-- close
944 
+
945 
+xCloseDisplay     		:: LispName("xlib:close-display")
946 
+
947 
+-- SCREENS
948 
+
949 
+xScreenBackingStores		:: LispName("xlib:screen-backing-stores")
950 
+xScreenBlackPixel		:: LispName("xlib:screen-black-pixel")
951 
+xScreenDefaultColormap		:: LispName("xlib:screen-default-colormap")
952 
+xScreenDepths			:: LispName("x-screen-depths")
953 
+xScreenEventMaskAtOpen		:: LispName("xlib:screen-event-mask-at-open")
954 
+xScreenSize			:: LispName("x-screen-size")
955 
+xScreenMMSize                   :: LispName("x-screen-mmsize")
956 
+xScreenMaxInstalledMaps		:: LispName("xlib:screen-max-installed-maps")
957 
+xScreenMinInstalledMaps		:: LispName("xlib:screen-min-installed-maps")
958 
+xScreenRoot                     :: LispName("xlib:screen-root")
959 
+xScreenRootDepth		:: LispName("xlib:screen-root-depth")
960 
+xScreenRootVisual		:: LispName("xlib:screen-root-visual")
961 
+xScreenSaveUndersP		:: LispName("xlib:screen-save-unders-p")
962 
+xScreenWhitePixel 		:: LispName("xlib:screen-white-pixel")
963 
+
964 
+-- WINDOWS AND PIXMAPS
965 
+
966 
+-- drawables
967 
+
968 
+xDrawableDisplay	:: LispName("xlib:drawable-display")
969 
+xDrawableEqual		:: LispName("xlib:drawable-equal")
970 
+xDrawableId		:: LispName("xlib:drawable-id")
971 
+
972 
+-- creating windows
973 
+
974 
+xCreateWindow           :: LispName("x-create-window")
975 
+
976 
+-- window attributes
977 
+
978 
+xWindowBorderWidth      :: LispName("xlib:drawable-border-width")
979 
+xSetWindowBorderWidth   :: LispName("x-set-drawable-border-width")
980 
+
981 
+xDrawableDepth		:: LispName("xlib:drawable-depth")
982 
+
983 
+xDrawableSize           :: LispName("x-drawable-size")
984 
+xDrawableResize         :: LispName("x-drawable-resize")
985 
+
986 
+xWindowPos              :: LispName("x-window-pos")
987 
+xWindowMove             :: LispName("x-window-move")
988 
+
989 
+xWindowAllEventMasks	:: LispName("xlib:window-all-event-masks")
990 
+
991 
+xSetWindowBackground    :: LispName("x-set-window-background")
992 
+
993 
+xWindowBackingPixel     :: LispName("xlib:window-backing-pixel")
994 
+xSetWindowBackingPixel  :: LispName("x-set-window-backing-pixel")
995 
+
996 
+xWindowBackingPlanes    :: LispName("xlib:window-backing-planes")
997 
+xSetWindowBackingPlanes :: LispName("x-set-window-backing-planes")
998 
+
999 
+xWindowBackingStore     :: LispName("xlib:window-backing-store")
1000 
+xSetWindowBackingStore  :: LispName("x-set-window-backing-store")
1001 
+
1002 
+xWindowBitGravity	:: LispName("xlib:window-bit-gravity")
1003 
+xSetWindowBitGravity	:: LispName("x-set-window-bit-gravity")
1004 
+
1005 
+xSetWindowBorder        :: LispName("x-set-window-border")
1006 
+
1007 
+xWindowClass            :: LispName("xlib:window-class")
1008 
+
1009 
+xWindowColorMap         :: LispName("xlib:window-colormap")
1010 
+xSetWindowColorMap      :: LispName("x-set-window-colormap")
1011 
+xWindowColormapInstalledP :: LispName("xlib:window-colormap-installed-p")
1012 
+
1013 
+xSetWindowCursor        :: LispName("x-set-window-cursor")
1014 
+
1015 
+xWindowDisplay          :: LispName("xlib:window-display")
1016 
+
1017 
+xWindowDoNotPropagateMask    :: LispName("xlib:window-do-not-propagate-mask")
1018 
+xSetWindowDoNotPropagateMask :: LispName("x-set-window-do-not-propagate-mask")
1019 
+
1020 
+xWindowEqual		:: LispName("xlib:window-equal")
1021 
+
1022 
+xWindowEventMask	:: LispName("xlib:window-event-mask")
1023 
+xSetWindowEventMask	:: LispName("x-set-window-event-mask")
1024 
+
1025 
+xWindowGravity		:: LispName("xlib:window-gravity")
1026 
+xSetWindowGravity	:: LispName("x-set-window-gravity")
1027 
+
1028 
+xWindowId		:: LispName("xlib:window-id")
1029 
+
1030 
+xWindowMapState		:: LispName("xlib:window-map-state")
1031 
+
1032 
+xWindowOverrideRedirect		:: LispName("xlib:window-override-redirect")
1033 
+xSetWindowOverrideRedirect	:: LispName("x-set-window-override-redirect")
1034 
+
1035 
+xSetWindowPriority	:: LispName("x-set-window-priority")
1036 
+
1037 
+xWindowSaveUnder	:: LispName("xlib:window-save-under")
1038 
+xSetWindowSaveUnder	:: LispName("x-set-window-save-under")
1039 
+xWindowVisual		:: LispName("xlib:window-visual")
1040 
+
1041 
+-- stacking order
1042 
+
1043 
+xCirculateWindowDown	:: LispName("xlib:circulate-window-down")
1044 
+xCirculateWindowUp	:: LispName("xlib:circulate-window-up")
1045 
+
1046 
+-- window hierarchy
1047 
+
1048 
+xDrawableRoot		:: LispName("xlib:drawable-root")
1049 
+xQueryTree		:: LispName("x-query-tree")
1050 
+
1051 
+xReparentWindow		:: LispName("x-reparent-window")
1052 
+
1053 
+xTranslateCoordinates	:: LispName("x-translate-coordinates")
1054 
+
1055 
+-- mapping windows
1056 
+
1057 
+xMapWindow              :: LispName("xlib:map-window")
1058 
+xMapSubwindows          :: LispName("xlib:map-subwindows")
1059 
+xUnmapWindow		:: LispName("xlib:unmap-window")
1060 
+xUnmapSubwindows	:: LispName("xlib:unmap-subwindows")
1061 
+
1062 
+-- destroying windows
1063 
+
1064 
+xDestroyWindow		:: LispName("xlib:destroy-window")
1065 
+xDestroySubwindows	:: LispName("xlib:destroy-subwindows")
1066 
+
1067 
+-- pixmaps
1068 
+
1069 
+xCreatePixmap           :: LispName("x-create-pixmap")
1070 
+xFreePixmap             :: LispName("xlib:free-pixmap")
1071 
+xPixmapDisplay		:: LispName("xlib:pixmap-display")
1072 
+xPixmapEqual		:: LispName("xlib:pixmap-equal")
1073 
+
1074 
+-- GRAPHICS CONTEXTS
1075 
+
1076 
+xCreateGcontext   	:: LispName("x-create-gcontext")
1077 
+xUpdateGcontext	  	:: LispName("x-update-gcontext")
1078 
+xFreeGcontext     	:: LispName("xlib:free-gcontext")
1079 
+
1080 
+xGcontextDisplay	:: LispName("xlib:gcontext-display")
1081 
+xGcontextEqual		:: LispName("xlib:gcontext-equal")
1082 
+
1083 
+xGcontextId		:: LispName("xlib:gcontext-id")
1084 
+
1085 
+xQueryBestStipple	:: LispName("x-query-best-stipple")
1086 
+xQueryBestTile		:: LispName("x-query-best-tile")
1087 
+
1088 
+xCopyGcontext		:: LispName("xlib:copy-gcontext")
1089 
+
1090 
+-- GRAPHICS OPERATIONS
1091 
+
1092 
+xClearArea		:: LispName("x-clear-area")
1093 
+xCopyArea		:: LispName("x-copy-area")
1094 
+xCopyPlane		:: LispName("x-copy-plane")
1095 
+xDrawPoint		:: LispName("x-draw-point")
1096 
+xDrawPoints		:: LispName("x-draw-points")
1097 
+xDrawLine		:: LispName("x-draw-line")
1098 
+xDrawLines		:: LispName("x-draw-lines")
1099 
+xDrawSegments		:: LispName("x-draw-segments")
1100 
+xDrawRectangle		:: LispName("x-draw-rectangle")
1101 
+xDrawRectangles		:: LispName("x-draw-rectangles")
1102 
+xDrawArc		:: LispName("x-draw-arc")
1103 
+xDrawArcs		:: LispName("x-draw-arcs")
1104 
+xDrawGlyph		:: LispName("x-draw-glyph")
1105 
+xDrawGlyphs		:: LispName("x-draw-glyphs")
1106 
+xDrawImageGlyph		:: LispName("x-draw-image-glyph")
1107 
+xDrawImageGlyphs	:: LispName("x-draw-image-glyphs")
1108 
+
1109 
+-- IMAGES
1110 
+
1111 
+xImageBlueMask		:: LispName("xlib:image-blue-mask")
1112 
+xImageDepth 		:: LispName("xlib:image-depth")
1113 
+xImageGreenMask		:: LispName("xlib:image-green-mask")
1114 
+xImageSize		:: LispName("x-image-size")
1115 
+xImageName		:: LispName("x-image-name")
1116 
+xSetImageName		:: LispName("x-set-image-name")
1117 
+xImageRedMask		:: LispName("xlib:image-red-mask")
1118 
+xImageHotSpot		:: LispName("x-image-hot-spot")
1119 
+xSetImageHotSpot	:: LispName("x-set-image-hot-spot")
1120 
+
1121 
+-- XY-format images
1122 
+
1123 
+xImageXYBitmaps		:: LispName("xlib:image-xy-bitmap-list")
1124 
+xSetImageXYBitmaps	:: LispName("x-set-image-xy-bitmap-list")
1125 
+
1126 
+-- Z-format images
1127 
+
1128 
+xImageZBitsPerPixel	:: LispName("xlib:image-z-bits-per-pixel")
1129 
+xsetImageZBitsPerPixel	:: LispName("x-set-image-z-bits-per-pixel")
1130 
+xImageZPixarray		:: LispName("xlib:image-z-pixarray")
1131 
+xSetImageZPixarray	:: LispName("x-set-image-z-pixarray")
1132 
+
1133 
+-- image functions
1134 
+
1135 
+xCreateImage		:: LispName("x-create-image")
1136 
+xCopyImage		:: LispName("x-copy-image")
1137 
+xGetImage		:: LispName("x-get-image")
1138 
+xPutImage		:: LispName("x-put-image")
1139 
+
1140 
+-- image files
1141 
+
1142 
+xReadBitmapFile		:: LispName("xlib:read-bitmap-file")
1143 
+xWriteBitmapFile	:: LispName("xlib:write-bitmap-file")
1144 
+
1145 
+-- direct image transfer
1146 
+
1147 
+xGetRawImage		:: LispName("x-get-raw-image")
1148 
+xPutRawImage		:: LispName("x-put-raw-image")
1149 
+
1150 
+-- FONTS
1151 
+
1152 
+-- opening fonts
1153 
+
1154 
+xOpenFont		:: LispName ("xlib:open-font")
1155 
+xCloseFont		:: LispName ("xlib:close-font")
1156 
+xDiscardFontInfo	:: LispName ("xlib:discard-font-info")
1157 
+
1158 
+-- listing fonts
1159 
+
1160 
+xFontPath		:: LispName ("xlib:font-path")
1161 
+xListFontNames		:: LispName ("xlib:list-font-names")
1162 
+xListFonts		:: LispName ("xlib:list-fonts")
1163 
+
1164 
+-- font attriburtes
1165 
+
1166 
+xFontAllCharExistsP	:: LispName ("xlib:font-all-chars-exist-p")
1167 
+xFontAscent		:: LispName ("xlib:font-ascent")
1168 
+xFontDefaultChar	:: LispName ("xlib:font-default-char")
1169 
+xFontDescent		:: LispName ("xlib:font-descent")
1170 
+xFontDirection		:: LispName ("xlib:font-direction")
1171 
+xFontDisplay		:: LispName ("xlib:font-display")
1172 
+xFontEqual		:: LispName ("xlib:font-equal")
1173 
+xFontId			:: LispName ("xlib:font-id")
1174 
+
1175 
+xFontMaxByte1		:: LispName ("xlib:font-max-byte1")
1176 
+xFontMaxByte2		:: LispName ("xlib:font-max-byte2")
1177 
+xFontMaxChar		:: LispName ("xlib:font-max-char")
1178 
+xFontMinByte1		:: LispName ("xlib:font-min-byte1")
1179 
+xFontMinByte2		:: LispName ("xlib:font-min-byte2")
1180 
+xFontMinChar		:: LispName ("xlib:font-min-char")
1181 
+
1182 
+xFontName		:: LispName ("x-font-name")
1183 
+
1184 
+xFontMaxCharAscent	:: LispName ("xlib:max-char-ascent")
1185 
+xFontMaxCharAttributes	:: LispName ("xlib:max-char-attributes")
1186 
+xFontMaxCharDescent	:: LispName ("xlib:max-char-descent")
1187 
+xFontMaxCharLeftBearing	:: LispName ("xlib:max-char-left-bearing")
1188 
+xFontMaxCharRightBearing	:: LispName ("xlib:max-char-right-bearing")
1189 
+xFontMaxCharWidth	:: LispName ("xlib:max-char-width")
1190 
+xFontMinCharAscent	:: LispName ("xlib:min-char-ascent")
1191 
+xFontMinCharAttributes	:: LispName ("xlib:min-char-attributes")
1192 
+xFontMinCharDescent	:: LispName ("xlib:min-char-descent")
1193 
+xFontMinCharLeftBearing	:: LispName ("xlib:min-char-left-bearing")
1194 
+xFontMinCharRightBearing	:: LispName ("xlib:min-char-right-bearing")
1195 
+xFontMinCharWidth	:: LispName ("xlib:min-char-width")
1196 
+
1197 
+-- char attributes
1198 
+
1199 
+xCharAscent		:: LispName ("xlib:char-ascent")
1200 
+xCharAttributes		:: LispName ("xlib:char-attributes")
1201 
+xCharDescent		:: LispName ("xlib:char-descent")
1202 
+xCharLeftBearing	:: LispName ("xlib:char-left-bearing")
1203 
+xCharRightBearing	:: LispName ("xlib:char-right-bearing")
1204 
+xCharWidth		:: LispName ("xlib:char-width")
1205 
+
1206 
+-- querying text size
1207 
+
1208 
+xTextWidth		:: LispName ("xlib:text-width")
1209 
+
1210 
+-- COLORS
1211 
+
1212 
+-- creating colormaps
1213 
+
1214 
+xCreateColormap		:: LispName ("xlib:create-colormap")
1215 
+xCopyColormapAndFree	:: LispName ("xlib:copy-colormap-and-free")
1216 
+xFreeColormap		:: LispName ("xlib:free-colormap")
1217 
+
1218 
+-- installing colormaps
1219 
+
1220 
+xInstallColormap	:: LispName ("xlib:install-colormap")
1221 
+xInstalledColormaps	:: LispName ("xlib:installed-colormaps")
1222 
+xUnInstallColormap	:: LispName ("xlib:uninstall-colormap")
1223 
+
1224 
+-- allocating colors
1225 
+
1226 
+xAllocColor		:: LispName ("x-alloc-color")
1227 
+xAllocColorCells	:: LispName ("x-alloc-color-cells")
1228 
+xAllocColorPlanes	:: LispName ("x-alloc-color-planes")
1229 
+
1230 
+xFreeColors		:: LispName ("xlib:free-colors")
1231 
+
1232 
+-- finding colors
1233 
+
1234 
+xLookupColor		:: LispName ("x-lookup-color")
1235 
+xQueryColors		:: LispName ("xlib:query-colors")
1236 
+
1237 
+-- changing colors
1238 
+
1239 
+xStoreColor		:: LispName ("xlib:store-color")
1240 
+xStoreColors		:: LispName ("x-store-colors")
1241 
+
1242 
+-- colormap attributes
1243 
+
1244 
+xColormapDisplay	:: LispName ("xlib:colormap-display")
1245 
+xColormapEqual		:: LispName ("xlib:colormap-equal")
1246 
+
1247 
+-- CURSORS
1248 
+
1249 
+xCreateCursor		:: LispName ("x-create-cursor")
1250 
+xCreateGlyphCursor	:: LispName ("x-create-glyph-cursor")
1251 
+xFreeCursor		:: LispName ("xlib:free-cursor")
1252 
+
1253 
+xQueryBestCursor	:: LispName ("x-query-best-cursor")
1254 
+xRecolorCursor		:: LispName ("xlib:recolor-cursor")
1255 
+
1256 
+xCursorDisplay		:: LispName ("xlib:cursor-display")
1257 
+xCursorEqual		:: LispName ("xlib:cursor-equal")
1258 
+
1259 
+-- ATOMS, PROPERTIES, AND SELECTIONS
1260 
+
1261 
+-- atoms
1262 
+
1263 
+xAtomName		:: LispName ("xlib:atom-name")
1264 
+xFindAtom		:: LispName ("xlib:find-atom")
1265 
+xInternAtom		:: LispName ("xlib:intern-atom")
1266 
+
1267 
+-- properties
1268 
+
1269 
+xChangeProperty		:: LispName ("x-change-property")
1270 
+xDeleteProperty		:: LispName ("xlib:delete-property")
1271 
+xGetProperty		:: LispName ("x-get-property")
1272 
+xListProperties		:: LispName ("xlib:list-properties")
1273 
+xRotateProperties	:: LispName ("xlib:rotate-properties")
1274 
+
1275 
+-- selections
1276 
+
1277 
+xConvertSelection	:: LispName ("x-convert-selection")
1278 
+xSelectionOwner		:: LispName ("xlib:selection-owner")
1279 
+xSetSelectionOwner	:: LispName ("x-set-selection-owner")
1280 
+
1281 
+-- EVENT
1282 
+
1283 
+-- Wait for the next event
1284 
+
1285 
+xGetEvent		:: LispName ("x-get-event")
1286 
+
1287 
+-- managing the event queue
1288 
+
1289 
+xQueueEvent		:: LispName ("x-queue-event")
1290 
+xEventListen		:: LispName ("x-event-listen")
1291 
+
1292 
+-- sending events
1293 
+
1294 
+xSendEvent		:: LispName ("x-send-event")
1295 
+
1296 
+-- pointer position
1297 
+
1298 
+xGlobalPointerPosition	:: LispName ("x-global-pointer-position")
1299 
+xPointerPosition	:: LispName ("x-pointer-position")
1300 
+xMotionEvents		:: LispName ("x-motion-events")
1301 
+xWarpPointer		:: LispName ("x-warp-pointer")
1302 
+
1303 
+-- keyboard input focus
1304 
+
1305 
+xSetInputFocus		:: LispName ("x-set-input-focus")
1306 
+xInputFucus		:: LispName ("x-input-focus")
1307 
+
1308 
+-- grabbing the pointer
1309 
+
1310 
+xGrabPointer		:: LispName ("x-grab-pointer")
1311 
+xUngrabPointer		:: LispName ("x-ungrab-pointer")
1312 
+xChangeActivePointerGrab :: LispName ("x-change-active-pointer-grab")
1313 
+
1314 
+-- grabbing a button
1315 
+
1316 
+xGrabButton		:: LispName ("x-grab-button")
1317 
+xUngrabButton		:: LispName ("x-ungrab-button")
1318 
+
1319 
+-- grabbing the keyboard
1320 
+
1321 
+xGrabKeyboard		:: LispName ("x-grab-keyboard")
1322 
+xUngrabkeyboard		:: LispName ("x-ungrab-keyboard")
1323 
+
1324 
+-- grabbing a key
1325 
+
1326 
+xGrabKey		:: LispName ("x-grab-key")
1327 
+xUngrabKey		:: LispName ("x-ungrab-key")
1328 
+
1329 
+-- CONTROL FUNCTIONS
1330 
+
1331 
+-- grabbing the server
1332 
+
1333 
+xGrabServer		:: LispName ("xlib:grab-server")
1334 
+xUngrabServer		:: LispName ("xlib:ungrab-server")
1335 
+
1336 
+-- pointer control
1337 
+
1338 
+xSetPointerAcceleration	:: LispName ("x-set-pointer-acceleration")
1339 
+xSetPointerThreshold	:: LispName ("x-set-pointer-threshold")
1340 
+xPointerAcceleration	:: LispName ("x-pointer-acceleration")
1341 
+xPointerThreshold	:: LispName ("x-pointer-threshold")
1342 
+xSetPointerMapping	:: LispName ("x-set-pointer-mapping")
1343 
+xPointerMapping		:: LispName ("xlib:pointer-mapping")
1344 
+
1345 
+-- keyboard control
1346 
+
1347 
+xBell			:: LispName ("xlib:bell")
1348 
+
1349 
+xSetKeyboardKeyClickPercent 	:: LispName ("x-set-keyboard-key-click-percent")
1350 
+xSetKeyboardBellPercent	    	:: LispName ("x-set-keyboard-bell-percent")
1351 
+xSetKeyboardBellPitch	    	:: LispName ("x-set-keyboard-bell-pitch")
1352 
+xSetKeyboardBellDuration    	:: LispName ("x-set-keyboard-bell-duration")
1353 
+xSetKeyboardLed		    	:: LispName ("x-set-keyboard-led")
1354 
+xSetKeyboardAutoRepeatMode  	:: LispName ("x-set-keyboard-auto-repeat-mode")
1355 
+
1356 
+xKeyboardKeyClickPercent	:: LispName ("x-keyboard-key-click-percent")
1357 
+xKeyboardBellPercent		:: LispName ("x-keyboard-bell-percent")
1358 
+xKeyboardBellPitch		:: LispName ("x-keyboard-bell-pitch")
1359 
+xKeyboardBellDuration		:: LispName ("x-keyboard-bell-duration")
1360 
+xKeyboardLed			:: LispName ("x-keyboard-led")
1361 
+xKeyboardAutoRepeatMode		:: LispName ("x-keyboard-auto-repeat-mode")
1362 
+
1363 
+xModifierMapping		:: LispName ("x-modifier-mapping")
1364 
+xSetModifierMapping		:: LispName ("x-set-modifier-mapping")
1365 
+xQueryKeymap			:: LispName ("xlib:query-keymap")
1366 
+
1367 
+-- keyboard mapping
1368 
+
1369 
+xChangeKeyboardMapping 		:: LispName ("xlib:change-keyboard-mapping")
1370 
+xKeyboardMapping		:: LispName ("xlib:keyboard-mapping")
1371 
+
1372 
+xKeycodeKeysym			:: LispName ("xlib:keycode->keysym")
1373 
+xKeysymCharacter		:: LispName ("x-keysym-character")
1374 
+xKeycodeCharacter		:: LispName ("x-keycode-character")
1375 
+
1376 
+-- client termination
1377 
+
1378 
+xAddToSaveSet		:: LispName ("xlib:add-to-save-set")
1379 
+xCloseDownMode		:: LispName ("xlib:close-down-mode")
1380 
+xSetCloseDownMode	:: LispName ("x-set-close-down-mode")
1381 
+xKillClient		:: LispName ("xlib:kill-client")
1382 
+xKillTemporaryClients	:: LispName ("xlib:kill-temporary-clients")
1383 
+xRemoveFromSaveSet	:: LispName ("xlib:remove-from-save-set")
1384 
+
1385 
+-- managing host access
1386 
+
1387 
+xAccessControl		:: LispName ("xlib:access-control")
1388 
+xSetAccessControl	:: LispName ("x-set-access-control")
1389 
+xAccessHosts		:: LispName ("xlib:access-hosts")
1390 
+xAddAccessHost		:: LispName ("xlib:add-access-host")
1391 
+xRemoveAccessHost	:: LispName ("xlib:remove-access-host")
1392 
+
1393 
+-- screen saver
1394 
+
1395 
+xActivateScreenSaver	:: LispName ("xlib:activate-screen-saver")
1396 
+xResetScreenSaver	:: LispName ("xlib:reset-screen-saver")
1397 
+xScreenSaver		:: LispName ("x-screen-saver")
1398 
+xSetScreenSaver		:: LispName ("x-set-screen-saver")
1399 
+
1400 
+#-}
1401 
+
1402 
+data XMArray a
1403 
+
1404 
+xMArrayCreate     :: [a] -> IO (XMArray a)
1405 
+xMArrayLookup     :: XMArray a -> Int -> IO a
1406 
+xMArrayUpdate     :: XMArray a -> Int -> a -> IO ()
1407 
+xMArrayLength     :: XMArray a -> Int
1408 
+
1409 
+{-#
1410 
+xMArrayCreate     :: LispName("x-mutable-array-create")
1411 
+xMArrayLookup     :: LispName("x-mutable-array-lookup")
1412 
+xMArrayUpdate     :: LispName("x-mutable-array-update")
1413 
+xMArrayLength     :: LispName("x-mutable-array-length")
1414 
+#-}
1415 
+
1416 
+
1417 
+xprint			:: a -> IO ()
1418 
+{-#
1419 
+xprint			:: LispName ("x-print")
1420 
+#-}
1421 
+
1422 
+-- decoded time format:
1423 
+-- ([second, minute, hour, date, month, year, day-of-week],
1424 
+--  daylight-saving-time-p)
1425 
+-- time format to encode:
1426 
+-- [second, minute, hour, date, month, year]
1427 
+
1428 
+data TimeZone	= WestOfGMT Int {-# STRICT #-}
1429 
+		| CurrentZone
1430 
+
1431 
+getTime		:: IO Integer
1432 
+getTimeZone	:: IO Int
1433 
+decodeTime	:: Integer -> TimeZone -> ([Int], Bool)
1434 
+encodeTime	:: [Int] -> TimeZone -> Integer
1435 
+getRunTime	:: IO Float
1436 
+getElapsedTime	:: IO Float
1437 
+sleep		:: Int -> IO ()
1438 
+
1439 
+{-#
1440 
+ImportLispType (TimeZone (WestOfGMT ("number?", "identity", "identity")))
1441 
+ImportLispType (TimeZone (CurrentZone ("null?", "'()")))
1442 
+
1443 
+getTime		:: LispName("lisp:get-universal-time")
1444 
+getTimeZone	:: LispName("get-time-zone")
1445 
+decodeTime	:: LispName("decode-time")
1446 
+encodeTime	:: LispName("encode-time")
1447 
+getRunTime	:: LispName("get-run-time")
1448 
+getElapsedTime	:: LispName("get-elapsed-time")
1449 
+sleep		:: LispName("lisp:sleep")
1450 
+
1451 
+#-}
1452 
+
1453 
+xWmName 		:: XWindow -> IO String
1454 
+xSetWmName		:: XWindow -> String -> IO ()
1455 
+
1456 
+xWmIconName		:: XWindow -> IO String
1457 
+xSetWmIconName		:: XWindow -> String -> IO ()
1458 
+
1459 
+{-#
1460 
+xWmName 		:: LispName ("xlib:wm-name")
1461 
+xSetWmName		:: LispName ("x-set-wm-name")
1462 
+
1463 
+xWmIconName		:: LispName ("xlib:wm-icon-name")
1464 
+xSetWmIconName		:: LispName ("x-set-wm-icon-name")
1465 
+#-}
progs/lib/X11/xlibprims.hu
History View file @ 4e98702
0 1466 
new file mode 100644
... ... 
@@ -0,0 +1,5 @@
1 
+:output $LIBRARYBIN/
2 
+:stable
3 
+:o= all
4 
+xlibclx.scm
5 
+xlibprims.hi
progs/lib/cl/README
History View file @ 4e98702
0 6 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+This directory contains some libraries which allow you to use various
2 
+Common Lisp primitives from Haskell.
progs/lib/cl/logop-prims.hi
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,78 @@
1 
+-- logop-prims.hi -- interface to logical operations on numbers
2 
+--
3 
+-- author :  Sandra Loosemore
4 
+-- date   :  19 June 1993
5 
+--
6 
+
7 
+interface LogOpPrims where
8 
+
9 
+logiorInteger		:: Integer -> Integer -> Integer
10 
+logxorInteger		:: Integer -> Integer -> Integer
11 
+logandInteger		:: Integer -> Integer -> Integer
12 
+logeqvInteger		:: Integer -> Integer -> Integer
13 
+lognandInteger		:: Integer -> Integer -> Integer
14 
+lognorInteger		:: Integer -> Integer -> Integer
15 
+logandc1Integer		:: Integer -> Integer -> Integer
16 
+logandc2Integer		:: Integer -> Integer -> Integer
17 
+logorc1Integer		:: Integer -> Integer -> Integer
18 
+logorc2Integer		:: Integer -> Integer -> Integer
19 
+lognotInteger		:: Integer -> Integer
20 
+logtestInteger		:: Integer -> Integer -> Integer
21 
+logbitpInteger		:: Int -> Integer -> Integer
22 
+ashInteger		:: Integer -> Int -> Integer
23 
+logcountInteger		:: Integer -> Int
24 
+integerLengthInteger	:: Integer -> Int
25 
+
26 
+logiorInt		:: Int -> Int -> Int
27 
+logxorInt		:: Int -> Int -> Int
28 
+logandInt		:: Int -> Int -> Int
29 
+logeqvInt		:: Int -> Int -> Int
30 
+lognandInt		:: Int -> Int -> Int
31 
+lognorInt		:: Int -> Int -> Int
32 
+logandc1Int		:: Int -> Int -> Int
33 
+logandc2Int		:: Int -> Int -> Int
34 
+logorc1Int		:: Int -> Int -> Int
35 
+logorc2Int		:: Int -> Int -> Int
36 
+lognotInt		:: Int -> Int
37 
+logtestInt		:: Int -> Int -> Int
38 
+logbitpInt		:: Int -> Int -> Int
39 
+ashInt			:: Int -> Int -> Int
40 
+logcountInt		:: Int -> Int
41 
+integerLengthInt	:: Int -> Int
42 
+
43 
+{-#
44 
+logiorInteger		:: LispName("logop.logior-integer"), Complexity(4)
45 
+logxorInteger		:: LispName("logop.logxor-integer"), Complexity(4)
46 
+logandInteger		:: LispName("logop.logand-integer"), Complexity(4)
47 
+logeqvInteger		:: LispName("logop.logeqv-integer"), Complexity(4)
48 
+lognandInteger		:: LispName("logop.lognand-integer"), Complexity(4)
49 
+lognorInteger		:: LispName("logop.lognor-integer"), Complexity(4)
50 
+logandc1Integer		:: LispName("logop.logandc1-integer"), Complexity(4)
51 
+logandc2Integer		:: LispName("logop.logandc2-integer"), Complexity(4)
52 
+logorc1Integer		:: LispName("logop.logorc1-integer"), Complexity(4)
53 
+logorc2Integer		:: LispName("logop.logorc2-integer"), Complexity(4)
54 
+lognotInteger		:: LispName("logop.lognot-integer"), Complexity(4)
55 
+logtestInteger		:: LispName("logop.logtest-integer"), Complexity(4)
56 
+logbitpInteger		:: LispName("logop.logbitp-integer"), Complexity(4)
57 
+ashInteger		:: LispName("logop.ash-integer"), Complexity(4)
58 
+logcountInteger		:: LispName("logop.logcount-integer"), Complexity(4)
59 
+integerLengthInteger	:: LispName("logop.integer-length-integer"), Complexity(4)
60 
+
61 
+logiorInt		:: LispName("logop.logior-int"), Complexity(2)
62 
+logxorInt		:: LispName("logop.logxor-int"), Complexity(2)
63 
+logandInt		:: LispName("logop.logand-int"), Complexity(2)
64 
+logeqvInt		:: LispName("logop.logeqv-int"), Complexity(2)
65 
+lognandInt		:: LispName("logop.lognand-int"), Complexity(2)
66 
+lognorInt		:: LispName("logop.lognor-int"), Complexity(2)
67 
+logandc1Int		:: LispName("logop.logandc1-int"), Complexity(2)
68 
+logandc2Int		:: LispName("logop.logandc2-int"), Complexity(2)
69 
+logorc1Int		:: LispName("logop.logorc1-int"), Complexity(2)
70 
+logorc2Int		:: LispName("logop.logorc2-int"), Complexity(2)
71 
+lognotInt		:: LispName("logop.lognot-int"), Complexity(2)
72 
+logtestInt		:: LispName("logop.logtest-int"), Complexity(2)
73 
+logbitpInt		:: LispName("logop.logbitp-int"), Complexity(2)
74 
+ashInt			:: LispName("logop.ash-int"), Complexity(2)
75 
+logcountInt		:: LispName("logop.logcount-int"), Complexity(2)
76 
+integerLengthInt	:: LispName("logop.integer-length-int"), Complexity(2)
77 
+#-}
78 
+
progs/lib/cl/logop-prims.scm
History View file @ 4e98702
0 79 
new file mode 100644
... ... 
@@ -0,0 +1,81 @@
1 
+;;; logop-prims.scm -- primitives for logical operations on numbers
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  19 Jun 1993
5 
+;;;
6 
+
7 
+
8 
+;;; Integer operations
9 
+;;; Note that bit counts are still guaranteed to be fixnums....
10 
+
11 
+(define-syntax (logop.logior-integer i1 i2)
12 
+  `(the integer (lisp:logior (the integer ,i1) (the integer ,i2))))
13 
+(define-syntax (logop.logxor-integer i1 i2)
14 
+  `(the integer (lisp:logxor (the integer ,i1) (the integer ,i2))))
15 
+(define-syntax (logop.logand-integer i1 i2)
16 
+  `(the integer (lisp:logand (the integer ,i1) (the integer ,i2))))
17 
+(define-syntax (logop.logeqv-integer i1 i2)
18 
+  `(the integer (lisp:logeqv (the integer ,i1) (the integer ,i2))))
19 
+(define-syntax (logop.lognand-integer i1 i2)
20 
+  `(the integer (lisp:lognand (the integer ,i1) (the integer ,i2))))
21 
+(define-syntax (logop.lognor-integer i1 i2)
22 
+  `(the integer (lisp:lognor (the integer ,i1) (the integer ,i2))))
23 
+(define-syntax (logop.logandc1-integer i1 i2)
24 
+  `(the integer (lisp:logandc1 (the integer ,i1) (the integer ,i2))))
25 
+(define-syntax (logop.logandc2-integer i1 i2)
26 
+  `(the integer (lisp:logandc2 (the integer ,i1) (the integer ,i2))))
27 
+(define-syntax (logop.logorc1-integer i1 i2)
28 
+  `(the integer (lisp:logorc1 (the integer ,i1) (the integer ,i2))))
29 
+(define-syntax (logop.logorc2-integer i1 i2)
30 
+  `(the integer (lisp:logorc2 (the integer ,i1) (the integer ,i2))))
31 
+(define-syntax (logop.lognot-integer i1)
32 
+  `(the integer (lisp:lognot (the integer ,i1))))
33 
+(define-syntax (logop.logtest-integer i1 i2)
34 
+  `(the integer (lisp:logtest (the integer ,i1) (the integer ,i2))))
35 
+(define-syntax (logop.logbitp-integer i1 i2)
36 
+  `(the integer (lisp:logbitp (the fixnum ,i1) (the integer ,i2))))
37 
+(define-syntax (logop.ash-integer i1 i2)
38 
+  `(the integer (lisp:ash (the integer ,i1) (the fixnum ,i2))))
39 
+(define-syntax (logop.logcount-integer i1)
40 
+  `(the fixnum (lisp:logcount (the integer ,i1))))
41 
+(define-syntax (logop.integer-length-integer i1)
42 
+  `(the fixnum (lisp:integer-length (the integer ,i1))))
43 
+
44 
+
45 
+;;; Fixnum operations
46 
+
47 
+(define-syntax (logop.logior-int i1 i2)
48 
+  `(the fixnum (lisp:logior (the fixnum ,i1) (the fixnum ,i2))))
49 
+(define-syntax (logop.logxor-int i1 i2)
50 
+  `(the fixnum (lisp:logxor (the fixnum ,i1) (the fixnum ,i2))))
51 
+(define-syntax (logop.logand-int i1 i2)
52 
+  `(the fixnum (lisp:logand (the fixnum ,i1) (the fixnum ,i2))))
53 
+(define-syntax (logop.logeqv-int i1 i2)
54 
+  `(the fixnum (lisp:logeqv (the fixnum ,i1) (the fixnum ,i2))))
55 
+(define-syntax (logop.lognand-int i1 i2)
56 
+  `(the fixnum (lisp:lognand (the fixnum ,i1) (the fixnum ,i2))))
57 
+(define-syntax (logop.lognor-int i1 i2)
58 
+  `(the fixnum (lisp:lognor (the fixnum ,i1) (the fixnum ,i2))))
59 
+(define-syntax (logop.logandc1-int i1 i2)
60 
+  `(the fixnum (lisp:logandc1 (the fixnum ,i1) (the fixnum ,i2))))
61 
+(define-syntax (logop.logandc2-int i1 i2)
62 
+  `(the fixnum (lisp:logandc2 (the fixnum ,i1) (the fixnum ,i2))))
63 
+(define-syntax (logop.logorc1-int i1 i2)
64 
+  `(the fixnum (lisp:logorc1 (the fixnum ,i1) (the fixnum ,i2))))
65 
+(define-syntax (logop.logorc2-int i1 i2)
66 
+  `(the fixnum (lisp:logorc2 (the fixnum ,i1) (the fixnum ,i2))))
67 
+(define-syntax (logop.lognot-int i1)
68 
+  `(the fixnum (lisp:lognot (the fixnum ,i1))))
69 
+(define-syntax (logop.logtest-int i1 i2)
70 
+  `(the fixnum (lisp:logtest (the fixnum ,i1) (the fixnum ,i2))))
71 
+(define-syntax (logop.logbitp-int i1 i2)
72 
+  `(the fixnum (lisp:logbitp (the fixnum ,i1) (the fixnum ,i2))))
73 
+(define-syntax (logop.ash-int i1 i2)
74 
+  `(the fixnum (lisp:ash (the fixnum ,i1) (the fixnum ,i2))))
75 
+(define-syntax (logop.logcount-int i1)
76 
+  `(the fixnum (lisp:logcount (the fixnum ,i1))))
77 
+(define-syntax (logop.integer-length-int i1)
78 
+  `(the fixnum (lisp:integer-length (the fixnum ,i1))))
79 
+
80 
+
81 
+
progs/lib/cl/logop.hs
History View file @ 4e98702
0 82 
new file mode 100644
... ... 
@@ -0,0 +1,63 @@
1 
+-- logop.hs -- logical operations on numbers
2 
+--
3 
+-- author :  Sandra Loosemore
4 
+-- date   :  19 June 1993
5 
+--
6 
+
7 
+module LogOp where
8 
+
9 
+import LogOpPrims  -- from logop-prims.hi
10 
+
11 
+class LogOperand a where
12 
+  logior	:: a -> a -> a
13 
+  logxor	:: a -> a -> a
14 
+  logand	:: a -> a -> a
15 
+  logeqv	:: a -> a -> a
16 
+  lognand	:: a -> a -> a
17 
+  lognor	:: a -> a -> a
18 
+  logandc1	:: a -> a -> a
19 
+  logandc2	:: a -> a -> a
20 
+  logorc1	:: a -> a -> a
21 
+  logorc2	:: a -> a -> a
22 
+  lognot	:: a -> a
23 
+  logtest	:: a -> a -> a
24 
+  logbitp	:: Int -> a -> a
25 
+  ash		:: a -> Int -> a
26 
+  logcount	:: a -> Int
27 
+  integerLength :: a -> Int
28 
+
29 
+instance LogOperand Integer where
30 
+  logior	= logiorInteger
31 
+  logxor	= logxorInteger
32 
+  logand	= logandInteger
33 
+  logeqv	= logeqvInteger
34 
+  lognand	= lognandInteger
35 
+  lognor	= lognorInteger
36 
+  logandc1	= logandc1Integer
37 
+  logandc2	= logandc2Integer
38 
+  logorc1	= logorc1Integer
39 
+  logorc2	= logorc2Integer
40 
+  lognot	= lognotInteger
41 
+  logtest	= logtestInteger
42 
+  logbitp	= logbitpInteger
43 
+  ash		= ashInteger
44 
+  logcount	= logcountInteger
45 
+  integerLength	= integerLengthInteger
46 
+
47 
+instance LogOperand Int where
48 
+  logior	= logiorInt
49 
+  logxor	= logxorInt
50 
+  logand	= logandInt
51 
+  logeqv	= logeqvInt
52 
+  lognand	= lognandInt
53 
+  lognor	= lognorInt
54 
+  logandc1	= logandc1Int
55 
+  logandc2	= logandc2Int
56 
+  logorc1	= logorc1Int
57 
+  logorc2	= logorc2Int
58 
+  lognot	= lognotInt
59 
+  logtest	= logtestInt
60 
+  logbitp	= logbitpInt
61 
+  ash		= ashInt
62 
+  logcount	= logcountInt
63 
+  integerLength	= integerLengthInt
progs/lib/cl/logop.hu
History View file @ 4e98702
0 64 
new file mode 100644
... ... 
@@ -0,0 +1,5 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+logop.hs
4 
+logop-prims.scm
5 
+logop-prims.hi
progs/lib/cl/maybe.hs
History View file @ 4e98702
0 6 
new file mode 100644
... ... 
@@ -0,0 +1,12 @@
1 
+-- maybe.hs -- "maybe" type
2 
+--
3 
+-- author :  Sandra Loosemore
4 
+-- date   :  22 June 1993
5 
+--
6 
+
7 
+module Maybe where
8 
+
9 
+data Maybe a = Some a | Null
10 
+
11 
+{-# ImportLispType (Maybe(Some("identity", "identity", "identity"),
12 
+                          Null("not", "'#f")))  #-}
progs/lib/cl/maybe.hu
History View file @ 4e98702
0 13 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+maybe.hs
progs/lib/cl/random-prims.hi
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,20 @@
1 
+-- random-prims.hi -- interface file to random number primitives
2 
+--
3 
+-- author :  Sandra Loosemore
4 
+-- date   :  22 June 1993
5 
+--
6 
+
7 
+
8 
+interface RandomPrims where
9 
+
10 
+randomInt	:: Int -> IO Int
11 
+randomInteger   :: Integer -> IO Integer
12 
+randomFloat     :: Float -> IO Float
13 
+randomDouble    :: Double -> IO Double
14 
+
15 
+{-#
16 
+randomInt	:: LispName("lisp:random"), Complexity(5)
17 
+randomInteger	:: LispName("lisp:random"), Complexity(5)
18 
+randomFloat	:: LispName("lisp:random"), Complexity(5)
19 
+randomDouble	:: LispName("lisp:random"), Complexity(5)
20 
+#-}
progs/lib/cl/random.hs
History View file @ 4e98702
0 21 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+-- random.hs -- random number functions
2 
+--
3 
+-- author :  Sandra Loosemore
4 
+-- date   :  22 June 1993
5 
+--
6 
+
7 
+module Random where
8 
+
9 
+import RandomPrims  -- from random-prims.hi
10 
+
11 
+class RandomOperand a where
12 
+  random	:: a -> IO a
13 
+
14 
+instance RandomOperand Int where
15 
+  random	= randomInt
16 
+instance RandomOperand Integer where
17 
+  random	= randomInteger
18 
+instance RandomOperand Float where
19 
+  random	= randomFloat
20 
+instance RandomOperand Double where
21 
+  random	= randomDouble
progs/lib/cl/random.hu
History View file @ 4e98702
0 22 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+random.hs
4 
+random-prims.hi
progs/lib/hbc/Either.hs
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+module Either(Either(..)) where
2 
+data Either a b = Left a | Right b deriving (Eq, Ord, Text, Binary)
progs/lib/hbc/Either.hu
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+Either.hs
progs/lib/hbc/Hash.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,79 @@
1 
+module Hash where
2 
+--
3 
+-- Hash a value.  Hashing produces an Int of
4 
+-- unspecified range.
5 
+--
6 
+
7 
+class Hashable a where
8 
+    hash :: a -> Int
9 
+
10 
+instance Hashable Char where
11 
+    hash x = ord x
12 
+
13 
+instance Hashable Int where
14 
+    hash x = x
15 
+
16 
+instance Hashable Integer where
17 
+    hash x = fromInteger x
18 
+
19 
+instance Hashable Float where
20 
+    hash x = truncate x
21 
+
22 
+instance Hashable Double where
23 
+    hash x = truncate x
24 
+
25 
+instance Hashable Bin where
26 
+    hash x = 0
27 
+
28 
+{-instance Hashable File where
29 
+    hash x = 0 -}
30 
+
31 
+instance Hashable () where
32 
+    hash x = 0
33 
+
34 
+instance Hashable (a -> b) where
35 
+    hash x = 0
36 
+
37 
+instance Hashable a => Hashable [a] where
38 
+    hash x = sum (map hash x)
39 
+
40 
+instance (Hashable a, Hashable b) => Hashable (a,b) where
41 
+    hash (a,b) = hash a + 3 * hash b
42 
+
43 
+instance (Hashable a, Hashable b, Hashable c) => Hashable (a,b,c) where
44 
+    hash (a,b,c) = hash a + 3 * hash b + 5 * hash c
45 
+
46 
+instance (Hashable a, Hashable b, Hashable c, Hashable d) => Hashable (a,b,c,d) where
47 
+    hash (a,b,c,d) = hash a + 3 * hash b + 5 * hash c + 7 * hash d
48 
+
49 
+instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e) => Hashable (a,b,c,d,e) where
50 
+    hash (a,b,c,d,e) = hash a + hash b + hash c + hash d + hash e
51 
+
52 
+instance Hashable Bool where
53 
+    hash False = 0
54 
+    hash True = 1
55 
+
56 
+instance (Integral a, Hashable a) => Hashable (Ratio a) where
57 
+    hash x = hash (denominator x) + hash (numerator x)
58 
+
59 
+instance (RealFloat a, Hashable a) => Hashable (Complex a) where
60 
+    hash (x :+ y) = hash x + hash y
61 
+
62 
+instance (Hashable a, Hashable b) => Hashable (Assoc a b) where
63 
+    hash (x := y) = hash x + hash y
64 
+
65 
+instance (Ix a) => Hashable (Array a b) where
66 
+    hash x = 0 -- !!!
67 
+
68 
+instance Hashable Request where
69 
+    hash x = 0 -- !!
70 
+
71 
+instance Hashable Response where
72 
+    hash x = 0 -- !!
73 
+
74 
+instance Hashable IOError where
75 
+    hash x = 0 -- !!
76 
+
77 
+hashToMax maxhash x =
78 
+    let h = abs (hash x)
79 
+    in  if h < 0 then 0 else h `rem` maxhash
progs/lib/hbc/Hash.hu
History View file @ 4e98702
0 80 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+Hash.hs
progs/lib/hbc/ListUtil.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,48 @@
1 
+module ListUtil(assoc, concatMap, unfoldr, mapAccuml, union, intersection, chopList, assocDef, lookup, Maybe..) where
2 
+import Maybe
3 
+
4 
+-- Lookup an item in an association list.  Apply a function to it if it is found, otherwise return a default value.
5 
+assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b
6 
+assoc f d [] x                       = d
7 
+assoc f d ((x',y):xys) x | x' == x   = f y
8 
+                         | otherwise = assoc f d xys x
9 
+
10 
+-- Map and concatename results.
11 
+concatMap :: (a -> [b]) -> [a] -> [b]
12 
+concatMap f []	   = []
13 
+concatMap f (x:xs) =
14 
+	case f x of
15 
+	[] -> concatMap f xs
16 
+	ys -> ys ++ concatMap f xs
17 
+
18 
+-- Repeatedly extract (and transform) values until a predicate hold.  Return the list of values.
19 
+unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
20 
+unfoldr f p x | p x       = []
21 
+	      | otherwise = y:unfoldr f p x'
22 
+			      where (y, x') = f x
23 
+
24 
+-- Map, but plumb a state through the map operation.
25 
+mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
26 
+mapAccuml f s []     = (s, [])
27 
+mapAccuml f s (x:xs) = (s'', y:ys)
28 
+		       where (s',  y)  = f s x
29 
+			     (s'', ys) = mapAccuml f s' xs
30 
+
31 
+-- Union of sets as lists.
32 
+union :: (Eq a) => [a] -> [a] -> [a]
33 
+union xs ys = xs ++ (ys \\ xs)
34 
+
35 
+-- Intersection of sets as lists.
36 
+intersection :: (Eq a) => [a] -> [a] -> [a]
37 
+intersection xs ys = [x | x<-xs, x `elem` ys]
38 
+
39 
+--- Functions derived from those above
40 
+
41 
+chopList :: ([a] -> (b, [a])) -> [a] -> [b]
42 
+chopList f l = unfoldr f null l
43 
+
44 
+assocDef :: (Eq a) => [(a, b)] -> b -> a -> b
45 
+assocDef l d x = assoc id d l x
46 
+
47 
+lookup :: (Eq a) => [(a, b)] -> a -> Maybe b
48 
+lookup l x = assoc Just Nothing l x
progs/lib/hbc/ListUtil.hu
History View file @ 4e98702
0 49 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+ListUtil.hs
4 
+Maybe.hu
progs/lib/hbc/Maybe.hs
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,6 @@
1 
+module Maybe(Maybe(..), thenM) where
2 
+-- Maybe together with Just and thenM forms a monad, but is more
3 
+-- by accident than by design.
4 
+data Maybe a = Nothing | Just a	deriving (Eq, Ord, Text, Binary)
5 
+Nothing `thenM` _ = Nothing
6 
+Just a  `thenM` f = f a
progs/lib/hbc/Maybe.hu
History View file @ 4e98702
0 7 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+Maybe.hs
progs/lib/hbc/Miranda.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,90 @@
1 
+module Miranda(cjustify, lay, layn, limit, ljustify, merge, rep, rjustify, spaces,
2 
+	       {-force,seq,-}sort) where
3 
+--import UnsafeDirty
4 
+import QSort
5 
+
6 
+cjustify :: Int -> String -> String
7 
+cjustify n s = spaces l ++ s ++ spaces r
8 
+               where
9 
+               m = n - length s
10 
+               l = m `div` 2
11 
+               r = m - l
12 
+
13 
+{-
14 
+index :: [a] -> [Int]
15 
+index xs = f xs 0
16 
+		where f []     n = []
17 
+		      f (_:xs) n = n : f xs (n+1)
18 
+-}
19 
+
20 
+lay :: [String] -> String
21 
+lay = concat . map (++"\n")
22 
+
23 
+layn :: [String] -> String
24 
+layn =  concat . zipWith f [1..]
25 
+           where
26 
+	   f :: Int -> String -> String
27 
+           f n x = rjustify 4 (show n) ++ ") " ++ x ++ "\n"
28 
+
29 
+limit :: (Eq a) => [a] -> a
30 
+limit (x:y:ys) | x == y    = x
31 
+               | otherwise = limit (y:ys)
32 
+limit _                    = error "Miranda.limit: bad use"
33 
+
34 
+ljustify :: Int -> String -> String
35 
+ljustify n s = s ++ spaces (n - length s)
36 
+
37 
+merge :: (Ord a) => [a] -> [a] -> [a]
38 
+merge []         ys                     = ys
39 
+merge xs         []                     = xs
40 
+merge xxs@(x:xs) yys@(y:ys) | x <= y    = x : merge xs  yys
41 
+		            | otherwise = y : merge xxs ys
42 
+
43 
+rep :: Int -> b -> [b]
44 
+rep n x = take n (repeat x)
45 
+
46 
+rjustify :: Int -> String -> String
47 
+rjustify n s = spaces (n - length s) ++ s
48 
+
49 
+spaces :: Int -> String
50 
+spaces 0 = ""
51 
+spaces n = ' ' : spaces (n-1)
52 
+
53 
+-------------
54 
+
55 
+arctan x = atan x
56 
+code c = ord c
57 
+converse f a b = flip f a b
58 
+decode n = chr n
59 
+digit c = isDigit c
60 
+e :: (Floating a) => a
61 
+e = exp 1
62 
+entier x = floor x
63 
+filemode f = error "Miranda.filemode"
64 
+--getenv
65 
+hd xs = head xs
66 
+hugenum :: (Floating a) => a
67 
+hugenum = error "hugenum" --!!!
68 
+integer x = x == truncate x
69 
+letter c = isAlpha c
70 
+map2 f xs ys = zipWith f xs ys
71 
+--max
72 
+max2 x y = max x y
73 
+member xs x = x `elem` xs
74 
+--min
75 
+min2 x y = min x y
76 
+mkset xs = nub xs
77 
+neg x = negate x
78 
+numval :: (Num a) => String -> a
79 
+numval cs = read cs
80 
+postfix xs x = xs ++ [x]
81 
+--read
82 
+scan f z l = scanl f z l
83 
+--shownum !!!
84 
+--showfloat !!!
85 
+--showscaled !!!
86 
+tinynum :: (Floating a) => a
87 
+tinynum = error "tinynum"
88 
+undef = error "undefined"
89 
+zip2 xs ys = zip xs ys
90 
+--zip
progs/lib/hbc/Miranda.hu
History View file @ 4e98702
0 91 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+Miranda.hs
4 
+QSort.hu
progs/lib/hbc/Option.hs
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+module Option(Option(..), thenO) where
2 
+import Maybe renaming (Maybe to Option, Nothing to None, Just to Some, thenM to thenO)
3 
+
progs/lib/hbc/Option.hu
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+Option.hs
progs/lib/hbc/Pretty.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,50 @@
1 
+module Pretty(text, separate, nest, pretty, (~.), (^.), IText(..), Context(..)) where
2 
+infixr 8 ~.
3 
+infixr 8 ^.
4 
+
5 
+type IText   = Context -> [String]
6 
+type Context = (Bool,Int,Int,Int)
7 
+
8 
+text :: String -> IText
9 
+text s (v,w,m,m') = [s]
10 
+
11 
+(~.) :: IText -> IText -> IText
12 
+(~.) d1 d2 (v,w,m,m') =
13 
+	let t = d1 (False,w,m,m')
14 
+            tn = last t
15 
+	    indent = length tn
16 
+	    sig = if length t == 1
17 
+		  then m' + indent
18 
+		  else length (dropWhile (==' ') tn)
19 
+	    (l:ls) = d2 (False,w-indent,m,sig)
20 
+	in  init t ++
21 
+	    [tn ++ l] ++
22 
+	    map (space indent++) ls
23 
+
24 
+space :: Int -> String
25 
+space n = [' ' | i<-[1..n]]
26 
+
27 
+(^.) :: IText -> IText -> IText
28 
+(^.) d1 d2 (v,w,m,m') = d1 (True,w,m,m') ++ d2 (True,w,m,0)
29 
+
30 
+separate :: [IText] -> IText
31 
+separate [] _ = [""]
32 
+separate ds (v,w,m,m') =
33 
+	let hor = foldr1 (\d1 d2 -> d1 ~. text " " ~. d2) ds
34 
+	    ver = foldr1 (^.) ds
35 
+	    t = hor (v,w,m,m')
36 
+	in  if fits 1 t && fits (w `min` m-m') (head t)
37 
+	    then t
38 
+	    else ver (v,w,m,m')
39 
+
40 
+fits n xs = length xs <= n `max` 0 --null (drop n xs)
41 
+
42 
+nest :: Int -> IText -> IText
43 
+nest n d (v,w,m,m') =
44 
+	if v then
45 
+	    map (space n++) (d (v,w-n,m,if m'==0 then 0 else m'+n))
46 
+	else
47 
+	    d (v,w,m,m')
48 
+
49 
+pretty :: Int->Int->IText->String
50 
+pretty w m d = concat (map (++"\n") (d (False,w,m,0)))
progs/lib/hbc/Printf.hs
History View file @ 4e98702
0 51 
new file mode 100644
... ... 
@@ -0,0 +1,150 @@
1 
+-- This code used a function in the lml library (fmtf) that I don't have.
2 
+-- If someone makes this work for floats let me know   -- jcp
3 
+--
4 
+-- A C printf like formatter.
5 
+-- Conversion specs:
6 
+--	-	left adjust
7 
+--	num	field width
8 
+--	.	separates width from precision
9 
+-- Formatting characters:
10 
+-- 	c	Char, Int, Integer
11 
+--	d	Char, Int, Integer
12 
+--	o	Char, Int, Integer
13 
+--	x	Char, Int, Integer
14 
+--	u	Char, Int, Integer
15 
+--	f	Float, Double
16 
+--	g	Float, Double
17 
+--	e	Float, Double
18 
+--	s	String
19 
+--
20 
+module Printf(UPrintf(..), printf) where
21 
+
22 
+-- import LMLfmtf
23 
+
24 
+data UPrintf = UChar Char |
25 
+	       UString String |
26 
+               UInt Int |
27 
+	       UInteger Integer |
28 
+               UFloat Float |
29 
+	       UDouble Double
30 
+
31 
+printf :: String -> [UPrintf] -> String
32 
+printf ""       []       = ""
33 
+printf ""       (_:_)    = fmterr
34 
+printf ('%':_)  []       = argerr
35 
+printf ('%':cs) us@(_:_) = fmt cs us
36 
+printf (c:cs)   us       = c:printf cs us
37 
+
38 
+fmt :: String -> [UPrintf] -> String
39 
+fmt cs us =
40 
+	let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us
41 
+	    adjust (pre, str) =
42 
+		let lstr = length str
43 
+		    lpre = length pre
44 
+		    fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
45 
+		in  if ladj then pre ++ str ++ fill else pre ++ fill ++ str
46 
+        in
47 
+	case cs' of
48 
+	[]     -> fmterr
49 
+	c:cs'' ->
50 
+	    case us' of
51 
+	    []     -> argerr
52 
+	    u:us'' ->
53 
+		(case c of
54 
+		'c' -> adjust ("", [chr (toint u)])
55 
+		'd' -> adjust (fmti u)
56 
+		'x' -> adjust ("", fmtu 16 u)
57 
+		'o' -> adjust ("", fmtu 8  u)
58 
+		'u' -> adjust ("", fmtu 10 u)
59 
+		'%' -> "%"
60 
+		'e' -> adjust (dfmt c prec (todbl u))
61 
+		'f' -> adjust (dfmt c prec (todbl u))
62 
+		'g' -> adjust (dfmt c prec (todbl u))
63 
+		's' -> adjust ("", tostr u)
64 
+		c   -> perror ("bad formatting char " ++ [c])
65 
+		) ++ printf cs'' us''
66 
+unimpl = perror "unimplemented"
67 
+
68 
+fmti (UInt i)     = if i < 0 then
69 
+			if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
70 
+		    else
71 
+			("", itos i)
72 
+fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
73 
+fmti (UChar c)    = fmti (UInt (ord c))
74 
+fmti u		  = baderr
75 
+
76 
+fmtu b (UInt i)     = if i < 0 then
77 
+			  if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
78 
+		      else
79 
+			  itosb b (toInteger i)
80 
+fmtu b (UInteger i) = itosb b i
81 
+fmtu b (UChar c)    = itosb b (toInteger (ord c))
82 
+fmtu b u            = baderr
83 
+
84 
+maxi :: Integer
85 
+maxi = (toInteger maxInt + 1) * 2
86 
+
87 
+toint (UInt i)     = i
88 
+toint (UInteger i) = toInt i
89 
+toint (UChar c)    = ord c
90 
+toint u		   = baderr
91 
+
92 
+tostr (UString s) = s
93 
+tostr u		  = baderr
94 
+
95 
+todbl (UDouble d) = d
96 
+todbl (UFloat f)  = fromRational (toRational f)
97 
+todbl u           = baderr
98 
+
99 
+itos n =
100 
+	if n < 10 then
101 
+	    [chr (ord '0' + toInt n)]
102 
+	else
103 
+	    let (q, r) = quotRem n 10 in
104 
+	    itos q ++ [chr (ord '0' + toInt r)]
105 
+
106 
+chars = array (0,15) (zipWith (:=) [0..] "0123456789abcdef")
107 
+itosb :: Integer -> Integer -> String
108 
+itosb b n =
109 
+	if n < b then
110 
+	    [chars!n]
111 
+	else
112 
+	    let (q, r) = quotRem n b in
113 
+	    itosb b q ++ [chars!r]
114 
+
115 
+stoi :: Int -> String -> (Int, String)
116 
+stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '0') cs
117 
+stoi a cs                 = (a, cs)
118 
+
119 
+getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
120 
+getSpecs l z ('-':cs) us = getSpecs True z cs us
121 
+getSpecs l z ('0':cs) us = getSpecs l True cs us
122 
+getSpecs l z ('*':cs) us = unimpl
123 
+getSpecs l z cs@(c:_) us | isDigit c =
124 
+	let (n, cs') = stoi 0 cs
125 
+	    (p, cs'') = case cs' of
126 
+			'.':r -> stoi 0 r
127 
+			_     -> (-1, cs')
128 
+	in  (n, p, l, z, cs'', us)
129 
+getSpecs l z cs       us = (0, -1, l, z, cs, us)
130 
+
131 
+-- jcp: I don't know what the lml function fmtf does.  Someone needs to
132 
+-- rewrite this.
133 
+
134 
+{-
135 
+dfmt c p d =
136 
+	case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of
137 
+	'-':cs -> ("-", cs)
138 
+	cs     -> ("" , cs)
139 
+-}
140 
+dfmt = error "fmtf not implemented"
141 
+
142 
+perror s = error ("Printf.printf: "++s)
143 
+fmterr = perror "formatting string ended prematurely"
144 
+argerr = perror "argument list ended prematurely"
145 
+baderr = perror "bad argument"
146 
+
147 
+-- This is needed because standard Haskell does not have toInt
148 
+
149 
+toInt :: Integral a => a -> Int
150 
+toInt x = fromIntegral x
progs/lib/hbc/Printf.hu
History View file @ 4e98702
0 151 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+Printf.hs
progs/lib/hbc/QSort.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,47 @@
1 
+{-
2 
+   This module implements a sort function using a variation on
3 
+   quicksort.  It is stable, uses no concatenation and compares
4 
+   only with <=.
5 
+
6 
+   sortLe sorts with a given predicate
7 
+   sort   uses the <= method
8 
+
9 
+   Author: Lennart Augustsson
10 
+-}
11 
+
12 
+module QSort(sortLe, sort) where
13 
+sortLe :: (a -> a -> Bool) -> [a] -> [a]
14 
+sortLe le l = qsort le   l []
15 
+
16 
+sort :: (Ord a) => [a] -> [a]
17 
+sort      l = qsort (<=) l []
18 
+
19 
+-- qsort is stable and does not concatenate.
20 
+qsort le []     r = r
21 
+qsort le [x]    r = x:r
22 
+qsort le (x:xs) r = qpart le x xs [] [] r
23 
+
24 
+-- qpart partitions and sorts the sublists
25 
+qpart le x [] rlt rge r =
26 
+    -- rlt and rge are in reverse order and must be sorted with an
27 
+    -- anti-stable sorting
28 
+    rqsort le rlt (x:rqsort le rge r)
29 
+qpart le x (y:ys) rlt rge r =
30 
+    if le x y then
31 
+	qpart le x ys rlt (y:rge) r
32 
+    else
33 
+	qpart le x ys (y:rlt) rge r
34 
+
35 
+-- rqsort is as qsort but anti-stable, i.e. reverses equal elements
36 
+rqsort le []     r = r
37 
+rqsort le [x]    r = x:r
38 
+rqsort le (x:xs) r = rqpart le x xs [] [] r
39 
+
40 
+rqpart le x [] rle rgt r =
41 
+    qsort le rle (x:qsort le rgt r)
42 
+rqpart le x (y:ys) rle rgt r =
43 
+    if le y x then
44 
+	rqpart le x ys (y:rle) rgt r
45 
+    else
46 
+	rqpart le x ys rle (y:rgt) r
47 
+
progs/lib/hbc/QSort.hu
History View file @ 4e98702
0 48 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+QSort.hs
progs/lib/hbc/README
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,97 @@
1 
+These libraries are adapted from the lml library.  Also included are a number
2 
+of Common Lisp functions.
3 
+
4 
+The hbc library contains the following modules and functions:
5 
+
6 
+* module Either
7 
+    binary sum data type
8 
+	data Either a b = Left a | Right b
9 
+    constructor Left typically used for errors
10 
+
11 
+* module Option
12 
+    type for success or failure
13 
+	data Option a = None | Some a
14 
+	thenO :: Option a -> (a -> Option b) -> Option b	apply a function that may fail
15 
+
16 
+
17 
+* module ListUtil
18 
+    Various useful functions involving lists that are missing from the Prelude
19 
+	assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b
20 
+		assoc f d l k looks for k in the association list l, if it is found f is applied to the value, otherwise d is returned
21 
+	concatMap :: (a -> [b]) -> [a] -> [b]
22 
+		flattening map (LMLs concmap)
23 
+	unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
24 
+		unfoldr f p x repeatedly applies f to x until (p x) holds. (f x) should give a list element and a new x
25 
+	mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
26 
+		mapAccuml f s l  maps f over l, but also threads the state s though (LMLs mapstate)
27 
+	union :: (Eq a) => [a] -> [a] -> [a]
28 
+		unions of two lists
29 
+	intersection :: (Eq a) => [a] -> [a] -> [a]
30 
+		intersection of two lists
31 
+	chopList :: ([a] -> (b, [a])) -> [a] -> [b]
32 
+		LMLs choplist
33 
+	assocDef :: (Eq a) => [(a, b)] -> b -> a -> b
34 
+		LMLs assocdef
35 
+	lookup :: (Eq a) => [(a, b)] -> a -> Option b
36 
+		lookup l k looks for the key k in the association list l and returns an optional value
37 
+
38 
+* module Pretty
39 
+    John Hughes pretty printing library.
40 
+	type Context = (Bool, Int, Int, Int)
41 
+	type IText = Context -> [String]
42 
+	text :: String -> IText				just text
43 
+	(~.) :: IText -> IText -> IText			horizontal composition
44 
+	(^.) :: IText -> IText -> IText			vertical composition
45 
+	separate :: [IText] -> IText			separate by spaces
46 
+	nest :: Int -> IText -> IText			indent
47 
+	pretty :: Int -> Int -> IText -> String		format it
48 
+
49 
+* module QSort
50 
+    Sort function using quicksort.
51 
+	sortLe :: (a -> a -> Bool) -> [a] -> [a]	sort le l  sorts l with le as less than predicate
52 
+	sort :: (Ord a) => [a] -> [a]			sort l  sorts l using the Ord class
53 
+
54 
+* module Random
55 
+    Random numbers.
56 
+	randomInts :: Int -> Int -> [Int]		given two seeds gives a list of random Int
57 
+	randomDoubles :: Int -> Int -> [Double]		given two seeds gives a list of random Double
58 
+
59 
+* module RunDialogue
60 
+    Test run programs of type Dialogue.
61 
+    Only a few Requests are implemented, unfortunately not ReadChannel.
62 
+	run :: Dialogue -> String			just run the program, showing the output
63 
+	runTrace :: Dialogue -> String			run the program, showing each Request and Response
64 
+
65 
+* module Miranda
66 
+    Functions found in the Miranda(tm) library.
67 
+
68 
+* module Printf
69 
+    C printf style formatting.  Handles same types as printf in C, but requires the arguments
70 
+    to be tagged.  Useful for formatting of floating point values.
71 
+	data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double
72 
+	printf :: String -> [UPrintf] -> String		convert arguments in the list according to the formatting string
73 
+
74 
+
75 
+* module Time
76 
+    Manipulate time values (a Double with seconds since 1970).
77 
+	--               year mon  day  hour min  sec  dec-sec  weekday
78 
+	data Time = Time Int  Int  Int  Int  Int  Int  Double  Int
79 
+	dblToTime :: Double -> Time			convert a Double to a Time
80 
+	timeToDbl :: Time -> Double			convert a Time to a Double
81 
+	timeToString :: Time -> String			convert a Time to a readable String
82 
+
83 
+-----  To add:
84 
+
85 
+Bytes
86 
+IO Library
87 
+Word oprtations
88 
+Time clock stuff
89 
+Lisp stuff: symbols
90 
+            hashtables
91 
+            strings
92 
+
93 
+
94 
+
95 
+
96 
+
97 
+
progs/lib/hbc/Random.hs
History View file @ 4e98702
0 98 
new file mode 100644
... ... 
@@ -0,0 +1,52 @@
1 
+{-
2 
+   This module implements a (good) random number generator.
3 
+
4 
+   The June 1988 (v31 #6) issue of the Communications of the ACM has an
5 
+   article by Pierre L'Ecuyer called, "Efficient and Portable Combined
6 
+   Random Number Generators".  Here is the Portable Combined Generator of
7 
+   L'Ecuyer for 32-bit computers.  It has a period of roughly 2.30584e18.
8 
+
9 
+   Transliterator: Lennart Augustsson
10 
+-}
11 
+
12 
+module Random(randomInts, randomDoubles) where
13 
+-- Use seeds s1 in 1..2147483562 and s2 in 1..2147483398 to generate
14 
+-- an infinite list of random Ints.
15 
+randomInts :: Int -> Int -> [Int]
16 
+randomInts s1 s2 =
17 
+    if 1 <= s1 && s1 <= 2147483562 then
18 
+	if 1 <= s2 && s2 <= 2147483398 then
19 
+	    rands s1 s2
20 
+	else
21 
+	    error "randomInts: Bad second seed."
22 
+    else
23 
+	error "randomInts: Bad first seed."
24 
+
25 
+rands :: Int -> Int -> [Int]
26 
+rands s1 s2 =
27 
+    let
28 
+	k    = s1 `div` 53668
29 
+	s1'  = 40014 * (s1 - k * 53668) - k * 12211
30 
+	s1'' = if s1' < 0 then s1' + 2147483563 else s1'
31 
+
32 
+	k'   = s2 `div` 52774
33 
+	s2'  = 40692 * (s2 - k' * 52774) - k' * 3791
34 
+	s2'' = if s2' < 0 then s2' + 2147483399 else s2'
35 
+
36 
+	z    = s1'' - s2''
37 
+{-
38 
+	z'   = if z < 1 then z + 2147483562 else z
39 
+
40 
+    in  z' : rands s1'' s2''
41 
+-}
42 
+-- Use this instead; it is a little stricter and generates much better code
43 
+    in  if z < 1 then z + 2147483562 : rands s1'' s2''
44 
+                 else z : rands s1'' s2''
45 
+
46 
+-- For those of you who don't have fromInt
47 
+fromInt = fromInteger . toInteger
48 
+
49 
+-- Same values for s1 and s2 as above, generates an infinite
50 
+-- list of Doubles uniformly distibuted in (0,1).
51 
+randomDoubles :: Int -> Int -> [Double]
52 
+randomDoubles s1 s2 = map (\x -> fromInt x * 4.6566130638969828e-10) (randomInts s1 s2)
progs/lib/hbc/Random.hu
History View file @ 4e98702
0 53 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+Random.hs
progs/lib/hbc/Time.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,51 @@
1 
+module Time(Time(..), dblToTime, timeToDbl, timeToString) where
2 
+--               year mon  day  hour min  sec  ...    wday
3 
+data Time = Time Int  Int  Int  Int  Int  Int  Double Int deriving (Eq, Ord, Text)
4 
+
5 
+isleap :: Int -> Bool
6 
+isleap n = n `rem` 4 == 0			-- good enough for the UNIX time span
7 
+
8 
+daysin :: Int -> Int
9 
+daysin n = if isleap n then 366 else 365
10 
+
11 
+monthlen :: Array (Bool, Int) Int
12 
+monthlen = array ((False, 1), (True, 12)) (zipWith3 (\ a b c -> (a,b):=c) (repeat False) [1..] [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] ++
13 
+					   zipWith3 (\ a b c -> (a,b):=c) (repeat True)  [1..] [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31])
14 
+
15 
+-- Time zone offset in minutes
16 
+tzOffset = 120		-- Swedish DST
17 
+
18 
+dblToTime :: Double -> Time
19 
+dblToTime d =
20 
+	let t = truncate d :: Int
21 
+	    offset       = tzOffset		-- timezone
22 
+	    (days, rem)  = (t+offset*60) `quotRem` (60*60*24)
23 
+	    (hour, rem') = rem `quotRem` (60*60)
24 
+	    (min,  sec)  = rem' `quotRem` 60
25 
+	    wday         = (days+3) `mod` 7
26 
+	    (year, days')= until (\ (y, d) -> d < daysin y) (\ (y, d) -> (y+1, d - daysin y)) (1970, days)
27 
+	    (mon, day)   = until (\ (m, d) -> d <= monthlen!(isleap year, m)) (\ (m, d) -> (m+1, d - monthlen!(isleap year, m))) (1, days')
28 
+	in  Time year mon (day+1) hour min sec (d - fromInt t) wday
29 
+
30 
+timeToDbl :: Time -> Double
31 
+timeToDbl (Time year mon day hour min sec sdec _) =
32 
+	let year'  = year - 1970
33 
+	    offset = tzOffset		-- timezone
34 
+	    days   = year' * 365 + (year'+1) `div` 4 +
35 
+		     sum [monthlen!(isleap year, m) | m<-[1..mon-1]] + day - 1
36 
+            secs   = ((days*24 + hour) * 60 + min - offset) * 60 + sec
37 
+        in  fromInt secs + sdec
38 
+
39 
+show2 :: Int -> String
40 
+show2 x = [chr (x `quot` 10 + ord '0'), chr (x `rem` 10 + ord '0')]
41 
+
42 
+weekdays = ["Mon","Tue","Wen","Thu","Fri","Sat","Sun"]
43 
+
44 
+timeToString :: Time -> String
45 
+timeToString (Time year mon day hour min sec sdec wday) =
46 
+	show  year ++ "-" ++ show2 mon ++ "-" ++ show2 day ++ " " ++
47 
+	show2 hour ++ ":" ++ show2 min ++ ":" ++ show2 sec ++
48 
+	tail (take 5 (show sdec)) ++ " " ++ weekdays!!wday
49 
+
50 
+-- For those of you who don't have fromInt
51 
+fromInt = fromInteger . toInteger
progs/lib/hbc/Time.hu
History View file @ 4e98702
0 52 
new file mode 100644
... ... 
@@ -0,0 +1,3 @@
1 
+:output $LIBRARYBIN/
2 
+:o= all
3 
+Time.hs
progs/prelude/Prelude.hs
History View file @ 4e98702
0 4 
new file mode 100644
... ... 
@@ -0,0 +1,187 @@
1 
+-- Standard value bindings
2 
+
3 
+module Prelude (
4 
+    PreludeCore.., PreludeRatio.., PreludeComplex.., PreludeList..,
5 
+    PreludeArray.., PreludeText.., PreludeIO..,
6 
+    nullBin, isNullBin, appendBin,
7 
+    (&&), (||), not, otherwise,
8 
+    minChar, maxChar, ord, chr,
9 
+    isAscii, isControl, isPrint, isSpace,
10 
+    isUpper, isLower, isAlpha, isDigit, isAlphanum,
11 
+    toUpper, toLower,
12 
+    minInt, maxInt, subtract, gcd, lcm, (^), (^^),
13 
+    fromIntegral, fromRealFrac, atan2,
14 
+    fst, snd, id, const, (.), flip, ($), until, asTypeOf, error ) where
15 
+
16 
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
17 
+
18 
+import PreludePrims
19 
+
20 
+import PreludeCore
21 
+import PreludeList
22 
+import PreludeArray
23 
+import PreludeRatio
24 
+import PreludeComplex
25 
+import PreludeText
26 
+import PreludeIO
27 
+
28 
+infixr 9  .
29 
+infixr 8  ^, ^^
30 
+infixr 3  &&
31 
+infixr 2  ||
32 
+infixr 0  $
33 
+
34 
+
35 
+-- Binary functions
36 
+
37 
+nullBin	    	    	:: Bin
38 
+nullBin	    	    	=  primNullBin
39 
+
40 
+isNullBin    	    	:: Bin -> Bool
41 
+isNullBin    	    	=  primIsNullBin
42 
+
43 
+appendBin		:: Bin -> Bin -> Bin
44 
+appendBin		=  primAppendBin
45 
+
46 
+-- Boolean functions
47 
+
48 
+(&&), (||)		:: Bool -> Bool -> Bool
49 
+True  && x		=  x
50 
+False && _		=  False
51 
+True  || _		=  True
52 
+False || x		=  x
53 
+
54 
+not			:: Bool -> Bool
55 
+not True		=  False
56 
+not False		=  True
57 
+
58 
+{-# (&&)  :: Inline #-}
59 
+{-# (||)  :: Inline #-}
60 
+{-# not  :: Inline #-}
61 
+
62 
+
63 
+otherwise		:: Bool
64 
+otherwise 		=  True
65 
+
66 
+-- Character functions
67 
+
68 
+minChar, maxChar	:: Char
69 
+minChar			= '\0'
70 
+maxChar			= '\255'
71 
+
72 
+ord			:: Char -> Int
73 
+ord 			=  primCharToInt
74 
+
75 
+chr 			:: Int -> Char
76 
+chr 			=  primIntToChar
77 
+
78 
+isAscii, isControl, isPrint, isSpace		:: Char -> Bool
79 
+isUpper, isLower, isAlpha, isDigit, isAlphanum	:: Char -> Bool
80 
+
81 
+isAscii c	 	=  ord c < 128
82 
+isControl c		=  c < ' ' || c == '\DEL'
83 
+isPrint c		=  c >= ' ' && c <= '~'
84 
+isSpace c		=  c == ' ' || c == '\t' || c == '\n' ||
85 
+			   c == '\r' || c == '\f' || c == '\v'
86 
+isUpper c		=  c >= 'A' && c <= 'Z'
87 
+isLower c		=  c >= 'a' && c <= 'z'
88 
+isAlpha c		=  isUpper c || isLower c
89 
+isDigit c		=  c >= '0' && c <= '9'
90 
+isAlphanum c		=  isAlpha c || isDigit c
91 
+
92 
+
93 
+toUpper, toLower	:: Char -> Char
94 
+toUpper c | isLower c	= chr ((ord c - ord 'a') + ord 'A')
95 
+	  | otherwise	= c
96 
+
97 
+toLower c | isUpper c	= chr ((ord c - ord 'A') + ord 'a')
98 
+	  | otherwise	= c
99 
+
100 
+-- Numeric functions
101 
+
102 
+minInt, maxInt	:: Int
103 
+minInt		=  primMinInt
104 
+maxInt		=  primMaxInt
105 
+
106 
+subtract	:: (Num a) => a -> a -> a
107 
+subtract	=  flip (-)
108 
+
109 
+gcd		:: (Integral a) => a -> a -> a
110 
+gcd 0 0		=  error "gcd{Prelude}: gcd 0 0 is undefined"
111 
+gcd x y		=  gcd' (abs x) (abs y)
112 
+		   where gcd' x 0  =  x
113 
+			 gcd' x y  =  gcd' y (x `rem` y)
114 
+
115 
+lcm		:: (Integral a) => a -> a -> a
116 
+lcm _ 0		=  0
117 
+lcm 0 _		=  0
118 
+lcm x y		=  abs ((x `quot` (gcd x y)) * y)
119 
+
120 
+(^)		:: (Num a, Integral b) => a -> b -> a
121 
+x ^ 0		=  1
122 
+x ^ (n+1)	=  f x n x
123 
+		   where f _ 0 y = y
124 
+		         f x n y = g x n  where
125 
+			           g x n | even n  = g (x*x) (n `quot` 2)
126 
+				         | otherwise = f x (n-1) (x*y)
127 
+_ ^ _		= error "(^){Prelude}: negative exponent"
128 
+
129 
+(^^)		:: (Fractional a, Integral b) => a -> b -> a
130 
+x ^^ n		=  if n >= 0 then x^n else recip (x^(-n))
131 
+
132 
+fromIntegral	:: (Integral a, Num b) => a -> b
133 
+fromIntegral	=  fromInteger . toInteger
134 
+
135 
+fromRealFrac	:: (RealFrac a, Fractional b) => a -> b
136 
+fromRealFrac	=  fromRational . toRational
137 
+
138 
+atan2		:: (RealFloat a) => a -> a -> a
139 
+atan2 y x	=  case (signum y, signum x) of
140 
+			( 0, 1) ->  0
141 
+			( 1, 0) ->  pi/2
142 
+			( 0,-1) ->  pi
143 
+			(-1, 0) -> -pi/2
144 
+			( _, 1) ->  atan (y/x)
145 
+			( _,-1) ->  atan (y/x) + pi
146 
+			( 0, 0) ->  error "atan2{Prelude}: atan2 of origin"
147 
+
148 
+
149 
+-- Some standard functions:
150 
+-- component projections for pairs:
151 
+fst			:: (a,b) -> a
152 
+fst (x,y)		=  x
153 
+
154 
+snd			:: (a,b) -> b
155 
+snd (x,y)		=  y
156 
+
157 
+-- identity function
158 
+id			:: a -> a
159 
+id x			=  x
160 
+
161 
+-- constant function
162 
+const			:: a -> b -> a
163 
+const x _		=  x
164 
+
165 
+-- function composition
166 
+(.)			:: (b -> c) -> (a -> b) -> a -> c
167 
+f . g			=  \ x -> f (g x)
168 
+
169 
+-- flip f  takes its (first) two arguments in the reverse order of f.
170 
+flip			:: (a -> b -> c) -> b -> a -> c
171 
+flip f x y		=  f y x
172 
+
173 
+-- right-associating infix application operator (useful in continuation-
174 
+-- passing style)
175 
+($)			:: (a -> b) -> a -> b
176 
+f $ x			=  f x
177 
+
178 
+-- until p f  yields the result of applying f until p holds.
179 
+until			:: (a -> Bool) -> (a -> a) -> a -> a
180 
+until p f x | p x	=  x
181 
+	    | otherwise =  until p f (f x)
182 
+
183 
+-- asTypeOf is a type-restricted version of const.  It is usually used
184 
+-- as an infix operator, and its typing forces its first argument
185 
+-- (which is usually overloaded) to have the same type as the second.
186 
+asTypeOf		:: a -> a -> a
187 
+asTypeOf		=  const
progs/prelude/Prelude.hu
History View file @ 4e98702
0 188 
new file mode 100644
... ... 
@@ -0,0 +1,16 @@
1 
+:output $PRELUDEBIN/Prelude
2 
+:stable
3 
+:prelude
4 
+PreludePrims.hu
5 
+PreludeArrayPrims.hu
6 
+PreludeTuplePrims.hu
7 
+PreludeIOPrims.hu
8 
+Prelude.hs
9 
+PreludeArray.hs
10 
+PreludeComplex.hs
11 
+PreludeCore.hs
12 
+PreludeIO.hs
13 
+PreludeList.hs
14 
+PreludeRatio.hs
15 
+PreludeText.hs
16 
+PreludeTuple.hs
progs/prelude/PreludeArray.hs
History View file @ 4e98702
0 17 
new file mode 100644
... ... 
@@ -0,0 +1,201 @@
1 
+module  PreludeArray ( Array, Assoc((:=)), array, listArray, (!), bounds,
2 
+		     indices, elems, assocs, accumArray, (//), accum, amap,
3 
+		     ixmap
4 
+		   ) where
5 
+
6 
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
7 
+
8 
+-- This module uses some simple techniques with updatable vectors to
9 
+-- avoid vector copying in loops where single threading is obvious.
10 
+-- This is rather fragile and depends on the way the compiler handles
11 
+-- strictness.
12 
+
13 
+import PreludeBltinArray
14 
+
15 
+infixl 9  !
16 
+infixl 9  //
17 
+infix  1  :=
18 
+
19 
+data  Assoc a b =  a := b  deriving (Eq, Ord, Ix, Text, Binary)
20 
+data  (Ix a)    => Array a b = MkArray (a,a) {-#STRICT#-}
21 
+                                       (Vector (Box b)) {-#STRICT#-}
22 
+				       deriving ()
23 
+
24 
+array		:: (Ix a) => (a,a) -> [Assoc a b] -> Array a b
25 
+listArray	:: (Ix a) => (a,a) -> [b] -> Array a b
26 
+(!)		:: (Ix a) => Array a b -> a -> b
27 
+bounds		:: (Ix a) => Array a b -> (a,a)
28 
+indices		:: (Ix a) => Array a b -> [a]
29 
+elems		:: (Ix a) => Array a b -> [b]
30 
+assocs		:: (Ix a) => Array a b -> [Assoc a b]
31 
+accumArray	:: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [Assoc a c]
32 
+			     -> Array a b
33 
+(//)		:: (Ix a) => Array a b -> [Assoc a b] -> Array a b
34 
+accum		:: (Ix a) => (b -> c -> b) -> Array a b -> [Assoc a c]
35 
+			     -> Array a b
36 
+amap		:: (Ix a) => (b -> c) -> Array a b -> Array a c
37 
+ixmap		:: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c
38 
+			     -> Array a c
39 
+
40 
+-- Arrays are a datatype containing a bounds pair and a vector of values.
41 
+-- Uninitialized array elements contain an error value.
42 
+
43 
+-- Primitive vectors now contain only unboxed values.  This permits us to
44 
+-- treat array indexing as an atomic operation without forcing the element
45 
+-- being accessed.  The boxing and unboxing of array elements happens
46 
+-- explicitly using these operations:
47 
+
48 
+data Box a = MkBox a
49 
+unBox (MkBox x) = x
50 
+{-# unBox :: Inline #-}
51 
+
52 
+
53 
+-- Array construction and update using index/value associations share
54 
+-- the same helper function.
55 
+
56 
+array b@(bmin, bmax) ivs =
57 
+  let size = (index b bmax) + 1
58 
+      v = primMakeVector size uninitializedArrayError
59 
+  in (MkArray b (updateArrayIvs b v ivs))
60 
+{-# array :: Inline #-}
61 
+
62 
+a@(MkArray b v) // ivs =
63 
+  let v' = primCopyVector v
64 
+  in (MkArray b (updateArrayIvs b v' ivs))
65 
+{-# (//) :: Inline #-}
66 
+
67 
+updateArrayIvs b v ivs =
68 
+  let g (i := x) next =  strict1 (primVectorUpdate v (index b i) (MkBox x))
69 
+                                 next
70 
+  in foldr g v ivs
71 
+{-# updateArrayIvs :: Inline #-}
72 
+
73 
+uninitializedArrayError =
74 
+  MkBox (error "(!){PreludeArray}: uninitialized array element.")
75 
+
76 
+
77 
+-- when mapping a list onto an array, be smart and don't do full index
78 
+-- computation
79 
+
80 
+listArray b@(bmin, bmax) vs =
81 
+  let size = (index b bmax) + 1
82 
+      v = primMakeVector size uninitializedArrayError
83 
+  in (MkArray b (updateArrayVs size v vs))
84 
+{-# listArray :: Inline #-}
85 
+
86 
+updateArrayVs size v vs =
87 
+  let g x next j = if (j == size)
88 
+                     then v
89 
+		     else strict1 (primVectorUpdate v j (MkBox x))
90 
+		                  (next (j + 1))
91 
+  in foldr g (\ _ -> v) vs 0
92 
+{-# updateArrayVs :: Inline #-}
93 
+
94 
+
95 
+-- Array access
96 
+
97 
+a@(MkArray b v) ! i = unBox (primVectorSel v (index b i))
98 
+{-# (!) :: Inline #-}
99 
+
100 
+bounds (MkArray b _)  = b
101 
+
102 
+indices		      = range . bounds
103 
+
104 
+
105 
+-- Again, when mapping array elements into a list, be smart and don't do
106 
+-- the full index computation for every element.
107 
+
108 
+elems a@(MkArray b@(bmin, bmax) v) =
109 
+  build (\ c n ->
110 
+          let size = (index b bmax) + 1
111 
+	      g j  = if (j == size)
112 
+	                then n
113 
+			else c (unBox (primVectorSel v j)) (g (j + 1))
114 
+          -- This strict1 is so size doesn't get inlined and recomputed
115 
+	  -- at every iteration.  It should also force the array argument
116 
+	  -- to be strict.
117 
+          in strict1 size (g 0))
118 
+{-# elems :: Inline #-}
119 
+
120 
+assocs a@(MkArray b@(bmin, bmax) v) =
121 
+  build (\ c n ->
122 
+          let g i next j = let y = unBox (primVectorSel v j)
123 
+                           in c (i := y) (next (j + 1))
124 
+	  in foldr g (\ _ -> n) (range b) 0)
125 
+{-# assocs :: Inline #-}
126 
+
127 
+
128 
+-- accum and accumArray share the same helper function.  The difference is
129 
+-- that accum makes a copy of an existing array and accumArray creates
130 
+-- a new one with all elements initialized to the given value.
131 
+
132 
+accum f a@(MkArray b v) ivs =
133 
+  let v' = primCopyVector v
134 
+  in (MkArray b (accumArrayIvs f b v' ivs))
135 
+{-# accum :: Inline #-}
136 
+
137 
+accumArray f z b@(bmin, bmax) ivs =
138 
+  let size = (index b bmax) + 1
139 
+      v = primMakeVector size (MkBox z)
140 
+  in (MkArray b (accumArrayIvs f b v ivs))
141 
+{-# accumArray :: Inline #-}
142 
+
143 
+
144 
+-- This is a bit tricky.  We need to force the access to the array element
145 
+-- before the update, but not force the thunk that is the value of the
146 
+-- array element unless f is strict.
147 
+
148 
+accumArrayIvs f b v ivs =
149 
+  let g (i := x) next =
150 
+        let j = index b i
151 
+	    y = primVectorSel v j
152 
+	in strict1
153 
+	     y
154 
+	     (strict1 (primVectorUpdate v j (MkBox (f (unBox y) x)))
155 
+	              next)
156 
+  in foldr g v ivs
157 
+{-# accumArrayIvs :: Inline #-}
158 
+
159 
+
160 
+-- again, be smart and bypass full array indexing on array mapping
161 
+
162 
+amap f a@(MkArray b@(bmin, bmax) v) =
163 
+  let size = (index b bmax) + 1
164 
+      v' = primMakeVector size uninitializedArrayError
165 
+      g j = if (j == size)
166 
+              then v'
167 
+	      else let y = primVectorSel v j
168 
+	           in strict1 (primVectorUpdate v' j (MkBox (f (unBox y))))
169 
+	                      (g (j + 1))
170 
+  in (MkArray b (g 0))
171 
+{-# amap :: Inline #-}
172 
+
173 
+
174 
+-- can't bypass the index computation here since f needs it as an argument
175 
+
176 
+ixmap b f a           = array b [i := a ! f i | i <- range b]
177 
+{-# ixmap :: Inline #-}
178 
+
179 
+
180 
+-- random other stuff
181 
+
182 
+instance  (Ix a, Eq b)  => Eq (Array a b)  where
183 
+    a == a'  	        =  assocs a == assocs a'
184 
+
185 
+instance  (Ix a, Ord b) => Ord (Array a b)  where
186 
+    a <=  a'  	    	=  assocs a <=  assocs a'
187 
+
188 
+instance  (Ix a, Text a, Text b) => Text (Array a b)  where
189 
+    showsPrec p a = showParen (p > 9) (
190 
+		    showString "array " .
191 
+		    shows (bounds a) . showChar ' ' .
192 
+		    shows (assocs a)                  )
193 
+
194 
+    readsPrec p = readParen (p > 9)
195 
+	   (\r -> [(array b as, u) | ("array",s) <- lex r,
196 
+				     (b,t)       <- reads s,
197 
+				     (as,u)      <- reads t   ]
198 
+		  ++
199 
+		  [(listArray b xs, u) | ("listArray",s) <- lex r,
200 
+					 (b,t)           <- reads s,
201 
+					 (xs,u)          <- reads t ])
progs/prelude/PreludeArrayPrims.hi
History View file @ 4e98702
0 202 
new file mode 100644
... ... 
@@ -0,0 +1,37 @@
1 
+-- These primitives are used to implement arrays with constant time
2 
+-- access.  There are destructive update routines for arrays for use
3 
+-- internally in functions such as array.  These are impure but are
4 
+-- marked as pure to keep them out of the top level monad.  This should
5 
+-- be redone using lambda-var someday.
6 
+
7 
+interface PreludeBltinArray where
8 
+
9 
+
10 
+data Vector a    -- Used to represent vectors with delayed components
11 
+data Delay a     -- An explicit represenation of a delayed object
12 
+
13 
+
14 
+-- Primitive vectors now always have strict components.  This permits us
15 
+-- to treat array indexing as an atomic operation without the explicit
16 
+-- force on access.
17 
+
18 
+primVectorSel :: Vector a -> Int -> a
19 
+primVectorUpdate :: Vector a -> Int -> a -> a
20 
+primMakeVector :: Int -> a -> Vector a
21 
+primCopyVector :: Vector a -> Vector a
22 
+
23 
+-- These functions are used for explicit sequencing of destructive ops
24 
+
25 
+strict1 :: a -> b -> b
26 
+primForce :: Delay a -> a
27 
+
28 
+{-#
29 
+primVectorSel ::  LispName("prim.vector-sel"), Complexity(1)
30 
+primVectorUpdate :: LispName("prim.vector-update"), Complexity(1)
31 
+primMakeVector :: LispName("prim.make-vector"), Complexity(4)
32 
+primCopyVector :: LispName("prim.copy-vector"), Complexity(5)
33 
+strict1 :: Strictness("S,N"),
34 
+	   LispName("prim.strict1")
35 
+primForce :: LispName("prim.force")
36 
+#-}
37 
+
progs/prelude/PreludeArrayPrims.hu
History View file @ 4e98702
0 38 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+:output $PRELUDEBIN/PreludeArrayPrims
2 
+:stable
3 
+:prelude
4 
+PreludeArrayPrims.hi
progs/prelude/PreludeComplex.hs
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,94 @@
1 
+-- Complex Numbers
2 
+
3 
+module PreludeComplex where
4 
+
5 
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
6 
+
7 
+infixl  6  :+
8 
+
9 
+data  (RealFloat a)     => Complex a = a {-#STRICT#-} :+ a {-#STRICT #-}
10 
+                               deriving (Eq,Binary,Text)
11 
+
12 
+instance  (RealFloat a) => Num (Complex a)  where
13 
+    (x:+y) + (x':+y')	=  (x+x') :+ (y+y')
14 
+    (x:+y) - (x':+y')	=  (x-x') :+ (y-y')
15 
+    (x:+y) * (x':+y')	=  (x*x'-y*y') :+ (x*y'+y*x')
16 
+    negate (x:+y)	=  negate x :+ negate y
17 
+    abs z		=  magnitude z :+ 0
18 
+    signum 0		=  0
19 
+    signum z@(x:+y)	=  x/r :+ y/r  where r = magnitude z
20 
+    fromInteger n	=  fromInteger n :+ 0
21 
+
22 
+instance  (RealFloat a) => Fractional (Complex a)  where
23 
+    (x:+y) / (x':+y')	=  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d
24 
+			   where x'' = scaleFloat k x'
25 
+				 y'' = scaleFloat k y'
26 
+				 k   = - max (exponent x') (exponent y')
27 
+				 d   = x'*x'' + y'*y''
28 
+
29 
+    fromRational a	=  fromRational a :+ 0
30 
+
31 
+instance  (RealFloat a) => Floating (Complex a)	where
32 
+    pi             =  pi :+ 0
33 
+    exp (x:+y)     =  expx * cos y :+ expx * sin y
34 
+                      where expx = exp x
35 
+    log z          =  log (magnitude z) :+ phase z
36 
+
37 
+    sqrt 0         =  0
38 
+    sqrt z@(x:+y)  =  u :+ (if y < 0 then -v else v)
39 
+                      where (u,v) = if x < 0 then (v',u') else (u',v')
40 
+                            v'    = abs y / (u'*2)
41 
+                            u'    = sqrt ((magnitude z + abs x) / 2)
42 
+
43 
+    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y
44 
+    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)
45 
+    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
46 
+                      where sinx  = sin x
47 
+                            cosx  = cos x
48 
+                            sinhy = sinh y
49 
+                            coshy = cosh y
50 
+
51 
+    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x
52 
+    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x
53 
+    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)
54 
+                      where siny  = sin y
55 
+                            cosy  = cos y
56 
+                            sinhx = sinh x
57 
+                            coshx = cosh x
58 
+
59 
+    asin z@(x:+y)  =  y':+(-x')
60 
+                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
61 
+    acos z@(x:+y)  =  y'':+(-x'')
62 
+                      where (x'':+y'') = log (z + ((-y'):+x'))
63 
+                            (x':+y')   = sqrt (1 - z*z)
64 
+    atan z@(x:+y)  =  y':+(-x')
65 
+                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))
66 
+
67 
+    asinh z        =  log (z + sqrt (1+z*z))
68 
+    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))
69 
+    atanh z        =  log ((1+z) / sqrt (1-z*z))
70 
+
71 
+
72 
+realPart, imagPart :: (RealFloat a) => Complex a -> a
73 
+realPart (x:+y)	 =  x
74 
+imagPart (x:+y)	 =  y
75 
+
76 
+conjugate	 :: (RealFloat a) => Complex a -> Complex a
77 
+conjugate (x:+y) =  x :+ (-y)
78 
+
79 
+mkPolar		 :: (RealFloat a) => a -> a -> Complex a
80 
+mkPolar r theta	 =  r * cos theta :+ r * sin theta
81 
+
82 
+cis		 :: (RealFloat a) => a -> Complex a
83 
+cis theta	 =  cos theta :+ sin theta
84 
+
85 
+polar		 :: (RealFloat a) => Complex a -> (a,a)
86 
+polar z		 =  (magnitude z, phase z)
87 
+
88 
+magnitude, phase :: (RealFloat a) => Complex a -> a
89 
+magnitude (x:+y) =  scaleFloat k
90 
+		     (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2))
91 
+		    where k  = max (exponent x) (exponent y)
92 
+		          mk = - k
93 
+
94 
+phase (x:+y)	 =  atan2 y x
progs/prelude/PreludeCore.hs
History View file @ 4e98702
0 95 
new file mode 100644
... ... 
@@ -0,0 +1,817 @@
1 
+-- Standard types, classes, and instances
2 
+
3 
+module PreludeCore (
4 
+    Eq((==), (/=)),
5 
+    Ord((<), (<=), (>=), (>), max, min),
6 
+    Num((+), (-), (*), negate, abs, signum, fromInteger),
7 
+    Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger),
8 
+    Fractional((/), recip, fromRational),
9 
+    Floating(pi, exp, log, sqrt, (**), logBase,
10 
+	     sin, cos, tan, asin, acos, atan,
11 
+	     sinh, cosh, tanh, asinh, acosh, atanh),
12 
+    Real(toRational),
13 
+    RealFrac(properFraction, truncate, round, ceiling, floor),
14 
+    RealFloat(floatRadix, floatDigits, floatRange,
15 
+	      encodeFloat, decodeFloat, exponent, significand, scaleFloat),
16 
+    Ix(range, index, inRange),
17 
+    Enum(enumFrom, enumFromThen, enumFromTo, enumFromThenTo),
18 
+    Text(readsPrec, showsPrec, readList, showList), ReadS(..), ShowS(..),
19 
+    Binary(readBin, showBin),
20 
+--  List type: [_]((:), [])
21 
+--  Tuple types: (_,_), (_,_,_), etc.
22 
+--  Trivial type: ()
23 
+    Bool(True, False),
24 
+    Char, Int, Integer, Float, Double, Bin,
25 
+    Ratio, Complex((:+)), Assoc((:=)), Array,
26 
+    String(..), Rational(..) )  where
27 
+
28 
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
29 
+
30 
+import PreludePrims
31 
+import PreludeText
32 
+import PreludeRatio(Ratio, Rational(..))
33 
+import PreludeComplex(Complex((:+)))
34 
+import PreludeArray(Assoc((:=)), Array)
35 
+import PreludeIO({-Request, Response,-} IOError,
36 
+		 Dialogue(..), SuccCont(..), StrCont(..),
37 
+		 StrListCont(..), BinCont(..), FailCont(..))
38 
+
39 
+infixr 8  **
40 
+infixl 7  *, /, `quot`, `rem`, `div`, `mod`
41 
+infixl 6  +, -
42 
+infix  4  ==, /=, <, <=, >=, >
43 
+
44 
+
45 
+infixr 5 :
46 
+
47 
+data Int = MkInt
48 
+data Integer = MkInteger
49 
+data Float = MkFloat
50 
+data Double   = MkDouble
51 
+data Char = MkChar
52 
+data Bin = MkBin
53 
+data List a = a : (List a) | Nil deriving (Eq, Ord)
54 
+data Arrow a b = MkArrow a b
55 
+data UnitType = UnitConstructor deriving (Eq, Ord, Ix, Enum, Binary)
56 
+
57 
+-- Equality and Ordered classes
58 
+
59 
+class  Eq a  where
60 
+    (==), (/=)		:: a -> a -> Bool
61 
+
62 
+    x /= y		=  not (x == y)
63 
+
64 
+class  (Eq a) => Ord a  where
65 
+    (<), (<=), (>=), (>):: a -> a -> Bool
66 
+    max, min		:: a -> a -> a
67 
+
68 
+    x <	 y		=  x <= y && x /= y
69 
+    x >= y		=  y <= x
70 
+    x >	 y		=  y <	x
71 
+
72 
+    -- The following default methods are appropriate for partial orders.
73 
+    -- Note that the second guards in each function can be replaced
74 
+    -- by "otherwise" and the error cases, eliminated for total orders.
75 
+    max x y | x >= y	=  x
76 
+	    | y >= x	=  y
77 
+	    |otherwise	=  error "max{PreludeCore}: no ordering relation"
78 
+    min x y | x <= y	=  x
79 
+	    | y <= x	=  y
80 
+	    |otherwise	=  error "min{PreludeCore}: no ordering relation"
81 
+
82 
+
83 
+-- Numeric classes
84 
+
85 
+class  (Eq a, Text a) => Num a  where
86 
+    (+), (-), (*)	:: a -> a -> a
87 
+    negate		:: a -> a
88 
+    abs, signum		:: a -> a
89 
+    fromInteger		:: Integer -> a
90 
+
91 
+    x - y		=  x + negate y
92 
+
93 
+class  (Num a, Enum a) => Real a  where
94 
+    toRational		::  a -> Rational
95 
+
96 
+class  (Real a, Ix a) => Integral a  where
97 
+    quot, rem, div, mod	:: a -> a -> a
98 
+    quotRem, divMod	:: a -> a -> (a,a)
99 
+    even, odd		:: a -> Bool
100 
+    toInteger		:: a -> Integer
101 
+
102 
+    n `quot` d		=  q  where (q,r) = quotRem n d
103 
+    n `rem` d		=  r  where (q,r) = quotRem n d
104 
+    n `div` d		=  q  where (q,r) = divMod n d
105 
+    n `mod` d		=  r  where (q,r) = divMod n d
106 
+    divMod n d 		=  if signum r == - signum d then (q-1, r+d) else qr
107 
+			   where qr@(q,r) = quotRem n d
108 
+    even n		=  n `rem` 2 == 0
109 
+    odd			=  not . even
110 
+
111 
+class  (Num a) => Fractional a  where
112 
+    (/)			:: a -> a -> a
113 
+    recip		:: a -> a
114 
+    fromRational	:: Rational -> a
115 
+
116 
+    recip x		=  1 / x
117 
+
118 
+class  (Fractional a) => Floating a  where
119 
+    pi			:: a
120 
+    exp, log, sqrt	:: a -> a
121 
+    (**), logBase	:: a -> a -> a
122 
+    sin, cos, tan	:: a -> a
123 
+    asin, acos, atan	:: a -> a
124 
+    sinh, cosh, tanh	:: a -> a
125 
+    asinh, acosh, atanh :: a -> a
126 
+
127 
+    x ** y		=  exp (log x * y)
128 
+    logBase x y		=  log y / log x
129 
+    sqrt x		=  x ** 0.5
130 
+    tan  x		=  sin  x / cos  x
131 
+    tanh x		=  sinh x / cosh x
132 
+
133 
+class  (Real a, Fractional a) => RealFrac a  where
134 
+    properFraction	:: (Integral b) => a -> (b,a)
135 
+    truncate, round	:: (Integral b) => a -> b
136 
+    ceiling, floor	:: (Integral b) => a -> b
137 
+
138 
+    truncate x		=  m  where (m,_) = properFraction x
139 
+
140 
+    round x		=  let (n,r) = properFraction x
141 
+    			       m     = if r < 0 then n - 1 else n + 1
142 
+    			   in case signum (abs r - 0.5) of
143 
+    				-1 -> n
144 
+    			 	0  -> if even n then n else m
145 
+    				1  -> m
146 
+
147 
+    ceiling x		=  if r > 0 then n + 1 else n
148 
+    			   where (n,r) = properFraction x
149 
+
150 
+    floor x		=  if r < 0 then n - 1 else n
151 
+    			   where (n,r) = properFraction x
152 
+
153 
+class  (RealFrac a, Floating a) => RealFloat a  where
154 
+    floatRadix		:: a -> Integer
155 
+    floatDigits		:: a -> Int
156 
+    floatRange		:: a -> (Int,Int)
157 
+    decodeFloat		:: a -> (Integer,Int)
158 
+    encodeFloat		:: Integer -> Int -> a
159 
+    exponent		:: a -> Int
160 
+    significand		:: a -> a
161 
+    scaleFloat		:: Int -> a -> a
162 
+
163 
+    exponent x		=  if m == 0 then 0 else n + floatDigits x
164 
+			   where (m,n) = decodeFloat x
165 
+
166 
+    significand x	=  encodeFloat m (- floatDigits x)
167 
+			   where (m,_) = decodeFloat x
168 
+
169 
+    scaleFloat k x	=  encodeFloat m (n+k)
170 
+			   where (m,n) = decodeFloat x
171 
+
172 
+
173 
+-- Index and Enumeration classes
174 
+
175 
+class  (Ord a, Text a) => Ix a  where   -- This is a Yale modification
176 
+    range		:: (a,a) -> [a]
177 
+    index		:: (a,a) -> a -> Int
178 
+    inRange		:: (a,a) -> a -> Bool
179 
+
180 
+class  (Ord a) => Enum a	where
181 
+    enumFrom		:: a -> [a]		-- [n..]
182 
+    enumFromThen	:: a -> a -> [a]	-- [n,n'..]
183 
+    enumFromTo		:: a -> a -> [a]	-- [n..m]
184 
+    enumFromThenTo	:: a -> a -> a -> [a]	-- [n,n'..m]
185 
+
186 
+    enumFromTo          = defaultEnumFromTo
187 
+    enumFromThenTo      = defaultEnumFromThenTo
188 
+
189 
+defaultEnumFromTo n m	=  takeWhile (<= m) (enumFrom n)
190 
+defaultEnumFromThenTo n n' m
191 
+			=  takeWhile (if n' >= n then (<= m) else (>= m))
192 
+				     (enumFromThen n n')
193 
+{-# defaultEnumFromTo :: Inline #-}
194 
+{-# defaultEnumFromThenTo :: Inline #-}
195 
+
196 
+-- Text class
197 
+
198 
+type  ReadS a = String -> [(a,String)]
199 
+type  ShowS   = String -> String
200 
+
201 
+class  Text a  where
202 
+    readsPrec :: Int -> ReadS a
203 
+    showsPrec :: Int -> a -> ShowS
204 
+    readList  :: ReadS [a]
205 
+    showList  :: [a] -> ShowS
206 
+
207 
+    readList    = readParen False (\r -> [pr | ("[",s)	<- lex r,
208 
+					       pr	<- readl s])
209 
+	          where readl  s = [([],t)   | ("]",t)  <- lex s] ++
210 
+				   [(x:xs,u) | (x,t)    <- reads s,
211 
+					       (xs,u)   <- readl' t]
212 
+			readl' s = [([],t)   | ("]",t)  <- lex s] ++
213 
+			           [(x:xs,v) | (",",t)  <- lex s,
214 
+					       (x,u)	<- reads t,
215 
+					       (xs,v)   <- readl' u]
216 
+    showList []	= showString "[]"
217 
+    showList (x:xs)
218 
+		= showChar '[' . shows x . showl xs
219 
+		  where showl []     = showChar ']'
220 
+			showl (x:xs) = showString ", " . shows x . showl xs
221 
+
222 
+
223 
+
224 
+-- Binary class
225 
+
226 
+class  Binary a  where
227 
+    readBin		:: Bin -> (a,Bin)
228 
+    showBin		:: a -> Bin -> Bin
229 
+
230 
+
231 
+-- Trivial type
232 
+
233 
+-- data  ()  =  ()  deriving (Eq, Ord, Ix, Enum, Binary)
234 
+
235 
+instance  Text ()  where
236 
+    readsPrec p    = readParen False
237 
+    	    	    	    (\r -> [((),t) | ("(",s) <- lex r,
238 
+					     (")",t) <- lex s ] )
239 
+    showsPrec p () = showString "()"
240 
+
241 
+
242 
+-- Binary type
243 
+
244 
+instance  Text Bin  where
245 
+    readsPrec p s  =  error "readsPrec{PreludeText}: Cannot read Bin."
246 
+    showsPrec p b  =  showString "<<Bin>>"
247 
+
248 
+
249 
+-- Boolean type
250 
+
251 
+data  Bool  =  False | True	deriving (Eq, Ord, Ix, Enum, Text, Binary)
252 
+
253 
+
254 
+-- Character type
255 
+
256 
+instance  Eq Char  where
257 
+    (==)		=  primEqChar
258 
+    (/=)                =  primNeqChar
259 
+
260 
+instance  Ord Char  where
261 
+    (<)                 =  primLsChar
262 
+    (<=)		=  primLeChar
263 
+    (>)                 =  primGtChar
264 
+    (>=)                =  primGeChar
265 
+
266 
+instance  Ix Char  where
267 
+    range (c,c')	=  [c..c']
268 
+    index b@(c,c') ci
269 
+	| inRange b ci	=  ord ci - ord c
270 
+	| otherwise	=  error "index{PreludeCore}: Index out of range."
271 
+    inRange (c,c') ci	=  ord c <= i && i <= ord c'
272 
+			   where i = ord ci
273 
+    {-# range :: Inline #-}
274 
+
275 
+instance  Enum Char  where
276 
+    enumFrom		= charEnumFrom
277 
+    enumFromThen        = charEnumFromThen
278 
+    enumFromTo          = defaultEnumFromTo
279 
+    enumFromThenTo      = defaultEnumFromThenTo
280 
+    {-# enumFrom :: Inline #-}
281 
+    {-# enumFromThen :: Inline #-}
282 
+    {-# enumFromTo :: Inline #-}
283 
+    {-# enumFromThenTo :: Inline #-}
284 
+
285 
+charEnumFrom c		=  map chr [ord c .. ord maxChar]
286 
+charEnumFromThen c c'	=  map chr [ord c, ord c' .. ord lastChar]
287 
+			   where lastChar = if c' < c then minChar else maxChar
288 
+{-# charEnumFrom :: Inline #-}
289 
+{-# charEnumFromThen :: Inline #-}
290 
+
291 
+instance  Text Char  where
292 
+    readsPrec p      = readParen False
293 
+    	    	    	    (\r -> [(c,t) | ('\'':s,t)<- lex r,
294 
+					    (c,_)     <- readLitChar s])
295 
+
296 
+    showsPrec p '\'' = showString "'\\''"
297 
+    showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''
298 
+
299 
+    readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
300 
+					       (l,_)      <- readl s ])
301 
+	       where readl ('"':s)	= [("",s)]
302 
+		     readl ('\\':'&':s)	= readl s
303 
+		     readl s		= [(c:cs,u) | (c ,t) <- readLitChar s,
304 
+						      (cs,u) <- readl t	      ]
305 
+
306 
+    showList cs = showChar '"' . showl cs
307 
+		 where showl ""       = showChar '"'
308 
+		       showl ('"':cs) = showString "\\\"" . showl cs
309 
+		       showl (c:cs)   = showLitChar c . showl cs
310 
+
311 
+type  String = [Char]
312 
+
313 
+
314 
+-- Standard Integral types
315 
+
316 
+instance  Eq Int  where
317 
+    (==)		=  primEqInt
318 
+    (/=)                =  primNeqInt
319 
+
320 
+instance  Eq Integer  where
321 
+    (==)		=  primEqInteger
322 
+    (/=)                =  primNeqInteger
323 
+
324 
+instance  Ord Int  where
325 
+    (<)                 =  primLsInt
326 
+    (<=)		=  primLeInt
327 
+    (>)                 =  primGtInt
328 
+    (>=)                =  primGeInt
329 
+    max                 =  primIntMax
330 
+    min                 =  primIntMin
331 
+
332 
+instance  Ord Integer  where
333 
+    (<)                 =  primLsInteger
334 
+    (<=)		=  primLeInteger
335 
+    (>)                 =  primGtInteger
336 
+    (>=)                =  primGeInteger
337 
+    max                 =  primIntegerMax
338 
+    min                 =  primIntegerMin
339 
+
340 
+instance  Num Int  where
341 
+    (+)			=  primPlusInt
342 
+    (-)                 =  primMinusInt
343 
+    negate		=  primNegInt
344 
+    (*)			=  primMulInt
345 
+    abs			=  primAbsInt
346 
+    signum		=  signumReal
347 
+    fromInteger		=  primIntegerToInt
348 
+
349 
+instance  Num Integer  where
350 
+    (+)			=  primPlusInteger
351 
+    (-)                 =  primMinusInteger
352 
+    negate		=  primNegInteger
353 
+    (*)			=  primMulInteger
354 
+    abs			=  primAbsInteger
355 
+    signum		=  signumReal
356 
+    fromInteger x	=  x
357 
+
358 
+signumReal x | x == 0	 =  0
359 
+   	     | x > 0	 =  1
360 
+	     | otherwise = -1
361 
+
362 
+instance  Real Int  where
363 
+    toRational x	=  toInteger x % 1
364 
+
365 
+instance  Real Integer	where
366 
+    toRational x	=  x % 1
367 
+
368 
+instance  Integral Int	where
369 
+    quotRem		=  primQuotRemInt
370 
+    toInteger		=  primIntToInteger
371 
+
372 
+instance  Integral Integer  where
373 
+    quotRem		=  primQuotRemInteger
374 
+    toInteger x		=  x
375 
+
376 
+instance  Ix Int  where
377 
+    range (m,n)		=  [m..n]
378 
+    index b@(m,n) i
379 
+	| inRange b i	=  i - m
380 
+	| otherwise	=  error "index{PreludeCore}: Index out of range."
381 
+    inRange (m,n) i	=  m <= i && i <= n
382 
+    {-# range :: Inline #-}
383 
+
384 
+instance  Ix Integer  where
385 
+    range (m,n)		=  [m..n]
386 
+    index b@(m,n) i
387 
+	| inRange b i	=  fromInteger (i - m)
388 
+	| otherwise	=  error "index{PreludeCore}: Index out of range."
389 
+    inRange (m,n) i	=  m <= i && i <= n
390 
+    {-# range :: Inline #-}
391 
+
392 
+instance  Enum Int  where
393 
+    enumFrom		=  numericEnumFrom
394 
+    enumFromThen	=  numericEnumFromThen
395 
+    enumFromTo          = defaultEnumFromTo
396 
+    enumFromThenTo      = defaultEnumFromThenTo
397 
+    {-# enumFrom :: Inline #-}
398 
+    {-# enumFromThen :: Inline #-}
399 
+    {-# enumFromTo :: Inline #-}
400 
+    {-# enumFromThenTo :: Inline #-}
401 
+
402 
+instance  Enum Integer  where
403 
+    enumFrom		=  numericEnumFrom
404 
+    enumFromThen	=  numericEnumFromThen
405 
+    enumFromTo          = defaultEnumFromTo
406 
+    enumFromThenTo      = defaultEnumFromThenTo
407 
+    {-# enumFrom :: Inline #-}
408 
+    {-# enumFromThen :: Inline #-}
409 
+    {-# enumFromTo :: Inline #-}
410 
+    {-# enumFromThenTo :: Inline #-}
411 
+
412 
+numericEnumFrom		:: (Real a) => a -> [a]
413 
+numericEnumFromThen	:: (Real a) => a -> a -> [a]
414 
+numericEnumFrom		=  iterate (+1)
415 
+numericEnumFromThen n m	=  iterate (+(m-n)) n
416 
+
417 
+{-# numericEnumFrom :: Inline #-}
418 
+{-# numericEnumFromThen :: Inline #-}
419 
+
420 
+
421 
+instance  Text Int  where
422 
+    readsPrec p		= readSigned readDec
423 
+    showsPrec   	= showSigned showInt
424 
+
425 
+instance  Text Integer  where
426 
+    readsPrec p 	= readSigned readDec
427 
+    showsPrec		= showSigned showInt
428 
+
429 
+
430 
+-- Standard Floating types
431 
+
432 
+instance  Eq Float  where
433 
+    (==)		=  primEqFloat
434 
+    (/=)                =  primNeqFloat
435 
+
436 
+instance  Eq Double  where
437 
+    (==)		=  primEqDouble
438 
+    (/=)                =  primNeqDouble
439 
+
440 
+instance  Ord Float  where
441 
+    (<)                 =  primLsFloat
442 
+    (<=)		=  primLeFloat
443 
+    (>)                 =  primGtFloat
444 
+    (>=)                =  primGeFloat
445 
+    max                 =  primFloatMax
446 
+    min                 =  primFloatMin
447 
+
448 
+instance  Ord Double  where
449 
+    (<)                 =  primLsDouble
450 
+    (<=)		=  primLeDouble
451 
+    (>)                 =  primGtDouble
452 
+    (>=)                =  primGeDouble
453 
+    max                 =  primDoubleMax
454 
+    min                 =  primDoubleMax
455 
+
456 
+instance  Num Float  where
457 
+    (+)			=  primPlusFloat
458 
+    (-)                 =  primMinusFloat
459 
+    negate		=  primNegFloat
460 
+    (*)			=  primMulFloat
461 
+    abs			=  primAbsFloat
462 
+    signum		=  signumReal
463 
+    fromInteger n	=  encodeFloat n 0
464 
+
465 
+instance  Num Double  where
466 
+    (+)			=  primPlusDouble
467 
+    (-)                 =  primMinusDouble
468 
+    negate		=  primNegDouble
469 
+    (*)			=  primMulDouble
470 
+    abs			=  primAbsDouble
471 
+    signum		=  signumReal
472 
+    fromInteger n	=  encodeFloat n 0
473 
+
474 
+instance  Real Float  where
475 
+    toRational		=  primFloatToRational
476 
+
477 
+instance  Real Double  where
478 
+    toRational		=  primDoubleToRational
479 
+
480 
+-- realFloatToRational x	=  (m%1)*(b%1)^^n
481 
+--	 		   where (m,n) = decodeFloat x
482 
+-- 				 b     = floatRadix  x
483 
+
484 
+instance  Fractional Float  where
485 
+    (/)			=  primDivFloat
486 
+    fromRational        =  primRationalToFloat
487 
+--    fromRational	=  rationalToRealFloat
488 
+
489 
+instance  Fractional Double  where
490 
+    (/)			=  primDivDouble
491 
+    fromRational        =  primRationalToDouble
492 
+--    fromRational	=  rationalToRealFloat
493 
+
494 
+-- rationalToRealFloat x	= x'
495 
+--         where x'    = f e
496 
+--               f e   = if e' == e then y else f e'
497 
+--                       where y      = encodeFloat (round (x * (1%b)^^e)) e
498 
+--                             (_,e') = decodeFloat y
499 
+--               (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
500 
+--                                         / fromInteger (denominator x))
501 
+--               b     = floatRadix x'
502 
+
503 
+instance  Floating Float  where
504 
+    pi			=  primPiFloat
505 
+    exp			=  primExpFloat
506 
+    log			=  primLogFloat
507 
+    sqrt		=  primSqrtFloat
508 
+    sin			=  primSinFloat
509 
+    cos			=  primCosFloat
510 
+    tan			=  primTanFloat
511 
+    asin		=  primAsinFloat
512 
+    acos		=  primAcosFloat
513 
+    atan		=  primAtanFloat
514 
+    sinh		=  primSinhFloat
515 
+    cosh		=  primCoshFloat
516 
+    tanh		=  primTanhFloat
517 
+    asinh		=  primAsinhFloat
518 
+    acosh		=  primAcoshFloat
519 
+    atanh		=  primAtanhFloat
520 
+
521 
+instance  Floating Double  where
522 
+    pi			=  primPiDouble
523 
+    exp			=  primExpDouble
524 
+    log			=  primLogDouble
525 
+    sqrt		=  primSqrtDouble
526 
+    sin			=  primSinDouble
527 
+    cos			=  primCosDouble
528 
+    tan			=  primTanDouble
529 
+    asin		=  primAsinDouble
530 
+    acos		=  primAcosDouble
531 
+    atan		=  primAtanDouble
532 
+    sinh		=  primSinhDouble
533 
+    cosh		=  primCoshDouble
534 
+    tanh		=  primTanhDouble
535 
+    asinh		=  primAsinhDouble
536 
+    acosh		=  primAcoshDouble
537 
+    atanh		=  primAtanhDouble
538 
+
539 
+
540 
+instance  RealFrac Float  where
541 
+    properFraction	=  floatProperFraction
542 
+
543 
+instance  RealFrac Double  where
544 
+    properFraction	=  floatProperFraction
545 
+
546 
+floatProperFraction x
547 
+	| n >= 0	=  (fromInteger m * fromInteger b ^ n, 0)
548 
+	| otherwise	=  (fromInteger w, encodeFloat r n)
549 
+			where (m,n) = decodeFloat x
550 
+			      b     = floatRadix x
551 
+			      (w,r) = quotRem m (b^(-n))
552 
+
553 
+instance  RealFloat Float  where
554 
+    floatRadix _	=  primFloatRadix
555 
+    floatDigits _	=  primFloatDigits
556 
+    floatRange _	=  (primFloatMinExp,primFloatMaxExp)
557 
+    decodeFloat		=  primDecodeFloat
558 
+    encodeFloat		=  primEncodeFloat
559 
+
560 
+instance  RealFloat Double  where
561 
+    floatRadix _	=  primDoubleRadix
562 
+    floatDigits	_	=  primDoubleDigits
563 
+    floatRange _	=  (primDoubleMinExp,primDoubleMaxExp)
564 
+    decodeFloat		=  primDecodeDouble
565 
+    encodeFloat		=  primEncodeDouble
566 
+
567 
+instance  Enum Float  where
568 
+    enumFrom		=  numericEnumFrom
569 
+    enumFromThen	=  numericEnumFromThen
570 
+    enumFromTo          = defaultEnumFromTo
571 
+    enumFromThenTo      = defaultEnumFromThenTo
572 
+    {-# enumFrom :: Inline #-}
573 
+    {-# enumFromThen :: Inline #-}
574 
+    {-# enumFromTo :: Inline #-}
575 
+    {-# enumFromThenTo :: Inline #-}
576 
+
577 
+instance  Enum Double  where
578 
+    enumFrom		=  numericEnumFrom
579 
+    enumFromThen	=  numericEnumFromThen
580 
+    enumFromTo          = defaultEnumFromTo
581 
+    enumFromThenTo      = defaultEnumFromThenTo
582 
+    {-# enumFrom :: Inline #-}
583 
+    {-# enumFromThen :: Inline #-}
584 
+    {-# enumFromTo :: Inline #-}
585 
+    {-# enumFromThenTo :: Inline #-}
586 
+
587 
+instance  Text Float  where
588 
+    readsPrec p		= readSigned readFloat
589 
+    showsPrec   	= showSigned showFloat
590 
+
591 
+instance  Text Double  where
592 
+    readsPrec p		= readSigned readFloat
593 
+    showsPrec   	= showSigned showFloat
594 
+
595 
+
596 
+-- Lists
597 
+
598 
+-- data  [a]  =  [] | a : [a]  deriving (Eq, Ord, Binary)
599 
+
600 
+instance  (Text a) => Text [a]  where
601 
+    readsPrec p		= readList
602 
+    showsPrec p		= showList
603 
+
604 
+
605 
+-- Tuples
606 
+
607 
+-- data  (a,b)  =  (a,b)  deriving (Eq, Ord, Ix, Binary)
608 
+{-
609 
+instance  (Text a, Text b) => Text (a,b)  where
610 
+    readsPrec p = readParen False
611 
+    	    	    	    (\r -> [((x,y), w) | ("(",s) <- lex r,
612 
+						 (x,t)   <- reads s,
613 
+						 (",",u) <- lex t,
614 
+						 (y,v)   <- reads u,
615 
+						 (")",w) <- lex v ] )
616 
+
617 
+    showsPrec p (x,y) = showChar '(' . shows x . showChar ',' .
618 
+    	    	    	    	       shows y . showChar ')'
619 
+-- et cetera
620 
+-}
621 
+
622 
+-- Functions
623 
+
624 
+instance  Text (a -> b)  where
625 
+    readsPrec p s  =  error "readsPrec{PreludeCore}: Cannot read functions."
626 
+    showsPrec p f  =  showString "<<function>>"
627 
+
628 
+-- Support for class Bin
629 
+
630 
+instance Binary Int where
631 
+  showBin i b = primShowBinInt i b
632 
+  readBin b = primReadBinInt b
633 
+
634 
+instance Binary Integer where
635 
+  showBin i b = primShowBinInteger i b
636 
+  readBin b = primReadBinInteger b
637 
+
638 
+instance Binary Float where
639 
+  showBin f b = primShowBinFloat f b
640 
+  readBin b = primReadBinFloat b
641 
+
642 
+instance Binary Double where
643 
+  showBin d b = primShowBinDouble d b
644 
+  readBin b = primReadBinDouble b
645 
+
646 
+instance Binary Char where
647 
+  showBin c b = primShowBinInt (ord c) b
648 
+  readBin b = (chr i,b') where
649 
+     (i,b') = primReadBinSmallInt b primMaxChar
650 
+
651 
+instance (Binary a) => Binary [a]  where
652 
+    showBin l b = showBin (length l :: Int) (sb1 l b) where
653 
+      sb1 [] b = b
654 
+      sb1 (h:t) b = showBin h (sb1 t b)
655 
+    readBin bin = rbl len bin' where
656 
+       len :: Int
657 
+       (len,bin') = readBin bin
658 
+       rbl 0 b = ([],b)
659 
+       rbl n b = (h:t,b'') where
660 
+         (h,b') = readBin b
661 
+         (t,b'') = rbl (n-1) b'
662 
+
663 
+instance  (Ix a, Binary a, Binary b) => Binary (Array a b)  where
664 
+    showBin a = showBin (bounds a) . showBin (elems a)
665 
+    readBin bin = (listArray b vs, bin'')
666 
+		 where (b,bin')   = readBin bin
667 
+		       (vs,bin'') = readBin bin'
668 
+
669 
+{-
670 
+instance (Binary a, Binary b) => Binary (a,b) where
671 
+  showBin (x,y) = (showBin x) . (showBin y)
672 
+  readBin b = ((x,y),b'') where
673 
+                (x,b') = readBin b
674 
+                (y,b'') = readBin b'
675 
+
676 
+instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
677 
+  showBin (x,y,z) = (showBin x) . (showBin y) . (showBin z)
678 
+  readBin b = ((x,y,z),b3) where
679 
+                (x,b1) = readBin b
680 
+                (y,b2) = readBin b1
681 
+	        (z,b3) = readBin b2
682 
+
683 
+instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
684 
+  showBin (a,b,c,d) = (showBin a) . (showBin b) . (showBin c) . (showBin d)
685 
+  readBin b = ((a1,a2,a3,a4),b4) where
686 
+                (a1,b1) = readBin b
687 
+                (a2,b2) = readBin b1
688 
+	        (a3,b3) = readBin b2
689 
+	        (a4,b4) = readBin b3
690 
+-}
691 
+--   Instances for tuples
692 
+
693 
+-- This whole section should be handled in the support code.  For now,
694 
+-- only tuple instances expliticly provided here are available.
695 
+-- Currently provided:
696 
+
697 
+-- 2,3 tuples: all classes (Eq, Ord, Ix, Bin, Text)
698 
+-- 4 tuples: Eq, Bin, Text
699 
+-- 5, 6 tuples: Text (printing only)
700 
+
701 
+{-
702 
+rangeSize               :: (Ix a) => (a,a) -> Int
703 
+rangeSize (l,u)         =  index (l,u) u + 1
704 
+
705 
+instance (Eq a1, Eq a2) => Eq (a1,a2) where
706 
+  (a1,a2) == (z1,z2) = a1==z1 && a2==z2
707 
+
708 
+instance (Ord a1, Ord a2) => Ord (a1,a2) where
709 
+  (a1,a2) <= (z1,z2) = a1<=z1 || a1==z1 && a2<=z2
710 
+  (a1,a2) <  (z1,z2) = a1<z1  || a1==z1 && a2<z2
711 
+
712 
+instance (Ix a1, Ix a2) => Ix (a1,a2) where
713 
+  range ((l1,l2),(u1,u2)) = [(i1,i2) | i1 <- range(l1,u1),
714 
+                                       i2 <- range(l2,u2)]
715 
+  index ((l1,l2),(u1,u2)) (i1,i2) =
716 
+    index (l1,u1) i1 * rangeSize (l2,u2)
717 
+    + index (l2,u2) i2
718 
+  inRange ((l1,l2),(u1,u2)) (i1,i2) =
719 
+    inRange (l1,u1) i1 && inRange (l2,u2) i2
720 
+
721 
+{-    Apprears in Joe's code.
722 
+instance (Text a1, Text a2) => Text (a1,a2) where
723 
+  readsPrec p = readParen False
724 
+                          (\r0 -> [((a1,a2), w) | ("(",r1) <- lex r0,
725 
+                                                  (a1,r2)  <- reads r1,
726 
+                                                  (",",r3) <- lex r2,
727 
+                                                  (a2,r4)  <- reads r3,
728 
+                                                  (")",w)  <- lex r4 ])
729 
+
730 
+  showsPrec p (a1,a2) = showChar '(' . shows a1 . showChar ',' .
731 
+                                       shows a2 . showChar ')'
732 
+-}
733 
+
734 
+instance (Eq a1, Eq a2, Eq a3) => Eq (a1,a2,a3) where
735 
+  (a1,a2,a3) == (z1,z2,z3) = a1==z1 && a2==z2 && a3==z3
736 
+
737 
+instance (Ord a1, Ord a2, Ord a3) => Ord (a1,a2,a3) where
738 
+  (a1,a2,a3) <= (z1,z2,z3) = a1<=z1 || a1==z1 &&
739 
+			      (a2<=z2 || a2==z2 &&
740 
+				a3<=z3)
741 
+  (a1,a2,a3) <  (z1,z2,z3) = a1<z1  || a1==z1 &&
742 
+   			      (a2<z2 || a2==z2 &&
743 
+           			a3<z3)
744 
+
745 
+
746 
+instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where
747 
+  range ((l1,l2,l3),(u1,u2,u3)) =
748 
+     [(i1,i2,i3) | i1 <- range(l1,u1),
749 
+                   i2 <- range(l2,u2),
750 
+                   i3 <- range(l3,u3)]
751 
+  index ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =
752 
+    (index (l1,u1) i1 * rangeSize (l2,u2)
753 
+     + index (l2,u2) i2 ) * rangeSize (l3,u3)
754 
+     + index (l3,u3) i3
755 
+  inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =
756 
+    inRange (l1,u1) i1 && inRange (l2,u2) i2 && inRange (l3,u3) i3
757 
+
758 
+
759 
+instance (Text a1, Text a2, Text a3) => Text (a1,a2,a3) where
760 
+  readsPrec p = readParen False
761 
+                          (\r0 -> [((a1,a2,a3), w) |
762 
+                                                  ("(",r1) <- lex r0,
763 
+                                                  (a1,r2)  <- reads r1,
764 
+                                                  (",",r3) <- lex r2,
765 
+                                                  (a2,r4)  <- reads r3,
766 
+                                                  (",",r5) <- lex r4,
767 
+                                                  (a3,r6)  <- reads r5,
768 
+                                                  (")",w)  <- lex r6 ])
769 
+  showsPrec p (a1,a2,a3) =
770 
+                        showChar '(' . shows a1 . showChar ',' .
771 
+                                       shows a2 . showChar ',' .
772 
+                                       shows a3 . showChar ')'
773 
+
774 
+instance (Eq a1, Eq a2, Eq a3, Eq a4) => Eq (a1,a2,a3,a4) where
775 
+  (a1,a2,a3,a4) == (z1,z2,z3,z4) = a1==z1 && a2==z2 && a3==z3 && a4 == z4
776 
+
777 
+instance (Text a1, Text a2, Text a3, Text a4) => Text (a1,a2,a3,a4) where
778 
+  readsPrec p = readParen False
779 
+                          (\r0 -> [((a1,a2,a3,a4), w) |
780 
+                                                  ("(",r1) <- lex r0,
781 
+                                                  (a1,r2)  <- reads r1,
782 
+                                                  (",",r3) <- lex r2,
783 
+                                                  (a2,r4)  <- reads r3,
784 
+                                                  (",",r5) <- lex r4,
785 
+                                                  (a3,r6)  <- reads r5,
786 
+	                                          (",",r7) <- lex r6,
787 
+						  (a4,r8)  <- reads r7,
788 
+                                                  (")",w)  <- lex r8 ])
789 
+  showsPrec p (a1,a2,a3,a4) =
790 
+                        showChar '(' . shows a1 . showChar ',' .
791 
+                                       shows a2 . showChar ',' .
792 
+                                       shows a3 . showChar ',' .
793 
+                                       shows a4 . showChar ')'
794 
+
795 
+instance (Text a1, Text a2, Text a3, Text a4, Text a5) =>
796 
+      Text (a1,a2,a3,a4,a5) where
797 
+  readsPrec p = error "Read of 5 tuples not implemented"
798 
+  showsPrec p (a1,a2,a3,a4,a5) =
799 
+                        showChar '(' . shows a1 . showChar ',' .
800 
+                                       shows a2 . showChar ',' .
801 
+                                       shows a3 . showChar ',' .
802 
+                                       shows a4 . showChar ',' .
803 
+                                       shows a5 . showChar ')'
804 
+
805 
+instance (Text a1, Text a2, Text a3, Text a4, Text a5, Text a6) =>
806 
+      Text (a1,a2,a3,a4,a5,a6) where
807 
+  readsPrec p = error "Read of 6 tuples not implemented"
808 
+  showsPrec p (a1,a2,a3,a4,a5,a6) =
809 
+                        showChar '(' . shows a1 . showChar ',' .
810 
+                                       shows a2 . showChar ',' .
811 
+                                       shows a3 . showChar ',' .
812 
+                                       shows a4 . showChar ',' .
813 
+                                       shows a5 . showChar ',' .
814 
+                                       shows a6 . showChar ')'
815 
+
816 
+
817 
+-}
progs/prelude/PreludeIO.hs
History View file @ 4e98702
0 818 
new file mode 100644
... ... 
@@ -0,0 +1,232 @@
1 
+-- I/O functions and definitions
2 
+
3 
+module PreludeIO(stdin,stdout,stderr,stdecho,{-Request(..),Response(..),-}
4 
+                 IOError(..),Dialogue(..),IO(..),SystemState,IOResult,
5 
+                 SuccCont(..),StrCont(..),
6 
+                 StrListCont(..),BinCont(..),FailCont(..),
7 
+                 readFile, writeFile,  appendFile,  readBinFile,
8 
+                 writeBinFile,  appendBinFile,  deleteFile,  statusFile,
9 
+                 readChan,  appendChan,  readBinChan,  appendBinChan,
10 
+                 statusChan,  echo,  getArgs,  getProgName,  getEnv,  setEnv,
11 
+                 done, exit, abort, print, prints, interact,
12 
+		 thenIO,thenIO_,seqIO,returnIO, doneIO)
13 
+   where
14 
+
15 
+import PreludeBltinIO
16 
+import PreludeBltinArray(strict1)
17 
+
18 
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
19 
+
20 
+-- These datatypes are used by the monad.
21 
+
22 
+type IO a = SystemState -> IOResult a
23 
+
24 
+data SystemState = SystemState
25 
+data IOResult a = IOResult a
26 
+
27 
+-- Operations in the monad
28 
+
29 
+-- This definition is needed to allow proper tail recursion of the Lisp
30 
+-- code.  The use of strict1 forces f1 s (since getState is strict) before
31 
+-- the call to f2.  The optimizer removed getState and getRes from the
32 
+-- generated code.
33 
+
34 
+{-# thenIO :: Inline #-}
35 
+thenIO f1 f2 s =
36 
+  let g = f1 s
37 
+      s' = getState g in
38 
+    strict1 s' (f2 (getRes g) s')
39 
+
40 
+{-# thenIO_ :: Inline #-}
41 
+x `thenIO_` y = x `thenIO` \_ -> y
42 
+x `seqIO` y = x `thenIO` \_ -> y
43 
+
44 
+-- The returnIO function is implemented directly as a primitive.
45 
+doneIO = returnIO ()
46 
+
47 
+
48 
+-- File and channel names:
49 
+
50 
+stdin	    =  "stdin"
51 
+stdout      =  "stdout"
52 
+stderr      =  "stderr"
53 
+stdecho     =  "stdecho"
54 
+
55 
+
56 
+-- Requests and responses:
57 
+
58 
+{-  Not used since streams are no longer supported:
59 
+data Request =	-- file system requests:
60 
+			  ReadFile      String
61 
+			| WriteFile     String String
62 
+			| AppendFile    String String
63 
+			| ReadBinFile   String
64 
+			| WriteBinFile  String Bin
65 
+			| AppendBinFile String Bin
66 
+			| DeleteFile    String
67 
+			| StatusFile    String
68 
+		-- channel system requests:
69 
+			| ReadChan	String
70 
+			| AppendChan    String String
71 
+			| ReadBinChan   String
72 
+			| AppendBinChan String Bin
73 
+			| StatusChan    String
74 
+		-- environment requests:
75 
+			| Echo          Bool
76 
+			| GetArgs
77 
+			| GetProgName
78 
+			| GetEnv        String
79 
+			| SetEnv        String String
80 
+		deriving Text
81 
+
82 
+data Response =		  Success
83 
+			| Str String
84 
+			| StrList [String]
85 
+			| Bn  Bin
86 
+			| Failure IOError
87 
+		deriving Text
88 
+
89 
+-}
90 
+
91 
+data IOError =		  WriteError   String
92 
+			| ReadError    String
93 
+			| SearchError  String
94 
+			| FormatError  String
95 
+			| OtherError   String
96 
+		deriving Text
97 
+
98 
+-- Continuation-based I/O:
99 
+
100 
+type Dialogue    =  IO ()
101 
+type SuccCont    =                Dialogue
102 
+type StrCont     =  String     -> Dialogue
103 
+type StrListCont =  [String]   -> Dialogue
104 
+type BinCont     =  Bin        -> Dialogue
105 
+type FailCont    =  IOError    -> Dialogue
106 
+
107 
+done	      ::                                                Dialogue
108 
+readFile      :: String ->           FailCont -> StrCont     -> Dialogue
109 
+writeFile     :: String -> String -> FailCont -> SuccCont    -> Dialogue
110 
+appendFile    :: String -> String -> FailCont -> SuccCont    -> Dialogue
111 
+readBinFile   :: String ->           FailCont -> BinCont     -> Dialogue
112 
+writeBinFile  :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
113 
+appendBinFile :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
114 
+deleteFile    :: String ->           FailCont -> SuccCont    -> Dialogue
115 
+statusFile    :: String ->           FailCont -> StrCont     -> Dialogue
116 
+readChan      :: String ->           FailCont -> StrCont     -> Dialogue
117 
+appendChan    :: String -> String -> FailCont -> SuccCont    -> Dialogue
118 
+readBinChan   :: String ->           FailCont -> BinCont     -> Dialogue
119 
+appendBinChan :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
120 
+statusChan    :: String ->           FailCont -> StrCont     -> Dialogue
121 
+echo          :: Bool ->             FailCont -> SuccCont    -> Dialogue
122 
+getArgs	      ::		     FailCont -> StrListCont -> Dialogue
123 
+getProgName   ::		     FailCont -> StrCont     -> Dialogue
124 
+getEnv	      :: String ->	     FailCont -> StrCont     -> Dialogue
125 
+setEnv	      :: String -> String -> FailCont -> SuccCont    -> Dialogue
126 
+
127 
+done = returnIO ()
128 
+
129 
+readFile name fail succ =
130 
+    primReadStringFile name `thenIO` objDispatch fail succ
131 
+
132 
+writeFile name contents fail succ =
133 
+    primWriteStringFile name contents `thenIO` succDispatch fail succ
134 
+
135 
+appendFile name contents fail succ =
136 
+    primAppendStringFile name contents `thenIO` succDispatch fail succ
137 
+
138 
+readBinFile name fail succ =
139 
+    primReadBinFile name `thenIO` objDispatch fail succ
140 
+
141 
+writeBinFile name contents fail succ =
142 
+    primWriteBinFile name contents `thenIO` succDispatch fail succ
143 
+
144 
+appendBinFile name contents fail succ =
145 
+    primAppendBinFile name contents `thenIO` succDispatch fail succ
146 
+
147 
+deleteFile name fail succ =
148 
+    primDeleteFile name `thenIO` succDispatch fail succ
149 
+
150 
+statusFile name fail succ =
151 
+    primStatusFile name `thenIO`
152 
+      (\status ->  case status of Succ s            -> succ s
153 
+                                  Fail msg          -> fail (SearchError msg))
154 
+
155 
+readChan name fail succ =
156 
+ if name == stdin then
157 
+    primReadStdin `thenIO` succ
158 
+ else
159 
+    badChan fail name
160 
+
161 
+appendChan name contents fail succ =
162 
+ if name == stdout then
163 
+    primWriteStdout contents `thenIO` succDispatch fail succ
164 
+ else
165 
+    badChan fail name
166 
+
167 
+readBinChan name fail succ =
168 
+  if name == stdin then
169 
+    primReadBinStdin `thenIO` objDispatch fail succ
170 
+  else
171 
+    badChan fail name
172 
+
173 
+appendBinChan name contents fail succ =
174 
+  if name == stdout then
175 
+    primWriteBinStdout contents `thenIO` succDispatch fail succ
176 
+  else
177 
+    badChan fail name
178 
+
179 
+statusChan name fail succ =
180 
+  if name == stdin || name == stdout then
181 
+     succ "0 0"
182 
+  else
183 
+     fail (SearchError "Channel not defined")
184 
+
185 
+echo bool fail succ =
186 
+  if bool then
187 
+     succ
188 
+  else
189 
+     fail (OtherError "Echo cannot be turned off")
190 
+
191 
+getArgs fail succ =
192 
+  succ [""]
193 
+
194 
+getProgName fail succ =
195 
+    succ "haskell"
196 
+
197 
+getEnv name fail succ =
198 
+    primGetEnv name `thenIO` objDispatch fail succ
199 
+
200 
+setEnv name val fail succ =
201 
+    fail (OtherError "setEnv not implemented")
202 
+
203 
+objDispatch fail succ r =
204 
+            case r of Succ s            -> succ s
205 
+                      Fail msg          -> fail (OtherError msg)
206 
+
207 
+succDispatch fail succ r =
208 
+            case r of Succ _            -> succ
209 
+                      Fail msg          -> fail (OtherError msg)
210 
+
211 
+badChan f name = f (OtherError ("Improper IO Channel: " ++ name))
212 
+
213 
+abort		:: FailCont
214 
+abort err	=  done
215 
+
216 
+exit		:: FailCont
217 
+exit err	= appendChan stderr (msg ++ "\n") abort done
218 
+		  where msg = case err of ReadError s   -> s
219 
+		  			  WriteError s  -> s
220 
+		  			  SearchError s -> s
221 
+		      			  FormatError s -> s
222 
+		      			  OtherError s  -> s
223 
+
224 
+print		:: (Text a) => a -> Dialogue
225 
+print x		=  appendChan stdout (show x) exit done
226 
+prints          :: (Text a) => a -> String -> Dialogue
227 
+prints x s	=  appendChan stdout (shows x s) exit done
228 
+
229 
+interact	:: (String -> String) -> Dialogue
230 
+interact f	=  readChan stdin exit
231 
+			    (\x -> appendChan stdout (f x) exit done)
232 
+
progs/prelude/PreludeIOMonad.hs
History View file @ 4e98702
0 233 
new file mode 100644
... ... 
@@ -0,0 +1,60 @@
1 
+module IOMonad (State, IO(..)) where
2 
+
3 
+import IOMonadPrims
4 
+
5 
+{- I use data instead of type so that IO can be abstract. For efficiency,
6 
+   IO can be annotated as a strict constructor.
7 
+-}
8 
+
9 
+type IO a = State -> (State, a)
10 
+
11 
+data State = State
12 
+
13 
+-- The rest of this file is unnecessary at the moment since
14 
+-- unitIO & bindIO are primitives and we're not using the rest of this
15 
+
16 
+{- Implemented as a primitives:
17 
+bindIO :: IO a -> (a -> IO b) -> IO b
18 
+bindIO (IO m) (IO k) = IO (\s0 -> let (s1, a) = m s0 in k a s1) -}
19 
+
20 
+unitIO :: a -> IO a
21 
+unitIO x = IO (\s -> (s, x))
22 
+
23 
+-}
24 
+
25 
+{-  Not currently used:
26 
+pureIO :: IO a -> a
27 
+pureIO (IO m) = let (s, x) = m State in x
28 
+
29 
+-- execIO executes a program of type IO ().
30 
+execIO :: IO () -> State
31 
+execIO (IO m) = let (s, x) = m State in s
32 
+
33 
+infixr  1 =:
34 
+infixr  1 ?
35 
+
36 
+-- assignment
37 
+(=:)      :: a -> Var a -> IO ()
38 
+x =: v  = IO (\s -> (update v x s, ()))
39 
+
40 
+-- reader
41 
+(?)       :: Var a -> (a -> IO b) -> IO b
42 
+v ? k   = IO (\s -> (s, readVar v s)) `bindIO` k
43 
+
44 
+-- new
45 
+newvar    :: IO (Var a)
46 
+newvar = IO allocVar
47 
+
48 
+instance Eq (Var a) where
49 
+   x == y = eqVar x y
50 
+-}
51 
+
52 
+
53 
+
54 
+
55 
+
56 
+
57 
+
58 
+
59 
+
60 
+
progs/prelude/PreludeIOPrims.hi
History View file @ 4e98702
0 61 
new file mode 100644
... ... 
@@ -0,0 +1,55 @@
1 
+-- These lisp functions implement the standard Haskell requests
2 
+
3 
+interface PreludeBltinIO where
4 
+
5 
+import PreludeCore(String,Bin)
6 
+import PreludeIO(SystemState,IOResult,IO)
7 
+data IOResponse a = Succ a | Fail String
8 
+
9 
+{-# Prelude #-}
10 
+
11 
+primReadStringFile :: String -> IO (IOResponse String)
12 
+primWriteStringFile :: String -> String -> IO (IOResponse ())
13 
+primAppendStringFile :: String -> String -> IO (IOResponse ())
14 
+primReadBinFile :: String -> IO (IOResponse Bin)
15 
+primWriteBinFile :: String -> Bin -> IO (IOResponse ())
16 
+primAppendBinFile :: String -> Bin -> IO (IOResponse ())
17 
+primDeleteFile :: String -> IO (IOResponse ())
18 
+primStatusFile :: String -> IO (IOResponse String)
19 
+primReadStdin :: IO String
20 
+primWriteStdout :: String -> IO (IOResponse ())
21 
+primReadBinStdin :: IO (IOResponse Bin)
22 
+primWriteBinStdout :: Bin -> IO (IOResponse ())
23 
+primGetEnv :: String -> IO (IOResponse String)
24 
+
25 
+{-#
26 
+primReadStringFile ::   LispName("prim.read-string-file")
27 
+primWriteStringFile ::  LispName("prim.write-string-file"), NoConversion
28 
+primAppendStringFile :: LispName("prim.append-string-file"), NoConversion
29 
+primReadBinFile ::      LispName("prim.read-bin-file")
30 
+primWriteBinFile ::     LispName("prim.write-bin-file")
31 
+primAppendBinFile ::    LispName("prim.append-bin-file")
32 
+primDeleteFile ::       LispName("prim.delete-file")
33 
+primStatusFile ::       LispName("prim.status-file")
34 
+primReadStdin ::        LispName("prim.read-string-stdin"), NoConversion
35 
+primWriteStdout ::      LispName("prim.write-string-stdout"), NoConversion
36 
+primReadBinStdin ::     LispName("prim.read-bin-stdin")
37 
+primWriteBinStdout ::   LispName("prim.write-bin-stdout")
38 
+primGetEnv ::           LispName("prim.getenv")
39 
+#-}
40 
+
41 
+--   Monad prims
42 
+
43 
+returnIO :: a -> IO a
44 
+getState :: IOResult a -> SystemState
45 
+getRes :: IOResult a -> a
46 
+
47 
+{-#
48 
+returnIO :: LispName("prim.returnio"),
49 
+            Strictness("N,S"), NoConversion, Complexity(3)
50 
+getState :: LispName("prim.getstate"),
51 
+            Strictness("S"), NoConversion, Complexity(3)
52 
+getRes :: LispName("prim.getres"),
53 
+          Strictness("S"), NoConversion
54 
+#-}
55 
+
progs/prelude/PreludeIOPrims.hu
History View file @ 4e98702
0 56 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+:output $PRELUDEBIN/PreludeIOPrims
2 
+:stable
3 
+:prelude
4 
+PreludeIOPrims.hi
progs/prelude/PreludeList.hs
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,585 @@
1 
+-- Standard list functions
2 
+
3 
+-- build really shouldn't be exported, but what the heck.
4 
+-- some of the helper functions in this file shouldn't be
5 
+-- exported either!
6 
+
7 
+module PreludeList (PreludeList.., foldr, build) where
8 
+
9 
+import PreludePrims(build, foldr)
10 
+
11 
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
12 
+
13 
+infixl 9  !!
14 
+infix  5  \\
15 
+infixr 5  ++
16 
+infix  4 `elem`, `notElem`
17 
+
18 
+
19 
+-- These are primitives used by the deforestation stuff in the optimizer.
20 
+-- the optimizer will turn references to foldr and build into
21 
+-- inlineFoldr and inlineBuild, respectively, but doesn't want to
22 
+-- necessarily inline all references immediately.
23 
+
24 
+inlineFoldr :: (a -> b -> b) -> b -> [a] -> b
25 
+inlineFoldr f z l =
26 
+  let foldr' []	 	= z
27 
+      foldr' (x:xs)	= f x (foldr' xs)
28 
+  in foldr' l
29 
+{-# inlineFoldr :: Inline #-}
30 
+
31 
+
32 
+inlineBuild :: ((a -> [a] -> [a]) -> [b] -> [c]) -> [c]
33 
+inlineBuild g           = g (:) []
34 
+{-# inlineBuild :: Inline #-}
35 
+
36 
+
37 
+-- head and tail extract the first element and remaining elements,
38 
+-- respectively, of a list, which must be non-empty.  last and init
39 
+-- are the dual functions working from the end of a finite list,
40 
+-- rather than the beginning.
41 
+
42 
+head			:: [a] -> a
43 
+head (x:_)		=  x
44 
+head []			=  error "head{PreludeList}: head []"
45 
+
46 
+last			:: [a] -> a
47 
+last [x]		=  x
48 
+last (_:xs)		=  last xs
49 
+last []			=  error "last{PreludeList}: last []"
50 
+
51 
+tail			:: [a] -> [a]
52 
+tail (_:xs)		=  xs
53 
+tail []			=  error "tail{PreludeList}: tail []"
54 
+
55 
+init			:: [a] -> [a]
56 
+init [x]		=  []
57 
+init (x:xs)		=  x : init xs
58 
+init []			=  error "init{PreludeList}: init []"
59 
+
60 
+-- null determines if a list is empty.
61 
+null			:: [a] -> Bool
62 
+null []			=  True
63 
+null (_:_)		=  False
64 
+
65 
+
66 
+-- list concatenation (right-associative)
67 
+
68 
+(++)			:: [a] -> [a] -> [a]
69 
+xs ++ ys		= build (\ c n -> foldr c (foldr c n ys) xs)
70 
+{-# (++) :: Inline #-}
71 
+
72 
+
73 
+-- the first occurrence of each element of ys in turn (if any)
74 
+-- has been removed from xs.  Thus, (xs ++ ys) \\ xs == ys.
75 
+(\\)			:: (Eq a) => [a] -> [a] -> [a]
76 
+(\\)			=  foldl del
77 
+			   where [] `del` _	    = []
78 
+				 (x:xs) `del` y
79 
+					| x == y    = xs
80 
+					| otherwise = x : xs `del` y
81 
+
82 
+-- length returns the length of a finite list as an Int; it is an instance
83 
+-- of the more general genericLength, the result type of which may be
84 
+-- any kind of number.
85 
+
86 
+genericLength		:: (Num a) => [b] -> a
87 
+genericLength l         = foldr (\ x n -> 1 + n) 0 l
88 
+--genericLength []	=  0
89 
+--genericLength (x:xs)    =  1 + genericLength xs
90 
+{-# genericLength :: Inline #-}
91 
+
92 
+
93 
+length			:: [a] -> Int
94 
+length l		= foldr (\ x n -> 1 + n) 0 l
95 
+--length []               = 0
96 
+--length (x:xs)           = 1 + length xs
97 
+{-# length :: Inline #-}
98 
+
99 
+-- List index (subscript) operator, 0-origin
100 
+(!!)			:: (Integral a) => [b] -> a -> b
101 
+l !! i			=  nth l (fromIntegral i)
102 
+{-# (!!)  :: Inline #-}
103 
+
104 
+nth                     :: [b] -> Int -> b
105 
+nth l m	= let f x g 0 = x
106 
+	      f x g i = g (i - 1)
107 
+	      fail _ = error "(!!){PreludeList}: index too large"
108 
+	  in foldr f fail l m
109 
+{-# nth  :: Inline #-}
110 
+--nth _ n  | n < 0	= error "(!!){PreludeList}: negative index"
111 
+--nth [] n		= error "(!!){PreludeList}: index too large"
112 
+--nth (x:xs) n
113 
+--	| n == 0	= x
114 
+--	| otherwise     = nth xs (n - 1)
115 
+--{-# nth  :: Strictness("S,S") #-}
116 
+
117 
+-- map f xs applies f to each element of xs; i.e., map f xs == [f x | x <- xs].
118 
+map			:: (a -> b) -> [a] -> [b]
119 
+map f xs		= build (\ c n -> foldr (\ a b -> c (f a) b) n xs)
120 
+--map f []		=  []
121 
+--map f (x:xs)		=  f x : map f xs
122 
+{-# map  :: Inline #-}
123 
+
124 
+
125 
+-- filter, applied to a predicate and a list, returns the list of those
126 
+-- elements that satisfy the predicate; i.e.,
127 
+-- filter p xs == [x | x <- xs, p x].
128 
+filter			:: (a -> Bool) -> [a] -> [a]
129 
+filter f xs		= build (\ c n ->
130 
+                                  foldr (\ a b -> if f a then c a b else b)
131 
+				  n xs)
132 
+--filter p		=  foldr (\x xs -> if p x then x:xs else xs) []
133 
+{-# filter  :: Inline #-}
134 
+
135 
+
136 
+-- partition takes a predicate and a list and returns a pair of lists:
137 
+-- those elements of the argument list that do and do not satisfy the
138 
+-- predicate, respectively; i.e.,
139 
+-- partition p xs == (filter p xs, filter (not . p) xs).
140 
+partition		:: (a -> Bool) -> [a] -> ([a],[a])
141 
+partition p		=  foldr select ([],[])
142 
+			   where select x (ts,fs) | p x	      = (x:ts,fs)
143 
+						  | otherwise = (ts,x:fs)
144 
+{-# partition  :: Inline #-}
145 
+
146 
+
147 
+-- foldl, applied to a binary operator, a starting value (typically the
148 
+-- left-identity of the operator), and a list, reduces the list using
149 
+-- the binary operator, from left to right:
150 
+--	foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
151 
+-- foldl1 is a variant that has no starting value argument, and  thus must
152 
+-- be applied to non-empty lists.  scanl is similar to foldl, but returns
153 
+-- a list of successive reduced values from the left:
154 
+--	scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
155 
+-- Note that  last (scanl f z xs) == foldl f z xs.
156 
+-- scanl1 is similar, again without the starting element:
157 
+--	scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
158 
+
159 
+foldl			:: (a -> b -> a) -> a -> [b] -> a
160 
+foldl f z xs            = foldr (\ b g a -> g (f a b)) id xs z
161 
+--foldl f z []		=  z
162 
+--foldl f z (x:xs)	=  foldl f (f z x) xs
163 
+{-# foldl  :: Inline #-}
164 
+
165 
+foldl1			:: (a -> a -> a) -> [a] -> a
166 
+foldl1 f (x:xs)		=  foldl f x xs
167 
+foldl1 _ []		=  error "foldl1{PreludeList}: empty list"
168 
+{-# foldl1  :: Inline #-}
169 
+
170 
+scanl			:: (a -> b -> a) -> a -> [b] -> [a]
171 
+scanl f q xs		=  q : (case xs of
172 
+				[]   -> []
173 
+				x:xs -> scanl f (f q x) xs)
174 
+{-# scanl  :: Inline #-}
175 
+
176 
+scanl1			:: (a -> a -> a) -> [a] -> [a]
177 
+scanl1 f (x:xs)		=  scanl f x xs
178 
+scanl1 _ []		=  error "scanl1{PreludeList}: empty list"
179 
+{-# scanl1 :: Inline #-}
180 
+
181 
+
182 
+-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
183 
+-- above functions.
184 
+
185 
+--foldr			:: (a -> b -> b) -> b -> [a] -> b
186 
+--foldr f z []		=  z
187 
+--foldr f z (x:xs)	=  f x (foldr f z xs)
188 
+
189 
+
190 
+foldr1			:: (a -> a -> a) -> [a] -> a
191 
+foldr1 f [x]		=  x
192 
+foldr1 f (x:xs)		=  f x (foldr1 f xs)
193 
+foldr1 _ []		=  error "foldr1{PreludeList}: empty list"
194 
+{-# foldr1  :: Inline #-}
195 
+
196 
+
197 
+-- I'm not sure the build/foldr expansion wins.
198 
+
199 
+scanr			:: (a -> b -> b) -> b -> [a] -> [b]
200 
+--scanr f q0 l = build (\ c n ->
201 
+--                        let g x qs@(q:_) = c (f x q) qs
202 
+--			in foldr g (c q0 n) l)
203 
+scanr f q0 []		=  [q0]
204 
+scanr f q0 (x:xs)	=  f x q : qs
205 
+			   where qs@(q:_) = scanr f q0 xs
206 
+{-# scanr  :: Inline #-}
207 
+
208 
+scanr1			:: (a -> a -> a) -> [a] -> [a]
209 
+scanr1 f  [x]		=  [x]
210 
+scanr1 f  (x:xs)	=  f x q : qs
211 
+			   where qs@(q:_) = scanr1 f xs
212 
+scanr1 _ []		=  error "scanr1{PreludeList}: empty list"
213 
+{-# scanr1  :: Inline #-}
214 
+
215 
+
216 
+-- iterate f x returns an infinite list of repeated applications of f to x:
217 
+-- iterate f x == [x, f x, f (f x), ...]
218 
+iterate			:: (a -> a) -> a -> [a]
219 
+iterate f x	= build (\ c n ->
220 
+                          let iterate' x' = c x' (iterate' (f x'))
221 
+			  in iterate' x)
222 
+--iterate f x		=  x : iterate f (f x)
223 
+{-# iterate  :: Inline #-}
224 
+
225 
+
226 
+-- repeat x is an infinite list, with x the value of every element.
227 
+repeat			:: a -> [a]
228 
+repeat x		= build (\ c n -> let r = c x r in r)
229 
+--repeat x		=  xs where xs = x:xs
230 
+{-# repeat  :: Inline #-}
231 
+
232 
+-- cycle ties a finite list into a circular one, or equivalently,
233 
+-- the infinite repetition of the original list.  It is the identity
234 
+-- on infinite lists.
235 
+
236 
+cycle			:: [a] -> [a]
237 
+cycle xs		=  xs' where xs' = xs ++ xs'
238 
+
239 
+
240 
+-- take n, applied to a list xs, returns the prefix of xs of length n,
241 
+-- or xs itself if n > length xs.  drop n xs returns the suffix of xs
242 
+-- after the first n elements, or [] if n > length xs.  splitAt n xs
243 
+-- is equivalent to (take n xs, drop n xs).
244 
+
245 
+take			:: (Integral a) => a -> [b] -> [b]
246 
+take n l		= takeInt (fromIntegral n) l
247 
+{-# take  :: Inline #-}
248 
+
249 
+takeInt                 :: Int -> [b] -> [b]
250 
+takeInt m l =
251 
+  build (\ c n ->
252 
+           let f x g i | i <= 0		= n
253 
+	               | otherwise      = c x (g (i - 1))
254 
+           in foldr f (\ _ -> n) l m)
255 
+--takeInt  0     _	=  []
256 
+--takeInt  _     []	=  []
257 
+--takeInt  n l | n > 0    = primTake n l
258 
+{-# takeInt  :: Inline #-}
259 
+
260 
+
261 
+
262 
+-- Writing drop and friends in terms of build/foldr seems to lose
263 
+-- way big since they cause an extra traversal of the list tail
264 
+-- (except when the calls are being deforested).
265 
+
266 
+drop			:: (Integral a) => a -> [b] -> [b]
267 
+drop n l		= dropInt (fromIntegral n) l
268 
+{-# drop  :: Inline #-}
269 
+{-# drop  :: Strictness("S,S") #-}
270 
+
271 
+
272 
+dropInt                 :: Int -> [b] -> [b]
273 
+dropInt  0     xs	=  xs
274 
+dropInt  _     []	=  []
275 
+dropInt (n+1) (_:xs)	=  dropInt n xs
276 
+{-# dropInt  :: Inline #-}
277 
+
278 
+splitAt			:: (Integral a) => a -> [b] -> ([b],[b])
279 
+splitAt n l		= splitAtInt (fromIntegral n) l
280 
+{-# splitAt  :: Inline #-}
281 
+
282 
+splitAtInt		:: Int -> [b] -> ([b],[b])
283 
+splitAtInt  0     xs	=  ([],xs)
284 
+splitAtInt  _     []	=  ([],[])
285 
+splitAtInt (n+1) (x:xs)	=  (x:xs',xs'') where (xs',xs'') = splitAtInt n xs
286 
+{-# splitAtInt  :: Inline #-}
287 
+
288 
+-- takeWhile, applied to a predicate p and a list xs, returns the longest
289 
+-- prefix (possibly empty) of xs of elements that satisfy p.  dropWhile p xs
290 
+-- returns the remaining suffix.  Span p xs is equivalent to
291 
+-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.
292 
+
293 
+takeWhile		:: (a -> Bool) -> [a] -> [a]
294 
+takeWhile p l = build (\ c n -> foldr (\ a b -> if p a then c a b else n) n l)
295 
+--takeWhile p []		=  []
296 
+--takeWhile p (x:xs)
297 
+--            | p x       =  x : takeWhile p xs
298 
+--            | otherwise =  []
299 
+{-# takeWhile  :: Inline #-}
300 
+
301 
+
302 
+dropWhile		:: (a -> Bool) -> [a] -> [a]
303 
+dropWhile p []		=  []
304 
+dropWhile p xs@(x:xs')
305 
+	    | p x       =  dropWhile p xs'
306 
+	    | otherwise =  xs
307 
+{-# dropWhile  :: Inline #-}
308 
+
309 
+span, break		:: (a -> Bool) -> [a] -> ([a],[a])
310 
+span p []		=  ([],[])
311 
+span p xs@(x:xs')
312 
+	   | p x	=  let (ys,zs) = span p xs' in (x:ys,zs)
313 
+	   | otherwise	=  ([],xs)
314 
+break p			=  span (not . p)
315 
+
316 
+{-# span  :: Inline #-}
317 
+{-# break  :: Inline #-}
318 
+
319 
+
320 
+-- lines breaks a string up into a list of strings at newline characters.
321 
+-- The resulting strings do not contain newlines.  Similary, words
322 
+-- breaks a string up into a list of words, which were delimited by
323 
+-- white space.  unlines and unwords are the inverse operations.
324 
+-- unlines joins lines with terminating newlines, and unwords joins
325 
+-- words with separating spaces.
326 
+
327 
+lines			:: String -> [String]
328 
+lines ""		=  []
329 
+lines s			=  let (l, s') = break (== '\n') s
330 
+			   in  l : case s' of
331 
+					[]     	-> []
332 
+					(_:s'') -> lines s''
333 
+
334 
+words			:: String -> [String]
335 
+words s			=  case dropWhile isSpace s of
336 
+				"" -> []
337 
+				s' -> w : words s''
338 
+				      where (w, s'') = break isSpace s'
339 
+
340 
+unlines			:: [String] -> String
341 
+unlines			=  concat . map (++ "\n")
342 
+{-# unlines  :: Inline #-}
343 
+
344 
+
345 
+unwords			:: [String] -> String
346 
+unwords []		=  ""
347 
+unwords ws		=  foldr1 (\w s -> w ++ ' ':s) ws
348 
+
349 
+-- nub (meaning "essence") removes duplicate elements from its list argument.
350 
+nub			:: (Eq a) => [a] -> [a]
351 
+nub l = build (\ c n ->
352 
+                 let f x g [] = c x (g [x])
353 
+		     f x g xs = if elem x xs
354 
+		                   then (g xs)
355 
+				   else c x (g (x:xs))
356 
+                 in foldr f (\ _ -> n) l [])
357 
+{-# nub  :: Inline #-}
358 
+--nub []			=  []
359 
+--nub (x:xs)		=  x : nub (filter (/= x) xs)
360 
+
361 
+-- reverse xs returns the elements of xs in reverse order.  xs must be finite.
362 
+reverse			:: [a] -> [a]
363 
+reverse l = build (\ c n ->
364 
+                     let f x g tail = g (c x tail)
365 
+		     in foldr f id l n)
366 
+{-# reverse  :: Inline #-}
367 
+--reverse x               =  reverse1 x [] where
368 
+--  reverse1 [] a     = a
369 
+--  reverse1 (x:xs) a = reverse1 xs (x:a)
370 
+
371 
+-- and returns the conjunction of a Boolean list.  For the result to be
372 
+-- True, the list must be finite; False, however, results from a False
373 
+-- value at a finite index of a finite or infinite list.  or is the
374 
+-- disjunctive dual of and.
375 
+and, or			:: [Bool] -> Bool
376 
+and			=  foldr (&&) True
377 
+or			=  foldr (||) False
378 
+{-# and :: Inline #-}
379 
+{-# or  :: Inline #-}
380 
+
381 
+-- Applied to a predicate and a list, any determines if any element
382 
+-- of the list satisfies the predicate.  Similarly, for all.
383 
+any, all		:: (a -> Bool) -> [a] -> Bool
384 
+any p			=  or . map p
385 
+all p			=  and . map p
386 
+{-# any :: Inline #-}
387 
+{-# all :: Inline #-}
388 
+
389 
+-- elem is the list membership predicate, usually written in infix form,
390 
+-- e.g., x `elem` xs.  notElem is the negation.
391 
+elem, notElem		:: (Eq a) => a -> [a] -> Bool
392 
+
393 
+elem x ys = foldr (\ y t -> (x == y) || t) False ys
394 
+--x `elem` []		=  False
395 
+--x `elem` (y:ys)         =  x == y || x `elem` ys
396 
+{-# elem :: Inline #-}
397 
+notElem	x y		=  not (x `elem` y)
398 
+
399 
+-- sum and product compute the sum or product of a finite list of numbers.
400 
+sum, product		:: (Num a) => [a] -> a
401 
+sum			=  foldl (+) 0
402 
+product			=  foldl (*) 1
403 
+{-# sum :: Inline #-}
404 
+{-# product :: Inline #-}
405 
+
406 
+-- sums and products give a list of running sums or products from
407 
+-- a list of numbers.  For example,  sums [1,2,3] == [0,1,3,6].
408 
+sums, products		:: (Num a) => [a] -> [a]
409 
+sums			=  scanl (+) 0
410 
+products		=  scanl (*) 1
411 
+
412 
+-- maximum and minimum return the maximum or minimum value from a list,
413 
+-- which must be non-empty, finite, and of an ordered type.
414 
+maximum, minimum	:: (Ord a) => [a] -> a
415 
+maximum			=  foldl1 max
416 
+minimum			=  foldl1 min
417 
+{-# maximum :: Inline #-}
418 
+{-# minimum :: Inline #-}
419 
+
420 
+-- concat, applied to a list of lists, returns their flattened concatenation.
421 
+concat			:: [[a]] -> [a]
422 
+concat xs	= build (\ c n -> foldr (\ x y -> foldr c y x) n xs)
423 
+--concat []               =  []
424 
+--concat (l:ls)           =  l ++ concat ls
425 
+{-# concat :: Inline #-}
426 
+
427 
+
428 
+-- transpose, applied to a list of lists, returns that list with the
429 
+-- "rows" and "columns" interchanged.  The input need not be rectangular
430 
+-- (a list of equal-length lists) to be completely transposable, but can
431 
+-- be "triangular":  Each successive component list must be not longer
432 
+-- than the previous one; any elements outside of the "triangular"
433 
+-- transposable region are lost.  The input can be infinite in either
434 
+-- dimension or both.
435 
+transpose		:: [[a]] -> [[a]]
436 
+transpose		=  foldr
437 
+			     (\xs xss -> zipWith (:) xs (xss ++ repeat []))
438 
+			     []
439 
+{-# transpose :: Inline #-}
440 
+
441 
+-- zip takes two lists and returns a list of corresponding pairs.  If one
442 
+-- input list is short, excess elements of the longer list are discarded.
443 
+-- zip3 takes three lists and returns a list of triples, etc.  Versions
444 
+-- of zip producing up to septuplets are defined here.
445 
+
446 
+zip			:: [a] -> [b] -> [(a,b)]
447 
+zip			=  zipWith (\a b -> (a,b))
448 
+{-# zip :: Inline #-}
449 
+
450 
+zip3			:: [a] -> [b] -> [c] -> [(a,b,c)]
451 
+zip3			=  zipWith3 (\a b c -> (a,b,c))
452 
+{-# zip3 :: Inline #-}
453 
+
454 
+zip4			:: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
455 
+zip4			=  zipWith4 (\a b c d -> (a,b,c,d))
456 
+{-# zip4 :: Inline #-}
457 
+
458 
+zip5			:: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
459 
+zip5			=  zipWith5 (\a b c d e -> (a,b,c,d,e))
460 
+{-# zip5 :: Inline #-}
461 
+
462 
+zip6			:: [a] -> [b] -> [c] -> [d] -> [e] -> [f]
463 
+			   -> [(a,b,c,d,e,f)]
464 
+zip6			=  zipWith6 (\a b c d e f -> (a,b,c,d,e,f))
465 
+{-# zip6 :: Inline #-}
466 
+
467 
+zip7			:: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g]
468 
+			   -> [(a,b,c,d,e,f,g)]
469 
+zip7			=  zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g))
470 
+{-# zip7 :: Inline #-}
471 
+
472 
+-- The zipWith family generalises the zip family by zipping with the
473 
+-- function given as the first argument, instead of a tupling function.
474 
+-- For example, zipWith (+) is applied to two lists to produce the list
475 
+-- of corresponding sums.
476 
+
477 
+zipWith			:: (a->b->c) -> [a]->[b]->[c]
478 
+zipWith z as bs =
479 
+  build (\ c' n' ->
480 
+           let f' a g' (b:bs) = c' (z a b) (g' bs)
481 
+	       f' a g' _ = n'
482 
+           in foldr f' (\ _ -> n') as bs)
483 
+--zipWith z (a:as) (b:bs)	=  z a b : zipWith z as bs
484 
+--zipWith _ _ _		=  []
485 
+{-# zipWith :: Inline #-}
486 
+
487 
+zipWith3		:: (a->b->c->d) -> [a]->[b]->[c]->[d]
488 
+zipWith3 z as bs cs =
489 
+  build (\ c' n' ->
490 
+          let f' a g' (b:bs) (c:cs) = c' (z a b c) (g' bs cs)
491 
+              f' a g' _ _ = n'
492 
+          in foldr f' (\ _ _ -> n') as bs cs)
493 
+{-# zipWith3 :: Inline #-}
494 
+--zipWith3 z (a:as) (b:bs) (c:cs)
495 
+--			=  z a b c : zipWith3 z as bs cs
496 
+--zipWith3 _ _ _ _	=  []
497 
+
498 
+zipWith4		:: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
499 
+zipWith4 z as bs cs ds =
500 
+  build (\ c' n' ->
501 
+          let f' a g' (b:bs) (c:cs) (d:ds) = c' (z a b c d) (g' bs cs ds)
502 
+              f' a g' _ _ _ = n'
503 
+          in foldr f' (\ _ _ _ -> n') as bs cs ds)
504 
+{-# zipWith4 :: Inline #-}
505 
+--zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
506 
+--			=  z a b c d : zipWith4 z as bs cs ds
507 
+--zipWith4 _ _ _ _ _	=  []
508 
+
509 
+zipWith5		:: (a->b->c->d->e->f)
510 
+			   -> [a]->[b]->[c]->[d]->[e]->[f]
511 
+zipWith5 z as bs cs ds es=
512 
+  build (\ c' n' ->
513 
+          let f' a g' (b:bs) (c:cs) (d:ds) (e:es) =
514 
+	        c' (z a b c d e) (g' bs cs ds es)
515 
+              f' a g' _ _ _ _ = n'
516 
+          in foldr f' (\ _ _ _ _ -> n') as bs cs ds es)
517 
+{-# zipWith5 :: Inline #-}
518 
+--zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
519 
+--			=  z a b c d e : zipWith5 z as bs cs ds es
520 
+--zipWith5 _ _ _ _ _ _	=  []
521 
+
522 
+zipWith6		:: (a->b->c->d->e->f->g)
523 
+			   -> [a]->[b]->[c]->[d]->[e]->[f]->[g]
524 
+zipWith6 z as bs cs ds es fs =
525 
+  build (\ c' n' ->
526 
+          let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) =
527 
+	        c' (z a b c d e f) (g' bs cs ds es fs)
528 
+              f' a g' _ _ _ _ _ = n'
529 
+          in foldr f' (\ _ _ _ _ _ -> n') as bs cs ds es fs)
530 
+{-# zipWith6 :: Inline #-}
531 
+--zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
532 
+--			=  z a b c d e f : zipWith6 z as bs cs ds es fs
533 
+--zipWith6 _ _ _ _ _ _ _	=  []
534 
+
535 
+zipWith7		:: (a->b->c->d->e->f->g->h)
536 
+			   -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
537 
+zipWith7 z as bs cs ds es fs gs =
538 
+  build (\ c' n' ->
539 
+          let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) =
540 
+	        c' (z a b c d e f g) (g' bs cs ds es fs gs)
541 
+              f' a g' _ _ _ _ _ _ = n'
542 
+          in foldr f' (\ _ _ _ _ _ _ -> n') as bs cs ds es fs gs)
543 
+{-# zipWith7 :: Inline #-}
544 
+--zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
545 
+--		   =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs
546 
+--zipWith7 _ _ _ _ _ _ _ _ =  []
547 
+
548 
+
549 
+-- unzip transforms a list of pairs into a pair of lists.  As with zip,
550 
+-- a family of such functions up to septuplets is provided.
551 
+
552 
+unzip			:: [(a,b)] -> ([a],[b])
553 
+unzip			=  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
554 
+{-# unzip :: Inline #-}
555 
+
556 
+
557 
+unzip3			:: [(a,b,c)] -> ([a],[b],[c])
558 
+unzip3			=  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
559 
+				 ([],[],[])
560 
+{-# unzip3 :: Inline #-}
561 
+
562 
+unzip4			:: [(a,b,c,d)] -> ([a],[b],[c],[d])
563 
+unzip4			=  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
564 
+					(a:as,b:bs,c:cs,d:ds))
565 
+				 ([],[],[],[])
566 
+{-# unzip4 :: Inline #-}
567 
+
568 
+unzip5			:: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
569 
+unzip5			=  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
570 
+					(a:as,b:bs,c:cs,d:ds,e:es))
571 
+				 ([],[],[],[],[])
572 
+{-# unzip5 :: Inline #-}
573 
+
574 
+unzip6			:: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
575 
+unzip6			=  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
576 
+					(a:as,b:bs,c:cs,d:ds,e:es,f:fs))
577 
+				 ([],[],[],[],[],[])
578 
+{-# unzip6 :: Inline #-}
579 
+
580 
+unzip7			:: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
581 
+unzip7			=  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
582 
+					(a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
583 
+				 ([],[],[],[],[],[],[])
584 
+{-# unzip7 :: Inline #-}
585 
+
progs/prelude/PreludeLocal.hs
History View file @ 4e98702
0 586 
new file mode 100644
... ... 
@@ -0,0 +1,16 @@
1 
+module PreludeLocal where
2 
+
3 
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
4 
+
5 
+infixr 5 :
6 
+
7 
+data Int = MkInt
8 
+data Integer = MkInteger
9 
+data Float = MkFloat
10 
+data Double   = MkDouble
11 
+data Char = MkChar
12 
+data Bin = MkBin
13 
+data List a = a : (List a) | Nil
14 
+data Arrow a b = MkArrow a b
15 
+
16 
+data Triv = MkTriv
progs/prelude/PreludeLocalIO.hs
History View file @ 4e98702
0 17 
new file mode 100644
... ... 
@@ -0,0 +1,144 @@
1 
+module PreludeLocalIO where
2 
+
3 
+import PreludeIOPrims
4 
+import PreludeIOMonad
5 
+
6 
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
7 
+
8 
+data IOResponse a = Succ a | Fail String deriving Text
9 
+
10 
+exec :: ([Response] -> [Request]) -> IO ()
11 
+{-
12 
+-- Sunderesh's original definition
13 
+exec p = case (p bottom) of
14 
+          [] -> unitIO ()
15 
+          (q:qs) -> processRequest q `bindIO` \r ->
16 
+                    exec (\rs -> tail (p (r:rs)))
17 
+
18 
+bottom :: a
19 
+bottom = error "Should never be evaluated"
20 
+-}
21 
+-- modified from the existing compiler. no quadratic behavior
22 
+-- needs
23 
+-- pure :: IO a -> a
24 
+-- other alternatives:
25 
+-- 1. use reference cells
26 
+-- 2. implement exec in Lisp
27 
+
28 
+exec p = os requests `bindIO` \x -> unitIO () where
29 
+    requests = p responses
30 
+    responses = pureIO (os requests)
31 
+
32 
+os :: [Request] -> IO [Response]
33 
+os [] = unitIO []
34 
+os (q:qs) = processRequest q `bindIO` \r ->
35 
+            os qs `bindIO` \rs ->
36 
+            unitIO (r:rs)
37 
+
38 
+processRequest :: Request -> IO Response
39 
+
40 
+-- This needs to be rewritten in terms of the continuation based defs
41 
+
42 
+processRequest request =
43 
+  case request of
44 
+
45 
+-- File system requests
46 
+   ReadFile name ->
47 
+      primReadStringFile name `bindIO` \a ->
48 
+        case a of
49 
+          Succ s -> unitIO (Str s)
50 
+          Fail e -> unitIO (Failure e)
51 
+   WriteFile name contents ->
52 
+      primWriteStringFile name contents `bindIO` \a ->
53 
+        case a of
54 
+          MaybeNot -> unitIO Success
55 
+          Maybe e  -> unitIO (Failure e)
56 
+   AppendFile name contents ->
57 
+      primAppendStringFile name contents `bindIO` \a ->
58 
+        case a of
59 
+          MaybeNot -> unitIO Success
60 
+          Maybe e  -> unitIO (Failure e)
61 
+   ReadBinFile name ->
62 
+      primReadBinFile name `bindIO` \a ->
63 
+        case a of
64 
+          Succ s -> unitIO (Bn s)
65 
+          Fail e -> unitIO (Failure e)
66 
+   WriteBinFile name bin ->
67 
+      primWriteBinFile name bin `bindIO` \a ->
68 
+        case a of
69 
+          MaybeNot -> unitIO Success
70 
+          Maybe e  -> unitIO (Failure e)
71 
+   AppendBinFile name bin ->
72 
+      primAppendBinFile name bin `bindIO` \a ->
73 
+        case a of
74 
+          MaybeNot -> unitIO Success
75 
+          Maybe e  -> unitIO (Failure e)
76 
+   DeleteFile name ->
77 
+      primDeleteFile name `bindIO` \a ->
78 
+        case a of
79 
+          MaybeNot -> Success
80 
+          Maybe e  -> unitIO (Failure e)
81 
+   StatusFile name ->
82 
+      primStatusFile name `bindIO` \a ->
83 
+        case a of
84 
+          Succ s -> unitIO (Str s)
85 
+          Fail e -> unitIO (Failure e)
86 
+
87 
+-- Channel system requests
88 
+   ReadChan name ->
89 
+      primReadChan name `bindIO` \a ->
90 
+        case a of
91 
+          Succ s -> unitIO (Str s)
92 
+          Fail e -> unitIO (Failure e)
93 
+   AppendChan name string ->
94 
+      primAppendChan name string `bindIO` \a ->
95 
+        case a of
96 
+          MaybeNot -> unitIO Success
97 
+          Maybe e  -> unitIO (Failure e)
98 
+   ReadBinChan name ->
99 
+      primReadBinChan name `bindIO` \a ->
100 
+        case a of
101 
+          Succ s -> unitIO (Bn s)
102 
+          Fail e -> unitIO (Failure e)
103 
+   AppendBinChan name bin ->
104 
+      primAppendBinChan name bin `bindIO` \a ->
105 
+        case a of
106 
+          MaybeNot -> unitIO Success
107 
+          Maybe e  -> unitIO (Failure e)
108 
+   StatusChan name ->
109 
+      primStatusChan name `bindIO` \a ->
110 
+        case a of
111 
+          Succ s -> unitIO (Str s)
112 
+          Fail e -> unitIO (Failure e)
113 
+
114 
+-- Environment requests
115 
+   Echo status ->
116 
+      primEcho status `bindIO` \a ->
117 
+        case a of
118 
+          Succ s -> unitIO (Str s)
119 
+          Fail e -> unitIO (Failure e)
120 
+   GetArgs ->
121 
+      primGetArgs `bindIO` \a ->
122 
+        case a of
123 
+          Succ s -> unitIO (Str s)
124 
+          Fail e -> unitIO (Failure e)
125 
+   GetProgName ->
126 
+      primProgArgs `bindIO` \a ->
127 
+        case a of
128 
+          Succ s -> unitIO (Str s)
129 
+          Fail e -> unitIO (Failure e)
130 
+   GetEnv name ->
131 
+      primGetEnv name `bindIO` \a ->
132 
+        case a of
133 
+          Succ s -> unitIO (Str s)
134 
+          Fail e -> unitIO (Failure e)
135 
+   SetEnv name string ->
136 
+      primGetEnv name string `bindIO` \a ->
137 
+        case a of
138 
+          Succ s -> unitIO (Str s)
139 
+          Fail e -> unitIO (Failure e)
140 
+   _ -> unitIO (Failure (OtherError "Unrecognized IO Feature"))
141 
+
142 
+-- Monadic Style IO
143 
+-- Channel system requests
144 
+
progs/prelude/PreludePrims.hi
History View file @ 4e98702
0 145 
new file mode 100644
... ... 
@@ -0,0 +1,252 @@
1 
+-- interface.scm -- define interface to primitives
2 
+--
3 
+-- author :  Sandra & John
4 
+-- date   :  24 Apr 1992
5 
+--
6 
+-- This file declares the interface to the runtime system primitives.
7 
+-- The actual definitions for the Lisp functions all appear elsewhere;
8 
+-- they all have names like prim.xxx.  (They can actually be macros
9 
+-- instead of functions since they're never referenced by name.)
10 
+
11 
+interface PreludePrims where
12 
+
13 
+{-# Prelude #-}
14 
+
15 
+import PreludeCore(Int,Integer,Float,Double,Char,Bool)
16 
+import PreludeRational(Rational)
17 
+
18 
+error :: String -> a
19 
+primCharToInt :: Char -> Int
20 
+primIntToChar :: Int -> Char
21 
+primEqChar, primNeqChar, primLeChar, primGtChar, primLsChar, primGeChar
22 
+  :: Char -> Char -> Bool
23 
+primMaxChar :: Int
24 
+primEqFloat, primNeqFloat, primLeFloat, primGtFloat, primLsFloat, primGeFloat
25 
+  :: Float -> Float -> Bool
26 
+primFloatMax, primFloatMin :: Float -> Float -> Float
27 
+primEqDouble, primNeqDouble, primLeDouble, primGtDouble,
28 
+              primLsDouble, primGeDouble
29 
+  :: Double -> Double -> Bool
30 
+primDoubleMax, primDoubleMin :: Double -> Double -> Double
31 
+primPlusFloat, primMinusFloat, primMulFloat, primDivFloat
32 
+  :: Float -> Float -> Float
33 
+primPlusDouble, primMinusDouble, primMulDouble, primDivDouble
34 
+  :: Double -> Double -> Double
35 
+primNegFloat, primAbsFloat :: Float -> Float
36 
+primNegDouble, primAbsDouble :: Double -> Double
37 
+primExpFloat, primLogFloat, primSqrtFloat, primSinFloat, primCosFloat,
38 
+  primTanFloat, primAsinFloat, primAcosFloat, primAtanFloat, primSinhFloat,
39 
+  primCoshFloat, primTanhFloat, primAsinhFloat, primAcoshFloat, primAtanhFloat
40 
+  :: Float -> Float
41 
+primExpDouble, primLogDouble, primSqrtDouble, primSinDouble, primCosDouble,
42 
+  primTanDouble, primAsinDouble, primAcosDouble, primAtanDouble, primSinhDouble,
43 
+  primCoshDouble, primTanhDouble, primAsinhDouble, primAcoshDouble, primAtanhDouble
44 
+  :: Double -> Double
45 
+primPiFloat :: Float
46 
+primPiDouble :: Double
47 
+primRationalToFloat :: Rational -> Float
48 
+primRationalToDouble :: Rational -> Double
49 
+primFloatToRational :: Float -> Rational
50 
+primDoubleToRational :: Double -> Rational
51 
+primFloatDigits :: Int
52 
+primFloatRadix :: Integer
53 
+primFloatMinExp :: Int
54 
+primFloatMaxExp :: Int
55 
+primFloatRange :: Float -> (Int, Int)
56 
+primDecodeFloat :: Float -> (Integer, Int)
57 
+primEncodeFloat :: Integer -> Int -> Float
58 
+primDoubleDigits :: Int
59 
+primDoubleRadix :: Integer
60 
+primDoubleMinExp :: Int
61 
+primDoubleMaxExp :: Int
62 
+primDoubleRange :: Double -> (Int, Int)
63 
+primDecodeDouble :: Double -> (Integer, Int)
64 
+primEncodeDouble :: Integer -> Int -> Double
65 
+primEqInt, primNeqInt, primLeInt, primGtInt, primLsInt, primGeInt
66 
+  :: Int -> Int -> Bool
67 
+primIntMax, primIntMin :: Int -> Int -> Int
68 
+primEqInteger, primNeqInteger, primLeInteger, primGtInteger,
69 
+  primLsInteger, primGeInteger
70 
+    :: Integer -> Integer -> Bool
71 
+primIntegerMax, primIntegerMin :: Integer -> Integer -> Integer
72 
+primPlusInt, primMinusInt, primMulInt :: Int -> Int -> Int
73 
+primMinInt,primMaxInt :: Int
74 
+primNegInt, primAbsInt :: Int -> Int
75 
+primPlusInteger, primMinusInteger, primMulInteger :: Integer -> Integer -> Integer
76 
+primNegInteger, primAbsInteger :: Integer -> Integer
77 
+primQuotRemInt :: Int -> Int -> (Int, Int)
78 
+primQuotRemInteger :: Integer -> Integer -> (Integer, Integer)
79 
+primIntegerToInt :: Integer -> Int
80 
+primIntToInteger :: Int -> Integer
81 
+primNullBin :: Bin
82 
+primIsNullBin :: Bin -> Bool
83 
+primShowBinInt :: Int -> Bin -> Bin
84 
+primShowBinInteger :: Integer -> Bin -> Bin
85 
+primShowBinFloat :: Float -> Bin -> Bin
86 
+primShowBinDouble :: Double -> Bin -> Bin
87 
+primReadBinInt :: Bin -> (Int,Bin)
88 
+primReadBinInteger :: Bin -> (Integer,Bin)
89 
+primReadBinFloat :: Bin -> (Float,Bin)
90 
+primReadBinDouble :: Bin -> (Double,Bin)
91 
+primReadBinSmallInt :: Bin -> Int -> (Int,Bin)
92 
+primAppendBin :: Bin -> Bin -> Bin
93 
+
94 
+primStringEq  :: [Char] -> [Char] -> Bool
95 
+
96 
+primAppend :: [a] -> [a] -> [a]
97 
+primTake :: Int -> [a] -> [a]
98 
+
99 
+foldr :: (a -> b -> b) -> b -> [a] -> b
100 
+build :: ((a -> [a] -> [a]) -> [b] -> [c]) -> [c]
101 
+
102 
+
103 
+
104 
+-- I've assigned complexities for arithmetic primitives as follows:
105 
+-- Int and Char comparisons and arithmetic are very cheap (complexity 1).
106 
+-- Double and Float comparsions are also cheap, but most implementations
107 
+--   need to box the results of floating-point arithmetic so I have given
108 
+--   them a complexity of 3.
109 
+-- Integer operations need to do an extra bignum check that has a fixed
110 
+--   overhead.  I assume that actual bignums will be rare and give them
111 
+--   all a complexity of 2.
112 
+
113 
+{-#
114 
+error :: LispName("prim.abort")
115 
+primCharToInt ::    LispName("prim.char-to-int"), Complexity(0),NoConversion
116 
+primIntToChar ::    LispName("prim.int-to-char"), Complexity(0),NoConversion
117 
+primEqChar ::       LispName("prim.eq-char"), Complexity(1), NoConversion
118 
+primNeqChar::       LispName("prim.not-eq-char"), Complexity(1), NoConversion
119 
+primLeChar ::       LispName("prim.le-char"), Complexity(1), NoConversion
120 
+primGtChar ::       LispName("prim.not-le-char"), Complexity(1), NoConversion
121 
+primLsChar ::       LispName("prim.lt-char"), Complexity(1), NoConversion
122 
+primGeChar ::       LispName("prim.not-lt-char"), Complexity(1), NoConversion
123 
+primMaxChar ::      LispName("prim.max-char"), NoConversion
124 
+primEqFloat ::      LispName("prim.eq-float"), Complexity(1)
125 
+primNeqFloat ::     LispName("prim.not-eq-float"), Complexity(1)
126 
+primLeFloat  ::     LispName("prim.le-float"), Complexity(1)
127 
+primGtFloat  ::     LispName("prim.not-le-float"), Complexity(1)
128 
+primLsFloat  ::     LispName("prim.lt-float"), Complexity(1)
129 
+primGeFloat  ::     LispName("prim.not-lt-float"), Complexity(1)
130 
+primFloatMax ::     LispName("prim.float-max"), Complexity(3)
131 
+primFloatMin ::     LispName("prim.float-min"), Complexity(3)
132 
+primEqDouble  ::    LispName("prim.eq-double"), Complexity(1)
133 
+primNeqDouble ::    LispName("prim.not-eq-double"), Complexity(1)
134 
+primLeDouble  ::    LispName("prim.le-double"), Complexity(1)
135 
+primGtDouble  ::    LispName("prim.not-le-double"), Complexity(1)
136 
+primLsDouble  ::    LispName("prim.lt-double"), Complexity(1)
137 
+primGeDouble  ::    LispName("prim.not-lt-double"), Complexity(1)
138 
+primDoubleMax ::    LispName("prim.double-max"), Complexity(3)
139 
+primDoubleMin ::    LispName("prim.double-min"), Complexity(3)
140 
+primPlusFloat  ::   LispName("prim.plus-float"), Complexity(3)
141 
+primMinusFloat ::   LispName("prim.minus-float"), Complexity(3)
142 
+primMulFloat   ::   LispName("prim.mul-float"), Complexity(3)
143 
+primDivFloat   ::   LispName("prim.div-float"), Complexity(3)
144 
+primPlusDouble  ::  LispName("prim.plus-double"), Complexity(3)
145 
+primMinusDouble ::  LispName("prim.minus-double"), Complexity(3)
146 
+primMulDouble   ::  LispName("prim.mul-double"), Complexity(3)
147 
+primDivDouble   ::  LispName("prim.div-double"), Complexity(3)
148 
+primNegFloat ::     LispName("prim.neg-float"), Complexity(3)
149 
+primAbsFloat ::     LispName("prim.abs-float"), Complexity(3)
150 
+primNegDouble ::    LispName("prim.neg-double"), Complexity(3)
151 
+primAbsDouble ::    LispName("prim.abs-double"), Complexity(3)
152 
+primExpFloat   ::   LispName("prim.exp-float")
153 
+primLogFloat   ::   LispName("prim.log-float")
154 
+primSqrtFloat  ::   LispName("prim.sqrt-float")
155 
+primSinFloat   ::   LispName("prim.sin-float")
156 
+primCosFloat   ::   LispName("prim.cos-float")
157 
+primTanFloat   ::   LispName("prim.tan-float")
158 
+primAsinFloat  ::   LispName("prim.asin-float")
159 
+primAcosFloat  ::   LispName("prim.acos-float")
160 
+primAtanFloat  ::   LispName("prim.atan-float")
161 
+primSinhFloat  ::   LispName("prim.sinh-float")
162 
+primCoshFloat  ::   LispName("prim.cosh-float")
163 
+primTanhFloat  ::   LispName("prim.tanh-float")
164 
+primAsinhFloat ::   LispName("prim.asinh-float")
165 
+primAcoshFloat ::   LispName("prim.acosh-float")
166 
+primAtanhFloat ::   LispName("prim.atanh-float")
167 
+primExpDouble   ::  LispName("prim.exp-double")
168 
+primLogDouble   ::  LispName("prim.log-double")
169 
+primSqrtDouble  ::  LispName("prim.sqrt-double")
170 
+primSinDouble   ::  LispName("prim.sin-double")
171 
+primCosDouble   ::  LispName("prim.cos-double")
172 
+primTanDouble   ::  LispName("prim.tan-double")
173 
+primAsinDouble  ::  LispName("prim.asin-double")
174 
+primAcosDouble  ::  LispName("prim.acos-double")
175 
+primAtanDouble  ::  LispName("prim.atan-double")
176 
+primSinhDouble  ::  LispName("prim.sinh-double")
177 
+primCoshDouble  ::  LispName("prim.cosh-double")
178 
+primTanhDouble  ::  LispName("prim.tanh-double")
179 
+primAsinhDouble ::  LispName("prim.asinh-double")
180 
+primAcoshDouble ::  LispName("prim.acosh-double")
181 
+primAtanhDouble ::  LispName("prim.atanh-double")
182 
+primPiFloat ::      LispName("prim.pi-float")
183 
+primPiDouble ::     LispName("prim.pi-double")
184 
+primRationalToFloat  :: LispName("prim.rational-to-float"), Complexity(3)
185 
+primRationalToDouble :: LispName("prim.rational-to-double"), Complexity(3)
186 
+primFloatToRational  :: LispName("prim.float-to-rational"), Complexity(3)
187 
+primDoubleToRational :: LispName("prim.double-to-rational"), Complexity(3)
188 
+primFloatDigits ::  LispName("prim.float-digits")
189 
+primFloatRadix ::   LispName("prim.float-radix")
190 
+primFloatMinExp ::  LispName("prim.float-min-exp")
191 
+primFloatMaxExp ::  LispName("prim.float-max-exp")
192 
+primFloatRange ::   LispName("prim.float-range")
193 
+primDecodeFloat ::  LispName("prim.decode-float")
194 
+primEncodeFloat ::  LispName("prim.encode-float")
195 
+primDoubleDigits :: LispName("prim.double-digits")
196 
+primDoubleRadix ::  LispName("prim.double-radix")
197 
+primDoubleMinExp :: LispName("prim.double-min-exp")
198 
+primDoubleMaxExp :: LispName("prim.double-max-exp")
199 
+primDoubleRange ::  LispName("prim.double-range")
200 
+primDecodeDouble :: LispName("prim.decode-double")
201 
+primEncodeDouble :: LispName("prim.encode-double")
202 
+primEqInt ::        LispName("prim.eq-int"), Complexity(1)
203 
+primNeqInt::        LispName("prim.not-eq-int"), Complexity(1)
204 
+primLeInt ::        LispName("prim.le-int"), Complexity(1)
205 
+primGtInt ::        LispName("prim.not-le-int"), Complexity(1)
206 
+primLsInt ::        LispName("prim.lt-int"), Complexity(1)
207 
+primGeInt ::        LispName("prim.not-lt-int"), Complexity(1)
208 
+primIntMax ::       LispName("prim.int-max"), Complexity(1)
209 
+primIntMin ::       LispName("prim.int-min"), Complexity(1)
210 
+primEqInteger ::    LispName("prim.eq-integer"), Complexity(2)
211 
+primNeqInteger::    LispName("prim.not-eq-integer"), Complexity(2)
212 
+primLeInteger ::    LispName("prim.le-integer"), Complexity(2)
213 
+primGtInteger ::    LispName("prim.not-le-integer"), Complexity(2)
214 
+primLsInteger ::    LispName("prim.lt-integer"), Complexity(2)
215 
+primGeInteger ::    LispName("prim.not-lt-integer"), Complexity(2)
216 
+primIntegerMax ::   LispName("prim.integer-max"), Complexity(2)
217 
+primIntegerMin ::   LispName("prim.integer-min"), Complexity(2)
218 
+primPlusInt  ::     LispName("prim.plus-int"), Complexity(1)
219 
+primMinusInt ::     LispName("prim.minus-int"), Complexity(1)
220 
+primMulInt   ::     LispName("prim.mul-int"), Complexity(1)
221 
+primMinInt ::       LispName("prim.minint")
222 
+primMaxInt ::       LispName("prim.maxint")
223 
+primNegInt ::       LispName("prim.neg-int"), Complexity(1)
224 
+primAbsInt ::       LispName("prim.abs-int"), Complexity(1)
225 
+primPlusInteger  :: LispName("prim.plus-integer"), Complexity(2)
226 
+primMinusInteger :: LispName("prim.minus-integer"), Complexity(2)
227 
+primMulInteger   :: LispName("prim.mul-integer"), Complexity(2)
228 
+primNegInteger ::   LispName("prim.neg-integer"), Complexity(2)
229 
+primAbsInteger ::   LispName("prim.abs-integer"), Complexity(2)
230 
+primQuotRemInt ::   LispName("prim.div-rem-int")
231 
+primQuotRemInteger :: LispName("prim.div-rem-integer")
232 
+primIntegerToInt :: LispName("prim.integer-to-int"), Complexity(1)
233 
+primIntToInteger :: LispName("prim.int-to-integer"), Complexity(0)
234 
+primNullBin ::      LispName("prim.nullbin")
235 
+primIsNullBin ::    LispName("prim.is-null-bin"), Complexity(1)
236 
+primShowBinInt ::   LispName("prim.show-bin-int"), Complexity(2)
237 
+primShowBinInteger :: LispName("prim.show-bin-integer"), Complexity(2)
238 
+primShowBinFloat ::   LispName("prim.show-bin-float"), Complexity(2)
239 
+primShowBinDouble ::  LispName("prim.show-bin-double"), Complexity(2)
240 
+primReadBinInt ::     LispName("prim.read-bin-int")
241 
+primReadBinInteger :: LispName("prim.read-bin-integer")
242 
+primReadBinFloat ::   LispName("prim.read-bin-float")
243 
+primReadBinDouble ::  LispName("prim.read-bin-double")
244 
+primReadBinSmallInt :: LispName("prim.read-bin-small-int")
245 
+primAppendBin ::      LispName("prim.append-bin")
246 
+primStringEq :: LispName("prim.string-eq"), Strictness("S,S"), NoConversion
247 
+primAppend :: LispName("prim.append"), Strictness("S,N"), NoConversion
248 
+primTake   :: LispName("prim.take"), Strictness("S,S"), NoConversion
249 
+foldr   :: LispName("prim.foldr"), Strictness("N,N,S"), NoConversion
250 
+build   :: LispName("prim.build"), Strictness("S"), NoConversion
251 
+
252 
+#-}
progs/prelude/PreludePrims.hu
History View file @ 4e98702
0 253 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+:output $PRELUDEBIN/PreludePrims
2 
+:stable
3 
+:prelude
4 
+PreludePrims.hi
progs/prelude/PreludeRatio.hs
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,98 @@
1 
+-- Standard functions on rational numbers
2 
+
3 
+module	PreludeRatio (
4 
+    Ratio, Rational(..), (%), numerator, denominator, approxRational ) where
5 
+
6 
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
7 
+
8 
+infixl 7  %, :%
9 
+
10 
+prec = 7
11 
+
12 
+data  (Integral a)	=> Ratio a = a {-# STRICT #-} :% a {-# STRICT #-}
13 
+                              deriving (Eq, Binary)
14 
+
15 
+type  Rational		=  Ratio Integer
16 
+
17 
+(%)			:: (Integral a) => a -> a -> Ratio a
18 
+numerator, denominator	:: (Integral a) => Ratio a -> a
19 
+approxRational		:: (RealFrac a) => a -> a -> Rational
20 
+
21 
+
22 
+reduce _ 0		=  error "(%){PreludeRatio}: zero denominator"
23 
+reduce x y		=  (x `quot` d) :% (y `quot` d)
24 
+			   where d = gcd x y
25 
+
26 
+
27 
+x % y			=  reduce (x * signum y) (abs y)
28 
+
29 
+numerator (x:%y)	=  x
30 
+
31 
+denominator (x:%y)	=  y
32 
+
33 
+
34 
+instance  (Integral a)	=> Ord (Ratio a)  where
35 
+    (x:%y) <= (x':%y')	=  x * y' <= x' * y
36 
+    (x:%y) <  (x':%y')	=  x * y' <  x' * y
37 
+
38 
+instance  (Integral a)	=> Num (Ratio a)  where
39 
+    (x:%y) + (x':%y')	=  reduce (x*y' + x'*y) (y*y')
40 
+    (x:%y) * (x':%y')	=  reduce (x * x') (y * y')
41 
+    negate (x:%y)	=  (-x) :% y
42 
+    abs (x:%y)		=  abs x :% y
43 
+    signum (x:%y)	=  signum x :% 1
44 
+    fromInteger x	=  fromInteger x :% 1
45 
+
46 
+instance  (Integral a)	=> Real (Ratio a)  where
47 
+    toRational (x:%y)	=  toInteger x :% toInteger y
48 
+
49 
+instance  (Integral a)	=> Fractional (Ratio a)  where
50 
+    (x:%y) / (x':%y')	=  (x*y') % (y*x')
51 
+    recip (x:%y)	=  if x < 0 then (-y) :% (-x) else y :% x
52 
+    fromRational (x:%y) =  fromInteger x :% fromInteger y
53 
+
54 
+instance  (Integral a)	=> RealFrac (Ratio a)  where
55 
+    properFraction (x:%y) = (fromIntegral q, r:%y)
56 
+			    where (q,r) = quotRem x y
57 
+
58 
+instance  (Integral a)	=> Enum (Ratio a)  where
59 
+    enumFrom		=  iterate ((+)1)
60 
+    enumFromThen n m	=  iterate ((+)(m-n)) n
61 
+
62 
+instance  (Integral a) => Text (Ratio a)  where
63 
+    readsPrec p  =  readParen (p > prec)
64 
+			      (\r -> [(x%y,u) | (x,s)   <- reads r,
65 
+					        ("%",t) <- lex s,
66 
+						(y,u)   <- reads t ])
67 
+
68 
+    showsPrec p (x:%y)	=  showParen (p > prec)
69 
+    	    	    	       (shows x . showString " % " . shows y)
70 
+
71 
+
72 
+-- approxRational, applied to two real fractional numbers x and epsilon,
73 
+-- returns the simplest rational number within epsilon of x.  A rational
74 
+-- number n%d in reduced form is said to be simpler than another n'%d' if
75 
+-- abs n <= abs n' && d <= d'.  Any real interval contains a unique
76 
+-- simplest rational; here, for simplicity, we assume a closed rational
77 
+-- interval.  If such an interval includes at least one whole number, then
78 
+-- the simplest rational is the absolutely least whole number.  Otherwise,
79 
+-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
80 
+-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of
81 
+-- the simplest rational between d'%r' and d%r.
82 
+
83 
+approxRational x eps	=  simplest (x-eps) (x+eps)
84 
+	where simplest x y | y < x	=  simplest y x
85 
+			   | x == y	=  xr
86 
+			   | x > 0	=  simplest' n d n' d'
87 
+			   | y < 0	=  - simplest' (-n') d' (-n) d
88 
+			   | otherwise	=  0 :% 1
89 
+					where xr@(n:%d) = toRational x
90 
+					      (n':%d')	= toRational y
91 
+
92 
+	      simplest' n d n' d'	-- assumes 0 < n%d < n'%d'
93 
+			| r == 0     =	q :% 1
94 
+			| q /= q'    =	(q+1) :% 1
95 
+			| otherwise  =	(q*n''+d'') :% n''
96 
+				     where (q,r)      =	 quotRem n d
97 
+					   (q',r')    =	 quotRem n' d'
98 
+					   (n'':%d'') =	 simplest' d' r' d r
progs/prelude/PreludeText.hs
History View file @ 4e98702
0 99 
new file mode 100644
... ... 
@@ -0,0 +1,260 @@
1 
+module	PreludeText (
2 
+	reads, shows, show, read, lex,
3 
+	showChar, showString, readParen, showParen, readLitChar, showLitChar,
4 
+	readSigned, showSigned, readDec, showInt, readFloat, showFloat ) where
5 
+
6 
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
7 
+
8 
+reads 	        :: (Text a) => ReadS a
9 
+reads		=  readsPrec 0
10 
+
11 
+shows 	    	:: (Text a) => a -> ShowS
12 
+shows		=  showsPrec 0
13 
+
14 
+read 	    	:: (Text a) => String -> a
15 
+read s 	    	=  case [x | (x,t) <- reads s, ("","") <- lex t] of
16 
+			[x] -> x
17 
+			[]  -> error "read{PreludeText}: no parse"
18 
+			_   -> error "read{PreludeText}: ambiguous parse"
19 
+
20 
+show 	    	:: (Text a) => a -> String
21 
+show x 	    	=  shows x ""
22 
+
23 
+showChar    	:: Char -> ShowS
24 
+showChar    	=  (:)
25 
+
26 
+showString  	:: String -> ShowS
27 
+showString  	=  (++)
28 
+
29 
+showParen   	:: Bool -> ShowS -> ShowS
30 
+showParen b p 	=  if b then showChar '(' . p . showChar ')' else p
31 
+
32 
+readParen   	:: Bool -> ReadS a -> ReadS a
33 
+readParen b g	=  if b then mandatory else optional
34 
+		   where optional r  = g r ++ mandatory r
35 
+			 mandatory r = [(x,u) | ("(",s) <- lex r,
36 
+						(x,t)   <- optional s,
37 
+						(")",u) <- lex t    ]
38 
+
39 
+lex 	    		:: ReadS String
40 
+lex ""			= [("","")]
41 
+lex (c:s) | isSpace c	= lex (dropWhile isSpace s)
42 
+lex ('-':'-':s)		= case dropWhile (/= '\n') s of
43 
+				 '\n':t -> lex t
44 
+				 _	-> [] -- unterminated end-of-line
45 
+					      -- comment
46 
+
47 
+lex ('{':'-':s)		= lexNest lex s
48 
+			  where
49 
+			  lexNest f ('-':'}':s) = f s
50 
+			  lexNest f ('{':'-':s) = lexNest (lexNest f) s
51 
+			  lexNest f (c:s)	      = lexNest f s
52 
+			  lexNest _ ""		= [] -- unterminated
53 
+						     -- nested comment
54 
+
55 
+lex ('<':'-':s)		= [("<-",s)]
56 
+lex ('\'':s)		= [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
57 
+					       ch /= "'"		]
58 
+lex ('"':s)		= [('"':str, t)      | (str,t) <- lexString s]
59 
+			  where
60 
+			  lexString ('"':s) = [("\"",s)]
61 
+			  lexString s = [(ch++str, u)
62 
+						| (ch,t)  <- lexStrItem s,
63 
+						  (str,u) <- lexString t  ]
64 
+
65 
+			  lexStrItem ('\\':'&':s) = [("\\&",s)]
66 
+			  lexStrItem ('\\':c:s) | isSpace c
67 
+			      = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
68 
+			  lexStrItem s		  = lexLitChar s
69 
+
70 
+lex (c:s) | isSingle c	= [([c],s)]
71 
+	  | isSym1 c	= [(c:sym,t)	     | (sym,t) <- [span isSym s]]
72 
+	  | isAlpha c	= [(c:nam,t)	     | (nam,t) <- [span isIdChar s]]
73 
+	  | isDigit c	= [(c:ds++fe,t)	     | (ds,s)  <- [span isDigit s],
74 
+					       (fe,t)  <- lexFracExp s	   ]
75 
+	  | otherwise	= []	-- bad character
76 
+		where
77 
+		isSingle c  =  c `elem` ",;()[]{}_"
78 
+		isSym1 c    =  c `elem` "-~" || isSym c
79 
+		isSym c	    =  c `elem` "!@#$%&*+./<=>?\\^|:"
80 
+		isIdChar c  =  isAlphanum c || c `elem` "_'"
81 
+
82 
+		lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
83 
+						      (e,u)  <- lexExp t    ]
84 
+		lexFracExp s	   = [("",s)]
85 
+
86 
+		lexExp (e:s) | e `elem` "eE"
87 
+			 = [(e:c:ds,u) | (c:t)	<- [s], c `elem` "+-",
88 
+						   (ds,u) <- lexDigits t] ++
89 
+			   [(e:ds,t)   | (ds,t)	<- lexDigits s]
90 
+		lexExp s = [("",s)]
91 
+
92 
+lexDigits		:: ReadS String
93 
+lexDigits		=  nonnull isDigit
94 
+
95 
+nonnull			:: (Char -> Bool) -> ReadS String
96 
+nonnull p s		=  [(cs,t) | (cs@(_:_),t) <- [span p s]]
97 
+
98 
+lexLitChar		:: ReadS String
99 
+lexLitChar ('\\':s)	=  [('\\':esc, t) | (esc,t) <- lexEsc s]
100 
+	where
101 
+	lexEsc (c:s)	 | c `elem` "abfnrtv\\\"'" = [([c],s)]
102 
+	lexEsc ('^':c:s) | c >= '@' && c <= '_'  = [(['^',c],s)]
103 
+	lexEsc s@(d:_)	 | isDigit d		 = lexDigits s
104 
+	lexEsc ('o':s)	=  [('o':os, t) | (os,t) <- nonnull isOctDigit s]
105 
+	lexEsc ('x':s)	=  [('x':xs, t) | (xs,t) <- nonnull isHexDigit s]
106 
+	lexEsc s@(c:_)	 | isUpper c
107 
+			=  case [(mne,s') | mne <- "DEL" : elems asciiTab,
108 
+					    ([],s') <- [match mne s]	  ]
109 
+			   of (pr:_) -> [pr]
110 
+			      []     -> []
111 
+	lexEsc _	=  []
112 
+lexLitChar (c:s)	=  [([c],s)]
113 
+lexLitChar ""		=  []
114 
+
115 
+isOctDigit c  =  c >= '0' && c <= '7'
116 
+isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
117 
+			   || c >= 'a' && c <= 'f'
118 
+
119 
+match			:: (Eq a) => [a] -> [a] -> ([a],[a])
120 
+match (x:xs) (y:ys) | x == y  =  match xs ys
121 
+match xs     ys		      =  (xs,ys)
122 
+
123 
+asciiTab = listArray ('\NUL', ' ')
124 
+	   ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
125 
+	    "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
126 
+	    "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
127 
+	    "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
128 
+	    "SP"]
129 
+
130 
+
131 
+
132 
+readLitChar 		:: ReadS Char
133 
+readLitChar ('\\':s)	=  readEsc s
134 
+	where
135 
+	readEsc ('a':s)	 = [('\a',s)]
136 
+	readEsc ('b':s)	 = [('\b',s)]
137 
+	readEsc ('f':s)	 = [('\f',s)]
138 
+	readEsc ('n':s)	 = [('\n',s)]
139 
+	readEsc ('r':s)	 = [('\r',s)]
140 
+	readEsc ('t':s)	 = [('\t',s)]
141 
+	readEsc ('v':s)	 = [('\v',s)]
142 
+	readEsc ('\\':s) = [('\\',s)]
143 
+	readEsc ('"':s)	 = [('"',s)]
144 
+	readEsc ('\'':s) = [('\'',s)]
145 
+	readEsc ('^':c:s) | c >= '@' && c <= '_'
146 
+			 = [(chr (ord c - ord '@'), s)]
147 
+	readEsc s@(d:_) | isDigit d
148 
+			 = [(chr n, t) | (n,t) <- readDec s]
149 
+	readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]
150 
+	readEsc ('x':s)	 = [(chr n, t) | (n,t) <- readHex s]
151 
+	readEsc s@(c:_) | isUpper c
152 
+			 = let table = ('\DEL' := "DEL") : assocs asciiTab
153 
+			   in case [(c,s') | (c := mne) <- table,
154 
+					     ([],s') <- [match mne s]]
155 
+			      of (pr:_) -> [pr]
156 
+				 []	-> []
157 
+	readEsc _	 = []
158 
+readLitChar (c:s)	=  [(c,s)]
159 
+
160 
+showLitChar 		   :: Char -> ShowS
161 
+showLitChar c | c > '\DEL' =  showChar '\\' . protectEsc isDigit (shows (ord c))
162 
+showLitChar '\DEL'	   =  showString "\\DEL"
163 
+showLitChar '\\'	   =  showString "\\\\"
164 
+showLitChar c | c >= ' '   =  showChar c
165 
+showLitChar '\a'	   =  showString "\\a"
166 
+showLitChar '\b'	   =  showString "\\b"
167 
+showLitChar '\f'	   =  showString "\\f"
168 
+showLitChar '\n'	   =  showString "\\n"
169 
+showLitChar '\r'	   =  showString "\\r"
170 
+showLitChar '\t'	   =  showString "\\t"
171 
+showLitChar '\v'	   =  showString "\\v"
172 
+showLitChar '\SO'	   =  protectEsc (== 'H') (showString "\\SO")
173 
+showLitChar c		   =  showString ('\\' : asciiTab!c)
174 
+
175 
+protectEsc p f		   = f . cont
176 
+			     where cont s@(c:_) | p c = "\\&" ++ s
177 
+				   cont s	      = s
178 
+
179 
+readDec, readOct, readHex :: (Integral a) => ReadS a
180 
+readDec = readInt 10 isDigit (\d -> ord d - ord '0')
181 
+readOct = readInt  8 isOctDigit (\d -> ord d - ord '0')
182 
+readHex = readInt 16 isHexDigit hex
183 
+	    where hex d = ord d - (if isDigit d then ord '0'
184 
+				   else ord (if isUpper d then 'A' else 'a')
185 
+					- 10)
186 
+
187 
+readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
188 
+readInt radix isDig digToInt s =
189 
+    [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
190 
+	| (ds,r) <- nonnull isDig s ]
191 
+
192 
+showInt	:: (Integral a) => a -> ShowS
193 
+showInt n r = let (n',d) = quotRem n 10
194 
+		  r' = chr (ord '0' + fromIntegral d) : r
195 
+	      in if n' == 0 then r' else showInt n' r'
196 
+
197 
+readSigned:: (Real a) => ReadS a -> ReadS a
198 
+readSigned readPos = readParen False read'
199 
+		     where read' r  = read'' r ++
200 
+				      [(-x,t) | ("-",s) <- lex r,
201 
+						(x,t)   <- read'' s]
202 
+			   read'' r = [(n,s)  | (str,s) <- lex r,
203 
+		      				(n,"")  <- readPos str]
204 
+
205 
+showSigned:: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
206 
+showSigned showPos p x = if x < 0 then showParen (p > 6)
207 
+						 (showChar '-' . showPos (-x))
208 
+				  else showPos x
209 
+
210 
+
211 
+-- The functions readFloat and showFloat below use rational arithmetic
212 
+-- to insure correct conversion between the floating-point radix and
213 
+-- decimal.  It is often possible to use a higher-precision floating-
214 
+-- point type to obtain the same results.
215 
+
216 
+readFloat:: (RealFloat a) => ReadS a
217 
+readFloat r = [(fromRational ((n%1)*10^^(k-d)), t) | (n,d,s) <- readFix r,
218 
+						     (k,t)   <- readExp s]
219 
+              where readFix r = [(read (ds++ds'), length ds', t)
220 
+					| (ds,'.':s) <- lexDigits r,
221 
+					  (ds',t)    <- lexDigits s ]
222 
+
223 
+		    readExp (e:s) | e `elem` "eE" = readExp' s
224 
+                    readExp s			  = [(0,s)]
225 
+
226 
+                    readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
227 
+                    readExp' ('+':s) = readDec s
228 
+                    readExp' s	     = readDec s
229 
+
230 
+-- The number of decimal digits m below is chosen to guarantee
231 
+-- read (show x) == x.  See
232 
+--	Matula, D. W.  A formalization of floating-point numeric base
233 
+--	conversion.  IEEE Transactions on Computers C-19, 8 (1970 August),
234 
+--	681-692.
235 
+
236 
+showFloat:: (RealFloat a) => a -> ShowS
237 
+showFloat x =
238 
+    if x == 0 then showString ("0." ++ take (m-1) (repeat '0'))
239 
+	      else if e >= m-1 || e < 0 then showSci else showFix
240 
+    where
241 
+    showFix	= showString whole . showChar '.' . showString frac
242 
+		  where (whole,frac) = splitAt (e+1) (show sig)
243 
+    showSci	= showChar d . showChar '.' . showString frac
244 
+		      . showChar 'e' . shows e
245 
+    		  where (d:frac) = show sig
246 
+    (m, sig, e) = if b == 10 then (w,  	s,   n+w-1)
247 
+		  	     else (m', sig', e'   )
248 
+    m'		= ceiling
249 
+		      (fromIntegral w * log (fromInteger b) / log 10 :: Double)
250 
+		  + 1
251 
+    (sig', e')	= if	  sig1 >= 10^m'     then (round (t/10), e1+1)
252 
+		  else if sig1 <  10^(m'-1) then (round (t*10), e1-1)
253 
+		  			    else (sig1,		e1  )
254 
+    sig1 :: Integer
255 
+    sig1	= round t
256 
+    t		= s%1 * (b%1)^^n * 10^^(m'-e1-1)
257 
+    e1		= floor (logBase 10 x)
258 
+    (s, n)	= decodeFloat x
259 
+    b		= floatRadix x
260 
+    w		= floatDigits x
progs/prelude/PreludeTuple.hs
History View file @ 4e98702
0 261 
new file mode 100644
... ... 
@@ -0,0 +1,213 @@
1 
+module PreludeTuple where
2 
+
3 
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
4 
+
5 
+import PreludeTuplePrims
6 
+
7 
+-- This module contains support routines which handle tuple instances.
8 
+-- These are based on a implementation level data type which represents
9 
+-- general tuples and a data type to hold the set of dictionaries which
10 
+-- are associated with the tuple.
11 
+
12 
+-- Each of these functions takes the tupledicts as the first argument.
13 
+-- Force all of these functions to take strict arguments because they'll
14 
+-- never be called with 0-length tuples anyway.
15 
+
16 
+-- The following primitives operate on tuples.
17 
+
18 
+--  tupleSize :: TupleDicts -> Int
19 
+--  tupleSel :: Tuple -> Int -> Int -> a
20 
+--  dictSel :: TupleDicts -> method -> Int -> a
21 
+--  listToTuple :: [a] -> Tuple
22 
+
23 
+-- Eq functions
24 
+
25 
+tupleEq :: TupleDicts -> Tuple -> Tuple -> Bool
26 
+{-#  tupleEq :: Strictness("S,S,S") #-}
27 
+tupleEq dicts x y = tupleEq1 0 where
28 
+  tupleEq1 i | i == size = True
29 
+             | otherwise =
30 
+                  ((dictSel (cmpEq dicts i)) x' y') && tupleEq1 (i+1)
31 
+     where
32 
+        x' = tupleSel x i size
33 
+        y' = tupleSel y i size
34 
+  size = tupleSize dicts
35 
+
36 
+cmpEq x y = x == y
37 
+
38 
+tupleNeq dicts x y = not (tupleEq dicts x y)
39 
+
40 
+-- Ord functions
41 
+
42 
+tupleLe :: TupleDicts -> Tuple -> Tuple -> Bool
43 
+{-#  tupleLe :: Strictness("S,S,S") #-}
44 
+tupleLe dicts x y = tupleLe1 0 where
45 
+  tupleLe1 i | i == size = False
46 
+             | (dictSel (cmpLs dicts i)) x' y' = True
47 
+	     | (dictSel (ordEq dicts i)) x' y' = tupleLe1 (i+1)
48 
+	     | otherwise = False
49 
+      where
50 
+        x' = tupleSel x i size
51 
+        y' = tupleSel y i size
52 
+  size = tupleSize dicts
53 
+
54 
+cmpLs x y = x < y
55 
+
56 
+ordEq :: Ord a => a -> a -> Bool
57 
+ordEq x y = x == y
58 
+
59 
+tupleLeq :: TupleDicts -> Tuple -> Tuple -> Bool
60 
+{-#  tupleLeq :: Strictness("S,S,S") #-}
61 
+tupleLeq dicts x y = tupleLeq1 0 where
62 
+  tupleLeq1 i | i == size = True
63 
+             | (dictSel (cmpLs dicts i)) x' y' = True
64 
+	     | (dictSel (ordEq dicts i)) x' y' = tupleLeq1 (i+1)
65 
+	     | otherwise = False
66 
+      where
67 
+        x' = tupleSel x i size
68 
+        y' = tupleSel y i size
69 
+  size = tupleSize dicts
70 
+
71 
+tupleGe :: TupleDicts -> Tuple -> Tuple -> Bool
72 
+tupleGe d x y = tupleLe d y x
73 
+
74 
+tupleGeq :: TupleDicts -> Tuple -> Tuple -> Bool
75 
+tupleGeq d x y = tupleLeq d y x
76 
+
77 
+tupleMax,tupleMin :: TupleDicts -> Tuple -> Tuple -> Tuple
78 
+tupleMax d x y = if tupleGe d x y then x else y
79 
+tupleMin d x y = if tupleLe d x y then x else y
80 
+
81 
+-- Ix functions
82 
+
83 
+tupleRange :: TupleDicts -> (Tuple,Tuple) -> [Tuple]
84 
+{-#  tupleRange :: Strictness("S,S") #-}
85 
+
86 
+tupleRange dicts (x,y) = map listToTuple (tupleRange' 0) where
87 
+  tupleRange' i | i == size = [[]]
88 
+                | otherwise =
89 
+                   [(i1 : i2) | i1 <- r, i2 <- tupleRange' (i+1)]
90 
+      where
91 
+        x' = tupleSel x i size
92 
+        y' = tupleSel y i size
93 
+        r = (dictSel (range' dicts i)) (x',y')
94 
+  size = tupleSize dicts
95 
+
96 
+range' x = range x
97 
+
98 
+tupleIndex :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Int
99 
+{-#  tupleIndex :: Strictness("S,S,S") #-}
100 
+
101 
+tupleIndex dicts (low,high) n = tupleIndex' (size-1) where
102 
+  size = tupleSize dicts
103 
+  tupleIndex' i | i == 0 = i'
104 
+                | otherwise = i' + r' * (tupleIndex' (i-1))
105 
+   where
106 
+    low' = tupleSel low i size
107 
+    high' = tupleSel high i size
108 
+    n' = tupleSel n i size
109 
+    i' = (dictSel (index' dicts i)) (low',high') n'
110 
+    r' = (dictSel (rangeSize dicts i)) (low',high')
111 
+
112 
+index' x = index x
113 
+
114 
+rangeSize               :: (Ix a) => (a,a) -> Int
115 
+rangeSize (l,u)         =  index (l,u) u + 1
116 
+
117 
+tupleInRange :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Bool
118 
+{-#  tupleInRange :: Strictness("S,S,S") #-}
119 
+tupleInRange dicts (low,high) n = tupleInRange' 0 where
120 
+  size = tupleSize dicts
121 
+  tupleInRange' i | i == size = True
122 
+                  | otherwise = (dictSel (inRange' dicts i)) (low',high') n'
123 
+		                && tupleInRange' (i+1)
124 
+   where
125 
+    low' = tupleSel low i size
126 
+    high' = tupleSel high i size
127 
+    n' = tupleSel n i size
128 
+
129 
+inRange' x = inRange x
130 
+
131 
+-- Text functions
132 
+
133 
+tupleReadsPrec :: TupleDicts -> Int -> ReadS Tuple
134 
+
135 
+tupleReadsPrec dicts p = readParen False
136 
+                          (\s -> map ( \ (t,w) -> (listToTuple t,w))
137 
+			             (tRP' s 0))
138 
+    where
139 
+      size = tupleSize dicts
140 
+      tRP' s i | i == 0 = [(t':t,w) |
141 
+                             ("(",s1) <- lex s,
142 
+                             (t',s2) <- nextItem s1,
143 
+                             (t,w) <- tRP' s2 (i+1)]
144 
+               | i == size = [([],w) | (")",w) <- lex s]
145 
+               | otherwise =
146 
+                        [(t':t,w) |
147 
+                             (",",s1) <- lex s,
148 
+                             (t',s2) <- nextItem s1,
149 
+                             (t,w) <- tRP' s2 (i+1)]
150 
+       where
151 
+        nextItem s = (dictSel (reads dicts i)) s
152 
+
153 
+tupleShowsPrec :: TupleDicts -> Int -> Tuple -> ShowS
154 
+
155 
+tupleShowsPrec dicts p tuple =
156 
+  showChar '(' . tSP' 0
157 
+    where
158 
+      size = tupleSize dicts
159 
+      tSP' i | i == (size-1) =
160 
+                 showTup . showChar ')'
161 
+             | otherwise =
162 
+                 showTup . showChar ',' . tSP' (i+1)
163 
+        where
164 
+          showTup = (dictSel (shows dicts i)) (tupleSel tuple i size)
165 
+
166 
+tupleReadList :: TupleDicts -> ReadS [Tuple]
167 
+
168 
+tupleReadList dicts =
169 
+                  readParen False (\r -> [pr | ("[",s)	<- lex r,
170 
+					       pr	<- readl s])
171 
+	          where readl  s = [([],t)   | ("]",t)  <- lex s] ++
172 
+				   [(x:xs,u) | (x,t)    <- tupleReads s,
173 
+					       (xs,u)   <- readl' t]
174 
+			readl' s = [([],t)   | ("]",t)  <- lex s] ++
175 
+			           [(x:xs,v) | (",",t)  <- lex s,
176 
+					       (x,u)	<- tupleReads t,
177 
+					       (xs,v)   <- readl' u]
178 
+                        tupleReads s = tupleReadsPrec dicts 0 s
179 
+
180 
+tupleShowList :: TupleDicts -> [Tuple] -> ShowS
181 
+
182 
+tupleShowList dicts [] = showString "[]"
183 
+tupleShowList dicts (x:xs)
184 
+		= showChar '[' . showsTuple x . showl xs
185 
+		  where showl []     = showChar ']'
186 
+			showl (x:xs) = showString ", " . showsTuple x
187 
+			                               . showl xs
188 
+                        showsTuple x = tupleShowsPrec dicts 0 x
189 
+
190 
+-- Binary functions
191 
+
192 
+tupleShowBin :: TupleDicts -> Tuple -> Bin -> Bin
193 
+
194 
+tupleShowBin dicts t bin = tSB' 0
195 
+  where
196 
+    size = tupleSize dicts
197 
+    tSB' i | i == size = bin
198 
+    tSB' i | otherwise =
199 
+                  (dictSel (showBin' dicts i)) (tupleSel t i size) (tSB' (i+1))
200 
+
201 
+showBin' x = showBin x
202 
+
203 
+tupleReadBin :: TupleDicts -> Bin -> (Tuple,Bin)
204 
+
205 
+tupleReadBin dicts bin = (listToTuple t,b) where
206 
+  size = tupleSize dicts
207 
+  (t,b) = tRB' bin 0
208 
+  tRB' b i | i == size = ([],b)
209 
+           | otherwise = (t':ts,b') where
210 
+     (t',b'') = (dictSel (readBin' dicts i)) b
211 
+     (ts,b') = tRB' b'' (i+1)
212 
+
213 
+readBin' x = readBin x
progs/prelude/PreludeTuplePrims.hi
History View file @ 4e98702
0 214 
new file mode 100644
... ... 
@@ -0,0 +1,48 @@
1 
+
2 
+-- This is the interface to the primitives used to implement arbitrary
3 
+-- sized tuples.
4 
+
5 
+interface PreludeTuplePrims where
6 
+
7 
+{-# Prelude #-}
8 
+
9 
+-- The type checker fiddles around with the call to dictSel to use the
10 
+-- dictionary to resolve the overloading of a subexpression.  The call
11 
+-- dictSel (exp dict i) will typecheck exp and use the ith component of
12 
+-- the tupleDict dict to resolve the overloading.  No check is made to ensure
13 
+-- that the type of the dictionary matches the overloaded class!  Beware!
14 
+
15 
+import PreludeData(Int)
16 
+
17 
+data Tuple
18 
+data TupleDicts
19 
+
20 
+
21 
+tupleSize :: TupleDicts -> Int
22 
+tupleSel :: Tuple -> Int -> Int -> a
23 
+dictSel :: TupleDicts -> Int -> a
24 
+listToTuple :: [a] -> Tuple
25 
+-- These are not called by haskell code directly; these are introduced
26 
+-- during dictionary conversion by the type checker.
27 
+tupleEqDict :: a
28 
+tupleOrdDict :: a
29 
+tupleIxDict :: a
30 
+tupleTextDict :: a
31 
+tupleBinaryDict :: a
32 
+
33 
+{-#
34 
+tupleSize ::       LispName("prim.tupleSize"), Complexity(1)
35 
+tupleSel ::        LispName("prim.tupleSel")
36 
+dictSel ::         LispName("prim.dict-sel")
37 
+listToTuple ::     LispName("prim.list->tuple"), NoConversion
38 
+tupleEqDict ::     LispName("prim.tupleEqDict")
39 
+tupleOrdDict ::    LispName("prim.tupleOrdDict")
40 
+tupleIxDict ::     LispName("prim.tupleIxDict")
41 
+tupleTextDict ::   LispName("prim.tupleTextDict")
42 
+tupleBinaryDict :: LispName("prim.tupleBinaryDict")
43 
+
44 
+#-}
45 
+
46 
+
47 
+
48 
+
progs/prelude/PreludeTuplePrims.hu
History View file @ 4e98702
0 49 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+:output $PRELUDEBIN/PreludeTuplePrims
2 
+:stable
3 
+:prelude
4 
+PreludeTuplePrims.hi
progs/prelude/README
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,12 @@
1 
+
2 
+This is the actual prelude used by the Yale system.  This contains a many
3 
+small changes to the standard prelude, mostly optimizer annotations.
4 
+PreludeIO is totally different since we have flushed streams in favor
5 
+of the monad.  Primitives are defined using the Haskell to Lisp interface.
6 
+
7 
+Arrays are implemented internally using destructive updates - no array
8 
+primitive involves more than one copy operation and lookup is constant
9 
+time.
10 
+
11 
+The data constructors for Complex and Rational are strict.
12 
+
progs/tutorial/README
History View file @ 4e98702
0 13 
new file mode 100644
... ... 
@@ -0,0 +1,12 @@
1 
+
2 
+This is the text of the online version of the tutorial.  It is set up to
3 
+run under Emacs only.  Form feeds divide the pages of the tutorial.  Emacs
4 
+has a special mode just for the tutorial which makes a local copy of each
5 
+page for the user to scribble on without disturbing this source.
6 
+
7 
+It is possible that this could be adapted to the command interface by
8 
+breaking it up into one file per page.
9 
+
10 
+This is still preliminary - we need to work on the text and examples.
11 
+Please send comments to haskell-request@cs.yale.edu.
12 
+
progs/tutorial/tutorial.hs
History View file @ 4e98702
0 13 
new file mode 100644
... ... 
@@ -0,0 +1,2143 @@
1 
+-- Page 0    Introduction
2 
+
3 
+This is a programming supplement to `A Gentle Introduction to Haskell'
4 
+by Hudak and Fasel.  This supplement augments the tutorial by
5 
+providing executable Haskell programs which you can run and
6 
+experiment with.  All program fragments in the tutorial are
7 
+found here, as well as other examples not included in the tutorial.
8 
+
9 
+
10 
+Using This Tutorial
11 
+
12 
+You should have a copy of both the `Gentle Introduction' and the
13 
+report itself to make full use of this tutorial.  Although the
14 
+`Gentle Introduction' is meant to stand by itself, it is often easier
15 
+to learn a language through actual use and experimentation than by
16 
+reading alone.  Once you finish this introduction, we recommend that
17 
+you proceed section by section through the `Gentle Introduction' and
18 
+after having read each section go back to this online tutorial.  You
19 
+should wait until you have finished the tutorial before attempting to
20 
+read the report.  We assume that you are familiar with the basics of
21 
+Emacs and that Haskell has been installed at your site.
22 
+
23 
+This tutorial does not assume any familiarity with Haskell or other
24 
+functional languages.  However, knowledge of almost-functional
25 
+languages such as ML or Scheme is very useful.  Throughout the
26 
+online component of this tutorial, we try to relate Haskell to
27 
+other programming languages and clarify the written tutorial through
28 
+additional examples and text.
29 
+
30 
+
31 
+Organization of the Online Tutorial
32 
+
33 
+This online tutorial is divided into a series of pages.  Each page
34 
+covers one or more sections in the written tutorial.  You can use
35 
+special Emacs commands to move back and forth through the pages of the
36 
+online tutorial.  Each page is a single Haskell program.  Comments in
37 
+the program contain the text of the online tutorial.  You can modify
38 
+the program freely (this will not change the underlying tutorial
39 
+file!) and ask the system to print the value of expressions defined in
40 
+the program.
41 
+
42 
+At the beginning of each page, the sections covered by the page are
43 
+listed.  In addition, the start of each individual section is
44 
+marked within each page.  Emacs commands can take you directly to a
45 
+specific page or section in the tutorial.
46 
+
47 
+To create useful, executable examples of Haskell code, some language
48 
+constructs need to be revealed well before they are explained in the
49 
+tutorial.  We attempt to point these out when they occur.  Some
50 
+small changes have been made to the examples in the written tutorial;
51 
+these are usually cosmetic and should be ignored.  Don't feel you have
52 
+to understand everything on a page before you move on -- many times
53 
+concepts become clearer as you move on and can relate them to other
54 
+aspect of the language.
55 
+
56 
+Each page of the tutorial defines a set of variables.  Some of
57 
+these are named e1, e2, and so on.  These `e' variables are the ones
58 
+which are meant for you to evaluate as you go through the tutorial.
59 
+Of course you may evaluate any other expressions or variables you wish.
60 
+
61 
+
62 
+The Haskell Report
63 
+
64 
+While the report is not itself a tutorial on the Haskell language, it
65 
+can be an invaluable reference to even a novice user.  A very
66 
+important feature of Haskell is the prelude.  The prelude is a
67 
+rather large chunk of Haskell code which is implicitly a part of every
68 
+Haskell program.  Whenever you see functions used which are not
69 
+defined in the current page, these come from the Prelude.  Appendix A
70 
+of the report lists the entire Prelude; the index has an entry for
71 
+every function in the Prelude.  Looking at the definitions in the
72 
+Prelude is sometimes necessary to fully understand the programs in
73 
+this tutorial.
74 
+
75 
+Another reason to look at the report is to understand the syntax of
76 
+Haskell.  Appendix B contains the complete syntax for Haskell.  The
77 
+tutorial treats the syntax very informally; the precise details are
78 
+found only in the report.
79 
+
80 
+
81 
+The Yale Haskell System
82 
+
83 
+This version of the tutorial runs under version Y2.0 of Yale Haskell.
84 
+The Yale Haskell system is an interactive programming environment for
85 
+the Haskell language.  The system is best used in conjunction with the
86 
+Emacs editor.  Yale Haskell is available free of change via ftp.
87 
+
88 
+
89 
+Using the Compiler
90 
+
91 
+Yale Haskell runs as a subprocess under Emacs.  While many commands
92 
+are available to the Yale Haskell user, a single command is the
93 
+primary means of communicating with the compiler: C-c e.  This command
94 
+evaluates and prints an expression in the context of the program on
95 
+the screen.  Here is what this command does:
96 
+
97 
+a) You are prompted for an expression in the minibuffer.  You can
98 
+use M-p or M-n to move through a ring of previous inputs.
99 
+
100 
+b) If an inferior Haskell process is not running, a buffer named *haskell*
101 
+is created and the Haskell compiler is started up.  The *haskell* buffer
102 
+pops onto your screen.
103 
+
104 
+c) If the program in the current page of the tutorial has not yet been
105 
+compiled or the page has been modified after its most recent
106 
+compilation, the entire page is compiled.  This may result in a short delay.
107 
+
108 
+d) If there are no errors in the program, the expression entered in
109 
+step a) is compiled in the context of the program.  Any value defined
110 
+in the current page can be referenced.
111 
+
112 
+e) If there are no errors in the expression, its value is printed in
113 
+the *haskell* buffer.
114 
+
115 
+There are also a few other commands you can use.  C-c i interrupts
116 
+the Haskell program.  Some tight loops cannot be interrupted; in this
117 
+case you will have to kill the Haskell process.    C-c q exits the Haskell
118 
+process.
119 
+
120 
+
121 
+Emacs Commands Used by the Tutorial
122 
+
123 
+These commands are specific to the tutorial.  The tutorial is entered
124 
+using M-x haskell-tutorial and is exited with C-c q.  To move among
125 
+the pages of the tutorial, use
126 
+
127 
+C-c C-f  -- go forward 1 page
128 
+C-c C-b  -- go back 1 page
129 
+M-x ht-goto-page    - goto a specific page of the tutorial
130 
+M-x ht-goto-section - goto a specific section of the tutorial
131 
+
132 
+Each page of the tutorial can be modified without changing the
133 
+underlying text of the tutorial.  Changes are not saved as you go
134 
+between pages.  To revert a page to its original form use C-c C-l.
135 
+
136 
+You can get help regarding the Emacs commands with C-c ?.
137 
+
138 
+Summary of Emacs commands used by the tutorial:
139 
+  M-x haskell-tutorial  - start the tutorial
140 
+  C-c C-f  - Go to the next page of the tutorial program
141 
+  C-c C-b  - Go back to the previous page of the tutorial program
142 
+  C-c C-l  - Restore the current page to its original form
143 
+  C-c e    - Evaluate a Haskell expression
144 
+  C-c i    - Interrupt a running Haskell program
145 
+  C-c ?    - Shows a help message
146 
+  M-x ht-goto-page    - goto a specific page of the tutorial
147 
+  M-x ht-goto-section - goto a specific section of the tutorial
148 
+
149 
+
150 
+You are now ready to start the tutorial.  Start by reading the `Gentle
151 
+Introduction' section 1 then proceed through the online tutorial using
152 
+C-c C-f to advance to the next page.  You should read about each topic
153 
+first before turning to the associated programming example in the
154 
+online tutorial.
155 
+
156 
+
157 
+-- Page 1   Section 2
158 
+
159 
+-- Section 2   Values, Types, and Other Goodies
160 
+
161 
+-- Haskell uses `--' to designate end of line comments.  We use these
162 
+-- throughout the tutorial to place explanatory text in the program.
163 
+
164 
+-- Remember to use C-c e to evaluate expressions, C-c ? for help.
165 
+
166 
+-- All Haskell programs must start with a module declaration.  Ignore this
167 
+-- for now.
168 
+
169 
+module Test(Bool) where
170 
+
171 
+-- We will start by defining some identifiers (variables) using equations.
172 
+-- You can print out the value of an identifier by typing C-c e and
173 
+-- typing the name of the identifier you wish to evaluate.  This will
174 
+-- compile the entire program, not just the line with the definition
175 
+-- you want to see.  Not all definitions are very interesting to print out -
176 
+-- by convention, we will use variables e1, e2, ... to denote values that
177 
+-- are `interesting' to print.
178 
+
179 
+-- We'll start with some constants as well as their associated type.
180 
+-- There are two ways to associate a type with a value: a type declaration
181 
+-- and an expression type signature.  Here is an equation and a type
182 
+-- declaration:
183 
+
184 
+e1 :: Int     -- This is a type declaration for the identifier e1
185 
+e1 = 5        -- This is an equation defining e1
186 
+
187 
+-- You can evaluate the expression e1 and watch the system print `5'!  Wow!
188 
+
189 
+-- Remember that C-c e is prompting for an expression.  Expressions like
190 
+-- e1 or 5 or 1+1 are all valid.  However, `e1 = 5' is a definition,
191 
+-- not an expression.  Trying to evaluate it will result in a syntax error.
192 
+
193 
+-- The type declaration for e1 is not really necessary but we will try to
194 
+-- always provide type declarations for values to help document the program
195 
+-- and to ensure that the system infers the same type we do for an expression.
196 
+-- If you change the value for e1 to `True', the program will no longer
197 
+-- compile due to the type mismatch.
198 
+
199 
+-- We will briefly mention expression type signatures: these are attached to
200 
+-- expressions instead of identifiers.  Here are equivalent ways to do
201 
+-- the previous definition:
202 
+
203 
+e2 = 5 :: Int
204 
+e3 = (2 :: Int) + (3 :: Int)
205 
+
206 
+-- The :: has very low precedence in expressions and should usually be placed
207 
+-- in parenthesis.
208 
+
209 
+-- Note that there are two completely separate languages: an expression
210 
+-- language for values and a type language for type signatures.  The type
211 
+-- language is used only in the type declarations previously described and
212 
+-- declarations of new types, described later.  Haskell uses a
213 
+-- uniform syntax so that values resemble their type signature as much as
214 
+-- possible.  However, you must always be aware of the difference between
215 
+-- type expressions and value expressions.
216 
+
217 
+-- Here are some of the predefined types Haskell provides:
218 
+--    type           Value Syntax                Type Syntax
219 
+-- Small integers    <digits>                    Int
220 
+e4 :: Int
221 
+e4 = 12345
222 
+-- Characters        '<character>'               Char
223 
+e5 :: Char
224 
+e5 = 'a'
225 
+-- Boolean           True, False                 Bool
226 
+e6 :: Bool
227 
+e6 = True
228 
+-- Floating point    <digits.digits>             Float
229 
+e7 :: Float
230 
+e7 = 123.456
231 
+-- We will introduce these types now; there will be much more to say later.
232 
+-- Homogenous List   [<exp1>,<exp2>,...]         [<constituant type>]
233 
+e8 :: [Int]
234 
+e8 = [1,2,3]
235 
+-- Tuple             (<exp1>,<exp2>,...)         (<exp1-type>,<exp2-type>,...)
236 
+e9 :: (Char,Int)
237 
+e9 = ('b',4)
238 
+-- Functional        described later             domain type -> range type
239 
+succ :: Int -> Int  -- a function which takes an Int argument and returns Int
240 
+succ x = x + 1      -- test this by evaluating `succ 4'
241 
+
242 
+-- Here's a few leftover examples from section 2:
243 
+
244 
+e10 = succ (succ 3)  -- you could also evaluate `succ (succ 3)' directly
245 
+                     -- by entering the entire expression to the C-c e
246 
+
247 
+-- If you want to evaluate something more complex than the `e' variables
248 
+-- defined here, it is better to enter a complex expression, such as
249 
+-- succ (succ 3), directly than to edit a new definition like e10 into
250 
+-- the program.  This is because any change to the program will require
251 
+-- recompilation of the entire page.  The expressions entered to C-c e are
252 
+-- compiled separately (and very quickly!).
253 
+
254 
+-- Uncomment this next line to see a compile time type error.
255 
+-- e11 = 'a'+'b'
256 
+-- Don't worry about the error message - it will make more sense later.
257 
+
258 
+-- Proceed to the next page using C-c C-f
259 
+
260 
+-- Page 2   Section 2.1
261 
+
262 
+-- Section 2.1   Polymorphic Types
263 
+
264 
+module Test(Bool) where
265 
+
266 
+-- The following line allows us to redefine functions in the standard
267 
+-- prelude.  Ignore this for now.
268 
+
269 
+import Prelude hiding (length,head,tail,null)
270 
+
271 
+-- start with some sample lists to use in test cases
272 
+
273 
+list1 :: [Int]
274 
+list1 = [1,2,3]
275 
+list2 :: [Char]         -- This is the really a string
276 
+list2 = ['a','b','c']   -- This is the same as "abc"; evaluate list2 and see.
277 
+list3 :: [[a]]          -- The element type of the inner list is unknown
278 
+list3 = [[],[],[],[]]   -- so this list can't be printed
279 
+list4 :: [Int]
280 
+list4 = 1:2:3:4:[]      -- Exactly the same as [1,2,3,4]; print it and see.
281 
+
282 
+-- This is the length function.  You can test it by evaluating expressions
283 
+-- such as `length list1'.  Function application is written by
284 
+-- simple juxtaposition: `f(x)' in other languages would be `f x' in Haskell.
285 
+
286 
+length :: [a] -> Int
287 
+length [] = 0
288 
+length (x:xs) = 1 + length xs
289 
+
290 
+-- Function application has the highest precedence, so 1 + length xs is
291 
+-- parsed as 1 + (length xs).  In general, you have to surround
292 
+-- non-atomic arguments to a function with parens.  This includes
293 
+-- arguments which are also function applications.  For example,
294 
+-- f g x is the function f applied to arguments g and x, similar to
295 
+-- f(g,x) in other languages.  However, f (g x) is f applied to (g x), or
296 
+-- f(g(x)), which means something quite different!  Be especially
297 
+-- careful with infix operators: f x+1 y-2 would be parsed as (f x)+(1 y)-2.
298 
+-- This is also true on the left of the `=': the parens around (x:xs) are
299 
+-- absolutely necessary.  length x:xs would be parsed as (length x):xs.
300 
+
301 
+-- Also be careful with prefix negation, -.  The application `f -1' is
302 
+-- f-1, not f(-1).  Add parens around negative numbers to avoid this
303 
+-- problem.
304 
+
305 
+-- Here are some other list functions:
306 
+
307 
+head :: [a] -> a   -- returns the first element in a list (same as car in lisp)
308 
+head (x:xs) = x
309 
+
310 
+tail :: [a] -> [a] -- removes the first element from a list (same as cdr)
311 
+tail (x:xs) = xs
312 
+
313 
+null :: [a] -> Bool
314 
+null [] = True
315 
+null (x:xs) = False
316 
+
317 
+cons :: a -> [a] -> [a]
318 
+cons x xs = x:xs
319 
+
320 
+nil :: [a]
321 
+nil = []
322 
+
323 
+-- Length could be defined using these functions too.  This is
324 
+-- not good Haskell style but does illustrate these other list functions.
325 
+-- The if - then - else will be discussed later.  Haskell programmers feel
326 
+-- that the pattern matching style, as used in the previous version of
327 
+-- length, is more natural and readable.
328 
+
329 
+length' :: [a] -> Int   -- Note that ' can be part of a name
330 
+length' x = if null x then 0 else 1 + length' (tail x)
331 
+
332 
+-- A test case for length', cons, and nil
333 
+
334 
+e1 = length' (cons 1 (cons 2 nil))
335 
+
336 
+-- We haven't said anything about errors yet.  Each of the following
337 
+-- examples illustrates a potential runtime or compile time error.  The
338 
+-- compile time error is commented out so that other examples will compile;
339 
+-- you can uncomment them and see what happens.
340 
+
341 
+-- e2 = cons True False   -- Why is this not possible in Haskell?
342 
+e3 = tail (tail ['a'])  -- What happens if you evaluate this?
343 
+e4 = []       -- This is especially mysterious!
344 
+
345 
+-- This last example, e4, is something hard to explain but is often
346 
+-- encountered early by novices.  We haven't explained yet how the system
347 
+-- prints out the expressions you type in - this will wait until later.
348 
+-- However, the problem here is that e4 has the type [a].  The printer for
349 
+-- the list datatype is complaining that it needs to know a specific type
350 
+-- for the list elements even though the list has no elements!  This can
351 
+-- be avoided by giving e4 a type such as [Int].  (To further confuse you,
352 
+-- try giving e4 the type [Char] and see what happens.)
353 
+
354 
+-- Page 3   Section 2.2
355 
+
356 
+-- Section 2.2  User-Defined Types
357 
+
358 
+module Test(Bool) where
359 
+
360 
+-- The type Bool is already defined in the Prelude so there is no
361 
+-- need to define it here.
362 
+
363 
+data Color = Red | Green | Blue | Indigo | Violet deriving Text
364 
+-- The `deriving Text' is necessary if you want to print a Color value.
365 
+
366 
+-- You can now evaluate these expressions.
367 
+e1 :: Color
368 
+e1 = Red
369 
+e2 :: [Color]
370 
+e2 = [Red,Blue]
371 
+
372 
+-- It is very important to keep the expression language and the type
373 
+-- language in Haskell separated.  The data declaration above defines
374 
+-- the type constructor Color.  This is a nullary constructor: it takes no
375 
+-- arguments.  Color is found ONLY in the type language - it can not be
376 
+-- part of an expression.  e1 = Color is meaningless.  (Actually, Color could
377 
+-- be both a data constructor and a type constructor but we'll ignore this
378 
+-- possibility for now).  On the other hand, Red, Blue, and so on are
379 
+-- (nullary) data constructors.  They can appear in expressions and
380 
+-- in patterns (described later).  The declaration e1 :: Blue would also
381 
+-- be meaningless.  Data constructors can be defined ONLY in a data
382 
+-- declaration.
383 
+
384 
+-- In the next example, Point is a type constructor and Pt is a data
385 
+-- constructor.  Point takes one argument and Pt takes two.  A data constructor
386 
+-- like Pt is really just an ordinary function except that it can be used in
387 
+-- a pattern.  Type signatures can not be supplied directly for data
388 
+-- constructors; their typing is completely defined by the data declaration.
389 
+-- However, data constructors have a signature just like any variable:
390 
+-- Pt :: a -> a -> Point a   -- Not valid Haskell syntax
391 
+-- That is, Pt is a function which takes two arguments with the same
392 
+-- arbitrary type and returns a value containing the two argument values.
393 
+
394 
+data Point a = Pt a a   deriving Text
395 
+
396 
+e3 :: Point Float
397 
+e3 = Pt 2.0 3.0
398 
+e4 :: Point Char
399 
+e4 = Pt 'a' 'b'
400 
+e5 :: Point (Point Int)
401 
+e5 = Pt (Pt 1 2) (Pt 3 4)
402 
+-- e6 = Pt 'a' True         -- This is a typing error
403 
+
404 
+-- The individual components of a point do not have names.
405 
+-- Let's jump ahead a little so that we can write functions using these
406 
+-- data types.  Data constructors (Red, Blue, ..., and Pt) can be used in
407 
+-- patterns.  When more than one equation is used to define a function,
408 
+-- pattern matching occurs top down.
409 
+
410 
+-- A function to remove red from a list of colors.
411 
+
412 
+removeRed :: [Color] -> [Color]
413 
+removeRed [] = []
414 
+removeRed (Red:cs) = removeRed cs
415 
+removeRed (c:cs) = c : removeRed cs  -- c cannot be Red at this point
416 
+
417 
+e7 :: [Color]
418 
+e7 = removeRed [Blue,Red,Green,Red]
419 
+
420 
+-- Pattern matching is capable of testing equality with a specific color.
421 
+
422 
+-- All equations defining a function must share a common type.  A
423 
+-- definition such as:
424 
+-- foo Red = 1
425 
+-- foo (Pt x y) = x
426 
+-- would result in a type error since the argument to foo cannot be both a
427 
+-- Color and a Point.  Similarly, the right hand sides must also share a
428 
+-- common type; a definition such as
429 
+-- foo Red = Blue
430 
+-- foo Blue = Pt Red Red
431 
+-- would also result in a type error.
432 
+
433 
+-- Here's a couple of functions defined on points.
434 
+
435 
+dist :: Point Float -> Point Float -> Float
436 
+dist (Pt x1 y1) (Pt x2 y2) = sqrt ((x1-x2)^2 + (y1-y2)^2)
437 
+
438 
+midpoint :: Point Float -> Point Float -> Point Float
439 
+midpoint (Pt x1 y1) (Pt x2 y2) = Pt ((x1+x2)/2) ((y1+y2)/2)
440 
+
441 
+p1 :: Point Float
442 
+p1 = Pt 1.0 1.0
443 
+p2 :: Point Float
444 
+p2 = Pt 2.0 2.0
445 
+
446 
+e8 :: Float
447 
+e8 = dist p1 p2
448 
+e9 :: Point Float
449 
+e9 = midpoint p1 p2
450 
+
451 
+-- The only way to take apart a point is to pattern match.
452 
+-- That is, the two values which constitute a point must be extracted
453 
+-- by matching a pattern containing the Pt data constructor.  Much
454 
+-- more will be said about pattern matching later.
455 
+
456 
+-- Haskell prints values in the same syntax used in expressions.  Thus
457 
+-- Pt 1 2 would print as Pt 1 2 (of course, Pt 1 (1+1) would also print
458 
+-- as Pt 1 2).
459 
+
460 
+-- Page 4  Section 2.3
461 
+
462 
+-- Section 2.3  Recursive Types
463 
+
464 
+module Test where
465 
+
466 
+data Tree a = Leaf a | Branch (Tree a) (Tree a)    deriving Text
467 
+
468 
+-- The following typings are implied by this declaration.  As before,
469 
+-- this is not valid Haskell syntax.
470 
+-- Leaf :: a -> Tree a
471 
+-- Branch :: Tree a -> Tree a -> Tree a
472 
+
473 
+fringe :: Tree a -> [a]
474 
+fringe (Leaf x) = [x]
475 
+fringe (Branch left right) = fringe left ++ fringe right
476 
+
477 
+-- The following trees can be used to test functions:
478 
+
479 
+tree1 :: Tree Int
480 
+tree1 = Branch (Leaf 1) (Branch (Branch (Leaf 2) (Leaf 3)) (Leaf 4))
481 
+tree2 :: Tree Int
482 
+tree2 = Branch (Branch (Leaf 3) (Leaf 1)) (Branch (Leaf 4) (Leaf 1))
483 
+tree3 :: Tree Int
484 
+tree3 = Branch tree1 tree2
485 
+
486 
+-- Try evaluating `fringe tree1' and others.
487 
+
488 
+-- Here's another tree function:
489 
+
490 
+twist :: Tree a -> Tree a
491 
+twist (Branch left right) = Branch right left
492 
+twist x = x        -- This equation only applies to leaves
493 
+
494 
+-- Here's a function which compares two trees to see if they have the
495 
+-- same shape.  Note the signature: the two trees need not contain the
496 
+-- same type of values.
497 
+
498 
+sameShape :: Tree a -> Tree b -> Bool
499 
+sameShape (Leaf x) (Leaf y) = True
500 
+sameShape (Branch l1 r1) (Branch l2 r2) = sameShape l1 l2 && sameShape r1 r2
501 
+sameShape x y = False  -- One is a branch, the other is a leaf
502 
+
503 
+-- The && function is a boolean AND function.
504 
+
505 
+-- The entire pattern on the left hand side must match in order for the
506 
+-- right hand side to be evaluated.  The first clause requires both
507 
+-- arguments to be a leaf' otherwise the next equation is tested.
508 
+-- The last clause will always match: the final x and y match both
509 
+-- leaves and branches.
510 
+
511 
+-- This compares a tree of integers to a tree of booleans.
512 
+e1 = sameShape tree1 (Branch (Leaf True) (Leaf False))
513 
+
514 
+-- Page 5  Sections 2.4, 2.5, 2.6
515 
+
516 
+-- Section 2.4  Type Synonyms
517 
+
518 
+module Test(Bool) where
519 
+
520 
+-- Since type synonyms are part of the type language only, it's hard to
521 
+-- write a program which shows what they do.  Essentially, they are like
522 
+-- macros for the type language.  They can be used interchangably with their
523 
+-- definition:
524 
+
525 
+e1 :: String
526 
+e1 = "abc"
527 
+e2 :: [Char]   -- No different than String
528 
+e2 = e1
529 
+
530 
+-- In the written tutorial the declaration of `Addr' is a data type
531 
+-- declaration, not a synonym declaration.  This shows that the data
532 
+-- type declaration as well as a signature can reference a synonym.
533 
+
534 
+-- Section 2.5  Built-in Types
535 
+
536 
+-- Tuples are an easy way of grouping a set of data values.  Here are
537 
+-- a few tuples.  Note the consistancy in notation between the values and
538 
+-- types.
539 
+
540 
+e3 :: (Bool,Int)
541 
+e3 = (True,4)
542 
+e4 :: (Char,[Int],Char)
543 
+e4 = ('a',[1,2,3],'b')
544 
+
545 
+-- Here's a function which returns the second component of a 3 tuple.
546 
+second :: (a,b,c) -> b
547 
+second (a,b,c) = b
548 
+
549 
+-- Try out `second e3' and `second e4' - what happens?
550 
+-- Each different size of tuple is a completely distinct type.  There is
551 
+-- no general way to append two arbitrary tuples or randomly select the
552 
+-- i'th component of an arbitrary tuple.  Here's a function built using
553 
+-- 2-tuples to represent intervals.
554 
+
555 
+-- Use a type synonym to represent homogenous 2 tuples
556 
+type Interval a = (a,a)
557 
+
558 
+containsInterval :: Interval Int -> Interval Int -> Bool
559 
+containsInterval (xmin,xmax) (ymin,ymax) = xmin <= ymin && xmax >= ymax
560 
+
561 
+p1 :: Interval Int
562 
+p1 = (2,3)
563 
+p2 :: Interval Int
564 
+p2 = (1,4)
565 
+
566 
+e5 = containsInterval p1 p2
567 
+e6 = containsInterval p2 p1
568 
+
569 
+-- Here's a type declaration for a type isomorphic to lists:
570 
+
571 
+data List a = Nil | Cons a (List a) deriving Text
572 
+
573 
+-- Except for the notation, this is completely equivalent to ordinary lists
574 
+-- in Haskell.
575 
+
576 
+length' :: List a -> Int
577 
+length' Nil = 0
578 
+length' (Cons x y) = 1 + length' y
579 
+
580 
+e7 = length' (Cons 'a' (Cons 'b' (Cons 'c' Nil)))
581 
+
582 
+-- It's hard to demonstrate much about the `non-specialness' of built-in
583 
+-- types.  However, here is a brief summary:
584 
+
585 
+-- Numbers and characters, such as 1, 2.2, or 'a', are the same as nullary
586 
+-- type constructors.
587 
+
588 
+-- Lists have a special type constructor, [a] instead of List a, and
589 
+-- an odd looking data constructor, [].  The other data constructor, :, is
590 
+-- not `unusual', syntactically speaking.  The notation [x,y] is just
591 
+-- syntax for x:y:[] and "abc" for 'a' : 'b' : 'c' : [].
592 
+
593 
+-- Tuples use a special syntax.  In a type expression, a 2 tuple containing
594 
+-- types a and be would be written (a,b) instead of using a prefix type
595 
+-- constructor such as Tuple2 a b.  This same notation is used to build
596 
+-- tuple values: (1,2) would construct a 2 tuple containing the values 1 and 2.
597 
+
598 
+
599 
+-- Page 6   Sections 2.5.1, 2.5.2
600 
+
601 
+module Test(Bool) where
602 
+
603 
+-- Section 2.5.1  List Comprehensions and Arithmetic Sequences
604 
+
605 
+-- Warning: brackets in Haskell are used in three different types
606 
+-- of expressions: lists, as in [a,b,c], sequences (distinguished by
607 
+-- the ..), as in [1..2], and list comprehensions (distinguished by the
608 
+-- bar: |), as in [x+1 | x <- xs, x > 1].
609 
+
610 
+-- Before list comprehensions, let's start out with sequences:
611 
+
612 
+e1 :: [Int]
613 
+e1 = [1..10]   -- Step is 1
614 
+e2 :: [Int]
615 
+e2 = [1,3..10] -- Step is 3 - 1
616 
+e3 :: [Int]
617 
+e3 = [1,-1..-10]
618 
+e4 :: [Char]
619 
+e4 = ['a'..'z']   -- This works on chars too
620 
+
621 
+-- We'll avoid infinite sequences like [1..] for now.  If you print one,
622 
+-- use C-c i to interrupt the Haskell program.
623 
+
624 
+-- List comprehensions are very similar to nested loops.  They return a
625 
+-- list of values generated by the expression inside the loop.  The filter
626 
+-- expressions are similar to conditionals in the loop.
627 
+
628 
+-- This function does nothing at all!  It just scans through a list and
629 
+-- copies it into a new one.
630 
+
631 
+doNothing :: [a] -> [a]
632 
+doNothing l = [x | x <- l]
633 
+
634 
+-- Adding a filter to the previous function allows only selected elements to
635 
+-- be generated.  This is similar to what is done in quicksort.
636 
+
637 
+positives :: [Int] -> [Int]
638 
+positives l = [x | x <- l, x > 0]
639 
+
640 
+e5 = positives [2,-4,5,6,-5,3]
641 
+
642 
+-- Now the full quicksort function.
643 
+
644 
+quicksort :: [Char] -> [Char]  -- Use Char just to be different!
645 
+quicksort [] = []
646 
+quicksort (x:xs) = quicksort [y | y <- xs, y <= x] ++
647 
+                   [x] ++
648 
+                   quicksort [y | y <- xs, y > x]
649 
+
650 
+e6 = quicksort "Why use Haskell?"
651 
+
652 
+-- Now for some nested loops.  Each generator, <-, adds another level of
653 
+-- nesting to the loop.  Note that the variable introduced by each generator
654 
+-- can be used in each following generator; all variables can be used in the
655 
+-- generated expression:
656 
+
657 
+e7 :: [(Int,Int)]
658 
+e7 = [(x,y) | x <- [1..5], y <- [x..5]]
659 
+
660 
+-- Now let's add some guards: (the /= function is `not equal')
661 
+
662 
+e8 :: [(Int,Int)]
663 
+e8 = [(x,y) | x <- [1..7], x /= 5, y <- [x..8] , x*y /= 12]
664 
+
665 
+-- This is the same as the loop: (going to a psuedo Algol notation)
666 
+-- for x := 1 to 7 do
667 
+--  if x <> 5 then
668 
+--   for y := x to 8 do
669 
+--    if x*y <> 12
670 
+--     generate (x,y)
671 
+
672 
+-- Section 2.5.2  Strings
673 
+
674 
+e9 = "hello" ++ " world"
675 
+
676 
+-- Page 7    Sections 3, 3.1
677 
+
678 
+module Test(Bool) where
679 
+import Prelude hiding (map)
680 
+
681 
+-- Section 3   Functions
682 
+
683 
+add :: Int -> Int -> Int
684 
+add x y = x+y
685 
+
686 
+e1 :: Int
687 
+e1 = add 1 2
688 
+
689 
+-- This Int -> Int is the latter part of the signature of add:
690 
+-- add :: Int -> (Int -> Int)
691 
+
692 
+succ :: Int -> Int
693 
+succ = add 1
694 
+
695 
+e2 :: Int
696 
+e2 = succ 3
697 
+
698 
+map :: (a->b) -> [a] -> [b]
699 
+map f [] = []
700 
+map f (x:xs) = f x : (map f xs)
701 
+
702 
+e3 :: [Int]
703 
+e3 = map (add 1) [1,2,3]
704 
+-- This next definition is the equivalent to e3
705 
+e4 :: [Int]
706 
+e4 = map succ [1,2,3]
707 
+
708 
+-- Heres a more complex example.  Define flist to be a list of functions:
709 
+flist :: [Int -> Int]
710 
+flist = map add [1,2,3]
711 
+-- This returns a list of functions which add 1, 2, or 3 to their input.
712 
+-- Warning: Haskell should print flist as something like
713 
+--  [<<function>>,<<function>>,<<function>>]
714 
+
715 
+
716 
+-- Now, define a function which takes a function and returns its value
717 
+-- when applied to the constant 1:
718 
+applyTo1 :: (Int -> a) -> a
719 
+applyTo1 f = f 1
720 
+
721 
+e5 :: [Int]
722 
+e5 = map applyTo1 flist  -- Apply each function in flist to 1
723 
+
724 
+-- If you want to look at how the type inference works, figure out how
725 
+-- the signatures of map, applyTo1, and flist combine to yield [Int].
726 
+
727 
+-- Section 3.1  Lambda Abstractions
728 
+
729 
+-- The symbol \ is like `lambda' in lisp or scheme.
730 
+
731 
+-- Anonymous functions are written as \ arg1 arg2 ... argn -> body
732 
+-- Instead of naming every function, you can code it inline with this
733 
+-- notation:
734 
+
735 
+e6 = map (\f -> f 1) flist
736 
+
737 
+-- Be careful with the syntax here.  \x->\y->x+y parses as
738 
+--  \ x ->\ y -> x + y.  The ->\ is all one token.  Use spaces!!
739 
+
740 
+-- This is identical to e5 except that the applyTo1 function has no name.
741 
+
742 
+-- Function arguments on the left of an = are the same as lambda on the
743 
+-- right:
744 
+
745 
+add' = \x y -> x+y    -- identical to add
746 
+succ' = \x -> x+1     -- identical to succ
747 
+
748 
+-- As with ordinary function, the parameters to anonymous functions
749 
+-- can be patterns:
750 
+
751 
+e7 :: [Int]
752 
+e7 = map (\(x,y) -> x+y) [(1,2),(3,4),(5,6)]
753 
+
754 
+-- Functions defined by more than one equation, like map, cannot
755 
+-- be converted to anonymous lambda functions quite as easily - a case
756 
+-- statement is also required.  This is discussed later.
757 
+
758 
+-- Page 8   Sections 3.2, 3.2.1, 3.2.2
759 
+
760 
+module Test(Bool) where
761 
+
762 
+import Prelude hiding ((++),(.))
763 
+
764 
+-- Section 3.2  Infix operators
765 
+
766 
+-- Haskell has both identifiers, like x, and operators, like +.
767 
+-- These are just two different types of syntax for variables.
768 
+-- However, operators are by default used in infix notation.
769 
+
770 
+-- Briefly, identifiers begin with a letter and may have numbers, _, and '
771 
+-- in them:  x, xyz123, x'', xYz'_12a.  The case of the first letter
772 
+-- distinguishes variables from data constructors (or type variables from
773 
+-- type constructors).  An operator is a string of symbols, where
774 
+-- :!#$%&*+./<=>?@\^| are all symbols.  If the first character is : then
775 
+-- the operator is a data constructor; otherwise it is an ordinary
776 
+-- variable operator.  The - and ~ characters may start a symbol but cannot
777 
+-- be used after the first character.  This allows a*-b to parse as
778 
+-- a * - b instead of a *- b.
779 
+
780 
+-- Operators can be converted to identifiers by enclosing them in parens.
781 
+-- This is required in signature declarations.  Operators can be defined
782 
+-- as well as used in the infix style:
783 
+
784 
+(++) :: [a] -> [a] -> [a]
785 
+[] ++ y = y
786 
+(x:xs) ++ y = x : (xs ++ y)
787 
+
788 
+-- Table 2 (Page 54) of the report is invaluable for sorting out the
789 
+-- precedences of the many predefined infix operators.
790 
+
791 
+e1 = "Foo" ++ "Bar"
792 
+
793 
+-- This is the same function without operator syntax
794 
+appendList :: [a] -> [a] -> [a]
795 
+appendList [] y = y
796 
+appendList (x:xs) y = x : appendList xs y
797 
+
798 
+(.) :: (b -> c) -> (a -> b) -> (a -> c)
799 
+f . g = \x -> f (g x)
800 
+
801 
+add1 :: Int -> Int
802 
+add1 x = x+1
803 
+
804 
+e2 = (add1 . add1) 3
805 
+
806 
+-- Section 3.2.1  Sections
807 
+
808 
+-- Sections are a way of creating unary functions from infix binary
809 
+-- functions.  When a parenthesized expression starts or ends in an
810 
+-- operator, it is a section.  Another definition of add1:
811 
+
812 
+add1' :: Int -> Int
813 
+add1' = (+ 1)
814 
+
815 
+e3 = add1' 4
816 
+
817 
+-- Here are a few section examples:
818 
+
819 
+e4 = map (++ "abc") ["x","y","z"]
820 
+
821 
+e5 = map ("abc" ++) ["x","y","z"]
822 
+
823 
+
824 
+-- Section 3.2.2  Fixity Declarations
825 
+
826 
+-- We'll avoid any demonstration of fixity declarations.  The Prelude
827 
+-- contains numerous examples.
828 
+
829 
+-- Page 9  Sections 3.3, 3.4, 3.5
830 
+module Test(Bool) where
831 
+
832 
+import Prelude hiding (take,zip)
833 
+
834 
+-- Section 3.3  Functions are Non-strict
835 
+
836 
+-- Observing lazy evaluation can present difficulties.  The essential
837 
+-- question is `does an expression get evaluated?'.  While in theory using a
838 
+-- non-terminating computation is the way evaluation issues are examined,
839 
+-- we need a more practical approach.  The `error' function serves as
840 
+-- a bottom value.  Evaluating this function prints an error message and
841 
+-- halts execution.
842 
+
843 
+bot = error "Evaluating Bottom"
844 
+
845 
+e1 :: Bool    -- This can be any type at all!
846 
+e1 = bot      -- evaluate this and see what happens.
847 
+
848 
+const1 :: a -> Int
849 
+const1 x = 1
850 
+
851 
+e2 :: Int
852 
+e2 = const1 bot  -- The bottom is not needed and will thus not be evaluated.
853 
+
854 
+-- Section 3.4  "Infinite" Data Structures
855 
+
856 
+-- Data structures are constructed lazily.  A constructor like : will not
857 
+-- evaluate its arguments until they are demanded.  All demands arise from
858 
+-- the need to print the result of the computation -- components not needed
859 
+-- to compute the printed result will not be evaluated.
860 
+
861 
+list1 :: [Int]
862 
+list1 = (1:bot)
863 
+
864 
+e3 = head list1    -- doesnt evaluate bot
865 
+e4 = tail list1    -- does evaluate bot
866 
+
867 
+-- Some infinite data structures.  Don't print these!  If you do, you will
868 
+-- need to interrupt the system (C-c i) or kill the Haskell process.
869 
+
870 
+ones :: [Int]
871 
+ones = 1 : ones
872 
+
873 
+numsFrom :: Int -> [Int]
874 
+numsFrom n = n : numsFrom (n+1)
875 
+
876 
+-- An alternate numsFrom using series notation:
877 
+
878 
+numsFrom' :: Int -> [Int]
879 
+numsFrom' n = [n..]
880 
+
881 
+squares :: [Int]
882 
+squares = map (^2) (numsFrom 0)
883 
+
884 
+-- Before we start printing anything, we need a function to truncate these
885 
+-- infinite lists down to a more manageable size.  The `take' function
886 
+-- extracts the first k elements of a list:
887 
+
888 
+take :: Int -> [a] -> [a]
889 
+take 0 x      = []                 -- two base cases: k = 0
890 
+take k []     = []                 -- or the list is empty
891 
+take k (x:xs) = x : take (k-1) xs
892 
+
893 
+-- now some printable lists:
894 
+
895 
+e5 :: [Int]
896 
+e5 = take 5 ones
897 
+
898 
+e6 :: [Int]
899 
+e6 = take 5 (numsFrom 10)
900 
+
901 
+e7 :: [Int]
902 
+e7 = take 5 (numsFrom' 0)
903 
+
904 
+e8 :: [Int]
905 
+e8 = take 5 squares
906 
+
907 
+-- zip is a function which turns two lists into a list of 2 tuples.  If
908 
+-- the lists are of differing sizes, the result is as long as the
909 
+-- shortest list.
910 
+
911 
+zip (x:xs) (y:ys) = (x,y) : zip xs ys
912 
+zip xs ys = []   -- one of the lists is []
913 
+
914 
+e9 :: [(Int,Int)]
915 
+e9 = zip [1,2,3] [4,5,6]
916 
+
917 
+e10 :: [(Int,Int)]
918 
+e10 = zip [1,2,3] ones
919 
+
920 
+fib :: [Int]
921 
+fib = 1 : 1 : [x+y | (x,y) <- zip fib (tail fib)]
922 
+
923 
+e11 = take 5 fib
924 
+
925 
+-- Let's do this without the list comprehension:
926 
+
927 
+fib' :: [Int]
928 
+fib' = 1 : 1 : map (\(x,y) -> x+y) (zip fib (tail fib))
929 
+
930 
+-- This could be written even more cleanly using a map function which
931 
+-- maps a binary function over two lists at once.  This is in the
932 
+-- Prelude and is called zipWith.
933 
+
934 
+fib'' :: [Int]
935 
+fib'' = 1 : 1 : zipWith (+) fib (tail fib)
936 
+
937 
+-- For more examples using infinite structures look in the demo files
938 
+-- that come with Yale Haskell.  Both the pascal program and the
939 
+-- primes program use infinite lists.
940 
+
941 
+-- Section 3.5  The Error Function
942 
+
943 
+-- Too late - we already used it!
944 
+
945 
+
946 
+-- Page 10   Sections 4, 4.1, 4.2
947 
+
948 
+module Test(Bool) where
949 
+
950 
+import Prelude hiding (take,(^))
951 
+
952 
+-- Section 4  Case Expressions and Pattern Matching
953 
+
954 
+-- Now for details of pattern matching.  We use [Int] instead of [a]
955 
+-- since the only value of type [a] is [].
956 
+
957 
+contrived :: ([Int], Char, (Int, Float), String, Bool) -> Bool
958 
+contrived ([], 'b', (1, 2.0), "hi", True) = False
959 
+contrived x = True   -- add a second equation to avoid runtime errors
960 
+
961 
+e1 :: Bool
962 
+e1 = contrived ([], 'b', (1, 2.0), "hi", True)
963 
+e2 :: Bool
964 
+e2 = contrived ([1], 'b', (1, 2.0), "hi", True)
965 
+
966 
+-- Contrived just tests its input against a big constant.
967 
+
968 
+-- Linearity in pattern matching implies that patterns can only compare
969 
+-- values with constants.  The following is not valid Haskell:
970 
+
971 
+-- member x [] = False
972 
+-- member x (x:ys) = True      -- Invalid since x appears twice
973 
+-- member x (y:ys) = member x ys
974 
+
975 
+f :: [a] -> [a]
976 
+f s@(x:xs) = x:s
977 
+f _ = []
978 
+
979 
+e3 = f "abc"
980 
+
981 
+-- Another use of _:
982 
+
983 
+middle :: (a,b,c) -> b
984 
+middle (_,x,_) = x
985 
+
986 
+e4 :: Char
987 
+e4 = middle (True, 'a', "123")
988 
+
989 
+(^) :: Int -> Int -> Int
990 
+x ^ 0 = 1
991 
+x ^ (n+1) = x*(x^n)
992 
+
993 
+e5 :: Int
994 
+e5 = 3^3
995 
+e6 :: Int
996 
+e6 = 4^(-2)  -- Notice the behavior of the + pattern on this one
997 
+
998 
+-- Section 4.1  Pattern Matching Semantics
999 
+
1000 
+-- Here's an extended example to illustrate the left -> right, top -> bottom
1001 
+-- semantics of pattern matching.
1002 
+
1003 
+foo :: (Int,[Int],Int) -> Int
1004 
+foo (1,[2],3)   = 1
1005 
+foo (2,(3:_),3) = 2
1006 
+foo (1,_,3)     = 3
1007 
+foo _           = 4
1008 
+
1009 
+bot = error "Bottom Evaluated"
1010 
+
1011 
+e7 = foo (1,[],3)
1012 
+e8 = foo (1,bot,3)
1013 
+e9 = foo (1,1:bot,3)
1014 
+e10 = foo (2,bot,2)
1015 
+e11 = foo (3,bot,bot)
1016 
+
1017 
+-- Now add some guards:
1018 
+
1019 
+sign :: Int -> Int
1020 
+sign x | x > 0  = 1
1021 
+       | x == 0 = 0
1022 
+       | x < 0  = -1
1023 
+
1024 
+e12 = sign 3
1025 
+
1026 
+-- The last guard is often `True' to catch all other cases.  The identifier
1027 
+-- `otherwise' is defined as True for use in guards:
1028 
+
1029 
+max' :: Int -> Int -> Int
1030 
+max' x y | x > y      = x
1031 
+         | otherwise  = y
1032 
+
1033 
+-- Guards can refer to any variables bound by pattern matching.  When
1034 
+-- no guard is true, pattern matching resumes at the next equation.  Guards
1035 
+-- may also refer to values bound in an associated where declaration.
1036 
+
1037 
+
1038 
+inOrder :: [Int] -> Bool
1039 
+inOrder (x1:x2:xs) | x1 <= x2 = True
1040 
+inOrder _                     = False
1041 
+
1042 
+e13 = inOrder [1,2,3]
1043 
+e14 = inOrder [2,1]
1044 
+
1045 
+-- Section 4.2  An Example
1046 
+
1047 
+take :: Int -> [a] -> [a]
1048 
+take 0     _      = []
1049 
+take _     []     = []
1050 
+take (n+1) (x:xs) = x:take n xs
1051 
+
1052 
+take' :: Int -> [a] -> [a]
1053 
+take' _     []     = []
1054 
+take' 0     _      = []
1055 
+take' (n+1) (x:xs) = x:take' n xs
1056 
+
1057 
+e15, e16, e17, e18 :: [Int]
1058 
+e15 = take 0 bot
1059 
+e16 = take' 0 bot
1060 
+e17 = take bot []
1061 
+e18 = take' bot []
1062 
+
1063 
+-- Page 11    Sections 4.3, 4.4, 4.5, 4.6
1064 
+
1065 
+module Test(Bool) where
1066 
+
1067 
+-- import Prelude hiding (take,Request(..),Response(..)) -- Standard Haskell
1068 
+import Prelude hiding (take)    -- Y2.0-b4 only
1069 
+
1070 
+-- Section 4.3 Case Expressions
1071 
+
1072 
+-- The function take using a case statement instead of multiple equations
1073 
+
1074 
+take :: Int -> [a] -> [a]
1075 
+take m ys = case (m,ys) of
1076 
+             (0  ,_)    -> []
1077 
+             (_  ,[])   -> []
1078 
+             (n+1,x:xs) -> x : take n xs
1079 
+
1080 
+-- The function take using if then else.  We can also eliminate the n+k
1081 
+-- pattern just for fun.  The original version of take is much easier to read!
1082 
+
1083 
+take' :: Int -> [a] -> [a]
1084 
+take' m ys = if m == 0 then [] else
1085 
+              if null ys then [] else
1086 
+               if m > 0 then head ys : take (m-1) (tail ys)
1087 
+                else error "m < 0"
1088 
+
1089 
+-- Section 4.4  Lazy Patterns
1090 
+
1091 
+-- Before the client-server example, here is a contrived example of lazy
1092 
+-- patterns.  The first version will fail to pattern match whenever the
1093 
+-- the first argument is [].  The second version will always pattern
1094 
+-- match initially but x will fail if used when the list is [].
1095 
+
1096 
+nonlazy :: [Int] -> Bool -> [Int]
1097 
+nonlazy (x:xs) isNull  = if isNull then [] else [x]
1098 
+
1099 
+e1 = nonlazy [1,2] False
1100 
+e2 = nonlazy [] True
1101 
+e3 = nonlazy [] False
1102 
+
1103 
+-- This version will never fail the initial pattern match
1104 
+lazy :: [Int] -> Bool -> [Int]
1105 
+lazy ~(x:xs) isNull  = if isNull then [] else [x]
1106 
+
1107 
+e4 = lazy [1,2] False
1108 
+e5 = lazy [] True
1109 
+e6 = lazy [] False
1110 
+
1111 
+-- The server - client example is a little hard to demonstrate.  We'll avoid
1112 
+-- the initial version which loops.  Here is the version with irrefutable
1113 
+-- patterns.
1114 
+
1115 
+type Response = Int
1116 
+type Request = Int
1117 
+
1118 
+client :: Request -> [Response] -> [Request]
1119 
+client init ~(resp:resps) = init : client (next resp) resps
1120 
+
1121 
+server :: [Request] -> [Response]
1122 
+server (req : reqs) = process req : server reqs
1123 
+
1124 
+-- Next maps the response from the previous request onto the next request
1125 
+next :: Response -> Request
1126 
+next resp = resp
1127 
+
1128 
+-- Process maps a request to a response
1129 
+process :: Request -> Response
1130 
+process req = req+1
1131 
+
1132 
+requests :: [Request]
1133 
+requests = client 0 responses
1134 
+
1135 
+responses :: [Response]
1136 
+responses = server requests
1137 
+
1138 
+e7 = take 5 responses
1139 
+
1140 
+-- The lists of requests and responses are infinite - there is no need to
1141 
+-- check for [] in this program.  These lists correspond to streams in other
1142 
+-- languages.
1143 
+
1144 
+-- Here is fib again:
1145 
+
1146 
+fib :: [Int]
1147 
+fib@(1:tfib) = 1 : 1 : [ a+b | (a,b) <- zip fib tfib]
1148 
+
1149 
+e8 = take 10 fib
1150 
+
1151 
+-- Section 4.5  Lexical Scoping and Nested Forms
1152 
+
1153 
+-- One thing that is important to note is that the order of the
1154 
+-- definitions in a program, let expression, or where clauses is
1155 
+-- completely arbitrary.  Definitions can be arranged 'top down'
1156 
+-- or `bottom up' without changing the program.
1157 
+
1158 
+e9 = let y = 2 :: Float
1159 
+         f x = (x+y)/y
1160 
+     in f 1 + f 2
1161 
+
1162 
+f :: Int -> Int -> String
1163 
+f x y | y > z  = "y > x^2"
1164 
+      | y == z = "y = x^2"
1165 
+      | y < z  = "y < x^2"
1166 
+  where
1167 
+    z = x*x
1168 
+
1169 
+e10 = f 2 5
1170 
+e11 = f 2 4
1171 
+
1172 
+-- Section 4.6  Layout
1173 
+
1174 
+-- There's nothing much to demonstrate here.  We have been using layout all
1175 
+-- through the tutorial.  The main thing is to be careful line up the
1176 
+-- first character of each definition.  For example, if you
1177 
+-- change the indentation of the definition of f in e9 you will get a
1178 
+-- parse error.
1179 
+
1180 
+-- Page 12  Section 5
1181 
+module Test(Bool) where
1182 
+
1183 
+import Prelude hiding (elem)
1184 
+
1185 
+-- Section 5  Type Classes
1186 
+
1187 
+-- Names in the basic class structure of Haskell cannot be hidden (they are
1188 
+-- in PreludeCore) so we have to modify the names used in the tutorial.
1189 
+
1190 
+-- Here is a new Eq class:
1191 
+
1192 
+class Eq' a where
1193 
+  eq :: a -> a -> Bool
1194 
+
1195 
+-- Now we can define elem using eq from above:
1196 
+
1197 
+elem :: (Eq' a) => a -> [a] -> Bool
1198 
+x `elem` [] = False
1199 
+x `elem` (y:ys) = x `eq` y || x `elem` ys
1200 
+
1201 
+-- Before this is of any use, we need to admit some types to Eq'
1202 
+
1203 
+instance Eq' Int where
1204 
+ x `eq` y = abs (x-y) < 3  -- Let's make this `nearly equal' just for fun
1205 
+
1206 
+instance Eq' Float where
1207 
+ x `eq` y = abs (x-y) < 0.1
1208 
+
1209 
+list1 :: [Int]
1210 
+list1 = [1,5,9,23]
1211 
+
1212 
+list2 :: [Float]
1213 
+list2 = [0.2,5.6,33,12.34]
1214 
+
1215 
+e1 = 2 `elem` list1
1216 
+e2 = 100 `elem` list1
1217 
+e3 = 0.22 `elem` list2
1218 
+
1219 
+-- Watch out!  Integers in Haskell are overloaded - without a type signature
1220 
+-- to designate an integer as an Int, expressions like 3 `eq` 3 will be
1221 
+-- ambiguous.  See 5.5.4 about this problem.
1222 
+
1223 
+-- Now to add the tree type:
1224 
+
1225 
+data Tree a = Leaf a | Branch (Tree a) (Tree a)   deriving Text
1226 
+
1227 
+instance (Eq' a) => Eq' (Tree a) where
1228 
+  (Leaf a)       `eq` (Leaf b)       = a `eq` b
1229 
+  (Branch l1 r1) `eq` (Branch l2 r2) =  (l1 `eq` l2) && (r1 `eq` r2)
1230 
+  _              `eq` _              = False
1231 
+
1232 
+tree1,tree2 :: Tree Int
1233 
+tree1 = Branch (Leaf 1) (Leaf 2)
1234 
+tree2 = Branch (Leaf 2) (Leaf 1)
1235 
+
1236 
+e4 = tree1 `eq` tree2
1237 
+
1238 
+-- Now make a new class with Eq' as a super class:
1239 
+
1240 
+class (Eq' a) => Ord' a where
1241 
+ lt,le :: a -> a -> Bool          -- lt and le are operators in Ord'
1242 
+ x `le` y = x `eq` y || x `lt` y  -- This is a default for le
1243 
+
1244 
+-- The typing of lt & le is
1245 
+--  le,lt :: (Ord' a) => a -> a -> Bool
1246 
+-- This is identical to
1247 
+--  le,lt :: (Eq' a,Ord' a) => a -> a -> Bool
1248 
+
1249 
+-- Make Int an instance of Ord
1250 
+instance Ord' Int where
1251 
+ x `lt` y = x < y+1
1252 
+
1253 
+i :: Int  -- Avoid ambiguity
1254 
+i = 3
1255 
+e5 :: Bool
1256 
+e5 = i `lt` i
1257 
+
1258 
+-- Some constraints on instance declarations:
1259 
+--   A program can never have more than one instance declaration for
1260 
+--     a given combination of data type and class.
1261 
+--   If a type is declared to be a member of a class, it must also be
1262 
+--     declared in all superclasses of that class.
1263 
+--   An instance declaration does not need to supply a method for every
1264 
+--     operator in the class.  When a method is not supplied in an
1265 
+--     instance declaration and no default is present in the class
1266 
+--     declaration, a runtime error occurs if the method is invoked.
1267 
+--   You must supply the correct context for an instance declaration --
1268 
+--     this context is not inferred automatically.
1269 
+
1270 
+-- Section 5.1  Equality and Ordered Classes
1271 
+-- Section 5.2  Enumeration and Index Classes
1272 
+
1273 
+-- No examples are provided for 5.1 or 5.2.  The standard Prelude contains
1274 
+-- many instance declarations which illustrate the Eq, Ord, and Enum classes.
1275 
+
1276 
+-- Page 13    Section 5.3
1277 
+
1278 
+module Test(Bool) where
1279 
+
1280 
+-- Section 5.3   Text and Binary Classes
1281 
+
1282 
+-- This is the slow showTree.  The `show' function is part of the
1283 
+-- Text class and works with all the built-in types.  The context `Text a'
1284 
+-- arises from the call to show for leaf values.
1285 
+
1286 
+data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text
1287 
+
1288 
+showTree :: (Text a) => Tree a -> String
1289 
+showTree (Leaf x)    = show x
1290 
+showTree (Branch l r) = "<" ++ showTree l ++ "|" ++ showTree r ++ ">"
1291 
+
1292 
+tree1 :: Tree Int
1293 
+tree1 = Branch (Leaf 1) (Branch (Leaf 3) (Leaf 6))
1294 
+
1295 
+e1 = showTree tree1
1296 
+
1297 
+-- Now the improved showTree; shows is already defined for all
1298 
+-- built in types.
1299 
+
1300 
+showsTree  :: Text a => Tree a -> String -> String
1301 
+showsTree (Leaf x) s = shows x s
1302 
+showsTree (Branch l r) s = '<' : showsTree l ('|' : showsTree r ('>' : s))
1303 
+
1304 
+e2 = showsTree tree1 ""
1305 
+
1306 
+-- The final polished version.  ShowS is predefined in the Prelude so we
1307 
+-- don't need it here.
1308 
+
1309 
+
1310 
+showsTree'  :: Text a => Tree a -> ShowS
1311 
+showsTree' (Leaf x) = shows x
1312 
+showsTree' (Branch l r) = ('<' :) . showsTree' l . ('|' :) .
1313 
+                          showsTree' r . ('>' :)
1314 
+
1315 
+e3 = showsTree' tree1 ""
1316 
+
1317 
+
1318 
+-- Page 14    This page break is just to keep recompilation from getting too
1319 
+--            long.  The compiler takes a little longer to compile this
1320 
+--            page than other pages.
1321 
+
1322 
+module Test(Bool) where
1323 
+
1324 
+data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text
1325 
+
1326 
+-- Now for the reading function.  Again, ReadS is predefined and reads works
1327 
+-- for all built-in types.  The generators in the list comprehensions are
1328 
+-- patterns: p <- l binds pattern p to successive elements of l which match
1329 
+-- p.  Elements not matching p are skipped.
1330 
+
1331 
+readsTree :: (Text a) => ReadS (Tree a)
1332 
+readsTree ('<':s)  = [(Branch l r, u) | (l, '|':t) <- readsTree s,
1333 
+                                        (r, '>':u) <- readsTree t ]
1334 
+readsTree s        = [(Leaf x,t)      | (x,t) <- reads s]
1335 
+
1336 
+e4 :: [(Int,String)]
1337 
+e4 = reads "5 golden rings"
1338 
+
1339 
+e5 :: [(Tree Int,String)]
1340 
+e5 = readsTree "<1|<2|3>>"
1341 
+e6 :: [(Tree Int,String)]
1342 
+e6 = readsTree "<1|2"
1343 
+e7 :: [(Tree Int,String)]
1344 
+e7 = readsTree "<1|<<2|3>|<4|5>>> junk at end"
1345 
+
1346 
+-- Before we do the next readTree, let's play with the lex function.
1347 
+
1348 
+e8 :: [(String,String)]
1349 
+e8 = lex "foo bar bletch"
1350 
+
1351 
+-- Here's a function to completely lex a string.  This does not handle
1352 
+-- lexical ambiguity - lex would return more than one possible lexeme
1353 
+-- when an ambiguity is encountered and the patterns used here would not
1354 
+-- match.
1355 
+
1356 
+lexAll :: String -> [String]
1357 
+lexAll s = case lex s of
1358 
+            [("",_)] -> []  -- lex returns an empty token if none is found
1359 
+            [(token,rest)] -> token : lexAll rest
1360 
+
1361 
+e9 = lexAll "lexAll :: String -> [String]"
1362 
+e10 = lexAll "<1|<a|3>>"
1363 
+
1364 
+-- Finally, the `hard core' reader.  This is not sensitive to
1365 
+-- white space as were the previous versions.
1366 
+
1367 
+
1368 
+readsTree' :: (Text a) => ReadS (Tree a)
1369 
+readsTree' s = [(Branch l r, x) | ("<", t) <- lex s,
1370 
+				  (l, u)   <- readsTree' t,
1371 
+                                  ("|", v) <- lex u,
1372 
+                                  (r, w)   <- readsTree' v,
1373 
+				  (">", x) <- lex w ]
1374 
+                ++
1375 
+                [(Leaf x, t)    | (x, t) <- reads s]
1376 
+
1377 
+-- When testing this program, you must make sure the input conforms to
1378 
+-- Haskell lexical syntax.  If you remove spaces between | and < or
1379 
+-- > and > they will lex as a single token.
1380 
+
1381 
+e11 :: [(Tree Int,String)]
1382 
+e11 = readsTree' "<1 | <2 | 3> >"
1383 
+e12 :: [(Tree Bool,String)]
1384 
+e12 = readsTree' "<True|False>"
1385 
+
1386 
+-- Finally, here is a simple version of read for trees only:
1387 
+
1388 
+read' :: (Text a) => String -> (Tree a)
1389 
+read' s = case (readsTree' s) of
1390 
+           [(tree,"")] -> tree   -- Only one parse, no junk at end
1391 
+           []          -> error "Couldn't parse tree"
1392 
+           [_]         -> error "Crud after the tree"  -- unread chars at end
1393 
+           _           -> error "Ambiguous parse of tree"
1394 
+
1395 
+e13 :: Tree Int
1396 
+e13 = read' "foo"
1397 
+e14 :: Tree Int
1398 
+e14 = read' "< 1 | < 2 | 3 > >"
1399 
+e15 :: Tree Int
1400 
+e15 = read' "3 xxx"
1401 
+
1402 
+-- Page 15  Section 5.4
1403 
+
1404 
+module Test(Bool) where
1405 
+
1406 
+-- Section 5.4  Derived Instances
1407 
+
1408 
+-- We have actually been using the derived Text instances all along for
1409 
+-- printing out trees and other structures we have defined.  The code
1410 
+-- in the tutorial for the Eq and Ord instance of Tree is created
1411 
+-- implicitly by the deriving clause so there is no need to write it
1412 
+-- here.
1413 
+
1414 
+data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving (Eq,Ord,Text)
1415 
+
1416 
+-- Now we can fire up both Eq and Ord functions for trees:
1417 
+
1418 
+tree1, tree2, tree3, tree4 :: Tree Int
1419 
+tree1 = Branch (Leaf 1) (Leaf 3)
1420 
+tree2 = Branch (Leaf 1) (Leaf 5)
1421 
+tree3 = Leaf 4
1422 
+tree4 = Branch (Branch (Leaf 4) (Leaf 3)) (Leaf 5)
1423 
+
1424 
+e1 = tree1 == tree1
1425 
+e2 = tree1 == tree2
1426 
+e3 = tree1 < tree2
1427 
+
1428 
+quicksort :: Ord a => [a] -> [a]
1429 
+quicksort [] = []
1430 
+quicksort (x:xs) = quicksort [y | y <- xs, y <= x] ++
1431 
+                   [x] ++
1432 
+                   quicksort [y | y <- xs, y > x]
1433 
+
1434 
+e4 = quicksort [tree1,tree2,tree3,tree4]
1435 
+
1436 
+-- Now for Enum:
1437 
+
1438 
+data Day = Sunday | Monday | Tuesday | Wednesday | Thursday |
1439 
+           Friday | Saturday     deriving (Text,Eq,Ord,Enum)
1440 
+
1441 
+e5 = quicksort [Monday,Saturday,Friday,Sunday]
1442 
+e6 = [Wednesday .. Friday]
1443 
+e7 = [Monday, Wednesday ..]
1444 
+e8 = [Saturday, Friday ..]
1445 
+
1446 
+
1447 
+-- Page 16  Sections 5.5, 5.5.1, 5.5.2, 5.5.3
1448 
+
1449 
+module Test(Bool) where
1450 
+
1451 
+-- Section 5.5  Numbers
1452 
+-- Section 5.5.1  Numeric Class Structure
1453 
+-- Section 5.5.2  Constructed Numbers
1454 
+
1455 
+-- Here's a brief summary of Haskell numeric classes.
1456 
+
1457 
+-- Class Num
1458 
+--   Most general numeric class.  Has addition, subtraction, multiplication.
1459 
+--   Integers can be coerced to any instance of Num with fromInteger.
1460 
+--   All integer constants are in this class.
1461 
+-- Instances: Int, Integer, Float, Double, Ratio a, Complex a
1462 
+
1463 
+-- Class Real
1464 
+--   This class contains ordered numbers which can be converted to
1465 
+--   rationals.
1466 
+-- Instances: Int, Integer, Float, Double, Ratio a
1467 
+
1468 
+-- Class Integral
1469 
+--   This class deals with integer division.  All values in Integral can
1470 
+--   be mapped onto Integer.
1471 
+-- Instances: Int, Integer
1472 
+
1473 
+-- Class Fractional
1474 
+--   These are numbers which can be divided.  Any rational number can
1475 
+--   be converted to a fractional.  Floating point constants are in
1476 
+--   this class: 1.2 would be 12/10.
1477 
+-- Instances: Float, Double, Ratio a
1478 
+
1479 
+-- Class Floating
1480 
+--   This class contains all the standard floating point functions such
1481 
+--   as sqrt and sin.
1482 
+-- Instances: Float, Double, Complex a
1483 
+
1484 
+-- Class RealFrac
1485 
+--   These values can be rounded to integers and approximated by rationals.
1486 
+-- Instances: Float, Double, Ratio a
1487 
+
1488 
+-- Class RealFloat
1489 
+--   These are floating point numbers constructed from a fixed precision
1490 
+--   mantissa and exponent.
1491 
+-- Instances: Float, Double
1492 
+
1493 
+-- There are only a few sensible combinations of the constructed numerics
1494 
+-- with built-in types:
1495 
+--  Ratio Integer (same as Rational): arbitrary precision rationals
1496 
+--  Ratio Int: limited precision rationals
1497 
+--  Complex Float: complex numbers with standard precision components
1498 
+--  Complex Double: complex numbers with double precision components
1499 
+
1500 
+
1501 
+-- The following function works for arbitrary numerics:
1502 
+
1503 
+fact :: (Num a) => a -> a
1504 
+fact 0 = 1
1505 
+fact n = n*(fact (n-1))
1506 
+
1507 
+-- Note the behavior when applied to different types of numbers:
1508 
+
1509 
+e1 :: Int
1510 
+e1 = fact 6
1511 
+e2 :: Int
1512 
+e2 = fact 20   -- Yale Haskell may not handle overflow gracefully!
1513 
+e3 :: Integer
1514 
+e3 = fact 20
1515 
+e4 :: Rational
1516 
+e4 = fact 6
1517 
+e5 :: Float
1518 
+e5 = fact 6
1519 
+e6 :: Complex Float
1520 
+e6 = fact 6
1521 
+
1522 
+-- Be careful: values like `fact 1.5' will loop!
1523 
+
1524 
+-- As a practical matter, Int operations are much faster than Integer
1525 
+-- operations.  Also, overloaded functions can be much slower than non-
1526 
+-- overloaded functions.  Giving a function like fact a precise typing:
1527 
+
1528 
+-- fact :: Int -> Int
1529 
+
1530 
+-- will yield much faster code.
1531 
+
1532 
+-- In general, numeric expressions work as expected.  Literals are
1533 
+-- a little tricky - they are coerced to the appropriate value.  A
1534 
+-- constant like 1 can be used as ANY numeric type.
1535 
+
1536 
+e7 :: Float
1537 
+e7 = sqrt 2
1538 
+e8 :: Rational
1539 
+e8 = ((4%5) * (1%2)) / (3%4)
1540 
+e9 :: Rational
1541 
+e9 = 2.2 * (3%11) - 1
1542 
+e10 :: Complex Float
1543 
+e10 = (2 * (3:+3)) / (1.1:+2.0 - 1)
1544 
+e11 :: Complex Float
1545 
+e11 = sqrt (-1)
1546 
+e12 :: Integer
1547 
+e12 = numerator (4%2)
1548 
+e13 :: Complex Float
1549 
+e13 = conjugate (4:+5.2)
1550 
+
1551 
+-- A function using pattern matching on complex numbers:
1552 
+
1553 
+mag :: (RealFloat a) => Complex a -> a
1554 
+mag (a:+b) = sqrt (a^2 + b^2)
1555 
+
1556 
+e14 :: Float
1557 
+e14 = mag (1:+1)
1558 
+
1559 
+-- Section 5.5.3  Numeric Coercions and Overloaded Literals
1560 
+
1561 
+-- The Haskell type system does NOT implicitly coerce values between
1562 
+-- the different numeric types!  Although overloaded constants are
1563 
+-- coerced when the overloading is resolved, no implicit coercion goes
1564 
+-- on when values of different types are mixed.  For example:
1565 
+
1566 
+f :: Float
1567 
+f = 1.1
1568 
+i1 :: Int
1569 
+i1 = 1
1570 
+i2 :: Integer
1571 
+i2 = 2
1572 
+
1573 
+-- All of these expressions would result in a type error (try them!):
1574 
+
1575 
+-- g = i1 + f
1576 
+-- h = i1 + i2
1577 
+-- i3 :: Int
1578 
+-- i3 = i2
1579 
+
1580 
+-- Appropriate coercions must be introduced by the user to allow
1581 
+-- the mixing of types in arithmetic expressions.
1582 
+
1583 
+e15 :: Float
1584 
+e15 = f + fromIntegral i1
1585 
+e16 :: Integer
1586 
+e16 = fromIntegral i1 + i2
1587 
+e17 :: Int
1588 
+e17 = i1 + fromInteger i2  -- fromIntegral would have worked too.
1589 
+
1590 
+-- Page 17  Section 5.5.4
1591 
+module Test(Bool) where
1592 
+
1593 
+-- Section 5.5.4  Default Numeric Types
1594 
+
1595 
+-- Ambiguous contexts arise frequently in numeric expressions.  When an
1596 
+-- expression which produces a value with a general type, such as
1597 
+-- `1' (same as `fromInteger 1'; the type is (Num a) => a), with
1598 
+-- another expression which `consumes' the type, such as `show' or
1599 
+-- `toInteger', ambiguity arises.  This ambiguity can be resolved
1600 
+-- using expression type signatures, but this gets tedious fast!
1601 
+-- Assigning a type to the top level of an ambiguous expression does
1602 
+-- not help: the ambiguity does not propagate to the top level.
1603 
+
1604 
+e1 :: String -- This type does not influence the type of the argument to show
1605 
+e1 = show 1  -- Does this mean to show an Int or a Float or ...
1606 
+e2 :: String
1607 
+e2 = show (1 :: Float)
1608 
+e3 :: String
1609 
+e3 = show (1 :: Complex Float)
1610 
+
1611 
+-- The reason the first example works is that ambiguous numeric types are
1612 
+-- resolved using defaults.  The defaults in effect here are Int and
1613 
+-- Double.  Since Int `fits' in the expression for e1, Int is used.
1614 
+-- When Int is not valid (due to other context constraints), Double
1615 
+-- will be tried.
1616 
+
1617 
+-- This function defaults the type of the 2's to be Int
1618 
+
1619 
+rms :: (Floating a) => a -> a -> a
1620 
+rms x y = sqrt ((x^2 + y^2) * 0.5)
1621 
+
1622 
+-- The C-c e evaluation used to the Haskell system also makes use of
1623 
+-- defaulting.  When you type an expression, the system creates a
1624 
+-- simple program to print the value of the expression using a function
1625 
+-- like show.  If no type signature for the printed expression is given,
1626 
+-- defaulting may occur.
1627 
+
1628 
+-- One of the reasons for adding type signatures throughout these examples
1629 
+-- is to avoid unexpected defaulting.  Many of the top level signatures are
1630 
+-- required to avoid ambiguity.
1631 
+
1632 
+-- Defaulting can lead to overflow problems when values exceed Int limits.
1633 
+-- Evaluate a very large integer without a type signature to observe this
1634 
+-- (unfortunately this may cause a core dump or other unpleasantness).
1635 
+
1636 
+-- Notice that defaulting applies only to numeric classes.  The
1637 
+--   show (read "xyz")                       -- Try this if you want!
1638 
+-- example uses only class Text so no defaulting occurs.
1639 
+
1640 
+-- Ambiguity also arises with polymorphic types.  As discussed previously,
1641 
+-- expressions like [] have a similar problem.
1642 
+
1643 
+-- e4 = []   -- Won't work since [] has type [a] and `a' is not known.
1644 
+
1645 
+-- Note the difference: even though the lists have no components, the type
1646 
+-- of component makes a difference in printing.
1647 
+
1648 
+e5 = ([] :: [Int])
1649 
+e6 = ([] :: [Char])
1650 
+
1651 
+-- Page 18   Sections 6, 6.1, 6.2
1652 
+
1653 
+-- Section 6  Modules
1654 
+
1655 
+module Tree ( Tree(Leaf,Branch), fringe ) where
1656 
+--            Tree(..) would work also
1657 
+
1658 
+data Tree a = Leaf a | Branch (Tree a) (Tree a)   deriving Text
1659 
+
1660 
+fringe :: Tree a -> [a]
1661 
+fringe (Leaf x)             = [x]
1662 
+fringe (Branch left right)  = fringe left ++ fringe right
1663 
+
1664 
+-- The Emacs interface to Haskell performs evaluation within the
1665 
+-- module containing the cursor.  To evaluate e1 you must place the
1666 
+-- cursor in module Main.
1667 
+
1668 
+module Main (Tree) where
1669 
+import Tree ( Tree(Leaf, Branch), fringe)
1670 
+-- import Tree      -- this would be the same thing
1671 
+e1 :: [Int]
1672 
+e1 = fringe (Branch (Leaf 1) (Leaf 2))
1673 
+
1674 
+-- This interactive Haskell environment can evaluate expressions in
1675 
+-- any module.  The use of module Main is optional.
1676 
+
1677 
+-- Section 6.1  Original Names and Renaming
1678 
+
1679 
+module Renamed where
1680 
+import Tree ( Tree(Leaf,Branch), fringe)
1681 
+    renaming (Leaf to Root, Branch to Twig)
1682 
+
1683 
+e2 :: Tree Int
1684 
+e2 = Twig (Root 1) (Root 2)  -- Printing always uses the original names
1685 
+
1686 
+-- Section 6.2  Interfaces and Implementations
1687 
+
1688 
+-- Yale Haskell allows separate compilation of modules using
1689 
+-- unit files.  These are described in the user's guide.
1690 
+
1691 
+
1692 
+-- Page 19  Sections 6.3, 6.4
1693 
+
1694 
+-- Section 6.3  Abstract Data Types
1695 
+
1696 
+-- Since TreeADT does not import Tree it can use the name Tree without
1697 
+-- any conflict.  Each module has its own separate namespace.
1698 
+
1699 
+module TreeADT (Tree, leaf, branch, cell, left,
1700 
+               right, isLeaf) where
1701 
+
1702 
+data Tree a = Leaf a | Branch (Tree a) (Tree a)    deriving Text
1703 
+
1704 
+leaf = Leaf
1705 
+branch = Branch
1706 
+cell (Leaf a) = a
1707 
+left (Branch l r) = l
1708 
+right (Branch l r) = r
1709 
+isLeaf (Leaf _) = True
1710 
+isLeaf _        = False
1711 
+
1712 
+module Test where
1713 
+import TreeADT
1714 
+
1715 
+-- Since the constructors for type Tree are hidden, pattern matching
1716 
+-- cannot be used.
1717 
+
1718 
+fringe :: Tree a -> [a]
1719 
+fringe x = if isLeaf x then [cell x]
1720 
+                       else fringe (left x) ++ fringe (right x)
1721 
+
1722 
+e1 :: [Int]
1723 
+e1 = fringe (branch (branch (leaf 3) (leaf 2)) (leaf 1))
1724 
+
1725 
+-- Section 6.4
1726 
+
1727 
+
1728 
+-- Page 20  Sections 7, 7.1, 7.2, 7.3
1729 
+
1730 
+-- Section 7  Typing Pitfalls
1731 
+
1732 
+-- Section 7.1  Let-Bound Polymorphism
1733 
+
1734 
+module Test(e2) where
1735 
+
1736 
+-- f g = (g 'a',g [])    -- This won't typecheck.
1737 
+
1738 
+-- Section 7.2  Overloaded Numerals
1739 
+
1740 
+-- Overloaded numerics were covered previously - here is one more example.
1741 
+-- sum is a prelude function which sums the elements of a list.
1742 
+
1743 
+average :: (Fractional a) => [a] -> a
1744 
+average xs   = sum xs / fromIntegral (length xs)
1745 
+
1746 
+e1 :: Float   -- Note that e1 would default to Double instead of Int -
1747 
+              -- this is due to the Fractional context.
1748 
+e1 = average [1,2,3]
1749 
+
1750 
+-- Section 7.3  The Monomorphism Restriction
1751 
+
1752 
+-- The monomorphism restriction is usually encountered when functions
1753 
+-- are defined without parameters.  If you remove the signature for sum'
1754 
+-- the monomorphism restriction will apply.
1755 
+-- This will generate an error if either:
1756 
+--   sum' is added to the module export list at the start of this section
1757 
+--   both sumInt and sumFloat remain in the program.
1758 
+-- If sum' is not exported and all uses of sum' have the same overloading,
1759 
+-- there is no type error.
1760 
+
1761 
+sum' :: (Num a) => [a] -> a
1762 
+sum' = foldl (+) 0         -- foldl reduces a list with a binary function
1763 
+                           -- 0 is the initial value.
1764 
+
1765 
+sumInt :: Int
1766 
+sumInt = sum' [1,2,3]
1767 
+
1768 
+sumFloat :: Float
1769 
+sumFloat = sum' [1,2,3]
1770 
+
1771 
+-- If you use overloaded constants you also may encounter monomorphism:
1772 
+
1773 
+x :: Num a => a
1774 
+x = 1    -- The type of x is Num a => a
1775 
+y :: Int
1776 
+y = x            -- Uses x as an Int
1777 
+z :: Integer
1778 
+z = x          -- Uses x as an Integer.  A monomorphism will occur of the
1779 
+               -- signature for x is removed.
1780 
+                 -- comments to see an error.
1781 
+
1782 
+-- Finally, if a value is exported it must not be overloaded unless bound
1783 
+-- by a function binding.  e2 is the only value exported.
1784 
+
1785 
+e2 :: Int  -- Remove this to get an error.  Without this line e1 will
1786 
+           -- be overloaded.
1787 
+e2 = 1
1788 
+
1789 
+-- To prevent annoying error messages about exported monomorphic variables,
1790 
+-- most modules in this tutorial do not implicitly export everything - they
1791 
+-- only export a single value, Bool, which was chosen to keep the export
1792 
+-- list non-empty (a syntactic restriction!).  In Haskell systems without
1793 
+-- the evaluator used here, a module which does not export any names would
1794 
+-- be useless.
1795 
+
1796 
+-- module Test where  -- this would export everything in the module
1797 
+-- module Test(Bool)  -- exports only Bool
1798 
+-- module Test()      -- this is what we really want to do but is not valid.
1799 
+
1800 
+-- Page 21  Sections 8, 8.1
1801 
+
1802 
+module Test(Bool) where
1803 
+
1804 
+-- Section 8  Input/Output
1805 
+-- Section 8.1  Introduction to Continuations
1806 
+
1807 
+-- Simplify f here to be 1/x.
1808 
+
1809 
+data Maybe a  = Ok a | Oops String deriving Text
1810 
+
1811 
+f :: Float -> Maybe Float
1812 
+f x = if x == 0 then Oops "Divide by 0" else Ok (1/x)
1813 
+
1814 
+-- g is a `safe' call to x.  The call to error could be replaced by
1815 
+-- some explicit value like Oops msg -> 0.
1816 
+
1817 
+g x = case f x of
1818 
+        Ok y -> y
1819 
+        Oops msg -> error msg
1820 
+
1821 
+e1 = f 0
1822 
+e2 = g 0
1823 
+e3 = g 1
1824 
+
1825 
+-- Here is the same example using continuations:
1826 
+
1827 
+f' :: Float -> (String -> Float) -> Float
1828 
+f' x c = if x == 0 then c "Divide by 0"
1829 
+                   else 1/x
1830 
+
1831 
+g' x = f' x error   -- calls error on divide by 0
1832 
+g'' x = f' x (\s -> 0) -- returns 0 on divide by 0
1833 
+
1834 
+e4 = g' 0
1835 
+e5 = g'' 0
1836 
+
1837 
+-- Page 22  Sections 8.2, 8.3
1838 
+
1839 
+module Test where
1840 
+
1841 
+-- Section 8.2  Continuation Based I/O
1842 
+
1843 
+-- We will skip the program fragments at the start of this section and
1844 
+-- move directly to the writeFile / readFile example.
1845 
+
1846 
+-- Before we can use Haskell I/O, we need to introduce a new Emacs command:
1847 
+-- C-c r.  This command runs a dialogue instead of printing a value.
1848 
+-- (Actually C-c e creates a dialogue on the fly and runs it in the same
1849 
+-- manner as C-c r).  As with C-c e you are prompted for an expression.
1850 
+-- In this case, the expression must be of type Dialogue and it is
1851 
+-- executed by the I/O system.  We use d1,d2,... for dialogues to be
1852 
+-- executed by C-c r.
1853 
+
1854 
+-- We make the file name a parameter to allow for easier testing.
1855 
+-- Don't expect much error handling in exit.
1856 
+
1857 
+s1 = "This is a test of Haskell"
1858 
+
1859 
+main file = writeFile file s1 exit (
1860 
+            readFile  file    exit (\s2 ->
1861 
+            appendChan stdout (if s1==s2 then "contents match"
1862 
+                                         else "something intervened!") exit
1863 
+            done))
1864 
+
1865 
+d1,d2 :: Dialogue
1866 
+d1 = main "/tmp/ReadMe"
1867 
+d2 = main "/dev/null" -- this will read back as the empty string
1868 
+
1869 
+-- A simple IO program using $ for readability: ($ is defined in the Prelude)
1870 
+
1871 
+d3 = appendChan "stdout" "Type something: " exit $
1872 
+     readChan "stdin" exit $ \s2 ->
1873 
+     appendChan "stdout" ("You typed " ++ head (lines s2)) exit $
1874 
+     done
1875 
+
1876 
+-- This program suffers from a strictness problem.  Strictness deals
1877 
+-- with when things get evaluated.  In this program, the input is not
1878 
+-- needed until after the "You typed " is printed.  Fixing this would
1879 
+-- require some operation to look at the string before the final
1880 
+-- appendChan.  Here is one possible fix:
1881 
+
1882 
+d4 = appendChan "stdout" "Type something: " exit $
1883 
+     readChan "stdin" exit $ \s2 ->
1884 
+     let str = head (lines s2) in
1885 
+      if str == str then  -- This evaluates str
1886 
+       appendChan "stdout" ("You typed " ++ head (lines s2)) exit $
1887 
+       done
1888 
+      else done
1889 
+
1890 
+
1891 
+-- Section 8.3  Terminal I/O
1892 
+
1893 
+-- Since this programming environment runs under Emacs, the issue of
1894 
+-- echoing does not really apply.  However, the synchronization between
1895 
+-- input and output can be seen in the following example.  Since the input
1896 
+-- comes a line at a time, the X's come in groups between input lines.
1897 
+-- The cursor will move into the haskell dialogue buffer when the program
1898 
+-- requests input.  Use a ^D to stop the program (^Q^D actually).  [Warning:
1899 
+-- some brain damaged lisps stop not only the Haskell program but also
1900 
+-- the entire compiler on ^D]
1901 
+
1902 
+d5 = readChan stdin exit processInput where
1903 
+      processInput s = loop 1 s
1904 
+      loop n [] = done
1905 
+      loop n (x:xs) | n == 10  = appendChan stdout "X" exit (loop 1 xs)
1906 
+                    | True     = loop (n+1) xs
1907 
+
1908 
+-- For more examples using the I/O system look in the demo programs
1909 
+-- that come with haskell (in $HASKELL/progs/demo) and the report.
1910 
+
1911 
+-- Page 23  Sections 9, 9.1, 9.2
1912 
+
1913 
+module Test(Bool) where
1914 
+
1915 
+-- Section 9  Arrays
1916 
+-- Section 9.1  Index Types
1917 
+
1918 
+-- Arrays are built on the class Ix.  Here are some quick examples of Ix:
1919 
+
1920 
+e1 :: [Int]
1921 
+e1 = range (0,4)
1922 
+e2 :: Int
1923 
+e2 = index (0,4) 2
1924 
+low,high :: (Int,Int)
1925 
+low = (1,1)
1926 
+high = (3,4)
1927 
+e3 = range (low,high)
1928 
+e4 = index (low,high) (3,2)
1929 
+e5 = inRange (low,high) (4,3)
1930 
+
1931 
+-- Section 9.2  Array Creation
1932 
+
1933 
+squares :: Array Int Int
1934 
+squares = array (1,100) [i := i*i | i <- [1..100]]
1935 
+
1936 
+-- We can also parameterize this a little:
1937 
+
1938 
+squares' :: Int -> Array Int Int
1939 
+squares' n = array (1,n) [i := i*i | i <- [1..n]]
1940 
+
1941 
+e6 :: Int
1942 
+e6 = squares!6
1943 
+e7 :: (Int,Int)
1944 
+e7 = bounds squares
1945 
+e8 :: Array Int Int
1946 
+e8 = squares' 10
1947 
+
1948 
+-- Here is a function which corresponds to `take' for lists.  It takes
1949 
+-- an arbitrary slice out of an array.
1950 
+
1951 
+atake :: (Ix a) => Array a b -> (a,a) -> Array a b
1952 
+atake a (l,u) | inRange (bounds a) l && inRange (bounds a) u =
1953 
+                   array (l,u) [i := a!i | i <- range (l,u)]
1954 
+              | otherwise = error "Subarray out of range"
1955 
+
1956 
+e9 = atake squares (4,8)
1957 
+
1958 
+mkArray :: Ix a => (a -> b) -> (a,a) -> Array a b
1959 
+mkArray f bnds = array bnds [i := f i | i <- range bnds]
1960 
+
1961 
+e10 :: Array Int Int
1962 
+e10 = mkArray (\i -> i*i) (1,10)
1963 
+
1964 
+fibs :: Int -> Array Int Int
1965 
+fibs n = a where
1966 
+            a = array (0,n) ([0 := 1, 1 := 1] ++
1967 
+                             [i := a!(i-1) + a!(i-2) | i <- [2..n]])
1968 
+
1969 
+e11 = atake (fibs 50) (3,10)
1970 
+
1971 
+wavefront :: Int -> Array (Int,Int) Int
1972 
+wavefront n = a where
1973 
+                a = array ((1,1),(n,n))
1974 
+                     ([(1,j) := 1 | j <- [1..n]] ++
1975 
+                      [(i,1) := 1 | i <- [2..n]] ++
1976 
+                      [(i,j) := a!(i,j-1) + a!(i-1,j-1) + a!(i-1,j)
1977 
+                                  | i <- [2..n], j <- [2..n]])
1978 
+
1979 
+wave = wavefront 20
1980 
+e12 = atake wave ((1,1),(3,3))
1981 
+e13 = atake wave ((3,3),(5,5))
1982 
+
1983 
+-- Here are some errors in array operations:
1984 
+
1985 
+e14 :: Int
1986 
+e14 = wave ! (0,0)  -- Out of bounds
1987 
+arr1 :: Array Int Int
1988 
+arr1 = array (1,10) [1 := 1] -- No value provided for 2..10
1989 
+e15,e16 :: Int
1990 
+e15 = arr1 ! 1  -- works OK
1991 
+e16 = arr1 ! 2  -- undefined by array
1992 
+
1993 
+-- Page 24  Sections 9.3, 9.4
1994 
+
1995 
+module Test(Bool) where
1996 
+
1997 
+-- Section 9.3  Accumulation
1998 
+
1999 
+hist :: (Ix a, Integral b) => (a,a) -> [a] -> Array a b
2000 
+hist bnds is = accumArray (+) 0 bnds [i := 1 | i <- is, inRange bnds i]
2001 
+
2002 
+e1 :: Array Char Int
2003 
+e1 = hist ('a','z') "This counts the frequencies of each lowercase letter"
2004 
+
2005 
+decades :: (RealFrac a) => a -> a -> [a] -> Array Int Int
2006 
+decades a b = hist (0,9) . map decade
2007 
+                where
2008 
+                  decade x = floor ((x-a) * s)
2009 
+                  s = 10 / (b - a)
2010 
+
2011 
+test1 :: [Float]
2012 
+test1 = map sin [0..100]  -- take the sine of the 0 - 100
2013 
+e2 = decades 0 1 test1
2014 
+
2015 
+-- Section 9.4  Incremental Updates
2016 
+
2017 
+swapRows :: (Ix a, Ix b, Enum b) => a -> a -> Array (a,b) c -> Array (a,b) c
2018 
+swapRows i i' a = a // ([(i,j) := a!(i',j) | j <- [jLo..jHi]] ++
2019 
+			[(i',j) := a!(i,j) | j <- [jLo..jHi]])
2020 
+               where ((iLo,jLo),(iHi,jHi)) = bounds a
2021 
+
2022 
+arr1 :: Array (Int,Int) (Int,Int)
2023 
+arr1 = array ((1,1),(5,5)) [(i,j) := (i,j) | (i,j) <- range ((1,1),(5,5))]
2024 
+
2025 
+e3 = swapRows 2 3 arr1
2026 
+
2027 
+-- Printing the arrays in more readable form makes the results easier
2028 
+-- to view.
2029 
+
2030 
+-- This is a printer for 2d arrays
2031 
+
2032 
+aprint a width = shows (bounds a) . showChar '\n' . showRows lx ly where
2033 
+  showRows r c | r > ux = showChar '\n'
2034 
+  showRows r c | c > uy = showChar '\n' . showRows (r+1) ly
2035 
+  showRows r c = showElt (a!(r,c)) . showRows r (c+1)
2036 
+  showElt e = showString (take width (show e ++ repeat ' ')) . showChar ' '
2037 
+  ((lx,ly),(ux,uy)) = bounds a
2038 
+
2039 
+showArray a w = appendChan stdout (aprint a w "") abort done
2040 
+
2041 
+d1 = showArray e3 6
2042 
+
2043 
+swapRows' :: (Ix a, Ix b, Enum b) => a -> a -> Array (a,b) c -> Array (a,b) c
2044 
+swapRows' i i' a = a // [assoc | j <- [jLo..jHi],
2045 
+                                 assoc <- [(i,j) := a!(i',j),
2046 
+	  				   (i',j) := a!(i,j)]]
2047 
+               where ((iLo,jLo),(iHi,jHi)) = bounds a
2048 
+
2049 
+d2 = showArray (swapRows' 1 5 arr1) 6
2050 
+
2051 
+-- Page 25  Section 9.5
2052 
+
2053 
+module Test(Bool) where
2054 
+
2055 
+-- Section 9.5  An example: Matrix Multiplication
2056 
+
2057 
+aprint a width = shows (bounds a) . showChar '\n' . showRows lx ly where
2058 
+  showRows r c | r > ux = showChar '\n'
2059 
+  showRows r c | c > uy = showChar '\n' . showRows (r+1) ly
2060 
+  showRows r c = showElt (a!(r,c)) . showRows r (c+1)
2061 
+  showElt e = showString (take width (show e ++ repeat ' ')) . showChar ' '
2062 
+  ((lx,ly),(ux,uy)) = bounds a
2063 
+
2064 
+showArray a w = appendChan stdout (aprint a w "") abort done
2065 
+
2066 
+matMult :: (Ix a, Ix b, Ix c, Num d) =>
2067 
+              Array (a,b) d -> Array (b,c) d -> Array (a,c) d
2068 
+matMult x y =
2069 
+  array resultBounds
2070 
+        [(i,j) := sum [x!(i,k) * y!(k,j) | k <- range (lj,uj)]
2071 
+                  | i <- range (li,ui),
2072 
+                    j <- range (lj',uj')]
2073 
+ where
2074 
+    ((li,lj),(ui,uj)) = bounds x
2075 
+    ((li',lj'),(ui',uj')) = bounds y
2076 
+    resultBounds
2077 
+      | (lj,uj)==(li',ui')    =  ((li,lj'),(ui,uj'))
2078 
+      | otherwise             = error "matMult: incompatible bounds"
2079 
+
2080 
+mat1,mat2,mat3,mat4 :: Array (Int,Int) Int
2081 
+mat1 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 0,(1,0) := 0,(1,1) := 1]
2082 
+mat2 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 1,(1,0) := 1,(1,1) := 1]
2083 
+mat3 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 2,(1,0) := 3,(1,1) := 4]
2084 
+mat4 = array ((0,0),(1,2)) [(0,0) := 1,(0,1) := 2,(0,2) := 3,
2085 
+			    (1,0) := 4,(1,1) := 5,(1,2) := 6]
2086 
+
2087 
+d1 = showArray (matMult mat1 mat2) 4
2088 
+d2 = showArray (matMult mat2 mat3) 4
2089 
+d3 = showArray (matMult mat1 mat4) 4
2090 
+d4 = showArray (matMult mat4 mat1) 4
2091 
+
2092 
+matMult' :: (Ix a, Ix b, Ix c, Num d) =>
2093 
+              Array (a,b) d -> Array (b,c) d -> Array (a,c) d
2094 
+matMult' x y =
2095 
+  accumArray (+) 0 ((li,lj'),(ui,uj'))
2096 
+        [(i,j) := x!(i,k) * y!(k,j)
2097 
+                  | i <- range (li,ui),
2098 
+                    j <- range (lj',uj'),
2099 
+                    k <- range (lj,uj)]
2100 
+
2101 
+ where
2102 
+    ((li,lj),(ui,uj)) = bounds x
2103 
+    ((li',lj'),(ui',uj')) = bounds y
2104 
+    resultBounds
2105 
+       | (lj,uj)==(li',ui')    =  ((li,lj'),(ui,uj'))
2106 
+       | otherwise             = error "matMult: incompatible bounds"
2107 
+
2108 
+d5 = showArray (matMult mat1 mat2) 4
2109 
+d6 = showArray (matMult mat2 mat3) 4
2110 
+
2111 
+genMatMul :: (Ix a, Ix b, Ix c) =>
2112 
+              ([f] -> g) -> (d -> e -> f) ->
2113 
+              Array (a,b) d -> Array (b,c) e -> Array (a,c) g
2114 
+genMatMul f g x y =
2115 
+  array ((li,lj'),(ui,uj'))
2116 
+        [(i,j) := f [(x!(i,k)) `g` (y!(k,j)) | k <- range (lj,uj)]
2117 
+                  | i <- range (li,ui),
2118 
+                    j <- range (lj',uj')]
2119 
+ where
2120 
+    ((li,lj),(ui,uj)) = bounds x
2121 
+    ((li',lj'),(ui',uj')) = bounds y
2122 
+    resultBounds
2123 
+         | (lj,uj)==(li',ui')    =  ((li,lj'),(ui,uj'))
2124 
+         | otherwise             = error "matMult: incompatible bounds"
2125 
+
2126 
+d7 = showArray (genMatMul maximum (-) mat2 mat1) 4
2127 
+d8 = showArray (genMatMul and (==) mat1 mat2) 6
2128 
+d9 = showArray (genMatMul and (==) mat1 mat1) 6
2129 
+
2130 
+-- Page 26     More about Haskell
2131 
+
2132 
+This is the end of the tutorial.  If you wish to see more examples of
2133 
+Haskell programming, Yale Haskell comes with a set of demo programs.
2134 
+These can be found in $HASKELL/progs/demo.  Once you have mastered the
2135 
+tutorial, both the report and the user manual for Yale Haskell should
2136 
+be understandable.  Many examples of Haskell programming can be found in
2137 
+the Prelude.  The directory $HASKELL/progs/prelude contains the sources
2138 
+for the Prelude.
2139 
+
2140 
+We appreciate any comments you have on this tutorial.  Send any comments
2141 
+to haskell-requests@cs.yale.edu.
2142 
+
2143 
+   The Yale Haskell Group
runtime/README
History View file @ 4e98702
0 2144 
new file mode 100644
... ... 
@@ -0,0 +1,8 @@
1 
+This directory contains definitions of things that are used
2 
+exclusively in code generated by the Haskell compiler.  It contains
3 
+implementations of some of the things declared in the prims files for
4 
+the prelude, as well as some more generic things that the code
5 
+generator knows about.
6 
+
7 
+Note that some of the files in this directory access some Common Lisp
8 
+features directly.
runtime/array-prims.scm
History View file @ 4e98702
0 9 
new file mode 100644
... ... 
@@ -0,0 +1,55 @@
1 
+;;; array-prims.scm -- array primitives
2 
+;;;
3 
+;;; author :  John & Sandra
4 
+;;; date   :  14 May 1993
5 
+
6 
+
7 
+;;; Vector reference, returning unboxed value
8 
+
9 
+(define-syntax (prim.vector-sel vec i)
10 
+  `(vector-ref ,vec ,i))
11 
+
12 
+
13 
+;;; Destructive vector update.  All arguments are unboxed.
14 
+
15 
+(define-syntax (prim.vector-update vec i newval)
16 
+  `(setf (vector-ref ,vec ,i) ,newval))
17 
+
18 
+
19 
+;;; Make a vector whose elements are initialized to val (which is boxed).
20 
+
21 
+(define-syntax (prim.make-vector size val)
22 
+  `(make-vector ,size ,val))
23 
+
24 
+
25 
+;;; Copy an existing vector.
26 
+
27 
+(define-syntax (prim.copy-vector vec)
28 
+  `(vector-copy ,vec))
29 
+
30 
+
31 
+;;; Explicit force operation
32 
+
33 
+(define-syntax (prim.force x)
34 
+  `(force ,x))
35 
+
36 
+
37 
+;;; The first parameter is forced first since this prim is declared to
38 
+;;; be strict in the first arg.
39 
+
40 
+(define-syntax (prim.strict1 force-this leave-this)
41 
+  `(begin
42 
+     ;; Can't ignore the first argument entirely since doing so
43 
+     ;; might result in variable-bound-but-not-referenced errors.
44 
+     ;; Hopefully the Lisp compiler will be smart enough to get
45 
+     ;; rid of this when appropriate.
46 
+     ,force-this
47 
+     ;; Don't generate a stupid (force (delay x)) sequence here if
48 
+     ;; we don't need to.
49 
+     ,(if (and (pair? leave-this)
50 
+	       (or (eq? (car leave-this) 'delay)
51 
+		   (eq? (car leave-this) 'box)))
52 
+	  (cadr leave-this)
53 
+	  `(force ,leave-this))))
54 
+
55 
+
runtime/debug-utils.scm
History View file @ 4e98702
0 56 
new file mode 100644
... ... 
@@ -0,0 +1,33 @@
1 
+
2 
+;;; This has some diagnostic stuff
3 
+
4 
+;;; This forces all delays in a structure
5 
+
6 
+(define (force-all x)
7 
+  (cond ((delay? x)
8 
+	 (force-all (force x)))
9 
+	((pair? x)
10 
+	 (force-all (car x))
11 
+	 (force-all (cdr x)))
12 
+	((vector? x)
13 
+	 (dotimes (i (vector-length x))
14 
+            (force-all (vector-ref x i)))))
15 
+  x)
16 
+
17 
+;;; This forces & removes all delays in a structure.
18 
+
19 
+(define (remove-delays x)
20 
+  (cond ((delay? x)
21 
+	 (remove-delays (force x)))
22 
+	((pair? x)
23 
+	 (cons (remove-delays (car x))
24 
+	       (remove-delays (cdr x))))
25 
+	((vector? x)
26 
+	 (list->vector (map (function remove-delays) (vector->list x))))
27 
+	(else x)))
28 
+
29 
+(define (delay? x)
30 
+  (and (pair? x)
31 
+       (or (eq? (car x) '#t)
32 
+	   (eq? (car x) '#f))))
33 
+
runtime/io-primitives.scm
History View file @ 4e98702
0 34 
new file mode 100644
... ... 
@@ -0,0 +1,178 @@
1 
+
2 
+;;; These are the IO primitives used by PreludeIOPrims
3 
+
4 
+;;; Note: the box in write-string-stdout, write-string-file, and
5 
+;;;  append-string-file are due to the NoConversion in the .hi file.
6 
+;;; The problem is that NoConversion applies to everything, not just
7 
+;;; the input arg that the conversion is not needed or.
8 
+
9 
+
10 
+(predefine (notify-input-request))
11 
+
12 
+(define *emacs-notified* '#f)
13 
+(define *stdin-read* '#f)
14 
+
15 
+(define (initialize-io-system)
16 
+  (setf *emacs-notified* '#f)
17 
+  (setf *stdin-read* '#f))
18 
+
19 
+(define (io-success . res)
20 
+  (make-tagged-data 0
21 
+    (if (null? res)
22 
+	(box 0)
23 
+	(box (make-haskell-string (car res))))))
24 
+
25 
+(define (io-success/bin res)
26 
+  (make-tagged-data 0 (box res)))
27 
+
28 
+(define (io-success/lazy res)
29 
+  (make-tagged-data 0 res))
30 
+
31 
+(define (io-failure string)
32 
+  (make-tagged-data 1 (box (make-haskell-string string))))
33 
+
34 
+; primReadStringFile
35 
+(define (prim.read-string-file filename)
36 
+  (if (file-exists? filename)
37 
+      (let ((str (call-with-input-file filename
38 
+		   (lambda (port)
39 
+		     (port->string port)))))
40 
+	(io-success str))
41 
+      (io-failure (format '#f "File not found: ~A~%" filename))))
42 
+
43 
+(define (port->string port)
44 
+  (call-with-output-string
45 
+   (lambda (string-port)
46 
+     (copy-till-eof port string-port))))
47 
+
48 
+(define (copy-till-eof in-port out-port)
49 
+  (do ((ch (read-char in-port) (read-char in-port)))
50 
+      ((eof-object? ch))
51 
+    (write-char ch out-port)))
52 
+
53 
+; primWriteStringFile
54 
+(define (prim.write-string-file filename contents state)
55 
+ (declare (ignore state))
56 
+ (box
57 
+  (let ((stream (lisp:open (haskell-string->string filename)
58 
+			   :direction :output
59 
+			   :if-exists :overwrite
60 
+			   :if-does-not-exist :create)))
61 
+    (print-haskell-string contents stream)
62 
+    (close-output-port stream)
63 
+    (io-success))))
64 
+
65 
+;primAppendStringFile
66 
+(define (prim.append-string-file filename contents state)
67 
+ (declare (ignore state))
68 
+ (box
69 
+  (let ((stream (lisp:open (haskell-string->string filename)
70 
+			   :direction :output
71 
+			   :if-exists :append
72 
+			   :if-does-not-exist '())))
73 
+    (cond ((not (eq? stream '()))
74 
+           (print-haskell-string contents stream)
75 
+           (close-output-port stream)
76 
+	   (io-success))
77 
+          (else
78 
+	   (io-failure "Can't open file"))))))
79 
+
80 
+; primReadBinFile
81 
+(define (prim.read-bin-file name)
82 
+  (let ((bin (lisp-read name)))
83 
+    (if (and (pair? bin) (eq? (car bin) ':binary))
84 
+	(io-success/bin bin)
85 
+	(io-failure "Not a bin file"))))
86 
+
87 
+; primWriteBinFile
88 
+(define (prim.write-bin-file name contents)
89 
+  (let ((stream (lisp:open name :direction :output
90 
+			   :if-exists :overwrite
91 
+			   :if-does-not-exist :create)))
92 
+    (write (cons ':binary contents) stream)
93 
+    (close-output-port stream)
94 
+    (io-success)))
95 
+
96 
+; primAppendBinFile
97 
+(define (prim.append-bin-file name contents)
98 
+ (let ((bin (lisp-read name)))
99 
+   (if (and (pair? bin) (eq? (car bin) ':binary))
100 
+       (let ((stream (lisp:open name :direction :output :if-exists :overwrite)))
101 
+	 (write (append bin contents) stream)
102 
+	 (io-success))
103 
+       (io-failure "Can't open Bin file"))))
104 
+
105 
+; primDeleteFile
106 
+(define (prim.delete-file name)
107 
+  (if (file-exists? name)
108 
+      (if (lisp:delete-file name)
109 
+	  (io-success)
110 
+	  (io-failure "Can't delete file"))
111 
+      (io-failure "File not found")))
112 
+
113 
+; primStatusFile
114 
+(define (prim.status-file name)
115 
+  (if (file-exists? name)
116 
+      (io-success "frw")
117 
+      (io-failure (format '#f "File ~A not found" name))))
118 
+
119 
+;primReadStdin
120 
+(define (prim.read-string-stdin state)
121 
+  (declare (ignore state))
122 
+  (cond (*stdin-read*
123 
+	 (haskell-runtime-error "Multiple ReadChan from stdin"))
124 
+	(else
125 
+	 (setf *stdin-read* '#t)
126 
+	 (delay (read-next-char)))))
127 
+
128 
+(define (read-next-char)
129 
+  (when (and *emacs-mode* (not *emacs-notified*))
130 
+    (setf *emacs-notified* '#t)
131 
+    (notify-input-request))
132 
+  (let ((ch (read-char)))
133 
+    (if (eof-object? ch)
134 
+	'()
135 
+	(cons (box (char->integer ch))
136 
+	      (delay (read-next-char))))))
137 
+
138 
+; primWriteStdout
139 
+(define (prim.write-string-stdout string state)
140 
+  (declare (ignore state))
141 
+  (print-haskell-string string (current-output-port))
142 
+  (box (io-success)))
143 
+
144 
+; primReadBinStdin
145 
+(define (prim.read-bin-stdin)
146 
+  (haskell-runtime-error  "ReadBinChan not implemented"))
147 
+
148 
+; primWriteBinStdout
149 
+(define (prim.write-bin-stdout bin)
150 
+  (declare (ignore bin))
151 
+  (haskell-runtime-error  "WriteBinChan not implemented"))
152 
+
153 
+;;; %%% probably bogus
154 
+; primGetEnv
155 
+(define (prim.getenv name)
156 
+  (io-success (getenv name)))
157 
+
158 
+(define (lisp-read file)
159 
+  (if (not (file-exists? file))
160 
+      'error
161 
+      (call-with-input-file file
162 
+        (lambda (port)
163 
+	  (lisp:read port '#f 'error '#f)))))
164 
+
165 
+(define-integrable (prim.returnio x s)
166 
+  (declare (ignore s))
167 
+  x)
168 
+
169 
+(define-integrable (prim.getstate x)
170 
+  (declare (ignore x))
171 
+  'state)
172 
+
173 
+(define-integrable (prim.getres x)
174 
+  (force x))
175 
+
176 
+
177 
+
178 
+
runtime/prims.scm
History View file @ 4e98702
0 179 
new file mode 100644
... ... 
@@ -0,0 +1,595 @@
1 
+;;; prims.scm -- definitions for primitives
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  9 Jun 1992
5 
+;;;
6 
+;;; WARNING!!!  This file contains Common-Lisp specific code.
7 
+;;;
8 
+
9 
+
10 
+;;; Helper stuff
11 
+
12 
+(define-integrable (is-fixnum? x)
13 
+  (lisp:typep x 'lisp:fixnum))
14 
+
15 
+(define-integrable (is-integer? x)
16 
+  (lisp:typep x 'lisp:integer))
17 
+
18 
+(define-integrable (is-single-float? x)
19 
+  (lisp:typep x 'lisp:single-float))
20 
+
21 
+(define-integrable (is-double-float? x)
22 
+  (lisp:typep x 'lisp:double-float))
23 
+
24 
+(define-syntax (the-fixnum x)
25 
+  `(lisp:the lisp:fixnum ,x))
26 
+
27 
+(define-syntax (the-integer x)
28 
+  `(lisp:the lisp:integer ,x))
29 
+
30 
+(define-syntax (the-single-float x)
31 
+  `(lisp:the lisp:single-float ,x))
32 
+
33 
+(define-syntax (the-double-float x)
34 
+  `(lisp:the lisp:double-float ,x))
35 
+
36 
+(define-syntax (make-haskell-tuple2 x y)
37 
+  `(make-tuple (box ,x) (box ,y)))
38 
+
39 
+;;; Abort
40 
+;;; *** Should probably do something other than just signal an error.
41 
+
42 
+(define (prim.abort s)
43 
+  (haskell-runtime-error s))
44 
+
45 
+(define (haskell-string->list s)
46 
+  (if (null? s)
47 
+      '()
48 
+      (cons (integer->char (force (car s)))
49 
+	    (haskell-string->list (force (cdr s))))))
50 
+
51 
+;;; Char
52 
+
53 
+(define-syntax (prim.char-to-int c)
54 
+  `(the-fixnum ,c))
55 
+
56 
+(define-syntax (prim.int-to-char i)
57 
+  `(the-fixnum ,i))
58 
+
59 
+(define-syntax (prim.eq-char i1 i2)
60 
+  `(= (the-fixnum ,i1) (the-fixnum ,i2)))
61 
+(define-syntax (prim.not-eq-char i1 i2)
62 
+  `(not (= (the-fixnum ,i1) (the-fixnum ,i2))))
63 
+(define-syntax (prim.le-char i1 i2)
64 
+  `(<= (the-fixnum ,i1) (the-fixnum ,i2)))
65 
+(define-syntax (prim.not-le-char i1 i2)
66 
+  `(> (the-fixnum ,i1) (the-fixnum ,i2)))
67 
+(define-syntax (prim.not-lt-char i1 i2)
68 
+  `(>= (the-fixnum ,i1) (the-fixnum ,i2)))
69 
+(define-syntax (prim.lt-char i1 i2)
70 
+  `(< (the-fixnum ,i1) (the-fixnum ,i2)))
71 
+
72 
+(define-integrable prim.max-char 255)
73 
+
74 
+
75 
+;;; Floating
76 
+
77 
+(define-syntax (prim.eq-float f1 f2)
78 
+  `(= (the-single-float ,f1) (the-single-float ,f2)))
79 
+(define-syntax (prim.not-eq-float f1 f2)
80 
+  `(not (= (the-single-float ,f1) (the-single-float ,f2))))
81 
+(define-syntax (prim.le-float f1 f2)
82 
+  `(<= (the-single-float ,f1) (the-single-float ,f2)))
83 
+(define-syntax (prim.not-le-float f1 f2)
84 
+  `(> (the-single-float ,f1) (the-single-float ,f2)))
85 
+(define-syntax (prim.not-lt-float f1 f2)
86 
+  `(>= (the-single-float ,f1) (the-single-float ,f2)))
87 
+(define-syntax (prim.lt-float f1 f2)
88 
+  `(< (the-single-float ,f1) (the-single-float ,f2)))
89 
+
90 
+(define-syntax (prim.eq-double f1 f2)
91 
+  `(= (the-double-float ,f1) (the-double-float ,f2)))
92 
+(define-syntax (prim.not-eq-double f1 f2)
93 
+  `(not (= (the-double-float ,f1) (the-double-float ,f2))))
94 
+(define-syntax (prim.le-double f1 f2)
95 
+  `(<= (the-double-float ,f1) (the-double-float ,f2)))
96 
+(define-syntax (prim.not-le-double f1 f2)
97 
+  `(> (the-double-float ,f1) (the-double-float ,f2)))
98 
+(define-syntax (prim.not-lt-double f1 f2)
99 
+  `(>= (the-double-float ,f1) (the-double-float ,f2)))
100 
+(define-syntax (prim.lt-double f1 f2)
101 
+  `(< (the-double-float ,f1) (the-double-float ,f2)))
102 
+
103 
+(define-syntax (prim.float-max f1 f2)
104 
+  `(the-single-float (max (the-single-float ,f1) (the-single-float ,f2))))
105 
+(define-syntax (prim.float-min f1 f2)
106 
+  `(the-single-float (min (the-single-float ,f1) (the-single-float ,f2))))
107 
+
108 
+(define-syntax (prim.double-max f1 f2)
109 
+  `(the-double-float (max (the-double-float ,f1) (the-double-float ,f2))))
110 
+(define-syntax (prim.double-min f1 f2)
111 
+  `(the-double-float (min (the-double-float ,f1) (the-double-float ,f2))))
112 
+
113 
+(define-syntax (prim.plus-float f1 f2)
114 
+  `(the-single-float (+ (the-single-float ,f1) (the-single-float ,f2))))
115 
+(define-syntax (prim.minus-float f1 f2)
116 
+  `(the-single-float (- (the-single-float ,f1) (the-single-float ,f2))))
117 
+(define-syntax (prim.mul-float f1 f2)
118 
+  `(the-single-float (* (the-single-float ,f1) (the-single-float ,f2))))
119 
+(define-syntax (prim.div-float f1 f2)
120 
+  `(the-single-float (/ (the-single-float ,f1) (the-single-float ,f2))))
121 
+
122 
+(define-syntax (prim.plus-double f1 f2)
123 
+  `(the-double-float (+ (the-double-float ,f1) (the-double-float ,f2))))
124 
+(define-syntax (prim.minus-double f1 f2)
125 
+  `(the-double-float (- (the-double-float ,f1) (the-double-float ,f2))))
126 
+(define-syntax (prim.mul-double f1 f2)
127 
+  `(the-double-float (* (the-double-float ,f1) (the-double-float ,f2))))
128 
+(define-syntax (prim.div-double f1 f2)
129 
+  `(the-double-float (/ (the-double-float ,f1) (the-double-float ,f2))))
130 
+
131 
+
132 
+(define-syntax (prim.neg-float f)
133 
+  `(the-single-float (- (the-single-float ,f))))
134 
+
135 
+(define-syntax (prim.neg-double f)
136 
+  `(the-double-float (- (the-double-float ,f))))
137 
+
138 
+(define-syntax (prim.abs-float f)
139 
+  `(the-single-float (lisp:abs (the-single-float ,f))))
140 
+
141 
+(define-syntax (prim.abs-double f)
142 
+  `(the-double-float (lisp:abs (the-double-float ,f))))
143 
+
144 
+
145 
+(define-syntax (prim.exp-float f)
146 
+  `(the-single-float (lisp:exp (the-single-float ,f))))
147 
+(define-syntax (prim.log-float f)
148 
+  `(the-single-float (lisp:log (the-single-float ,f))))
149 
+(define-syntax (prim.sqrt-float f)
150 
+  `(the-single-float (lisp:sqrt (the-single-float ,f))))
151 
+(define-syntax (prim.sin-float f)
152 
+  `(the-single-float (lisp:sin (the-single-float ,f))))
153 
+(define-syntax (prim.cos-float f)
154 
+  `(the-single-float (lisp:cos (the-single-float ,f))))
155 
+(define-syntax (prim.tan-float f)
156 
+  `(the-single-float (lisp:tan (the-single-float ,f))))
157 
+(define-syntax (prim.asin-float f)
158 
+  `(the-single-float (lisp:asin (the-single-float ,f))))
159 
+(define-syntax (prim.acos-float f)
160 
+  `(the-single-float (lisp:acos (the-single-float ,f))))
161 
+(define-syntax (prim.atan-float f)
162 
+  `(the-single-float (lisp:atan (the-single-float ,f))))
163 
+(define-syntax (prim.sinh-float f)
164 
+  `(the-single-float (lisp:sinh (the-single-float ,f))))
165 
+(define-syntax (prim.cosh-float f)
166 
+  `(the-single-float (lisp:cosh (the-single-float ,f))))
167 
+(define-syntax (prim.tanh-float f)
168 
+  `(the-single-float (lisp:tanh (the-single-float ,f))))
169 
+(define-syntax (prim.asinh-float f)
170 
+  `(the-single-float (lisp:asinh (the-single-float ,f))))
171 
+(define-syntax (prim.acosh-float f)
172 
+  `(the-single-float (lisp:acosh (the-single-float ,f))))
173 
+(define-syntax (prim.atanh-float f)
174 
+  `(the-single-float (lisp:atanh (the-single-float ,f))))
175 
+
176 
+
177 
+(define-syntax (prim.exp-double f)
178 
+  `(the-double-float (lisp:exp (the-double-float ,f))))
179 
+(define-syntax (prim.log-double f)
180 
+  `(the-double-float (lisp:log (the-double-float ,f))))
181 
+(define-syntax (prim.sqrt-double f)
182 
+  `(the-double-float (lisp:sqrt (the-double-float ,f))))
183 
+(define-syntax (prim.sin-double f)
184 
+  `(the-double-float (lisp:sin (the-double-float ,f))))
185 
+(define-syntax (prim.cos-double f)
186 
+  `(the-double-float (lisp:cos (the-double-float ,f))))
187 
+(define-syntax (prim.tan-double f)
188 
+  `(the-double-float (lisp:tan (the-double-float ,f))))
189 
+(define-syntax (prim.asin-double f)
190 
+  `(the-double-float (lisp:asin (the-double-float ,f))))
191 
+(define-syntax (prim.acos-double f)
192 
+  `(the-double-float (lisp:acos (the-double-float ,f))))
193 
+(define-syntax (prim.atan-double f)
194 
+  `(the-double-float (lisp:atan (the-double-float ,f))))
195 
+(define-syntax (prim.sinh-double f)
196 
+  `(the-double-float (lisp:sinh (the-double-float ,f))))
197 
+(define-syntax (prim.cosh-double f)
198 
+  `(the-double-float (lisp:cosh (the-double-float ,f))))
199 
+(define-syntax (prim.tanh-double f)
200 
+  `(the-double-float (lisp:tanh (the-double-float ,f))))
201 
+(define-syntax (prim.asinh-double f)
202 
+  `(the-double-float (lisp:asinh (the-double-float ,f))))
203 
+(define-syntax (prim.acosh-double f)
204 
+  `(the-double-float (lisp:acosh (the-double-float ,f))))
205 
+(define-syntax (prim.atanh-double f)
206 
+  `(the-double-float (lisp:atanh (the-double-float ,f))))
207 
+
208 
+
209 
+(define-integrable prim.pi-float (lisp:coerce lisp:pi 'lisp:single-float))
210 
+
211 
+(define-integrable prim.pi-double (lisp:coerce lisp:pi 'lisp:double-float))
212 
+
213 
+
214 
+;;; Assumes rationals are represented as a 2-tuple of integers
215 
+
216 
+(define (prim.rational-to-float x)
217 
+  (let ((n (tuple-select 2 0 x))
218 
+	(d (tuple-select 2 1 x)))
219 
+    (if (eqv? d 0)
220 
+	(haskell-runtime-error "Divide by 0.")
221 
+	(prim.rational-to-float-aux n d))))
222 
+
223 
+(define (prim.rational-to-float-aux n d)
224 
+  (declare (type integer n d))
225 
+  (/ (lisp:coerce n 'lisp:single-float)
226 
+     (lisp:coerce d 'lisp:single-float)))
227 
+
228 
+(define (prim.rational-to-double x)
229 
+  (let ((n (tuple-select 2 0 x))
230 
+	(d (tuple-select 2 1 x)))
231 
+    (if (eqv? d 0)
232 
+	(haskell-runtime-error "Divide by 0.")
233 
+	(prim.rational-to-double-aux n d))))
234 
+
235 
+(define (prim.rational-to-double-aux n d)
236 
+  (declare (type integer n d))
237 
+  (/ (lisp:coerce n 'lisp:double-float)
238 
+     (lisp:coerce d 'lisp:double-float)))
239 
+
240 
+(define (prim.float-to-rational x)
241 
+  (let ((r  (lisp:rational (the lisp:single-float x))))
242 
+    (declare (type rational r))
243 
+    (make-tuple (lisp:numerator r) (lisp:denominator r))))
244 
+
245 
+(define (prim.double-to-rational x)
246 
+  (let ((r  (lisp:rational (the lisp:double-float x))))
247 
+    (declare (type rational r))
248 
+    (make-tuple (lisp:numerator r) (lisp:denominator r))))
249 
+
250 
+
251 
+(define-integrable prim.float-1 (lisp:coerce 1.0 'lisp:single-float))
252 
+(define-integrable prim.double-1 (lisp:coerce 1.0 'lisp:double-float))
253 
+
254 
+(define-integrable prim.float-digits
255 
+  (lisp:float-digits prim.float-1))
256 
+
257 
+(define-integrable prim.double-digits
258 
+  (lisp:float-digits prim.double-1))
259 
+
260 
+(define-integrable prim.float-radix
261 
+  (lisp:float-radix prim.float-1))
262 
+
263 
+(define-integrable prim.double-radix
264 
+  (lisp:float-radix prim.double-1))
265 
+
266 
+
267 
+;;; Sometimes least-positive-xxx-float is denormalized.
268 
+
269 
+(define-integrable prim.float-min-exp
270 
+  (multiple-value-bind (m e)
271 
+      (lisp:decode-float
272 
+        #+lucid lcl:least-positive-normalized-single-float
273 
+	#-lucid lisp:least-positive-single-float)
274 
+    (declare (ignore m))
275 
+    e))
276 
+
277 
+(define-integrable prim.double-min-exp
278 
+  (multiple-value-bind (m e)
279 
+      (lisp:decode-float
280 
+        #+lucid lcl:least-positive-normalized-double-float
281 
+	#-lucid lisp:least-positive-double-float)
282 
+    (declare (ignore m))
283 
+    e))
284 
+
285 
+(define-integrable prim.float-max-exp
286 
+  (multiple-value-bind (m e)
287 
+      (lisp:decode-float lisp:most-positive-single-float)
288 
+    (declare (ignore m))
289 
+    e))
290 
+
291 
+(define-integrable prim.double-max-exp
292 
+  (multiple-value-bind (m e)
293 
+      (lisp:decode-float lisp:most-positive-double-float)
294 
+    (declare (ignore m))
295 
+    e))
296 
+
297 
+(define-integrable (prim.float-range x)
298 
+  (declare (ignore x))
299 
+  (make-haskell-tuple2 prim.float-min-exp prim.float-max-exp))
300 
+
301 
+(define-integrable (prim.double-range x)
302 
+  (declare (ignore x))
303 
+  (make-haskell-tuple2 prim.double-min-exp prim.double-max-exp))
304 
+
305 
+
306 
+;;; *** I'm not sure if these are correct.  Should the exponent value
307 
+;;; *** be taken as the value that lisp:integer-decode-float returns,
308 
+;;; *** or as the value that lisp:decode-float returns?  (They're
309 
+;;; *** not the same because the significand is scaled differently.)
310 
+;;; *** I'm guessing that Haskell's model is to use the actual numbers
311 
+;;; *** that are in the bit fields
312 
+
313 
+;;; jcp - I removed this since Haskell requires an integer instead of a
314 
+;;; fractional mantissa.  My theory is that integer-decode-float returns
315 
+;;; what Haskell wants without fiddling (except sign reattachment)
316 
+
317 
+(define (exponent-adjustment m)
318 
+  (if (eqv? prim.float-radix 2)
319 
+      ;; the usual case -- e.g. IEEE floating point
320 
+      (lisp:integer-length m)
321 
+      (lisp:ceiling (lisp:log m prim.float-radix))))
322 
+
323 
+(define (prim.decode-float f)
324 
+  (multiple-value-bind (m e s)
325 
+      (lisp:integer-decode-float (the-single-float f))
326 
+    (make-haskell-tuple2 (* (the-integer m) (the-fixnum s))
327 
+			 (the-fixnum e))))
328 
+
329 
+(define (prim.decode-double f)
330 
+  (multiple-value-bind (m e s)
331 
+      (lisp:integer-decode-float (the-double-float f))
332 
+    (make-haskell-tuple2 (* (the-integer m) (the-fixnum s))
333 
+			 (the-fixnum e))))
334 
+
335 
+(define (prim.encode-float m e)
336 
+  (lisp:scale-float (lisp:coerce m 'lisp:single-float) (the-fixnum e)))
337 
+
338 
+(define (prim.encode-double m e)
339 
+  (lisp:scale-float (lisp:coerce m 'lisp:double-float) (the-fixnum e)))
340 
+
341 
+
342 
+;;; Integral
343 
+
344 
+(define-syntax (prim.eq-int i1 i2)
345 
+  `(= (the-fixnum ,i1) (the-fixnum ,i2)))
346 
+(define-syntax (prim.not-eq-int i1 i2)
347 
+  `(not (= (the-fixnum ,i1) (the-fixnum ,i2))))
348 
+(define-syntax (prim.le-int i1 i2)
349 
+  `(<= (the-fixnum ,i1) (the-fixnum ,i2)))
350 
+(define-syntax (prim.not-le-int i1 i2)
351 
+  `(> (the-fixnum ,i1) (the-fixnum ,i2)))
352 
+(define-syntax (prim.not-lt-int i1 i2)
353 
+  `(>= (the-fixnum ,i1) (the-fixnum ,i2)))
354 
+(define-syntax (prim.lt-int i1 i2)
355 
+  `(< (the-fixnum ,i1) (the-fixnum ,i2)))
356 
+(define-syntax (prim.int-max i1 i2)
357 
+  `(the-fixnum (max (the-fixnum ,i1) (the-fixnum ,i2))))
358 
+(define-syntax (prim.int-min i1 i2)
359 
+  `(the-fixnum (min (the-fixnum ,i1) (the-fixnum ,i2))))
360 
+
361 
+(define-syntax (prim.eq-integer i1 i2)
362 
+  `(= (the-integer ,i1) (the-integer ,i2)))
363 
+(define-syntax (prim.not-eq-integer i1 i2)
364 
+  `(not (= (the-integer ,i1) (the-integer ,i2))))
365 
+(define-syntax (prim.le-integer i1 i2)
366 
+  `(<= (the-integer ,i1) (the-integer ,i2)))
367 
+(define-syntax (prim.not-le-integer i1 i2)
368 
+  `(> (the-integer ,i1) (the-integer ,i2)))
369 
+(define-syntax (prim.not-lt-integer i1 i2)
370 
+  `(>= (the-integer ,i1) (the-integer ,i2)))
371 
+(define-syntax (prim.lt-integer i1 i2)
372 
+  `(< (the-integer ,i1) (the-integer ,i2)))
373 
+(define-syntax (prim.integer-max i1 i2)
374 
+  `(the-integer (max (the-integer ,i1) (the-integer ,i2))))
375 
+(define-syntax (prim.integer-min i1 i2)
376 
+  `(the-integer (min (the-integer ,i1) (the-integer ,i2))))
377 
+
378 
+
379 
+(define-syntax (prim.plus-int i1 i2)
380 
+  `(the-fixnum (+ (the-fixnum ,i1) (the-fixnum ,i2))))
381 
+(define-syntax (prim.minus-int i1 i2)
382 
+  `(the-fixnum (- (the-fixnum ,i1) (the-fixnum ,i2))))
383 
+(define-syntax (prim.mul-int i1 i2)
384 
+  `(the-fixnum (* (the-fixnum ,i1) (the-fixnum ,i2))))
385 
+(define-syntax (prim.neg-int i)
386 
+  `(the-fixnum (- (the-fixnum ,i))))
387 
+(define-syntax (prim.abs-int i)
388 
+  `(the-fixnum (lisp:abs (the-fixnum ,i))))
389 
+
390 
+(define-integrable prim.minint lisp:most-negative-fixnum)
391 
+(define-integrable prim.maxint lisp:most-positive-fixnum)
392 
+
393 
+(define-syntax (prim.plus-integer i1 i2)
394 
+  `(the-integer (+ (the-integer ,i1) (the-integer ,i2))))
395 
+(define-syntax (prim.minus-integer i1 i2)
396 
+  `(the-integer (- (the-integer ,i1) (the-integer ,i2))))
397 
+(define-syntax (prim.mul-integer i1 i2)
398 
+  `(the-integer (* (the-integer ,i1) (the-integer ,i2))))
399 
+(define-syntax (prim.neg-integer i)
400 
+  `(the-integer (- (the-integer ,i))))
401 
+(define-syntax (prim.abs-integer i)
402 
+  `(the-integer (lisp:abs (the-integer ,i))))
403 
+
404 
+
405 
+(define (prim.div-rem-int i1 i2)
406 
+  (multiple-value-bind (q r)
407 
+      (lisp:truncate (the-fixnum i1) (the-fixnum i2))
408 
+    (make-tuple (box (the-fixnum q)) (box (the-fixnum r)))))
409 
+
410 
+(define (prim.div-rem-integer i1 i2)
411 
+  (multiple-value-bind (q r)
412 
+      (lisp:truncate (the-integer i1) (the-integer i2))
413 
+    (make-tuple (box (the-integer q)) (box (the-integer r)))))
414 
+
415 
+(define (prim.integer-to-int i)
416 
+  (if (is-fixnum? i)
417 
+      (the-fixnum i)
418 
+      (haskell-runtime-error "Integer -> Int overflow.")))
419 
+
420 
+(define-syntax (prim.int-to-integer i)
421 
+  i)
422 
+
423 
+;;; Binary
424 
+
425 
+(define prim.nullbin '())
426 
+
427 
+(define (prim.is-null-bin x)
428 
+  (null? x))
429 
+
430 
+(define (prim.show-bin-int i b)
431 
+  (cons i b))
432 
+
433 
+(define (prim.show-bin-integer i b)
434 
+  (cons i b))
435 
+
436 
+(define (prim.show-bin-float f b)
437 
+  (cons f b))
438 
+
439 
+(define (prim.show-bin-double f b)
440 
+  (cons f b))
441 
+
442 
+(define (prim.bin-read-error)
443 
+  (haskell-runtime-error "Error: attempt to read from an incompatible Bin."))
444 
+
445 
+(define (prim.read-bin-int b)
446 
+  (if (or (null? b) (not (is-fixnum? (car b))))
447 
+      (prim.bin-read-error)
448 
+      (make-haskell-tuple2 (car b) (cdr b))))
449 
+
450 
+(define (prim.read-bin-integer b)
451 
+  (if (or (null? b) (not (is-integer? (car b))))
452 
+      (prim.bin-read-error)
453 
+      (make-haskell-tuple2 (car b) (cdr b))))
454 
+
455 
+(define (prim.read-bin-float b)
456 
+  (if (or (null? b) (not (is-single-float? (car b))))
457 
+      (prim.bin-read-error)
458 
+      (make-haskell-tuple2 (car b) (cdr b))))
459 
+
460 
+(define (prim.read-bin-double b)
461 
+  (if (or (null? b) (not (is-double-float? (car b))))
462 
+      (prim.bin-read-error)
463 
+      (make-haskell-tuple2 (car b) (cdr b))))
464 
+
465 
+(define (prim.read-bin-small-int b m)
466 
+  (if (or (null? b)
467 
+	  (not (is-fixnum? (car b)))
468 
+	  (> (the-fixnum (car b)) (the-fixnum m)))
469 
+      (prim.bin-read-error)
470 
+      (make-haskell-tuple2 (car b) (cdr b))))
471 
+
472 
+(define (prim.append-bin x y)
473 
+  (append x y))
474 
+
475 
+
476 
+;;; String primitives
477 
+
478 
+;;; Calls to prim.string-eq are generated by the CFN to pattern match
479 
+;;; against string constants.  So normally one of the arguments will be
480 
+;;; a constant string.  Treat this case specially to avoid consing up
481 
+;;; a haskell string whenever it's called.
482 
+;;; This function is strict in both its arguments.
483 
+
484 
+(define-syntax (prim.string-eq s1 s2)
485 
+  (cond ((and (pair? s1)
486 
+	      (eq? (car s1) 'make-haskell-string))
487 
+	 `(prim.string-eq-inline ,(cadr s1) 0 ,(string-length (cadr s1)) ,s2))
488 
+	((and (pair? s2)
489 
+	      (eq? (car s2) 'make-haskell-string))
490 
+	 `(prim.string-eq-inline ,(cadr s2) 0 ,(string-length (cadr s2)) ,s1))
491 
+	(else
492 
+	 `(prim.string-eq-notinline ,s1 ,s2))))
493 
+
494 
+(define (prim.string-eq-inline lisp-string i n haskell-string)
495 
+  (declare (type fixnum i n))
496 
+  (cond ((eqv? i n)
497 
+	 ;; Reached end of Lisp string constant -- better be at the end
498 
+	 ;; of the Haskell string, too.
499 
+	 (if (null? haskell-string) '#t '#f))
500 
+	((null? haskell-string)
501 
+	 ;; The Haskell string is too short.
502 
+	 '#f)
503 
+	((eqv? (the fixnum (char->integer (string-ref lisp-string i)))
504 
+	       (the fixnum (force (car haskell-string))))
505 
+	 ;; Next characters match, recurse
506 
+	 (prim.string-eq-inline
507 
+	   lisp-string (the fixnum (+ i 1)) n (force (cdr haskell-string))))
508 
+	(else
509 
+	 ;; No match
510 
+	 '#f)))
511 
+
512 
+(define (prim.string-eq-notinline s1 s2)
513 
+  (cond ((null? s1)
514 
+	 ;; Reached end of first string.
515 
+	 (if (null? s2) '#t '#f))
516 
+	((null? s2)
517 
+	 ;; Second string too short.
518 
+	 '#f)
519 
+	((eqv? (the fixnum (force (car s1))) (the fixnum (force (car s2))))
520 
+	 (prim.string-eq-notinline (force (cdr s1)) (force (cdr s2))))
521 
+	(else
522 
+	 '#f)))
523 
+
524 
+
525 
+;;; List primitives
526 
+
527 
+
528 
+;;; The first argument is strict and the second is a delay.
529 
+
530 
+(define-syntax (prim.append l1 l2)
531 
+  (cond ((and (pair? l1)
532 
+	      (eq? (car l1) 'make-haskell-string))
533 
+	 `(make-haskell-string-tail ,(cadr l1) ,l2))
534 
+	((equal? l1 ''())
535 
+	 `(force ,l2))
536 
+	((equal? l2 '(box '()))
537 
+	 l1)
538 
+	;; *** could also look for
539 
+	;; *** (append (cons x (box y)) z) => (cons x (box (append y z)))
540 
+	;; *** but I don't think this happens very often anyway
541 
+	(else
542 
+	 `(prim.append-aux ,l1 ,l2))))
543 
+
544 
+(define (prim.append-aux l1 l2)
545 
+  (cond ((null? l1)
546 
+	 (force l2))
547 
+	((and (forced? l2) (eq? (unbox l2) '()))
548 
+	 ;; Appending nil is identity.
549 
+	 l1)
550 
+	((forced? (cdr l1))
551 
+	 ;; Append eagerly if the tail of the first list argument has
552 
+         ;; already been forced.
553 
+	 (cons (car l1)
554 
+	       (if (null? (unbox (cdr l1)))
555 
+		   l2  ; don't force this!!
556 
+		   (box (prim.append-aux (unbox (cdr l1)) l2)))))
557 
+	(else
558 
+	 (cons (car l1) (delay (prim.append-aux (force (cdr l1)) l2))))
559 
+	))
560 
+
561 
+
562 
+;;; Both arguments are forced here.  Have to be careful not to call
563 
+;;; recursively with an argument of 0.
564 
+;;; *** This is no longer used.
565 
+
566 
+(define (prim.take n l)
567 
+  (declare (type fixnum n))
568 
+  (cond ((not (pair? l))
569 
+	 '())
570 
+	((eqv? n 1)
571 
+	 ;; Only one element to take.
572 
+	 (cons (car l) (box '())))
573 
+	((forced? (cdr l))
574 
+	 ;; Take eagerly if the tail of the list has already been forced.
575 
+	 (cons (car l) (box (prim.take (- n 1) (unbox (cdr l))))))
576 
+	(else
577 
+	 (cons (car l) (delay (prim.take (- n 1) (force (cdr l))))))
578 
+	))
579 
+
580 
+
581 
+;;; The optimizer gets rid of all first-order calls to these functions.
582 
+
583 
+(define (prim.foldr k z l)
584 
+  ;; k and z are nonstrict, l is strict
585 
+  (if (null? l)
586 
+      (force z)
587 
+      (funcall (force k)
588 
+	       (car l)
589 
+	       (delay (prim.foldr k z (force (cdr l)))))))
590 
+
591 
+(define (prim.build g)
592 
+  ;; g is strict
593 
+  (funcall g
594 
+	   (box (function make-cons-constructor))
595 
+	   (box '())))
runtime/runtime-utils.scm
History View file @ 4e98702
0 596 
new file mode 100644
... ... 
@@ -0,0 +1,384 @@
1 
+;;; runtime-utils.scm -- basic runtime support
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  9 Jun 1992
5 
+;;;
6 
+;;; This file contains definitions (beyond the normal mumble stuff)
7 
+;;; that is referenced directly in code built by the code generator.
8 
+;;; See backend/codegen.scm.
9 
+;;;
10 
+
11 
+
12 
+
13 
+;;; (delay form)
14 
+;;;   returns a delay object with unevaluated "form".
15 
+
16 
+(define-syntax (delay form)
17 
+  `(cons '#f (lambda () ,form)))
18 
+
19 
+
20 
+;;; (box form)
21 
+;;;   returns a delay object with evaluated "form".
22 
+
23 
+(define-syntax (box form)
24 
+  (cond ((number? form)
25 
+	 `(quote ,(cons '#t form)))
26 
+	((and (pair? form) (eq? (car form) 'quote))
27 
+	 `(quote ,(cons '#t (cadr form))))
28 
+	(else
29 
+	 `(cons '#t ,form))))
30 
+
31 
+(define-syntax (unbox form)
32 
+  `(cdr ,form))
33 
+
34 
+(define-syntax (forced? form)
35 
+  `(car ,form))
36 
+
37 
+
38 
+;;; (force delay)
39 
+;;;   return the value of the delay object.
40 
+
41 
+(define (force delay-object)
42 
+  (declare (type pair delay-object))
43 
+  (if (car delay-object)
44 
+      (cdr delay-object)
45 
+      (begin
46 
+        (let ((result  (funcall (cdr delay-object))))
47 
+	  (setf (car delay-object) '#t)
48 
+	  (setf (cdr delay-object) result)))))
49 
+
50 
+;;; Inline version of the above.  Not good to use everywhere because
51 
+;;; of code bloat problems, but handy for helper functions.
52 
+
53 
+(define-syntax (force-inline delay-object)
54 
+  (let ((temp1  (gensym))
55 
+	(temp2  (gensym)))
56 
+    `(let ((,temp1  ,delay-object))
57 
+       (declare (type pair ,temp1))
58 
+       (if (car ,temp1)
59 
+	   (cdr ,temp1)
60 
+	   (let ((,temp2  (funcall (cdr ,temp1))))
61 
+	     (setf (car ,temp1) '#t)
62 
+	     (setf (cdr ,temp1) ,temp2))))))
63 
+
64 
+
65 
+;;; (make-curried-fn opt-fn strictness)
66 
+;;; The basic idea is to compare the number of arguments received against
67 
+;;; the number expected.
68 
+;;; If the same, call the optimized entry point opt-fn.
69 
+;;; If more, apply the result of calling the optimized entry to the
70 
+;;;   leftover arguments.
71 
+;;; If less, make a closure that accepts the additional arguments.
72 
+
73 
+(define (make-curried-fn opt-fn strictness)
74 
+  (lambda args
75 
+    (curried-fn-body '() args opt-fn strictness)))
76 
+
77 
+(define (curried-fn-body previous-args args opt-fn strictness)
78 
+  (multiple-value-bind
79 
+      (saturated? actual-args leftover-args leftover-strictness)
80 
+      (process-curried-fn-args strictness args '())
81 
+    (setf actual-args (append previous-args actual-args))
82 
+    (if saturated?
83 
+	(if (null? leftover-args)
84 
+	    (apply opt-fn actual-args)
85 
+	    (apply (apply opt-fn actual-args) leftover-args))
86 
+	(lambda more-args
87 
+	  (curried-fn-body actual-args more-args opt-fn leftover-strictness)))
88 
+    ))
89 
+
90 
+(define (process-curried-fn-args strictness args actual-args)
91 
+  (cond ((null? strictness)
92 
+	 ;; At least as many arguments as expected.
93 
+	 (values '#t (nreverse actual-args) args strictness))
94 
+	((null? args)
95 
+	 ;; Not enough arguments supplied.
96 
+  	 (values '#f (nreverse actual-args) args strictness))
97 
+	(else
98 
+	 ;; Process the next argument.
99 
+	 (if (car strictness)
100 
+	     (push (force-inline (car args)) actual-args)
101 
+	     (push (car args) actual-args))
102 
+ 	 (process-curried-fn-args (cdr strictness) (cdr args) actual-args))
103 
+	))
104 
+
105 
+
106 
+;;; Special cases of the above.
107 
+
108 
+(define (make-curried-fn-1-strict opt-fn)
109 
+  (lambda (arg1 . moreargs)
110 
+    (setf arg1 (force-inline arg1))
111 
+    (if (null? moreargs)
112 
+	(funcall opt-fn arg1)
113 
+	(apply (funcall opt-fn arg1) moreargs))))
114 
+
115 
+(define (make-curried-fn-1-nonstrict opt-fn)
116 
+  (lambda (arg1 . moreargs)
117 
+    (if (null? moreargs)
118 
+	(funcall opt-fn arg1)
119 
+	(apply (funcall opt-fn arg1) moreargs))))
120 
+
121 
+
122 
+;;; Here's a similar helper function used for making data constructors.
123 
+
124 
+(define (constructor-body previous-args args arity fn)
125 
+  (declare (type fixnum arity))
126 
+  (let ((n  (length args)))
127 
+    (declare (type fixnum n))
128 
+    (setf args (append previous-args args))
129 
+    (cond ((eqv? n arity)
130 
+	   (apply fn args))
131 
+	  ((< n arity)
132 
+	   (lambda more-args
133 
+	     (constructor-body args more-args (- arity n) fn)))
134 
+	  (else
135 
+	   (error "Too many arguments supplied to constructor.")))))
136 
+
137 
+
138 
+;;; Special case for cons constructor
139 
+
140 
+(define (make-cons-constructor . args)
141 
+  (constructor-body '() args 2 (function cons)))
142 
+
143 
+
144 
+;;; (make-tuple-constructor arity)
145 
+;;;   return a function that makes an untagged data structure with "arity"
146 
+;;;   slots.  "arity" is a constant.
147 
+
148 
+(define-integrable *max-predefined-tuple-arity* 10)
149 
+
150 
+(define (make-tuple-constructor-aux arity)
151 
+  (cond ((eqv? arity 0)
152 
+	 ;; Actually, should never happen -- this is the unit constructor
153 
+	 0)
154 
+	((eqv? arity 1)
155 
+	 (lambda args
156 
+	   (constructor-body '() args 2 (lambda (x) x))))
157 
+	((eqv? arity 2)
158 
+	 (lambda args
159 
+	   (constructor-body '() args 2 (function cons))))
160 
+	(else
161 
+	 (lambda args
162 
+	   (constructor-body '() args arity (function vector))))))
163 
+
164 
+(define *predefined-tuple-constructors*
165 
+  (let ((result  '()))
166 
+    (dotimes (i *max-predefined-tuple-arity*)
167 
+      (push (make-tuple-constructor-aux i) result))
168 
+    (list->vector (nreverse result))))
169 
+
170 
+(define-syntax (make-tuple-constructor arity)
171 
+  (declare (type fixnum arity))
172 
+  (if (< arity *max-predefined-tuple-arity*)
173 
+      `(vector-ref *predefined-tuple-constructors* ,arity)
174 
+      `(make-tuple-constructor-aux ,arity)))
175 
+
176 
+
177 
+;;; (make-tuple . args)
178 
+;;;   uncurried version of the above
179 
+
180 
+(define-syntax (make-tuple . args)
181 
+  (let ((arity  (length args)))
182 
+    (cond ((eqv? arity 0)
183 
+	   ;; Actually, should never happen -- this is the unit constructor
184 
+	   0)
185 
+	  ((eqv? arity 1)
186 
+	   (car args))
187 
+	  ((eqv? arity 2)
188 
+	   `(cons ,@args))
189 
+	  (else
190 
+	   `(vector ,@args)))))
191 
+
192 
+
193 
+;;; (make-tagged-data-constructor n arity)
194 
+;;;   return a function that makes a data structure with tag "n" and
195 
+;;;   "arity" slots.
196 
+
197 
+(define-integrable *max-predefined-tagged-data-tag* 10)
198 
+(define-integrable *max-predefined-tagged-data-arity* 10)
199 
+
200 
+(define (make-tagged-data-constructor-aux n arity)
201 
+  (if (eqv? arity 0)
202 
+      (vector n)
203 
+      (lambda args
204 
+	(constructor-body (list n) args arity (function vector)))))
205 
+
206 
+(define *predefined-tagged-data-constructors*
207 
+  (let ((result  '()))
208 
+    (dotimes (i *max-predefined-tagged-data-arity*)
209 
+      (let ((inner-result  '()))
210 
+	(dotimes (j *max-predefined-tagged-data-tag*)
211 
+	  (push (make-tagged-data-constructor-aux j i) inner-result))
212 
+	(push (list->vector (nreverse inner-result)) result)))
213 
+    (list->vector (nreverse result))))
214 
+
215 
+(define-syntax (make-tagged-data-constructor n arity)
216 
+  (declare (type fixnum arity n))
217 
+  (if (and (< arity *max-predefined-tagged-data-arity*)
218 
+	   (< n *max-predefined-tagged-data-tag*))
219 
+      `(vector-ref (vector-ref *predefined-tagged-data-constructors* ,arity)
220 
+		   ,n)
221 
+      `(make-tagged-data-constructor-aux ,n ,arity)))
222 
+
223 
+
224 
+;;; (make-tagged-data n . args)
225 
+;;;   uncurried version of the above
226 
+
227 
+(define-syntax (make-tagged-data n . args)
228 
+  `(vector ,n ,@args))
229 
+
230 
+
231 
+;;; (tuple-select arity i object)
232 
+;;;   extract component "i" from untagged "object"
233 
+
234 
+(define-syntax (tuple-select arity i object)
235 
+  (cond ((eqv? arity 1)
236 
+	 object)
237 
+	((eqv? arity 2)
238 
+	 (if (eqv? i 0)
239 
+	     `(car ,object)
240 
+	     `(cdr ,object)))
241 
+	(else
242 
+	 `(vector-ref (the vector ,object) (the fixnum ,i)))))
243 
+
244 
+
245 
+;;; (tagged-data-select arity i object)
246 
+;;;   extract component "i" from tagged "object"
247 
+
248 
+(define-syntax (tagged-data-select arity i object)
249 
+  (declare (ignore arity))
250 
+  `(vector-ref (the vector ,object) (the fixnum ,(1+ i))))
251 
+
252 
+
253 
+;;; (constructor-number object)
254 
+;;;   return the tag from "object"
255 
+
256 
+(define-syntax (constructor-number object)
257 
+  `(vector-ref (the vector ,object) 0))
258 
+
259 
+(define-syntax (funcall-force fn . args)
260 
+  (let* ((n    (length args))
261 
+	 (junk (assv n '((1 . funcall-force-1)
262 
+			 (2 . funcall-force-2)
263 
+			 (3 . funcall-force-3)
264 
+			 (4 . funcall-force-4)))))
265 
+    `(,(if junk (cdr junk) 'funcall-force-n) ,fn ,@args)))
266 
+
267 
+(define (funcall-force-1 fn a1)
268 
+  (funcall (force-inline fn) a1))
269 
+(define (funcall-force-2 fn a1 a2)
270 
+  (funcall (force-inline fn) a1 a2))
271 
+(define (funcall-force-3 fn a1 a2 a3)
272 
+  (funcall (force-inline fn) a1 a2 a3))
273 
+(define (funcall-force-4 fn a1 a2 a3 a4)
274 
+  (funcall (force-inline fn) a1 a2 a3 a4))
275 
+(define-syntax (funcall-force-n fn . args)
276 
+  `(funcall (force ,fn) ,@args))
277 
+
278 
+
279 
+;;; (make-haskell-string string)
280 
+;;;   Converts a Lisp string lazily to a boxed haskell string (makes
281 
+;;;   a delay with a magic function).  Returns an unboxed result.
282 
+
283 
+(define (make-haskell-string string)
284 
+  (declare (type string string))
285 
+  (let ((index   1)
286 
+	(size    (string-length string)))
287 
+    (declare (type fixnum index size))
288 
+    (cond ((eqv? size 0)
289 
+	   '())
290 
+	  ((eqv? size 1)
291 
+	   (cons (box (char->integer (string-ref string 0)))
292 
+		 (box '())))
293 
+	  (else
294 
+	   (letrec ((next-fn
295 
+		      (lambda ()
296 
+			(let ((ch  (char->integer (string-ref string index))))
297 
+			  (incf index)
298 
+			  (cons (box ch)
299 
+				(if (eqv? index size)
300 
+				    (box '())
301 
+				    (cons '#f next-fn)))))))
302 
+	     (cons (box (char->integer (string-ref string 0)))
303 
+		   (cons '#f next-fn))))
304 
+	  )))
305 
+
306 
+
307 
+;;; Similar, but accepts an arbitrary tail (which must be a delay object)
308 
+
309 
+(define (make-haskell-string-tail string tail-delay)
310 
+  (declare (type string string))
311 
+  (let ((index   1)
312 
+	(size    (string-length string)))
313 
+    (declare (type fixnum index size))
314 
+    (cond ((eqv? size 0)
315 
+	   (force-inline tail-delay))
316 
+	  ((eqv? size 1)
317 
+	   (cons (box (char->integer (string-ref string 0)))
318 
+		 tail-delay))
319 
+	  (else
320 
+	   (letrec ((next-fn
321 
+		      (lambda ()
322 
+			(let ((ch  (char->integer (string-ref string index))))
323 
+			  (incf index)
324 
+			  (cons (box ch)
325 
+				(if (eqv? index size)
326 
+				    tail-delay
327 
+				    (cons '#f next-fn)))))))
328 
+	     (cons (box (char->integer (string-ref string 0)))
329 
+		   (cons '#f next-fn))))
330 
+	  )))
331 
+
332 
+
333 
+(define (haskell-string->string s)
334 
+  (let ((length  0))
335 
+    (declare (type fixnum length))
336 
+    (do ((s s (force (cdr s))))
337 
+	((null? s))
338 
+	(setf length (+ length 1)))
339 
+    (let ((result  (make-string length)))
340 
+      (declare (type string result))
341 
+      (do ((s s (unbox (cdr s)))
342 
+	   (i 0 (+ i 1)))
343 
+	  ((null? s))
344 
+	  (declare (type fixnum i))
345 
+	  (setf (string-ref result i) (integer->char (force (car s)))))
346 
+      result)))
347 
+
348 
+
349 
+(define (print-haskell-string s port)
350 
+   (do ((s1 s (force (cdr s1))))
351 
+       ((null? s1))
352 
+     (write-char (integer->char (force (car s1))) port)))
353 
+
354 
+;;; This explicates the value returned by a proc (the IO () type).
355 
+
356 
+(define (insert-unit-value x)
357 
+  (declare (ignore x))
358 
+  0)
359 
+
360 
+;;; These handle list conversions
361 
+
362 
+(define (haskell-list->list fn l)
363 
+  (if (null? l)
364 
+      '()
365 
+      (cons (funcall fn (force (car l)))
366 
+	    (haskell-list->list fn (force (cdr l))))))
367 
+
368 
+(define (list->haskell-list fn l)
369 
+  (if (null? l)
370 
+      '()
371 
+      (cons (box (funcall fn (car l)))
372 
+	    (box (list->haskell-list fn (cdr l))))))
373 
+
374 
+(define (haskell-list->list/identity l)
375 
+  (if (null? l)
376 
+      '()
377 
+      (cons (force (car l))
378 
+	    (haskell-list->list/identity (force (cdr l))))))
379 
+
380 
+(define (list->haskell-list/identity l)
381 
+  (if (null? l)
382 
+      '()
383 
+      (cons (box (car l))
384 
+	    (box (list->haskell-list/identity (cdr l))))))
runtime/runtime.scm
History View file @ 4e98702
0 385 
new file mode 100644
... ... 
@@ -0,0 +1,26 @@
1 
+;;; runtime.scm
2 
+;;;
3 
+;;; author :  John
4 
+;;;
5 
+
6 
+
7 
+(define-compilation-unit runtime
8 
+  (source-filename "$Y2/runtime/")
9 
+  (require global)
10 
+  (unit runtime-utils
11 
+	(source-filename "runtime-utils.scm"))
12 
+  (unit prims
13 
+	(require runtime-utils)
14 
+	(source-filename "prims.scm"))
15 
+  (unit io-primitives
16 
+	(require runtime-utils)
17 
+	(source-filename "io-primitives.scm"))
18 
+  (unit array-prims
19 
+	(require runtime-utils)
20 
+	(source-filename "array-prims.scm"))
21 
+  (unit debug-utils
22 
+	(require runtime-utils)
23 
+	(source-filename "debug-utils.scm"))
24 
+  (unit tuple-prims
25 
+        (require runtime-utils)
26 
+	(source-filename "tuple-prims.scm")))
runtime/tuple-prims.scm
History View file @ 4e98702
0 27 
new file mode 100644
... ... 
@@ -0,0 +1,86 @@
1 
+;; these primitives support arbitrary sized tuples.
2 
+
3 
+(define (prim.tupleSize x)
4 
+  (vector-length x))
5 
+
6 
+(define (prim.tupleSel tuple i n)
7 
+ (force
8 
+  (if (eqv? n 2)
9 
+      (if (eqv? i 0)
10 
+	  (car tuple)
11 
+	  (cdr tuple))
12 
+      (vector-ref tuple i))))
13 
+
14 
+(define (prim.list->tuple l)
15 
+  (let ((l (haskell-list->list/non-strict l)))
16 
+    (if (null? (cddr l))
17 
+	(cons (car l) (cadr l))
18 
+	(list->vector l))))
19 
+
20 
+(define (haskell-list->list/non-strict l)
21 
+  (if (null? l)
22 
+      '()
23 
+      (cons (car l)
24 
+	    (haskell-list->list/non-strict (force (cdr l))))))
25 
+
26 
+(define (prim.dict-sel dicts i)
27 
+  (force (vector-ref dicts i)))
28 
+
29 
+;;; These generate dictionaries.
30 
+
31 
+(define-local-syntax (create-dict dicts vars other-dicts)
32 
+  `(let ((dict-vector (box (list->vector ,dicts))))
33 
+     (make-tuple
34 
+       ,@(map (lambda (v)
35 
+		`(delay (funcall (dynamic ,v) dict-vector)))
36 
+	   vars)
37 
+       ,@(map (lambda (sd)
38 
+		`(delay (,(car sd)
39 
+			 (map (lambda (d)
40 
+			       (tuple-select ,(cadr sd) ,(caddr sd) (force d)))
41 
+			      ,dicts))))
42 
+	      other-dicts))))
43 
+
44 
+(define prim.tupleEqdict
45 
+  (lambda dicts
46 
+    (tupleEqDict/l dicts)))
47 
+
48 
+(define (tupleEqDict/l dicts)
49 
+  (create-dict dicts
50 
+     (|PreludeTuple:tupleEq| |PreludeTuple:tupleNeq|)
51 
+     ()))
52 
+
53 
+(define prim.tupleOrdDict
54 
+ (lambda dicts
55 
+   (tupleOrdDict/l dicts)))
56 
+
57 
+(define (tupleOrdDict/l d)
58 
+  (create-dict d
59 
+   (|PreludeTuple:tupleLe| |PreludeTuple:tupleLeq|
60 
+    |PreludeTuple:tupleGe| |PreludeTuple:tupleGeq|
61 
+    |PreludeTuple:tupleMax| |PreludeTuple:tupleMin|)
62 
+   ((tupleEqDict/l 7 6))))
63 
+
64 
+(define prim.tupleIxDict
65 
+ (lambda dicts
66 
+   (create-dict dicts
67 
+      (|PreludeTuple:tupleRange| |PreludeTuple:tupleIndex|
68 
+       |PreludeTuple:tupleInRange|)
69 
+      ((tupleEqDict/l 6 3) (tupleTextDict/l 6 4) (tupleOrdDict/l 6 5)))))
70 
+
71 
+(define prim.tupleTextDict
72 
+ (lambda dicts
73 
+   (tupleTextDict/l dicts)))
74 
+
75 
+(define (tupleTextDict/l d)
76 
+  (create-dict d
77 
+     (|PreludeTuple:tupleReadsPrec| |PreludeTuple:tupleShowsPrec|
78 
+      |PreludeTuple:tupleReadList| |PreludeTuple:tupleShowList|)
79 
+     ()))
80 
+
81 
+(define prim.tupleBinaryDict
82 
+ (lambda dicts
83 
+   (create-dict dicts
84 
+    (|PreludeTuple:tupleReadBin| |PreludeTuple:tupleShowBin|)
85 
+    ())))
86 
+
support/README
History View file @ 4e98702
0 87 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+This directory contains utilities that are layered on top of the basic
2 
+mumble support stuff.  There should be no T-specific or CL-specific
3 
+code in this area.
4 
+
support/compile.scm
History View file @ 4e98702
0 5 
new file mode 100644
... ... 
@@ -0,0 +1,447 @@
1 
+;;; compile.scm -- compilation utilities
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  24 Oct 1991
5 
+;;;
6 
+;;; This file defines a makefile-like compilation system that supports
7 
+;;; a hierarchy of dependencies.
8 
+;;; The external entry points are define-compilation-unit, load-unit, and
9 
+;;; compile-and-load-unit.
10 
+
11 
+
12 
+
13 
+;;;=====================================================================
14 
+;;; Parsing
15 
+;;;=====================================================================
16 
+
17 
+
18 
+;;; Establish global defaults for filenames.
19 
+
20 
+(define compile.source-filename source-file-type)
21 
+(define compile.binary-filename binary-file-type)
22 
+(define compile.binary-subdir (string-append lisp-implementation-name "/"))
23 
+(define compile.delayed-loads '())
24 
+
25 
+
26 
+;;; Top level units are stored in this table.
27 
+;;; This is really a slight wart on the whole scheme of things; this
28 
+;;; is done instead of storing the top-level units in variables because
29 
+;;; we were getting unintentional name collisions.
30 
+
31 
+(define compile.unit-table (make-table))
32 
+
33 
+(define-syntax (compile.lookup-unit name)
34 
+  `(table-entry compile.unit-table ,name))
35 
+
36 
+(define (mung-global-units names lexical-units)
37 
+  (map (lambda (n)
38 
+	 (if (memq n lexical-units)
39 
+	     n
40 
+	     `(compile.lookup-unit ',n)))
41 
+       names))
42 
+
43 
+
44 
+;;; Top-level compilation units are defined with define-compilation-unit.
45 
+;;; The body can consist of the following clauses:
46 
+;;;
47 
+;;; (source-filename <filename>)
48 
+;;; (binary-filename <filename>)
49 
+;;;   Specify source and/or binary file names.  For nested units, these
50 
+;;;   are merged with defaults from outer units.  If you don't specify
51 
+;;;   an explicit binary filename, it's inherited from the source file
52 
+;;;   name.
53 
+;;; (require ...)
54 
+;;;   Specify compile/load dependencies.  Arguments are names of other
55 
+;;;   units/component files; these names have scoping like let*, so a unit
56 
+;;;   can require previously listed units at the same or outer level.
57 
+;;; (unit name ....)
58 
+;;;   Specifies a nested unit.  This can appear multiple times.
59 
+;;;   If a unit doesn't include any nested units, then it's a leaf
60 
+;;;   consisting of a single source file.
61 
+;;; (load <boolean>)
62 
+;;;   If supplied and false, the unit isn't loaded unless it is needed
63 
+;;;   to satisfy a require clause.  Used for files containing compilation
64 
+;;;   support stuff.
65 
+;;; (compile <boolean>)
66 
+;;;   If supplied and false, the unit isn't compiled.  Only useful for
67 
+;;;   leaf nodes.  Typically used in combination with (load '#f) to suppress
68 
+;;;   compilation of stuff only used at compile time.
69 
+
70 
+(define-syntax (define-compilation-unit name . clauses)
71 
+  `(begin
72 
+     (let ((unit  ,(compile.process-unit-spec name clauses '#t '())))
73 
+       (setf (compile.lookup-unit ',name) unit)
74 
+       (setf compilation-units (append compilation-units (list unit))))
75 
+     ',name))
76 
+
77 
+
78 
+;;; The basic approach is to turn the compilation unit definition into
79 
+;;; a big LET*, and put calls to build the actual unit object inside
80 
+;;; of this.
81 
+;;;
82 
+
83 
+(define (compile.process-unit-spec name clauses top-level? lexical-units)
84 
+  (multiple-value-bind
85 
+      (source-filename binary-filename require nested-units
86 
+		       load? compile?)
87 
+      (compile.parse-unit-spec clauses lexical-units)
88 
+    `(let* ((compile.source-filename ,source-filename)
89 
+	    (compile.binary-filename ,binary-filename)
90 
+	    (compile.unit-require    (list ,@require))
91 
+	    (compile.delayed-loads   (append compile.delayed-loads
92 
+					     (compile.select-delayed-loads
93 
+						     compile.unit-require)))
94 
+	    ,@nested-units)
95 
+       (make compile.unit
96 
+	     (name ',name)
97 
+	     (source-filename compile.source-filename)
98 
+	     (binary-filename compile.binary-filename)
99 
+	     (components (list ,@(map (function car) nested-units)))
100 
+	     (require compile.unit-require)
101 
+	     (top-level? ',top-level?)
102 
+	     (load? ,load?)
103 
+	     (compile? ,compile?)
104 
+	     (delayed-loads compile.delayed-loads)))))
105 
+
106 
+(define (compile.parse-unit-spec clauses lexical-units)
107 
+  (let ((source-filename  '#f)
108 
+	(binary-filename  '#f)
109 
+	(require          '#f)
110 
+	(nested-units     '())
111 
+	(load?            ''#t)
112 
+	(compile?         ''#t))
113 
+    (dolist (c clauses)
114 
+      (cond ((not (pair? c))
115 
+	     (compile.unit-syntax-error c))
116 
+	    ((eq? (car c) 'source-filename)
117 
+	     (if source-filename
118 
+		 (compile.unit-duplicate-error c)
119 
+		 (setf source-filename (cadr c))))
120 
+	    ((eq? (car c) 'binary-filename)
121 
+	     (if binary-filename
122 
+		 (compile.unit-duplicate-error c)
123 
+		 (setf binary-filename (cadr c))))
124 
+	    ((eq? (car c) 'require)
125 
+	     (if require
126 
+		 (compile.unit-duplicate-error c)
127 
+		 (setf require (mung-global-units (cdr c) lexical-units))))
128 
+	    ((eq? (car c) 'unit)
129 
+	     (push (list (cadr c)
130 
+			 (compile.process-unit-spec (cadr c) (cddr c)
131 
+						    '#f lexical-units))
132 
+		   nested-units)
133 
+	     (push (cadr c) lexical-units))
134 
+	    ((eq? (car c) 'load)
135 
+	     (setf load? (cadr c)))
136 
+	    ((eq? (car c) 'compile)
137 
+	     (setf compile? (cadr c)))
138 
+	    (else
139 
+	     (compile.unit-syntax-error c))))
140 
+    (values
141 
+        (if source-filename
142 
+	    `(compile.merge-filenames ,source-filename
143 
+		     compile.source-filename '#f)
144 
+	    'compile.source-filename)
145 
+	(if binary-filename
146 
+	    `(compile.merge-filenames ,binary-filename
147 
+		     compile.binary-filename '#f)
148 
+	    (if source-filename
149 
+		'(compile.merge-filenames compile.binary-filename
150 
+			 compile.source-filename
151 
+			 compile.binary-subdir)
152 
+		'compile.binary-filename))
153 
+	(or require '())
154 
+	(nreverse nested-units)
155 
+	load?
156 
+	compile?)))
157 
+
158 
+
159 
+(predefine (error format . args))
160 
+
161 
+(define (compile.unit-syntax-error c)
162 
+  (error "Invalid compilation unit clause ~s." c))
163 
+
164 
+(define (compile.unit-duplicate-error c)
165 
+  (error "Duplicate compilation unit clause ~s." c))
166 
+
167 
+
168 
+
169 
+;;;=====================================================================
170 
+;;; Representation and utilities
171 
+;;;=====================================================================
172 
+
173 
+;;; Here are constructors and accessors for unit objects.
174 
+;;; Implementationally, the compilation unit has the following slots:
175 
+;;;
176 
+;;; * The unit name.
177 
+;;; * The source file name.
178 
+;;; * The binary file name.
179 
+;;; * A list of component file/units.
180 
+;;; * A list of units/files to require.
181 
+;;; * A load timestamp.
182 
+;;; * A timestamp to keep track of the newest source file.
183 
+;;; * Flags for compile and load.
184 
+
185 
+(define-struct compile.unit
186 
+  (predicate compile.unit?)
187 
+  (slots
188 
+    (name             (type symbol))
189 
+    (source-filename  (type string))
190 
+    (binary-filename  (type string))
191 
+    (components       (type list))
192 
+    (require          (type list))
193 
+    (top-level?       (type bool))
194 
+    (load?            (type bool))
195 
+    (compile?         (type bool))
196 
+    (delayed-loads    (type list))
197 
+    (load-time        (type (maybe integer)) (default '#f))
198 
+    (source-time      (type (maybe integer)) (default '#f))
199 
+    (last-update      (type (maybe integer)) (default 0))
200 
+    ))
201 
+
202 
+(define (compile.newer? t1 t2)
203 
+  (and t1
204 
+       t2
205 
+       (> t1 t2)))
206 
+
207 
+(define (compile.select-newest t1 t2)
208 
+  (if (compile.newer? t1 t2) t1 t2))
209 
+
210 
+(define (compile.get-source-time u)
211 
+  (let ((source-file  (compile.unit-source-filename u)))
212 
+    (if (file-exists? source-file)
213 
+	(file-write-date source-file)
214 
+	'#f)))
215 
+
216 
+(define (compile.get-binary-time u)
217 
+  (let ((binary-file  (compile.unit-binary-filename u)))
218 
+    (if (file-exists? binary-file)
219 
+	(file-write-date binary-file)
220 
+	'#f)))
221 
+
222 
+(define (compile.load-source u)
223 
+  (load (compile.unit-source-filename u))
224 
+  (setf (compile.unit-load-time u) (current-date)))
225 
+
226 
+(define (compile.load-binary u)
227 
+  (load (compile.unit-binary-filename u))
228 
+  (setf (compile.unit-load-time u) (current-date)))
229 
+
230 
+(define (compile.compile-and-load u)
231 
+  (let ((source-file  (compile.unit-source-filename u))
232 
+	(binary-file  (compile.unit-binary-filename u)))
233 
+    (compile-file source-file binary-file)
234 
+    (load binary-file)
235 
+    (setf (compile.unit-load-time u) (current-date))))
236 
+
237 
+(define (compile.do-nothing u)
238 
+  u)
239 
+
240 
+
241 
+;;;=====================================================================
242 
+;;; Runtime support for define-compilation-unit
243 
+;;;=====================================================================
244 
+
245 
+(define (compile.select-delayed-loads require)
246 
+  (let ((result  '()))
247 
+    (dolist (r require)
248 
+      (if (not (compile.unit-load? r))
249 
+	  (push r result)))
250 
+    (nreverse result)))
251 
+
252 
+(define (compile.merge-filenames fname1 fname2 add-subdir)
253 
+  (let ((place1  (filename-place fname1))
254 
+	(name1   (filename-name fname1))
255 
+	(type1   (filename-type fname1)))
256 
+    (assemble-filename
257 
+        (if (string=? place1 "")
258 
+	    (if add-subdir
259 
+		(string-append (filename-place fname2) add-subdir)
260 
+		fname2)
261 
+	    place1)
262 
+	(if (string=? name1 "") fname2 name1)
263 
+	(if (string=? type1 "") fname2 type1))))
264 
+
265 
+
266 
+
267 
+;;;=====================================================================
268 
+;;; Load operation
269 
+;;;=====================================================================
270 
+
271 
+;;; Load-unit and compile-and-load-unit are almost identical.  The only
272 
+;;; difference is that load-unit will load source files as necessary, while
273 
+;;; compile-and-load-unit will compile them and load binaries instead.
274 
+
275 
+(define (load-unit u)
276 
+  (compile.update-unit-source-times u '#f (current-date))
277 
+  (compile.load-unit-aux u))
278 
+
279 
+(define (compile.load-unit-aux u)
280 
+  (with-compilation-unit ()
281 
+    (compile.load-unit-recursive u '#f)))
282 
+
283 
+(define (compile-and-load-unit u)
284 
+  (compile.update-unit-source-times u '#f (current-date))
285 
+  (compile.compile-and-load-unit-aux u))
286 
+
287 
+(define (compile.compile-and-load-unit-aux u)
288 
+  (with-compilation-unit ()
289 
+    (compile.load-unit-recursive u '#t)))
290 
+
291 
+
292 
+;;; Load a bunch of compilation units as a group.  This is useful because
293 
+;;; it can prevent repeated lookups of file timestamps.  Basically, the
294 
+;;; assumption is that none of the source files will change while the loading
295 
+;;; is in progress.
296 
+;;; In case of an error, store the units left to be compiled in a global
297 
+;;; variable.
298 
+
299 
+(define remaining-units '())
300 
+
301 
+(define (load-unit-list l)
302 
+  (let ((timestamp  (current-date)))
303 
+    (dolist (u l)
304 
+      (compile.update-unit-source-times u '#f timestamp))
305 
+    (setf remaining-units l)
306 
+    (dolist (u l)
307 
+      (compile.load-unit-aux u)
308 
+      (pop remaining-units))))
309 
+
310 
+(define (compile-and-load-unit-list l)
311 
+  (let ((timestamp  (current-date)))
312 
+    (dolist (u l)
313 
+      (compile.update-unit-source-times u '#f timestamp))
314 
+    (setf remaining-units l)
315 
+    (dolist (u l)
316 
+      (compile.compile-and-load-unit-aux u)
317 
+      (pop remaining-units))))
318 
+
319 
+
320 
+;;; Walk the compilation unit, updating the source timestamps.
321 
+
322 
+(define (compile.update-unit-source-times u newest-require timestamp)
323 
+  (unless (eqv? timestamp (compile.unit-last-update u))
324 
+    (setf (compile.unit-last-update u) timestamp)
325 
+    (dolist (r (compile.unit-require u))
326 
+      (if (compile.unit-top-level? r)
327 
+	  (compile.update-unit-source-times r '#f timestamp))
328 
+      (setf newest-require
329 
+	    (compile.select-newest newest-require
330 
+				   (compile.unit-source-time r))))
331 
+    (let ((components  (compile.unit-components u)))
332 
+      (if (not (null? components))
333 
+	  (let ((source-time  newest-require))
334 
+	    (dolist (c components)
335 
+	      (compile.update-unit-source-times c newest-require timestamp)
336 
+	      (setf source-time
337 
+		    (compile.select-newest source-time
338 
+					   (compile.unit-source-time c))))
339 
+	    (setf (compile.unit-source-time u) source-time))
340 
+	  (setf (compile.unit-source-time u)
341 
+		(compile.select-newest
342 
+		  newest-require
343 
+		  (compile.get-source-time u)))))))
344 
+
345 
+
346 
+;;; Load a compilation unit.  Do this by first loading its require list,
347 
+;;; then by recursively loading each of its components, in sequence.
348 
+;;; Note that because of the way scoping of units works and the
349 
+;;; sequential nature of the load operation, only top-level
350 
+;;; units in the require list have to be loaded explicitly.
351 
+
352 
+(define (compile.load-unit-recursive u compile?)
353 
+  (let ((components       (compile.unit-components u)))
354 
+    ;; First recursively load dependencies.
355 
+    ;; No need to update time stamps again here.
356 
+    (dolist (r (compile.unit-require u))
357 
+      (if (compile.unit-top-level? r)
358 
+	  (compile.load-unit-aux r)))
359 
+    (if (not (null? components))
360 
+	;; Now recursively load subunits.
361 
+	(dolist (c components)
362 
+	  (unless (not (compile.unit-load? c))
363 
+	    (compile.load-unit-recursive c compile?)))
364 
+	;; For a leaf node, load either source or binary if necessary.
365 
+	(let ((source-time  (compile.unit-source-time u))
366 
+	      (binary-time  (compile.get-binary-time u))
367 
+	      (load-time    (compile.unit-load-time u)))
368 
+	  (cond ((compile.newer? load-time source-time)
369 
+		 ;; The module has been loaded since it was last changed,
370 
+		 ;; but maybe we want to compile it now.
371 
+		 (if (and compile?
372 
+			  (compile.unit-compile? u)
373 
+			  (compile.newer? source-time binary-time))
374 
+		     (begin
375 
+		       (compile.do-delayed-loads
376 
+			       (compile.unit-delayed-loads u)
377 
+			       compile?)
378 
+		       (compile.compile-and-load u))
379 
+		     (compile.do-nothing u)))
380 
+		((compile.newer? binary-time source-time)
381 
+		 ;; The binary is up-to-date, so load it.
382 
+		 (compile.load-binary u))
383 
+		(else
384 
+		 ;; The binary is out-of-date, so either load source or
385 
+		 ;; recompile the binary.
386 
+		 (compile.do-delayed-loads
387 
+			 (compile.unit-delayed-loads u)
388 
+			 compile?)
389 
+		 (if (and compile? (compile.unit-compile? u))
390 
+		     (compile.compile-and-load u)
391 
+		     (compile.load-source u)))
392 
+		)))))
393 
+
394 
+
395 
+(define (compile.do-delayed-loads units compile?)
396 
+  (dolist (u units)
397 
+    (compile.load-unit-recursive u compile?)))
398 
+
399 
+
400 
+
401 
+
402 
+;;;=====================================================================
403 
+;;; Extra stuff
404 
+;;;=====================================================================
405 
+
406 
+
407 
+;;; Reload a unit without testing to see if any of its dependencies are
408 
+;;; out of date.
409 
+
410 
+(define (reload-unit-source u)
411 
+  (let ((components  (compile.unit-components u)))
412 
+    (if (not (null? components))
413 
+	(dolist (c components)
414 
+	  (reload-unit-source c))
415 
+	(compile.load-source u))))
416 
+
417 
+(define (reload-unit-binary u)
418 
+  (let ((components  (compile.unit-components u)))
419 
+    (if (not (null? components))
420 
+	(dolist (c components)
421 
+	  (reload-unit-binary c))
422 
+	(compile.load-binary u))))
423 
+
424 
+
425 
+;;; Find a (not necessarily top-level) compilation unit with the given
426 
+;;; name.
427 
+
428 
+(define (find-unit name)
429 
+  (compile.find-unit-aux name compilation-units))
430 
+
431 
+(define (compile.find-unit-aux name units)
432 
+  (block find-unit-aux
433 
+    (dolist (u units '#f)
434 
+      (if (eq? name (compile.unit-name u))
435 
+	  (return-from find-unit-aux u)
436 
+	  (let* ((components (compile.unit-components u))
437 
+		 (result     (compile.find-unit-aux name components)))
438 
+	    (if result
439 
+		(return-from find-unit-aux result)))))))
440 
+
441 
+
442 
+;;; Combine the two above:  reload a compilation unit.
443 
+
444 
+(define-syntax (reload name)
445 
+  `(reload-unit-source
446 
+     (or (find-unit ',name)
447 
+	 (error "Couldn't find unit named ~s." ',name))))
support/format.scm
History View file @ 4e98702
0 448 
new file mode 100644
... ... 
@@ -0,0 +1,683 @@
1 
+;;; format.scm -- format function for Scheme
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  29 Oct 1991
5 
+;;;
6 
+;;;
7 
+;;; This code is adapted from the XP pretty printer originally written
8 
+;;; in Common Lisp by Dick Waters.  Here is the copyright notice attached
9 
+;;; to the original XP source file:
10 
+;;;
11 
+;;;------------------------------------------------------------------------
12 
+;;;
13 
+;;; Copyright 1989,1990 by the Massachusetts Institute of Technology,
14 
+;;; Cambridge, Massachusetts.
15 
+;;;
16 
+;;; Permission to use, copy, modify, and distribute this software and its
17 
+;;; documentation for any purpose and without fee is hereby granted,
18 
+;;; provided that this copyright and permission notice appear in all
19 
+;;; copies and supporting documentation, and that the name of M.I.T. not
20 
+;;; be used in advertising or publicity pertaining to distribution of the
21 
+;;; software without specific, written prior permission. M.I.T. makes no
22 
+;;; representations about the suitability of this software for any
23 
+;;; purpose.  It is provided "as is" without express or implied warranty.
24 
+;;;
25 
+;;;  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
26 
+;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
27 
+;;;  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
28 
+;;;  ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
29 
+;;;  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
30 
+;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
31 
+;;;  SOFTWARE.
32 
+;;;
33 
+;;;------------------------------------------------------------------------
34 
+;;;
35 
+
36 
+
37 
+;;; The stream argument can be #f, in which case a string is returned.
38 
+;;; If the stream is #t, (current-output-port) is used.
39 
+;;; We compile a string argument into a function and call the function.
40 
+;;; The only exception is if the string doesn't contain any ~ escapes;
41 
+;;; then we can treat it as a literal and just write it to the stream.
42 
+
43 
+(define (format stream string-or-fn . args)
44 
+  (cond ((not stream)
45 
+	 (call-with-output-string
46 
+	     (lambda (stream)
47 
+	       (apply (function format) stream string-or-fn args))))
48 
+	(else
49 
+	 (if (eq? stream '#t)
50 
+	     (setf stream (current-output-port)))
51 
+	 (when (string? string-or-fn)
52 
+	   (setf string-or-fn (xp.process-format-string string-or-fn)))
53 
+	 (if (string? string-or-fn)
54 
+	     (write-string string-or-fn stream)
55 
+	     (xp.maybe-initiate-xp-printing string-or-fn stream args))
56 
+	 '#f)))
57 
+
58 
+(define xp.format-string-cache (make-table))
59 
+
60 
+(define (xp.process-format-string string-or-fn)
61 
+  (cond ((not (string? string-or-fn)) string-or-fn)
62 
+	((not xp.format-string-cache)
63 
+	 (xp.maybe-compile-format-string string-or-fn))
64 
+	(else
65 
+	 (when (not (table? xp.format-string-cache))
66 
+	   (setf xp.format-string-cache (make-table)))
67 
+	 (let ((value
68 
+		   (table-entry xp.format-string-cache string-or-fn)))
69 
+	   (when (not value)
70 
+	     (setf value (xp.maybe-compile-format-string string-or-fn))
71 
+	     (setf (table-entry xp.format-string-cache string-or-fn)
72 
+		   value))
73 
+	   value))))
74 
+
75 
+
76 
+(define (xp.maybe-compile-format-string string)
77 
+  (let ((length  (string-length string)))
78 
+    (or (xp.simple-format-string? string 0 length)
79 
+	(let ((fn  (xp.parse-format-string string 0 length)))
80 
+	  (lambda (xp args)
81 
+	    (funcall fn xp args args))))))
82 
+
83 
+
84 
+;;; Try to detect format strings without fancy directives, that can be
85 
+;;; written with a call to  write-string.
86 
+;;; Can do simple transformations e.g. ~% => newline, ~~ => ~, etc.
87 
+
88 
+(define (xp.simple-format-string? s start end)
89 
+  (let ((twiddle  (string-position #\~ s start end)))
90 
+    (if (not twiddle)
91 
+	(if (eqv? start 0)
92 
+	    s
93 
+	    (substring s start end))
94 
+	(let ((char    (string-ref s (1+ twiddle))))
95 
+	  (cond ((eqv? char #\%)
96 
+		 (let ((tail (xp.simple-format-string? s (+ twiddle 2) end)))
97 
+		   (if tail
98 
+		       (string-append (substring s start twiddle)
99 
+				      (string #\newline)
100 
+				      tail)
101 
+		       '#f)))
102 
+		((eqv? char #\~)
103 
+		 (let ((tail (xp.simple-format-string? s (+ twiddle 2) end)))
104 
+		   (if tail
105 
+		       (string-append (substring s start (1+ twiddle))
106 
+				      tail)
107 
+		       '#f)))
108 
+		((eqv? char #\newline)
109 
+		 (let ((tail (xp.simple-format-string?
110 
+			         s
111 
+				 (xp.skip-whitespace s (+ twiddle 2) end)
112 
+				 end)))
113 
+		   (if tail
114 
+		       (string-append (substring s start twiddle)
115 
+				      tail)
116 
+		       '#f)))
117 
+		(else
118 
+		 '#f))))))
119 
+
120 
+(define (warning string-or-fn . args)
121 
+  (internal-warning (apply (function format) '#f string-or-fn args)))
122 
+
123 
+(define (error string-or-fn . args)
124 
+  (internal-error (apply (function format) '#f string-or-fn args)))
125 
+
126 
+
127 
+;;;=====================================================================
128 
+;;; Compiled format
129 
+;;;=====================================================================
130 
+
131 
+;;; Note that compiled format strings always print through xp streams even if
132 
+;;; they don't have any xp directives in them.  As a result, the compiled code
133 
+;;; can depend on the fact that the stream being operated on is an xp
134 
+;;; stream not an ordinary one.
135 
+
136 
+
137 
+;;; Parse a format string, returning a function to do the printing.
138 
+;;; The function is called with three arguments
139 
+;;;    * the xp stream
140 
+;;;    * the original argument list
141 
+;;;    * the argument list tail
142 
+;;; It should return the list of leftover, unprocessed arguments.
143 
+
144 
+(define (xp.parse-format-string string start end)
145 
+  (cond ((eqv? start end)
146 
+	 (function xp.format-finish))
147 
+	((eqv? (string-ref string start) #\~)
148 
+	 (xp.parse-format-string-dispatch string start end))
149 
+	(else
150 
+	 (let* ((next       (or (string-position #\~ string start end) end))
151 
+		(literal    (substring string start next))
152 
+		(count      (- next start))
153 
+		(continue   (xp.parse-format-string string next end))
154 
+		(newline?   (string-position #\newline literal 0 count)))
155 
+	   (if newline?
156 
+	       (lambda (xp args tail)
157 
+		 (xp.write-string+ literal xp 0 count)
158 
+		 (funcall continue xp args tail))
159 
+	       (lambda (xp args tail)
160 
+		 (xp.write-string++ literal xp 0 count)
161 
+		 (funcall continue xp args tail)))))
162 
+	))
163 
+
164 
+(define (xp.format-finish xp args tail)
165 
+  (declare (ignore xp args))
166 
+  tail)
167 
+
168 
+
169 
+;;; Functions for handling individual format specifiers are installed
170 
+;;; in this table.  They are called with these arguments:
171 
+;;; * the format string
172 
+;;; * the index of the next character
173 
+;;; * the index of the end of the format string
174 
+;;; * the list of parameters for the format specification
175 
+;;; * a boolean indicating whether the colon modifier was present
176 
+;;; * a boolean indicating whether the atsign modifier was present
177 
+;;; The handler is responsible for calling xp.parse-format-string to parse
178 
+;;; the rest of the format string, and returning a function.  (This has
179 
+;;; to be done by the individual handlers because some of them need to
180 
+;;; scan the format string for matching delimiters, etc.)
181 
+
182 
+;;; *** This probably isn't right, we assume characters can be compared
183 
+;;; *** with EQ? and used as table keys.
184 
+
185 
+(define xp.fn-table (make-table))
186 
+
187 
+(define (define-format char function)
188 
+  (setf (table-entry xp.fn-table (char-upcase char)) function)
189 
+  (setf (table-entry xp.fn-table (char-downcase char)) function))
190 
+
191 
+;;; Parse a ~ sequence from the format string and dispatch to the
192 
+;;; appropriate handler.
193 
+
194 
+(define (xp.parse-format-string-dispatch string start end)
195 
+  (multiple-value-bind (next params colon? atsign? char)
196 
+      (xp.parse-format-descriptor string start end)
197 
+    (let ((fn  (table-entry xp.fn-table char)))
198 
+      (if fn
199 
+	  (funcall fn string next end params colon? atsign?)
200 
+	  (error "Unrecognized format escape ~~~a." char)))))
201 
+
202 
+(define (xp.parse-format-descriptor string start end)
203 
+  (multiple-value-bind (params start)
204 
+      (xp.parse-format-parameters string start end)
205 
+    (let ((colon?    '#f)
206 
+	  (atsign?   '#f)
207 
+	  (char      '#f))
208 
+      (block parse-format-descriptor
209 
+	(do ()
210 
+	    ((xp.check-for-incomplete-format-string string start end))
211 
+	    (setf char (string-ref string start))
212 
+	    (incf start)
213 
+	    (cond ((eqv? char #\:)
214 
+		   (setf colon? '#t))
215 
+		  ((eqv? char #\@)
216 
+		   (setf atsign? '#t))
217 
+		  (else
218 
+		   (return-from parse-format-descriptor
219 
+		     (values start params colon? atsign? char)))
220 
+		))))))
221 
+
222 
+
223 
+;;; *** The stuff for V and # format parameters is disabled because
224 
+;;; *** it makes the handler functions hairier.  It's rarely used anyway,
225 
+;;; *** and you can get the same effect by consing up a format string
226 
+;;; *** on the fly if you really need to.
227 
+
228 
+(define (xp.parse-format-parameters string start end)
229 
+  (let ((params  '())
230 
+	(char    '#f))
231 
+    (incf start)  ; skip ~
232 
+    (block parse-format-parameters
233 
+      (do ()
234 
+	  ((xp.check-for-incomplete-format-string string start end))
235 
+	  (setf char (string-ref string start))
236 
+	  (cond ((char-numeric? char)
237 
+		 (multiple-value-bind (next value)
238 
+		     (xp.parse-format-number string start end 0)
239 
+		   (setf start next)
240 
+		   (push value params)))
241 
+		((eqv? char #\')
242 
+		 (push (string-ref string (1+ start)) params)
243 
+		 (setf start (+ start 2)))
244 
+		((or (eqv? char #\v) (eqv? char #\V))
245 
+		 (error "V format parameter not supported.")  ;***
246 
+		 (push 'value params)
247 
+		 (setf start (+ start 1)))
248 
+		((eqv? char #\#)
249 
+		 (error "# format parameter not supported.")  ;***
250 
+		 (push 'count params)
251 
+		 (setf start (+ start 1)))
252 
+		((eqv? char #\,)
253 
+		 (push '#f params))
254 
+		(else
255 
+		 (return-from parse-format-parameters
256 
+		   (values (nreverse params) start))))
257 
+	  (if (eqv? (string-ref string start) #\,)
258 
+	      (incf start))))))
259 
+
260 
+(define (xp.parse-format-number string start end value)
261 
+  (xp.check-for-incomplete-format-string string start end)
262 
+  (let* ((char    (string-ref string start))
263 
+	 (weight  (string-position char "0123456789" 0 10)))
264 
+    (if weight
265 
+	(xp.parse-format-number string (1+ start) end (+ (* value 10) weight))
266 
+	(values start value))))
267 
+
268 
+(define (xp.check-for-incomplete-format-string string start end)
269 
+  (if (eqv? start end)
270 
+      (error "Incomplete format string ~s." string)
271 
+      '#f))
272 
+
273 
+
274 
+;;; *** All of these format handlers probably ought to do more checking
275 
+;;; *** for the right number of parameters and not having colon? and
276 
+;;; *** atsign? supplied when they are not allowed.
277 
+
278 
+;;; ~A and ~S are the basic format directives.
279 
+
280 
+(define (xp.format-a string start end params colon? atsign?)
281 
+  (xp.format-a-s-helper string start end params colon? atsign? '#f))
282 
+(define-format #\a (function xp.format-a))
283 
+
284 
+(define (xp.format-s string start end params colon? atsign?)
285 
+  (xp.format-a-s-helper string start end params colon? atsign? '#t))
286 
+(define-format #\s (function xp.format-s))
287 
+
288 
+(define (xp.format-a-s-helper string start end params colon? atsign? escape?)
289 
+  (declare (ignore colon? atsign?))  ;***
290 
+  (let ((continuation  (xp.parse-format-string string start end)))
291 
+    (if (null? params)
292 
+	;; Do the simple, common case.
293 
+	(lambda (xp args tail)
294 
+	  (dynamic-let ((*print-escape*   escape?))
295 
+	    (xp.write+ (car tail) xp))
296 
+	  (funcall continuation xp args (cdr tail)))
297 
+	;; Do the hard case.
298 
+	(let* ((mincol   (or (and (not (null? params)) (pop params)) 0))
299 
+	       (colinc   (or (and (not (null? params)) (pop params)) 1))
300 
+	       (minpad   (or (and (not (null? params)) (pop params)) 0))
301 
+	       (padchar  (or (and (not (null? params)) (pop params)) #\space)))
302 
+	  (declare (ignore mincol colinc minpad padchar))  ;***
303 
+;;; *** I'm confused.  It seems like we have to print this to a string
304 
+;;; *** and then write the string to the XP stream along with the padding
305 
+;;; *** But won't switching to a new stream mess up circularity detection,
306 
+;;; *** indentation, etc?
307 
+	  (error "Unimplemented format option ~s!" string))
308 
+      )))
309 
+
310 
+
311 
+;;; ~W -> write
312 
+
313 
+(define (xp.format-w string start end params colon? atsign?)
314 
+  (declare (ignore params))
315 
+  (let ((continuation  (xp.parse-format-string string start end)))
316 
+    (cond ((and (not colon?) (not atsign?))
317 
+	   (lambda (xp args tail)
318 
+	     (xp.write+ (car tail) xp)
319 
+	     (funcall continuation xp args (cdr tail))))
320 
+	  ((and colon? (not atsign?))
321 
+	   (lambda (xp args tail)
322 
+	     (dynamic-let ((*print-pretty*  '#t))
323 
+	       (xp.write+ (car tail) xp))
324 
+	     (funcall continuation xp args (cdr tail))))
325 
+	  ((and (not colon?) atsign?)
326 
+	   (lambda (xp args tail)
327 
+	     (dynamic-let ((*print-level*  '#f)
328 
+			   (*print-length* '#f))
329 
+	       (xp.write+ (car tail) xp))
330 
+	     (funcall continuation xp args (cdr tail))))
331 
+	  ((and colon? atsign?)
332 
+	   (lambda (xp args tail)
333 
+	     (dynamic-let ((*print-level*  '#f)
334 
+			   (*print-length* '#f)
335 
+			   (*print-pretty* '#t))
336 
+	       (xp.write+ (car tail) xp))
337 
+	     (funcall continuation xp args (cdr tail))))
338 
+	  )))
339 
+(define-format #\w (function xp.format-w))
340 
+
341 
+
342 
+;;; Here are the directives for printing integers, ~D and friends.
343 
+
344 
+(define (xp.format-d string start end params colon? atsign?)
345 
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 10))
346 
+(define-format #\d (function xp.format-d))
347 
+
348 
+(define (xp.format-b string start end params colon? atsign?)
349 
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 2))
350 
+(define-format #\b (function xp.format-b))
351 
+
352 
+(define (xp.format-o string start end params colon? atsign?)
353 
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 8))
354 
+(define-format #\o (function xp.format-o))
355 
+
356 
+(define (xp.format-x string start end params colon? atsign?)
357 
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 16))
358 
+(define-format #\x (function xp.format-x))
359 
+
360 
+(define (xp.format-d-b-o-x-helper string start end params colon? atsign? radix)
361 
+  (let ((continuation  (xp.parse-format-string string start end)))
362 
+    (if (and (null? params) (not colon?) (not atsign?))
363 
+	;; Do the simple, common case.
364 
+	(lambda (xp args tail)
365 
+	  (dynamic-let ((*print-escape*  '#f)
366 
+			(*print-radix*   '#f)
367 
+			(*print-base*    radix))
368 
+	    (xp.write+ (car tail) xp))
369 
+	  (funcall continuation xp args (cdr tail)))
370 
+	;; Do the hard case.
371 
+	(let* ((mincol    (or (and (not (null? params)) (pop params)) 0))
372 
+	       (padchar   (or (and (not (null? params)) (pop params)) #\space))
373 
+	       (commachar (or (and (not (null? params)) (pop params)) #\,))
374 
+	       (commaint  (or (and (not (null? params)) (pop params)) 3)))
375 
+	  (declare (ignore mincol padchar commachar commaint))  ;***
376 
+	  ;; *** I'm too lazy to do this right now.
377 
+	  (error "Unimplemented format option ~s!" string)))))
378 
+
379 
+
380 
+(define (xp.format-r string start end params colon? atsign?)
381 
+  (if (not (null? params))
382 
+      (xp.format-d-b-o-x-helper string start end (cdr params)
383 
+			     colon? atsign? (car params))
384 
+      ;; *** The colon? and atsign? modifiers do weird things like
385 
+      ;; *** printing roman numerals.  I'm too lazy to do this until/unless
386 
+      ;; *** we have a real need for it.
387 
+      (error "Unimplemented format option ~s!" string)))
388 
+(define-format #\r (function xp.format-r))
389 
+
390 
+
391 
+;;; ~P -> plurals
392 
+
393 
+(define (xp.format-p string start end params colon? atsign?)
394 
+  (declare (ignore params))
395 
+  (let ((continuation  (xp.parse-format-string string start end)))
396 
+    (cond ((and (not colon?) (not atsign?))
397 
+	   (lambda (xp args tail)
398 
+	     (if (not (eqv? (car tail) 1))
399 
+		 (xp.write-char++ #\s xp))
400 
+	     (funcall continuation xp args (cdr tail))))
401 
+	  ((and colon? (not atsign?))
402 
+	   (lambda (xp args tail)
403 
+	     (setf tail (xp.back-up 1 args tail))
404 
+	     (if (not (eqv? (car tail) 1))
405 
+		 (xp.write-char++ #\s xp))
406 
+	     (funcall continuation xp args (cdr tail))))
407 
+	  ((and (not colon?) atsign?)
408 
+	   (lambda (xp args tail)
409 
+	     (if (eqv? (car tail) 1)
410 
+		 (xp.write-char++ #\y xp)
411 
+		 (begin
412 
+		   (xp.write-char++ #\i xp)
413 
+		   (xp.write-char++ #\e xp)
414 
+		   (xp.write-char++ #\s xp)))
415 
+	     (funcall continuation xp args (cdr tail))))
416 
+	  ((and colon? atsign?)
417 
+	   (lambda (xp args tail)
418 
+	     (setf tail (xp.back-up 1 args tail))
419 
+	     (if (eqv? (car tail) 1)
420 
+		 (xp.write-char++ #\y xp)
421 
+		 (begin
422 
+		   (xp.write-char++ #\i xp)
423 
+		   (xp.write-char++ #\e xp)
424 
+		   (xp.write-char++ #\s xp)))
425 
+	     (funcall continuation xp args (cdr tail)))))))
426 
+(define-format #\p (function xp.format-p))
427 
+
428 
+
429 
+;;; ~C -> character
430 
+
431 
+(define (xp.format-c string start end params colon? atsign?)
432 
+  (declare (ignore params))
433 
+  (let ((continuation  (xp.parse-format-string string start end)))
434 
+    (cond ((and (not colon?) (not atsign?))
435 
+	   (lambda (xp args tail)
436 
+	     (xp.write-char++ (car tail) xp)
437 
+	     (funcall continuation xp args (cdr tail))))
438 
+	  ((and (not colon?) atsign?)
439 
+	   (lambda (xp args tail)
440 
+	     (dynamic-let ((*print-escape*  '#t))
441 
+	       (xp.write+ (car tail) xp)
442 
+	       (funcall continuation xp args (cdr tail)))))
443 
+	  (else
444 
+	   ;; *** I don't know how to get at the character names.
445 
+	   (error "Unimplemented format option ~s!" string)))))
446 
+(define-format #\c (function xp.format-c))
447 
+
448 
+
449 
+
450 
+;;; Newline directives, ~% and ~&
451 
+
452 
+(define (xp.format-percent string start end params colon? atsign?)
453 
+  (xp.format-newline-helper string start end params colon? atsign?
454 
+			 'unconditional))
455 
+(define-format #\% (function xp.format-percent))
456 
+
457 
+(define (xp.format-ampersand string start end params colon? atsign?)
458 
+  (xp.format-newline-helper string start end params colon? atsign?
459 
+			 'fresh))
460 
+(define-format #\& (function xp.format-ampersand))
461 
+
462 
+(define (xp.format-newline-helper string start end params colon? atsign? kind)
463 
+  (declare (ignore colon? atsign?))
464 
+  (let ((continuation (xp.parse-format-string string start end))
465 
+	(n            (or (and (not (null? params)) (pop params)) 1)))
466 
+    (if (eqv? n 1)
467 
+	(lambda (xp args tail)
468 
+	  (xp.pprint-newline+ kind xp)
469 
+	  (funcall continuation xp args tail))
470 
+	(lambda (xp args tail)
471 
+	  (xp.pprint-newline+ kind xp)
472 
+	  (dotimes (i (1- n))
473 
+	    (xp.pprint-newline+ 'unconditional xp))
474 
+	  (funcall continuation xp args tail))
475 
+      )))
476 
+
477 
+
478 
+;;; ~_, Conditional newline
479 
+
480 
+(define (xp.format-underbar string start end params colon? atsign?)
481 
+  (declare (ignore params))
482 
+  (let ((continuation  (xp.parse-format-string string start end))
483 
+	(kind          (if colon?
484 
+			   (if atsign? 'mandatory 'fill)
485 
+			   (if atsign? 'miser 'linear))))
486 
+    (lambda (xp args tail)
487 
+      (xp.pprint-newline+ kind xp)
488 
+      (funcall continuation xp args tail))))
489 
+(define-format #\_ (function xp.format-underbar))
490 
+
491 
+
492 
+;;; Random character printing directives, ~| and ~~
493 
+
494 
+;;; *** commented out because #\page is not standard scheme
495 
+; (define (xp.format-bar string start end params colon? atsign?)
496 
+;  (xp.format-char-helper string start end params colon? atsign? #\page))
497 
+; (define-format #\| (function xp.format-bar))
498 
+
499 
+(define (xp.format-twiddle string start end params colon? atsign?)
500 
+  (xp.format-char-helper string start end params colon? atsign? #\~))
501 
+(define-format #\~ (function xp.format-twiddle))
502 
+
503 
+(define (xp.format-char-helper string start end params colon? atsign? char)
504 
+  (declare (ignore colon? atsign?))
505 
+  (let ((continuation  (xp.parse-format-string string start end))
506 
+	(n             (or (and (not (null? params)) (pop params)) 1)))
507 
+    (if (eqv? n 1)
508 
+	(lambda (xp args tail)
509 
+	  (xp.write-char++ char xp)
510 
+	  (funcall continuation xp args tail))
511 
+	(lambda (xp args tail)
512 
+	  (dotimes (i n)
513 
+	    (xp.write-char++ char xp))
514 
+	  (funcall continuation xp args tail)))))
515 
+
516 
+
517 
+
518 
+;;; ~<newline> directive (ignore whitespace in format string)
519 
+
520 
+(define (xp.format-newline string start end params colon? atsign?)
521 
+  (declare (ignore params))
522 
+  (let ((newline?   '#f)
523 
+	(skip?      '#f))
524 
+    (cond ((and (not colon?) (not atsign?))  ; skip both newline and whitespace
525 
+	   (setf skip? '#t))
526 
+	  ((and colon? (not atsign?)))  ; skip newline, leave whitespace
527 
+	  ((and (not colon?) atsign?)   ; do newline, skip whitespace
528 
+	   (setf newline? '#t)
529 
+	   (setf skip? '#t))
530 
+	  (else
531 
+	   (error "~:@<newline> not allowed.")))
532 
+    (if skip?
533 
+	(setf start (xp.skip-whitespace string start end)))
534 
+    (let ((continuation  (xp.parse-format-string string start end)))
535 
+      (if newline?
536 
+	  (lambda (xp args tail)
537 
+	    (xp.pprint-newline+ 'unconditional xp)
538 
+	    (funcall continuation xp args tail))
539 
+	  continuation))))
540 
+(define-format #\newline (function xp.format-newline))
541 
+
542 
+(define (xp.skip-whitespace string start end)
543 
+  (if (eqv? start end)
544 
+      start
545 
+      (let ((char  (string-ref string start)))
546 
+	(if (and (char-whitespace? char)
547 
+		 (not (eqv? char #\newline)))
548 
+	    (xp.skip-whitespace string (1+ start) end)
549 
+	    start))))
550 
+
551 
+
552 
+
553 
+;;; ~T -> tab
554 
+
555 
+(define (xp.format-t string start end params colon? atsign?)
556 
+  (let* ((continuation  (xp.parse-format-string string start end))
557 
+	 (colnum        (or (and (not (null? params)) (pop params)) 1))
558 
+	 (colinc        (or (and (not (null? params)) (pop params)) 1))
559 
+	 (kind          (if colon?
560 
+			    (if atsign? 'section-relative 'section)
561 
+			    (if atsign? 'line-relative 'line))))
562 
+    (lambda (xp args tail)
563 
+      (xp.pprint-tab+ kind colnum colinc xp)
564 
+      (funcall continuation xp args tail))))
565 
+(define-format #\t (function xp.format-t))
566 
+
567 
+
568 
+;;; ~I -> indent
569 
+
570 
+(define (xp.format-i string start end params colon? atsign?)
571 
+  (declare (ignore atsign?))
572 
+  (let ((continuation  (xp.parse-format-string string start end))
573 
+	(kind          (if colon? 'current 'block))
574 
+	(n             (or (and (not (null? params)) (pop params)) 0)))
575 
+    (lambda (xp args tail)
576 
+      (pprint-indent kind n)
577 
+      (funcall continuation xp args tail))))
578 
+(define-format #\i (function xp.format-i))
579 
+
580 
+
581 
+;;; ~* -> skip or back up over arguments
582 
+
583 
+(define (xp.format-star string start end params colon? atsign?)
584 
+  (let ((continuation  (xp.parse-format-string string start end))
585 
+	(n             (or (and (not (null? params)) (pop params)) 1)))
586 
+    (cond ((and (not colon?) (not atsign?))
587 
+	   (lambda (xp args tail)
588 
+	     (funcall continuation xp args (list-tail tail n))))
589 
+	  ((and colon? (not atsign?))
590 
+	   (lambda (xp args tail)
591 
+	     (funcall continuation xp args (xp.back-up n args tail))))
592 
+	  ((and (not colon?) atsign?)
593 
+	   (lambda (xp args tail)
594 
+	     (declare (ignore tail))
595 
+	     (funcall continuation xp args (list-tail args n))))
596 
+	  (else
597 
+	   (error "~:@* not allowed.")))))
598 
+(define-format #\* (function xp.format-star))
599 
+
600 
+(define (xp.back-up n head tail)
601 
+  (if (eq? (list-tail head n) tail)
602 
+      head
603 
+      (xp.back-up n (cdr head) tail)))
604 
+
605 
+
606 
+;;; ~? -> indirection
607 
+;;; Normally uses two arguments, a string and a list.
608 
+;;; With @, only uses a string, takes arguments from the tail.
609 
+
610 
+(define (xp.format-question string start end params colon? atsign?)
611 
+  (declare (ignore params colon?))
612 
+  (let ((continuation  (xp.parse-format-string string start end)))
613 
+    (if atsign?
614 
+	(lambda (xp args tail)
615 
+	  (setf tail (apply (function format) xp (car tail) (cdr tail)))
616 
+	  (funcall continuation xp args tail))
617 
+	(lambda (xp args tail)
618 
+	  (apply (function format) xp (car tail) (cadr tail))
619 
+	  (funcall continuation xp args (cddr tail))))))
620 
+(define-format #\? (function xp.format-question))
621 
+
622 
+
623 
+;;; ~(...~) -> case conversion.
624 
+
625 
+(define *xp.format-paren-next* '#f)
626 
+
627 
+(define (xp.format-paren string start end params colon? atsign?)
628 
+  (declare (ignore params))
629 
+  (let* ((handler      (dynamic-let ((*xp.format-paren-next* '#t))
630 
+			 (let ((result (xp.parse-format-string
631 
+					   string start end)))
632 
+			   (if (eq? (dynamic *xp.format-paren-next*) '#t)
633 
+			       (error "~( directive has no matching ~)."))
634 
+			   (setf start (dynamic *xp.format-paren-next*))
635 
+			   result)))
636 
+	 (continuation (xp.parse-format-string string start end))
637 
+	 (mode         (if colon?
638 
+			   (if atsign? 'up 'cap1)
639 
+			   (if atsign? 'cap0 'down))))
640 
+    (lambda (xp args tail)
641 
+      (xp.push-char-mode xp mode)
642 
+      (setf tail (funcall handler xp args tail))
643 
+      (xp.pop-char-mode xp)
644 
+      (funcall continuation xp args tail))))
645 
+(define-format #\( (function xp.format-paren))
646 
+
647 
+(define (xp.format-paren-end string start end params colon? atsign?)
648 
+  (declare (ignore string end params colon? atsign?))
649 
+  (if (not (dynamic *xp.format-paren-next*))
650 
+      (error "~) directive has no matching ~(."))
651 
+  (setf (dynamic *xp.format-paren-next*) start)
652 
+  (function xp.format-finish))
653 
+(define-format #\) (function xp.format-paren-end))
654 
+
655 
+;;; ~F      -> fixed-width      *** unimplemented
656 
+;;; ~E      -> e-notation       *** unimplemented
657 
+;;; ~G      -> general float    *** unimplemented
658 
+;;; ~$      -> dollars float    *** unimplemented
659 
+;;; ~[...~] -> conditional      *** unimplemented
660 
+;;; ~{...~} -> iteration        *** unimplemented
661 
+;;; ~<...~> -> justification    *** unimplemented
662 
+;;; ~;      -> clause seperator *** unimplemented
663 
+;;; ~^      -> up and out       *** unimplemented
664 
+;;; ~/.../  -> hook             *** unimplemented
665 
+
666 
+(define (xp.unimplemented-format string start end params colon? atsign?)
667 
+  (declare (ignore start end params colon? atsign?))
668 
+  (error "Unimplemented format directive in ~s." string))
669 
+
670 
+(define-format #\f (function xp.unimplemented-format))
671 
+(define-format #\e (function xp.unimplemented-format))
672 
+(define-format #\g (function xp.unimplemented-format))
673 
+(define-format #\$ (function xp.unimplemented-format))
674 
+(define-format #\[ (function xp.unimplemented-format))
675 
+(define-format #\] (function xp.unimplemented-format))
676 
+(define-format #\{ (function xp.unimplemented-format))
677 
+(define-format #\} (function xp.unimplemented-format))
678 
+(define-format #\< (function xp.unimplemented-format))
679 
+(define-format #\> (function xp.unimplemented-format))
680 
+(define-format #\; (function xp.unimplemented-format))
681 
+(define-format #\^ (function xp.unimplemented-format))
682 
+(define-format #\/ (function xp.unimplemented-format))
683 
+
support/mumble.txt
History View file @ 4e98702
0 684 
new file mode 100644
... ... 
@@ -0,0 +1,840 @@
1 
+Syntax
2 
+------
3 
+
4 
+(quote x)
5 
+
6 
+(function name)
7 
+  You must use this to reference a global function, as in CL.  (There
8 
+  isn't a local function namespace.)
9 
+
10 
+(lambda lambda-list . body)
11 
+  Equivalent to #'(lambda ...) in Common Lisp.
12 
+  The lambda-list can be dotted, as in Scheme.  CL lambda-list keywords
13 
+  are not supported.
14 
+
15 
+function call
16 
+  Order of evaluation is unspecified, as in Scheme.
17 
+  You have to use FUNCALL if the function is bound with let.
18 
+
19 
+(funcall function . args)
20 
+  As in Common Lisp, but might be a macro.  (The function is guaranteed
21 
+  to be a true function, not a symbol.)
22 
+
23 
+(apply procedure . args)
24 
+  As in Common Lisp/Scheme.
25 
+
26 
+(map procedure . lists)
27 
+  As in Scheme.  Equivalent to MAPCAR in CL.
28 
+
29 
+(for-each procedure . lists)
30 
+  As in Scheme.  Equivalent to MAPC in CL.
31 
+
32 
+(every procedure . lists)
33 
+(some procedure . lists)
34 
+(notany procedure . lists)
35 
+(notevery procedure . lists)
36 
+  As in CL, but only work on lists.
37 
+
38 
+(procedure? object)
39 
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
40 
+  Note that we never use symbols or quoted lambda expressions as functions.
41 
+
42 
+(if test then . maybe-else)
43 
+(when test . body)
44 
+(unless test . body)
45 
+
46 
+(cond . tests)
47 
+  As in Scheme, but the = syntax isn't supported.  When no test is true, the
48 
+  result is undefined.
49 
+
50 
+(case value . cases)
51 
+  As in Scheme.
52 
+  Stylistically, use this only when the case labels are symbols.
53 
+
54 
+(and . expressions)
55 
+(or  . expressions)
56 
+
57 
+(not value)
58 
+  As in Scheme but can return an arbitrary truth value instead of #t.
59 
+
60 
+(set! variable value)
61 
+  As in Scheme; this doesn't return a useful value.  Use setf instead.
62 
+
63 
+(setf place value)
64 
+  Similar to SETF in Common Lisp.  Returns value.
65 
+  See define-setf below.  Places that are macro calls are expanded
66 
+  if they don't have their own setter.
67 
+  Here is a list of the built-in setters:
68 
+    dynamic
69 
+    car
70 
+    cdr
71 
+    list-ref
72 
+    string-ref
73 
+    vector-ref
74 
+    table-entry
75 
+
76 
+(let    bindings . body)
77 
+(let*   bindings . body)
78 
+(letrec bindings . body)
79 
+  Note that each binding clause must be a list of the form (var init);
80 
+  you can't just supply var or (var) as in Common Lisp.  Also remember
81 
+  that the order of evaluation for the init-forms is not specified for
82 
+  let/letrec.
83 
+  The Scheme named LET construct is not supported.
84 
+
85 
+(flet   bindings . body)
86 
+(labels bindings . body)
87 
+  As in Common Lisp.
88 
+
89 
+(dynamic-let bindings . body)
90 
+(dynamic name)
91 
+  As in Eulisp.  Dynamic-let is equivalent to bind in T, or LET in
92 
+  Common Lisp with all of the variables declared special.  As a matter
93 
+  of style, use dynamic to reference the value rather than just the name.
94 
+
95 
+(begin . body)
96 
+  Like PROGN in Common Lisp.
97 
+
98 
+(block name . body)
99 
+(return-from name result)
100 
+  The intersection of the Eulisp and Common Lisp definitions.  The "name"
101 
+  may be bound as a lexical variable, but you should only refer to it
102 
+  inside a return-from.
103 
+  Don't depend on named functions (etc) establishing implicit blocks,
104 
+  as they do in CL.
105 
+
106 
+(do bindings-and-steppers (end-test . results) . body)
107 
+  As in Scheme.  It doesn't necessarily establish an implicit BLOCK
108 
+  as in CL so you can't RETURN from the loop.
109 
+
110 
+(dolist (variable init . maybe-result) . body)
111 
+(dotimes (variable init . maybe-result) . body)
112 
+  As in CL, except you can't RETURN from the loop.
113 
+
114 
+(values . values)
115 
+(multiple-value-bind variables values-expression . body)
116 
+  As in Common Lisp, except that the values-expression must explicitly
117 
+  return multiple values.
118 
+
119 
+(let/cc variable . body)
120 
+  As in EuLisp.  This is the same as catch in T.  The continuation
121 
+  has dynamic extent within the body.
122 
+  You call the continuation with an arbitrary number of arguments, which
123 
+  are the multiple values to be returned.
124 
+
125 
+(unwind-protect protected-form . body)
126 
+
127 
+(declare ...)
128 
+  Similar to Common Lisp declare.  Declarations are allowed only in the
129 
+  standard places that Common Lisp permits (in particular, at the
130 
+  beginning of binding forms).  For now, only the following declarations
131 
+  are permitted:
132 
+
133 
+  (ignore . variables)
134 
+  (ignorable . variables)
135 
+  (type type-spec . variables)  -- see info on type-specs below.
136 
+
137 
+
138 
+
139 
+
140 
+Definitions
141 
+-----------
142 
+
143 
+(define pattern . value)
144 
+  As in Scheme.
145 
+
146 
+(define-integrable pattern . value)
147 
+  Like DEFINE, but also tells the compiler to try to inline the value.
148 
+
149 
+(define-syntax (name . lambda-list) . body)
150 
+  Similar to the equivalent T functionality.  The lambda-list does not
151 
+  support destructuring, as does Common Lisp's DEFMACRO.
152 
+  The macro definition is made both when the file is loaded and when it
153 
+  is compiled.
154 
+
155 
+(define-local-syntax (name . lambda-list) . body)
156 
+  Again, similar to the T functionality.  In Common Lisp, equivalent to
157 
+  a DEFMACRO wrapped in (eval-when (compile) ...).
158 
+
159 
+(define-setf getter-name setter-name)
160 
+  Similar to the short form of DEFSETF in Common Lisp, except that the
161 
+  calling convention for the setter differs:  the value is passed as the
162 
+  first argument rather than as the last.  The setter must return this
163 
+  value.
164 
+
165 
+(predefine pattern)
166 
+  This is a forward definition for a function or variable.  It doesn't
167 
+  actually make a definition; its purpose is to try to get rid of compiler
168 
+  warnings about calls to functions that haven't been defined yet.  It can
169 
+  be a no-op if the underlying Lisp system doesn't provide any way to do
170 
+  this.
171 
+
172 
+(redefine pattern . value)
173 
+  Like DEFINE, but hints to the compiler not to complain if this
174 
+  function/variable was previously defined somewhere else.
175 
+
176 
+(redefine-syntax (name . lambda-list) . body)
177 
+  Like DEFINE-SYNTAX, but hints to the compiler not to complain if this
178 
+  macro was previously defined somewhere else.
179 
+
180 
+
181 
+Equivalence
182 
+-----------
183 
+
184 
+(eq? x1 x2)
185 
+(eqv? x1 x2)
186 
+(equal? x1 x2)
187 
+  As in Scheme but can return an arbitrary truth value instead of #t.
188 
+  Note that equal? is not the same as EQUAL in CL because it descends vectors.
189 
+  eqv? is different from the T equiv? because it doesn't descent strings.
190 
+
191 
+
192 
+Lists
193 
+-----
194 
+
195 
+(pair? x)
196 
+  As in Scheme but can return an arbitrary truth value instead of #t.
197 
+
198 
+(cons x y)
199 
+(list . values)
200 
+(make-list length . maybe-init)
201 
+
202 
+(cxxxxr x)
203 
+
204 
+(null? x)
205 
+(list? x)
206 
+  As in Scheme but can return an arbitrary truth value instead of #t.
207 
+  Note that this is a check for a proper (null-terminated) list, not
208 
+  like LISTP in CL.
209 
+
210 
+(length x)
211 
+(append list . more-lists)
212 
+(nconc list . more-lists)
213 
+
214 
+(reverse x)
215 
+(nreverse x)
216 
+
217 
+(list-tail list n)
218 
+  Like NTHCDR in Common Lisp.
219 
+
220 
+(list-ref list n)
221 
+  Like NTH in Common Lisp.
222 
+
223 
+(last list)
224 
+(butlast list)
225 
+  As in Common Lisp.
226 
+
227 
+(memq object list)
228 
+(memv object list)
229 
+(member object list)
230 
+
231 
+(assq object list)
232 
+(assv object list)
233 
+(assoc object list)
234 
+
235 
+(push item place)
236 
+(pop place)
237 
+  As in Common Lisp.
238 
+
239 
+(list-copy list)
240 
+
241 
+
242 
+Symbols
243 
+-------
244 
+
245 
+(symbol? object)
246 
+(symbol->string object)
247 
+(string->symbol object)
248 
+(gensym . maybe-prefix)
249 
+(gensym? object)
250 
+
251 
+(symbol-append . symbols)
252 
+
253 
+
254 
+Characters
255 
+----------
256 
+
257 
+(char? object)
258 
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
259 
+
260 
+(char=? c1 c2)
261 
+(char<? c1 c2)
262 
+(char>? c1 c2)
263 
+(char<=? c1 c2)
264 
+(char>=? c1 c2)
265 
+  As in Scheme, except that they can return an arbitrary truth value
266 
+  instead of just #t.
267 
+
268 
+(char-ci=? c1 c2)
269 
+(char-ci<? c1 c2)
270 
+(char-ci>? c1 c2)
271 
+(char-ci<=? c1 c2)
272 
+(char-ci>=? c1 c2)
273 
+  As in Scheme, except that they can return an arbitrary truth value
274 
+  instead of just #t.
275 
+
276 
+(char-alphabetic? c)
277 
+(char-numeric? c)
278 
+(char-whitespace? c)
279 
+(char-upper-case? c)
280 
+(char-lower-case? c)
281 
+
282 
+(char->integer c)
283 
+(integer->char n)
284 
+
285 
+(char-upcase c)
286 
+(char-downcase c)
287 
+
288 
+(char-name c)
289 
+  As in Common Lisp.
290 
+
291 
+(char->digit c . maybe-radix)
292 
+  Returns nil or the "weight" of the character as a fixnum in the given
293 
+  radix (defaults to 10).
294 
+
295 
+
296 
+Strings
297 
+-------
298 
+
299 
+(string? object)
300 
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
301 
+
302 
+(make-string length . maybe-init)
303 
+
304 
+(string char . more-chars)
305 
+
306 
+(string-length string)
307 
+(string-ref string index)
308 
+
309 
+(string=? s1 s2)
310 
+(string<? s1 s2)
311 
+(string>? s1 s2)
312 
+(string<=? s1 s2)
313 
+(string>=? s1 s2)
314 
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
315 
+
316 
+(string-ci=? s1 s2)
317 
+(string-ci<? s1 s2)
318 
+(string-ci>? s1 s2)
319 
+(string-ci<=? s1 s2)
320 
+(string-ci>=? s1 s2)
321 
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
322 
+
323 
+(substring string start end)
324 
+(string-append string . more-strings)
325 
+
326 
+(string->list string)
327 
+(list->string list)
328 
+
329 
+(string-copy string)
330 
+
331 
+(string-upcase string)
332 
+(string-downcase string)
333 
+
334 
+
335 
+Vectors
336 
+-------
337 
+
338 
+(vector? object)
339 
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
340 
+
341 
+(make-vector length . maybe-init)
342 
+(vector object . more-objects)
343 
+
344 
+(vector-length vector)
345 
+(vector-ref vector index)
346 
+(vector->list vector)
347 
+(list->vector list)
348 
+
349 
+(vector-copy vector)
350 
+
351 
+
352 
+Numbers
353 
+-------
354 
+
355 
+(number? object)
356 
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
357 
+
358 
+(integer? object)
359 
+(rational? object)
360 
+(float? object)
361 
+  These test the representation of a number, not its mathematical
362 
+  properties.  They're equivalent to the CL integerp, rationalp, and floatp
363 
+  predicates.  We ignore complex numbers for now.
364 
+
365 
+(exact->inexact number)
366 
+  Convert an exact-rational to a float.
367 
+
368 
+(= x1 x2)
369 
+(< x1 x2)
370 
+(> x1 x2)
371 
+(<= x1 x2)
372 
+(>= x1 x2)
373 
+  As in Scheme, except they can return an arbitrary truth value.
374 
+  They're restricted to being binary operators because that's all
375 
+  that's supported in T.
376 
+
377 
+(zero? x)
378 
+(positive? x)
379 
+(negative? x)
380 
+  As in Scheme, except they can return an arbitrary truth value.
381 
+
382 
+(min number . more-numbers)
383 
+(max number . more-numbers)
384 
+
385 
+(+ . numbers)
386 
+(* . numbers)
387 
+(- n1 . more-numbers)
388 
+(/ n1 . more-numbers)
389 
+  As in Scheme.
390 
+
391 
+(quotient n1 n2)
392 
+(remainder n1 n2)
393 
+(modulo n1 n2)
394 
+  quotient rounds towards zero.
395 
+  remainder has the sign of the second argument, modulo has the sign of
396 
+  the first argument.
397 
+
398 
+(floor x)
399 
+(ceiling x)
400 
+(truncate x)
401 
+(round x)
402 
+  As in Scheme.  These return a number of the same type as the argument.
403 
+
404 
+(floor->exact x)
405 
+(ceiling->exact x)
406 
+(truncate->exact x)
407 
+(round->exact x)
408 
+  Like the above, but return an exact-integer result.  Borrowed from
409 
+  MIT Scheme.
410 
+
411 
+(1+ n)
412 
+(1- n)
413 
+(incf place . maybe-delta)
414 
+(decf place . maybe-delta)
415 
+  As in Common Lisp.
416 
+
417 
+(number->string number . maybe-radix)
418 
+(string->number string . maybe-radix)
419 
+  As in Scheme.
420 
+
421 
+(expt base power)
422 
+  As in Common Lisp.  [our only use is when both args are integers]
423 
+
424 
+
425 
+Tables
426 
+------
427 
+
428 
+(table? object)
429 
+(make-table)
430 
+(table-entry table key)
431 
+(table-for-each proc table)
432 
+(copy-table table)
433 
+  More or less as in T.  For now we only bother with tables that use
434 
+  eq? as the comparison function -- mostly symbols are used as keys.
435 
+
436 
+
437 
+I/O
438 
+---
439 
+
440 
+(call-with-input-file string proc)
441 
+(call-with-output-file string proc)
442 
+  As in Scheme.  The proc is called with one argument, the port.
443 
+
444 
+(call-with-input-string string proc)
445 
+(call-with-output-string proc)
446 
+  Similar, but for reading/writing to a string stream string.
447 
+  Call-with-output-string returns the string.
448 
+
449 
+(input-port? object)
450 
+(output-port? object)
451 
+  As in Scheme, but can return an arbitrary truth value.
452 
+
453 
+(current-input-port)
454 
+(current-output-port)
455 
+
456 
+(open-input-file filename)
457 
+(open-output-file filename)
458 
+
459 
+(close-input-port port)
460 
+(close-output-port port)
461 
+
462 
+(read . maybe-port)
463 
+(read-char . maybe-port)
464 
+(peek-char . maybe-port)
465 
+(read-line . maybe-port)
466 
+
467 
+(eof-object? object)
468 
+
469 
+
470 
+Printer
471 
+-------
472 
+
473 
+(internal-write object port)
474 
+(internal-output-width port)
475 
+(internal-output-position port)
476 
+(internal-write-char char port)
477 
+(internal-write-string string port start end)
478 
+(internal-newline port)
479 
+(internal-fresh-line port)
480 
+(internal-finish-output port)
481 
+(internal-force-output port)
482 
+(internal-clear-output port)
483 
+(internal-write-to-string object)
484 
+(internal-warning string)
485 
+(internal-error string)
486 
+  These are all internal hooks.  Don't use them directly if you can
487 
+  avoid it.
488 
+
489 
+(write object . maybe-stream)
490 
+(print object . maybe-stream)
491 
+(prin1 object . maybe-stream)
492 
+(princ object . maybe-stream)
493 
+(pprint object . maybe-stream)
494 
+(prin1-to-string object)
495 
+(princ-to-string object)
496 
+(write-char char . maybe-stream)
497 
+(write-string string . maybe-stream-start-end)
498 
+(write-line string . maybe-stream-start-end)
499 
+(terpri . maybe-stream)
500 
+(fresh-line . maybe-stream)
501 
+(finish-output . maybe-stream)
502 
+(force-output . maybe-stream)
503 
+(clear-output . maybe-stream)
504 
+  These are the standard Common Lisp print functions.  All of them
505 
+  accept either a port or an XP stream as a stream argument.
506 
+
507 
+(display object . maybe-stream)
508 
+  Same as princ; for Scheme compatibility.
509 
+(newline object . maybe-stream)
510 
+  Same as terpri; for Scheme compatibility.
511 
+
512 
+
513 
+*print-escape*
514 
+*print-shared*
515 
+*print-circle*
516 
+*print-pretty*
517 
+*print-level*
518 
+*print-length*
519 
+  These are the standard Common Lisp printer control variables.  The
520 
+  functions listed above obey them.
521 
+
522 
+*print-base*
523 
+*print-radix*
524 
+*print-case*
525 
+*print-readably*
526 
+  These are more standard Common Lisp printer control variables, but
527 
+  support for them hasn't been implemented yet.  Maybe some day.
528 
+
529 
+*print-dispatch*
530 
+  This is the hook for user customization of the printer.  Its value is a
531 
+  function that is passed an object as an argument, and returns another
532 
+  function that takes a stream and the object as arguments.
533 
+
534 
+*print-structure*
535 
+  If true, use standard structure printing syntax (overriding any special
536 
+  print function for the structure type).
537 
+
538 
+*print-structure-slots*
539 
+  If true, recursively print structure slots when using standard structure
540 
+  printing syntax; otherwise just print the structure type name.
541 
+
542 
+
543 
+(standard-print-dispatch object)
544 
+  This function is the initial value of *print-dispatch*.
545 
+
546 
+*print-right-margin*
547 
+*print-miser-width*
548 
+*print-lines*
549 
+*default-right-margin*
550 
+*last-abbreviated-printing*
551 
+  These are the XP pretty-printer control variables.  For more information
552 
+  about the pretty-printer, read the XP document.
553 
+
554 
+(pprint-newline kind . maybe-stream)
555 
+  The kind argument can be one of LINEAR, FILL, MISER, or MANDATORY.
556 
+
557 
+(pprint-logical-block (stream-symbol list . more-options) . body)
558 
+  This is a macro.  The body should contain code for printing a logical
559 
+  block to the stream stream-symbol.
560 
+
561 
+  The format of the options is (stream-symbol list prefix suffix per-line?).
562 
+
563 
+  The list argument can be used with the pprint-pop macro.
564 
+
565 
+  The prefix is a string that is printed as the initial prefix of the logical
566 
+  block.  If per-line? is true, then the prefix is printed on every line.
567 
+  The suffix is a string that is printed at the end of the logical block.
568 
+
569 
+  You can use this macro even when not pretty-printing, to get support
570 
+  for *print-length* and *print-level*.  In that case, you should have
571 
+  the body forms put out only a minimal amount of whitespace.
572 
+
573 
+(pprint-pop)
574 
+  Returns the next item from the list specified to an enclosing
575 
+  pprint-logical-block.  Checks for circular list tails and *print-length*
576 
+  abbreviation.
577 
+
578 
+(pprint-exit-if-list-exhausted)
579 
+  Can be used inside pprint-logical-block to see if the list is empty.
580 
+  Causes the block to be exited if so.
581 
+
582 
+(pprint-indent relative-to n . maybe-stream)
583 
+  Specify the indentation level to use for a logical block.
584 
+  The relative-to argument can be either BLOCK or CURRENT.
585 
+
586 
+(pprint-tab kind colnum colinc . maybe-stream)
587 
+  Specify tabbing.  The kind argument can be one of LINE, SECTION,
588 
+  LINE-RELATIVE, or SECTION-RELATIVE.
589 
+
590 
+(pprint-fill stream list . maybe-colon-atsign)
591 
+(pprint-linear stream list . maybe-colon-atsign)
592 
+(pprint-tabular stream list . maybe-colon-atsign-tabsize)
593 
+  Pretty-print list to the stream in the given style.
594 
+
595 
+
596 
+(format stream string-or-fn . args)
597 
+  The standard Common Lisp format, except that some of the more esoteric
598 
+  directives are unimplemented.  (Specifically, watch out for specifying
599 
+  field widths or using # or V parameters; most of the numeric formatting
600 
+  options are unimplemented, as are complicated directives like ~{...~}.)
601 
+
602 
+  The stream parameter can be #f to output to a string, or #t to output
603 
+  to the (current-output-port).
604 
+
605 
+  The string-or-fn argument can be a function as well as a string containing
606 
+  embedded directives.  The function is applied to the stream and the args.
607 
+
608 
+(warning string-or-fn . args)
609 
+(error string-or-fn . args)
610 
+
611 
+
612 
+
613 
+System Interface
614 
+----------------
615 
+
616 
+(macroexpand-1 form . maybe-env)
617 
+(macroexpand form . maybe-env)
618 
+  As in Common Lisp.  Since we don't have lexical macros and don't allow
619 
+  syntax to be shadowed by local bindings, you can omit the environment
620 
+  argument.  These functions are provided mostly for debugging purposes.
621 
+
622 
+(eval form . maybe-compile)
623 
+  As in Common Lisp.  If the optional argument is supplied and is true,
624 
+  try to compile the code in memory, not interpret it.
625 
+
626 
+(load filename)
627 
+
628 
+*code-quality*
629 
+  A number between 0 and 3.  0 = minimal compilation, 1 = for debugging,
630 
+  2 = low safety, high speed, fast compilation, 3 = go all out.
631 
+
632 
+(compile-file source-filename . maybe-binary-filename)
633 
+
634 
+(with-compilation-unit options . forms)
635 
+  This is the ANSI CL macro.  We don't use any options.
636 
+
637 
+(filename-place filename)
638 
+(filename-name filename)
639 
+(filename-type filename)
640 
+  We use a rather simplistic file system model.  Filenames are strings
641 
+  with place (or directory), name, and type components.  These functions
642 
+  pick apart filename strings.  You shouldn't have to mess with string
643 
+  operations on the components directly.
644 
+
645 
+(assemble-filename place-filename name-filename type-filename)
646 
+  Build a new filename by combining the appropriate parts of the argument
647 
+  filenames.
648 
+
649 
+source-file-type
650 
+binary-file-type
651 
+  These constants hold appropriate default types for source and
652 
+  compiled files.  By convention, source-file-type is ".scm" but
653 
+  the binary-file-type depends on the underlying Lisp system.
654 
+
655 
+(file-exists? filename)
656 
+  Returns true if the file exists.
657 
+
658 
+(file-write-date filename)
659 
+(current-date)
660 
+  Dates are represented as integers relative to an arbitrary base.  These
661 
+  functions are mostly useful for recording timestamps.
662 
+
663 
+(get-run-time)
664 
+  Return run time as a floating-point number relative to an arbitrary base.
665 
+  Useful for doing timings.
666 
+
667 
+(getenv name)
668 
+  Explicitly expand an environment variable.  (Environment variables that
669 
+  appear as filename prefixes are expanded automagically by the functions
670 
+  that open files.)
671 
+
672 
+(cd filename)
673 
+  Change the current directory.
674 
+
675 
+
676 
+(exit)
677 
+  Go away.
678 
+
679 
+
680 
+Reader Support
681 
+--------------
682 
+
683 
+' => quote
684 
+` => backquote; also , and ,@
685 
+#t and #f
686 
+
687 
+
688 
+Random Stuff
689 
+------------
690 
+
691 
+lisp-implementation-name
692 
+  returns a string identifying the underlying lisp implementation; e.g.
693 
+  "lucid", "t", etc.
694 
+
695 
+(identify-system)
696 
+  return a longer string indentifying the lisp version and machine type.
697 
+
698 
+left-to-right-evaluation
699 
+  True if the underlying Lisp always evaluates function arguments
700 
+  left-to-right; false otherwise.
701 
+
702 
+(gc-messages onoff)
703 
+  Turn garbage collection messages on/off, if possible.
704 
+
705 
+(identity x)
706 
+  The identity function.
707 
+
708 
+
709 
+
710 
+Type specifiers
711 
+---------------
712 
+
713 
+t
714 
+procedure
715 
+pair
716 
+null
717 
+list, (list element-type)
718 
+symbol
719 
+char
720 
+string
721 
+vector
722 
+number
723 
+integer
724 
+rational
725 
+float
726 
+fixnum, int
727 
+table, (table key-type value-type)
728 
+(enum . values)
729 
+(tuple . component-types)
730 
+bool
731 
+alist, (alist key-type value-type)
732 
+(maybe type)
733 
+struct
734 
+type-descriptor
735 
+slot-descriptor
736 
+  These are the standard type specifiers.
737 
+
738 
+the
739 
+  As in Common Lisp.
740 
+subtype?
741 
+  Equivalent to CL subtypep
742 
+is-type?
743 
+  Equivalent to CL typep
744 
+typecase
745 
+  As in Common Lisp, also recognizes "else" clause.
746 
+
747 
+
748 
+
749 
+Structures
750 
+----------
751 
+
752 
+(struct? object)
753 
+  Returns true if the object is a struct.
754 
+(struct-type-descriptor object)
755 
+  Returns the type descriptor of a struct object.
756 
+
757 
+name, slots, parent-type, printer
758 
+  Slots of type-descriptor object.
759 
+
760 
+(td-name td)
761 
+(td-slots td)
762 
+(td-parent-type td)
763 
+(td-printer td)
764 
+  Accessors for type-descriptors.
765 
+
766 
+name, type, default, getter
767 
+  Slots of slot-descriptor object.
768 
+
769 
+(sd-name sd)
770 
+(sd-type sd)
771 
+(sd-default sd)
772 
+(sd-getter sd)
773 
+  Accessors for slot-descriptors.
774 
+(sd-getter-function sd)
775 
+  Returns a function which can be used to access a slot (as opposed to
776 
+  the symbol that names the function).
777 
+
778 
+(lookup-type-descriptor type-name)
779 
+(lookup-slot-descriptor type-name slot-name)
780 
+  Name to descriptor mappings.
781 
+
782 
+
783 
+(make type . initializers)
784 
+  The type must name a struct type; it is not evaluated.
785 
+  The initializers are of the form (slot-name value-form).
786 
+
787 
+(struct-slot type slot object)
788 
+  Generalized slot access.  Type and slot are symbols.  If both are
789 
+  quoted, can be used with SETF.
790 
+
791 
+(with-slots type slot-names object . body)
792 
+  Binds the specified slots of object to local variables with the
793 
+  same names.  Bindings are read-only.  Type is not evaluated.
794 
+
795 
+(update-slots type object . initializers)
796 
+  Modifies the slots of object.  Syntax of initializers is as for make.
797 
+  Type is not evaluated.
798 
+
799 
+(define-struct name
800 
+  (include parent-type-name)
801 
+  (type-template subtype-of-type-descriptor)
802 
+  (prefix prefix-symbol)
803 
+  (predicate predicate-name)
804 
+  (slots
805 
+    (slot-name
806 
+      (type type)
807 
+      (default init-form)
808 
+      (bit #t)
809 
+      (read-only? #t)
810 
+      (uninitialized? #t))
811 
+    ...))
812 
+
813 
+  Defines name as a subtype of struct with the given slots.
814 
+  All fields are optional.
815 
+
816 
+  Include specifies the immediate supertype.  All accessors on the supertype
817 
+  work on the newly defined type.  It defaults to struct.
818 
+
819 
+  Type-template specifies the metaclass.  It can be used to attach
820 
+  additional information to the type descriptor.  It defaults to
821 
+  type-descriptor.
822 
+
823 
+  Prefix can be used to specify an alternate prefix for accessors.  The
824 
+  default is name-.
825 
+
826 
+  Predicate can be used to create a predicate function.  The default is
827 
+  not to create one.
828 
+
829 
+  If no default is specified for a slot, it's expected to have an
830 
+  explicit initializer supplied with MAKE.  You'll get a compilation
831 
+  warning otherwise, unless you specify the uninitialized? option instead.
832 
+
833 
+  Bit is a hint for optimizing internal representation.
834 
+
835 
+  Read-only? says not to create a SETFer for the slot.
836 
+
837 
+
838 
+(define-struct-printer struct-name printer-function)
839 
+  Specifies a printer function to use when *print-structure* is false.
840 
+
support/pprint.scm
History View file @ 4e98702
0 841 
new file mode 100644
... ... 
@@ -0,0 +1,1788 @@
1 
+;;; pprint.scm -- xp pretty-printer in Scheme
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  29 Oct 1991
5 
+;;;
6 
+;;;
7 
+;;; This code is adapted from the XP pretty printer originally written
8 
+;;; in Common Lisp by Dick Waters.  Here is the copyright notice attached
9 
+;;; to the original XP source file:
10 
+;;;
11 
+;;;------------------------------------------------------------------------
12 
+;;;
13 
+;;; Copyright 1989,1990 by the Massachusetts Institute of Technology,
14 
+;;; Cambridge, Massachusetts.
15 
+;;;
16 
+;;; Permission to use, copy, modify, and distribute this software and its
17 
+;;; documentation for any purpose and without fee is hereby granted,
18 
+;;; provided that this copyright and permission notice appear in all
19 
+;;; copies and supporting documentation, and that the name of M.I.T. not
20 
+;;; be used in advertising or publicity pertaining to distribution of the
21 
+;;; software without specific, written prior permission. M.I.T. makes no
22 
+;;; representations about the suitability of this software for any
23 
+;;; purpose.  It is provided "as is" without express or implied warranty.
24 
+;;;
25 
+;;;  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
26 
+;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
27 
+;;;  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
28 
+;;;  ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
29 
+;;;  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
30 
+;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
31 
+;;;  SOFTWARE.
32 
+;;;
33 
+;;;------------------------------------------------------------------------
34 
+;;;
35 
+
36 
+
37 
+;;;=====================================================================
38 
+;;; Variables
39 
+;;;=====================================================================
40 
+
41 
+
42 
+;;; External variables.  These may be specially bound by user code.
43 
+
44 
+(define *print-escape*           '#t)
45 
+(define *print-circle*           '#f)
46 
+(define *print-level*            '#f)
47 
+(define *print-length*           '#f)
48 
+(define *print-base*             10)
49 
+(define *print-radix*            '#f)
50 
+
51 
+
52 
+(define *print-shared*           '#f)
53 
+(define *print-pretty*           '#f)
54 
+(define *print-right-margin*     '#f)
55 
+(define *print-miser-width*      40)
56 
+(define *print-lines*            '#f)
57 
+(define *default-right-margin*   70)
58 
+(define *last-abbreviated-printing*
59 
+  (lambda maybe-stream
60 
+    (declare (ignore maybe-stream))
61 
+    '#f))
62 
+
63 
+(define *print-dispatch*         '#f)  ; initialized later
64 
+(define *print-structure*        '#f)
65 
+(define *print-structure-slots*  '#t)
66 
+
67 
+
68 
+;;; *** These variables aren't really supported, but they should be.
69 
+
70 
+(define *print-readably*         '#f)
71 
+(define *print-case*             'upcase)
72 
+
73 
+
74 
+
75 
+;;; Internal variables.  These are all specially rebound when we initiate
76 
+;;; printing to an XP stream.
77 
+
78 
+(define *xp.current-level* 0)
79 
+(define *xp.current-length* 0)
80 
+(define *xp.abbreviation-happened* '#f)
81 
+(define *xp.locating-circularities* '#f)
82 
+(define *xp.parents* '())
83 
+(define *xp.circularity-hash-table* '#f)
84 
+(define *xp.line-limit-abbreviation-exit*
85 
+  (lambda values
86 
+    (declare (ignore values))
87 
+    (error "No line limit abbreviation exit in this extent.")))
88 
+
89 
+
90 
+
91 
+;;;=====================================================================
92 
+;;; Dispatching
93 
+;;;=====================================================================
94 
+
95 
+;;; Since Scheme doesn't have type specifiers or named structures,
96 
+;;; the dispatch mechanism defined for the Common Lisp XP won't work
97 
+;;; very well.  A more general alternative might be to maintain a
98 
+;;; sorted list of <priority predicate printer> tuples, but having to
99 
+;;; try each of these in sequence could get very slow.
100 
+;;;
101 
+;;; What I've decided to to instead is to have the value of
102 
+;;; *print-dispatch* be a user-defined dispatcher
103 
+;;; function:  given an object, it should return a function to print it,
104 
+;;; or #f.  In the latter case, the object is printed in some default
105 
+;;; way.
106 
+;;;
107 
+;;; The standard dispatcher function is defined towards the bottom
108 
+;;; of this file.  If you are writing your own dispatcher, you should
109 
+;;; probably call this function as the fall-through case.
110 
+
111 
+(define (xp.get-printer object)
112 
+  (funcall (dynamic *print-dispatch*) object))
113 
+
114 
+
115 
+;;;=====================================================================
116 
+;;; Internal data structures
117 
+;;;=====================================================================
118 
+
119 
+(define-integrable xp.block-stack-entry-size 1)
120 
+(define-integrable xp.prefix-stack-entry-size 5)
121 
+(define-integrable xp.queue-entry-size 7)
122 
+(define-integrable xp.buffer-entry-size 1)
123 
+(define-integrable xp.prefix-entry-size 1)
124 
+(define-integrable xp.suffix-entry-size 1)
125 
+
126 
+(define-integrable xp.block-stack-min-size (* 35 xp.block-stack-entry-size))
127 
+(define-integrable xp.prefix-stack-min-size (* 30 xp.prefix-stack-entry-size))
128 
+(define-integrable xp.queue-min-size (* 75 xp.queue-entry-size))
129 
+(define-integrable xp.buffer-min-size 256)
130 
+(define-integrable xp.prefix-min-size 256)
131 
+(define-integrable xp.suffix-min-size 256)
132 
+
133 
+
134 
+;;; The xp stream structure.
135 
+;;; Fields without defaults are initialized by xp.initialize-xp, below.
136 
+
137 
+(define-struct xp
138 
+  (prefix xp.)
139 
+  (predicate xp.xp-structure-p)
140 
+  (slots
141 
+   (base-stream (type t) (default '#f))
142 
+   (linel (type fixnum) (default 0))
143 
+   (line-limit (type (maybe fixnum)) (default '#f))
144 
+   (line-no (type fixnum) (default 0))
145 
+   (char-mode (type (enum #f up down cap0 cap1 capw)) (default '#f))
146 
+   (char-mode-counter (type fixnum) (default 0))
147 
+   ;; number of logical blocks at qright that are started but not ended.
148 
+   (depth-in-blocks (type fixnum) (default 0))
149 
+   ;; This stack is pushed and popped in accordance with the way blocks
150 
+   ;; are nested at the moment they are entered into the queue.
151 
+   (block-stack (type vector) (default (make-vector xp.block-stack-min-size)))
152 
+   ;; Pointer into block-stack vector.
153 
+   (block-stack-ptr (type fixnum) (default 0))
154 
+   ;; This is a string that builds up the line images that will be printed out.
155 
+   (buffer (type string) (default (make-string xp.buffer-min-size)))
156 
+   ;; The output character position of the first character in the buffer;
157 
+   ;; nonzero only if a partial line has been output.
158 
+   (charpos (type fixnum) (default 0))
159 
+   ;; The index in the buffer where the next character is to be inserted.
160 
+   (buffer-ptr (type fixnum) (default 0))
161 
+   ;; This is used in computing total lengths.  It is changed to reflect
162 
+   ;; all shifting and insertion of prefixes so that total length computes
163 
+   ;; things as they would be if they were all on one line.
164 
+   (buffer-offset (type fixnum) (default 0))
165 
+   ;; The queue of action descriptors.  The value is a vector.
166 
+   (queue (type vector) (default (make-vector xp.queue-min-size)))
167 
+   ;; Index of next queue entry to dequeue.
168 
+   (qleft (type fixnum) (default 0))
169 
+   ;; Index of last entry queued; queue is empty when (> qleft qright).
170 
+   (qright (type fixnum) (default 0))
171 
+   ;; This stores the prefix that should be used at the start of the line.
172 
+   (prefix (type string) (default (make-string xp.buffer-min-size)))
173 
+   ;; This stack is pushed and popped in accordance with the way blocks
174 
+   ;; are nested at the moment things are taken off the queue and printed.
175 
+   (prefix-stack (type vector) (default (make-vector xp.prefix-stack-min-size)))
176 
+   ;; Index into prefix-stack.
177 
+   (prefix-stack-ptr (type fixnum) (default 0))
178 
+   ;; This stores the suffixes that have to be pritned to close of the
179 
+   ;; current open blocks.  For convenience in popping, the whole suffix
180 
+   ;; is stored in reverse order.
181 
+   (suffix (type string) (default (make-string xp.buffer-min-size)))
182 
+   ))
183 
+
184 
+
185 
+(define (xp.make-xp-structure)
186 
+  (make xp))
187 
+
188 
+
189 
+;;; Positions within the buffer are kept in three ways:
190 
+;;; * Buffer position (eg BUFFER-PTR)
191 
+;;; * Line position (eg (+ BUFFER-PTR CHARPOS)).
192 
+;;;   Indentations are stored in this form.
193 
+;;; * Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET))
194 
+;;;   Positions are stored in this form.
195 
+
196 
+(define-local-syntax (xp.lp<-bp xp . maybe-ptr)
197 
+  (let ((ptr  (if (not (null? maybe-ptr))
198 
+		  (car maybe-ptr)
199 
+		  `(xp.buffer-ptr ,xp))))
200 
+    `(+ ,ptr (xp.charpos ,xp))))
201 
+
202 
+(define-local-syntax (xp.tp<-bp xp)
203 
+  `(+ (xp.buffer-ptr ,xp) (xp.buffer-offset ,xp)))
204 
+
205 
+(define-local-syntax (xp.bp<-lp xp ptr)
206 
+  `(- ,ptr (xp.charpos ,xp)))
207 
+
208 
+(define-local-syntax (xp.bp<-tp xp ptr)
209 
+  `(- ,ptr (xp.buffer-offset ,xp)))
210 
+
211 
+(define-local-syntax (xp.lp<-tp xp ptr)
212 
+  `(xp.lp<-bp ,xp (xp.bp<-tp ,xp ,ptr)))
213 
+
214 
+
215 
+;;; Define some macros for growing the various stacks in the xp-structure.
216 
+
217 
+(define-local-syntax (xp.check-block-stack-size xp ptr)
218 
+  `(setf (xp.block-stack ,xp)
219 
+	 (xp.grow-vector (xp.block-stack ,xp) ,ptr xp.block-stack-entry-size)))
220 
+
221 
+(define-local-syntax (xp.check-prefix-size xp ptr)
222 
+  `(setf (xp.prefix ,xp)
223 
+	 (xp.grow-string (xp.prefix ,xp) ,ptr xp.prefix-entry-size)))
224 
+
225 
+(define-local-syntax (xp.check-prefix-stack-size xp ptr)
226 
+  `(setf (xp.prefix-stack ,xp)
227 
+	 (xp.grow-vector (xp.prefix-stack ,xp) ,ptr xp.prefix-stack-entry-size)))
228 
+
229 
+(define-local-syntax (xp.check-queue-size xp ptr)
230 
+  `(setf (xp.queue ,xp)
231 
+	 (xp.grow-vector (xp.queue ,xp) ,ptr xp.queue-entry-size)))
232 
+
233 
+(define-local-syntax (xp.check-buffer-size xp ptr)
234 
+  `(setf (xp.buffer ,xp)
235 
+	 (xp.grow-string (xp.buffer ,xp) ,ptr xp.buffer-entry-size)))
236 
+
237 
+(define-local-syntax (xp.check-suffix-size xp ptr)
238 
+  `(setf (xp.suffix ,xp)
239 
+	 (xp.grow-string (xp.suffix ,xp) ,ptr xp.suffix-entry-size)))
240 
+
241 
+(define (xp.grow-vector old ptr entry-size)
242 
+  (let ((end  (vector-length old)))
243 
+    (if (> ptr (- end entry-size))
244 
+	(let ((new  (make-vector (+ ptr 50))))
245 
+	  (dotimes (i end)
246 
+	    (setf (vector-ref new i) (vector-ref old i)))
247 
+	  new)
248 
+	old)))
249 
+
250 
+(define (xp.grow-string old ptr entry-size)
251 
+  (let ((end  (string-length old)))
252 
+    (if (> ptr (- end entry-size))
253 
+	(let ((new  (make-string (+ ptr 50))))
254 
+	  (dotimes (i end)
255 
+	    (setf (string-ref new i) (string-ref old i)))
256 
+	  new)
257 
+	old)))
258 
+
259 
+
260 
+
261 
+;;; Things for manipulating the block stack.
262 
+
263 
+(define-local-syntax (xp.section-start xp)
264 
+  `(vector-ref (xp.block-stack ,xp) (xp.block-stack-ptr ,xp)))
265 
+
266 
+(define (xp.push-block-stack xp)
267 
+  (incf (xp.block-stack-ptr xp) xp.block-stack-entry-size)
268 
+  (xp.check-block-stack-size xp (xp.block-stack-ptr xp)))
269 
+
270 
+(define (xp.pop-block-stack xp)
271 
+  (decf (xp.block-stack-ptr xp) xp.block-stack-entry-size))
272 
+
273 
+
274 
+;;; Prefix stack manipulations
275 
+
276 
+(define-local-syntax (xp.prefix-ptr xp)
277 
+  `(vector-ref (xp.prefix-stack ,xp) (xp.prefix-stack-ptr ,xp)))
278 
+(define-local-syntax (xp.suffix-ptr xp)
279 
+  `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 1)))
280 
+(define-local-syntax (non-blank-prefix-ptr xp)
281 
+  `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 2)))
282 
+(define-local-syntax (initial-prefix-ptr xp)
283 
+  `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 3)))
284 
+(define-local-syntax (xp.section-start-line xp)
285 
+  `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 4)))
286 
+
287 
+(define (xp.push-prefix-stack xp)
288 
+  (let ((old-prefix 0)
289 
+	(old-suffix 0)
290 
+	(old-non-blank 0))
291 
+    (when (not (negative? (xp.prefix-stack-ptr xp)))
292 
+      (setf old-prefix (xp.prefix-ptr xp))
293 
+      (setf old-suffix (xp.suffix-ptr xp))
294 
+      (setf  old-non-blank (non-blank-prefix-ptr xp)))
295 
+    (incf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size)
296 
+    (xp.check-prefix-stack-size xp (xp.prefix-stack-ptr xp))
297 
+    (setf (xp.prefix-ptr xp) old-prefix)
298 
+    (setf (xp.suffix-ptr xp) old-suffix)
299 
+    (setf (non-blank-prefix-ptr xp) old-non-blank)))
300 
+
301 
+(define (xp.pop-prefix-stack xp)
302 
+  (decf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size))
303 
+
304 
+
305 
+;;; The queue entries have several parts:
306 
+;;; QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK
307 
+;;; QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH
308 
+;;;  or :BLOCK/:CURRENT
309 
+;;; QPOS total position corresponding to this entry
310 
+;;; QDEPTH depth in blocks of this entry.
311 
+;;; QEND offset to entry marking end of section this entry starts.
312 
+;;   (NIL until known.)
313 
+;;;  Only :start-block and non-literal :newline entries can start sections.
314 
+;;; QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known).
315 
+;;; QARG for :IND indentation delta
316 
+;;;      for :START-BLOCK suffix in the block if any.
317 
+;;;                       or if per-line-prefix then cons of suffix and
318 
+;;;                       per-line-prefix.
319 
+;;;      for :END-BLOCK suffix for the block if any.
320 
+
321 
+(define-local-syntax (xp.qtype   xp index)
322 
+  `(vector-ref (xp.queue ,xp) ,index))
323 
+(define-local-syntax (xp.qkind   xp index)
324 
+  `(vector-ref (xp.queue ,xp) (1+ ,index)))
325 
+(define-local-syntax (xp.qpos    xp index)
326 
+  `(vector-ref (xp.queue ,xp) (+ ,index 2)))
327 
+(define-local-syntax (xp.qdepth  xp index)
328 
+  `(vector-ref (xp.queue ,xp) (+ ,index 3)))
329 
+(define-local-syntax (xp.qend    xp index)
330 
+  `(vector-ref (xp.queue ,xp) (+ ,index 4)))
331 
+(define-local-syntax (xp.qoffset xp index)
332 
+  `(vector-ref (xp.queue ,xp) (+ ,index 5)))
333 
+(define-local-syntax (xp.qarg    xp index)
334 
+  `(vector-ref (xp.queue ,xp) (+ ,index 6)))
335 
+
336 
+;;; we shift the queue over rather than using a circular queue because
337 
+;;; that works out to be a lot faster in practice.  Note, short printout
338 
+;;; does not ever cause a shift, and even in long printout, the queue is
339 
+;;; shifted left for free every time it happens to empty out.
340 
+
341 
+(define (xp.enqueue xp type kind . maybe-arg)
342 
+  (incf (xp.qright xp) xp.queue-entry-size)
343 
+  (when (> (xp.qright xp) (- xp.queue-min-size xp.queue-entry-size))
344 
+    (vector-replace (xp.queue xp) (xp.queue xp) 0 (xp.qleft xp) (xp.qright xp))
345 
+    (setf (xp.qright xp) (- (xp.qright xp) (xp.qleft xp)))
346 
+    (setf (xp.qleft xp) 0))
347 
+  (xp.check-queue-size xp (xp.qright xp))
348 
+  (setf (xp.qtype xp (xp.qright xp)) type)
349 
+  (setf (xp.qkind xp (xp.qright xp)) kind)
350 
+  (setf (xp.qpos xp (xp.qright xp)) (xp.tp<-bp xp))
351 
+  (setf (xp.qdepth xp (xp.qright xp)) (xp.depth-in-blocks xp))
352 
+  (setf (xp.qend xp (xp.qright xp)) '#f)
353 
+  (setf (xp.qoffset xp (xp.qright xp)) '#f)
354 
+  (setf (xp.qarg xp (xp.qright xp)) (car maybe-arg)))
355 
+
356 
+(define-local-syntax (xp.qnext index) `(+ ,index xp.queue-entry-size))
357 
+
358 
+
359 
+
360 
+;;; Print routine for xp structures
361 
+;;; *** this is broken, it uses unimplemented format options.
362 
+
363 
+(define *xp.describe-xp-streams-fully* '#f)
364 
+
365 
+(define (xp.describe-xp xp . maybe-stream)
366 
+  (let ((s  (if (not (null? maybe-stream))
367 
+		(car maybe-stream)
368 
+		(current-output-port))))
369 
+    (format s "#<XP stream ")
370 
+    (if (not (xp.base-stream xp))
371 
+	(format s "not currently in use")
372 
+	(begin
373 
+ 	  (format s "outputting to ~S" (xp.base-stream xp))
374 
+	  (format s "~&buffer= ~S"
375 
+		  (substring (xp.buffer xp) 0 (max (xp.buffer-ptr xp) 0)))
376 
+	  (if (not (dynamic *xp.describe-xp-streams-fully*))
377 
+	      (format s " ...")
378 
+	      (begin
379 
+	        (format s "~&   pos   _123456789_123456789_123456789_123456789")
380 
+		(format s "~&depth-in-blocks= ~D linel= ~D line-no= ~D line-limit= ~D"
381 
+			(xp.depth-in-blocks xp) (xp.linel xp)
382 
+			(xp.line-no xp) (xp.line-limit xp))
383 
+		(when (or (xp.char-mode xp) (not (zero? (xp.char-mode-counter xp))))
384 
+		  (format s "~&char-mode= ~S char-mode-counter= ~D"
385 
+			  (xp.char-mode xp) (xp.char-mode-counter xp)))
386 
+		(unless (negative? (xp.block-stack-ptr xp))
387 
+		  (format s "~&section-start")
388 
+		  (do ((save (xp.block-stack-ptr xp)))
389 
+		      ((negative? (xp.block-stack-ptr xp))
390 
+		       (setf (xp.block-stack-ptr xp) save))
391 
+		      (format s " ~D" (xp.section-start xp))
392 
+		      (xp.pop-block-stack xp)))
393 
+		(format s "~&linel= ~D charpos= ~D buffer-ptr= ~D buffer-offset= ~D"
394 
+			(xp.linel xp) (xp.charpos xp)
395 
+			(xp.buffer-ptr xp) (xp.buffer-offset xp))
396 
+		(unless (negative? (xp.prefix-stack-ptr xp))
397 
+		  (format s "~&prefix= ~S"
398 
+			  (substring (xp.prefix xp) 0 (max (xp.prefix-ptr xp) 0)))
399 
+		  (format s "~&suffix= ~S"
400 
+			  (substring (xp.suffix xp) 0 (max (xp.suffix-ptr xp) 0))))
401 
+		(unless (> (xp.qleft xp) (xp.qright xp))
402 
+		  (format s "~&ptr type         kind           pos depth end offset arg")
403 
+		  (do ((p (xp.qleft xp) (xp.qnext p)))
404 
+		      ((> p (xp.qright xp)))
405 
+		      (format s "~&~4A~13A~15A~4A~6A~4A~7A~A"
406 
+			      (/ (- p (xp.qleft xp)) xp.queue-entry-size)
407 
+			      (xp.qtype xp p)
408 
+			      (if (memq (xp.qtype xp p) '(newline ind))
409 
+				  (xp.qkind xp p)
410 
+				  "")
411 
+			      (xp.bp<-tp xp (xp.qpos xp p))
412 
+			      (xp.qdepth xp p)
413 
+			      (if (not (memq (xp.qtype xp p)
414 
+					     '(newline start-block)))
415 
+				  ""
416 
+				  (and (xp.qend xp p)
417 
+				       (/ (- (+ p (xp.qend xp p)) (xp.qleft xp))
418 
+					  xp.queue-entry-size)))
419 
+			      (if (not (eq? (xp.qtype xp p) 'start-block))
420 
+				  ""
421 
+				  (and (xp.qoffset xp p)
422 
+				       (/ (- (+ p (xp.qoffset xp p)) (xp.qleft xp))
423 
+					  xp.queue-entry-size)))
424 
+			      (if (not (memq (xp.qtype xp p)
425 
+					     '(ind start-block end-block)))
426 
+				  ""
427 
+				  (xp.qarg xp p)))))
428 
+		(unless (negative? (xp.prefix-stack-ptr xp))
429 
+		  (format s "~&initial-prefix-ptr prefix-ptr suffix-ptr non-blank start-line")
430 
+		  (do ((save (xp.prefix-stack-ptr xp)))
431 
+		      ((negative? (xp.prefix-stack-ptr xp))
432 
+		       (setf (xp.prefix-stack-ptr xp) save))
433 
+		      (format s "~& ~19A~11A~11A~10A~A"
434 
+			      (initial-prefix-ptr xp)
435 
+			      (xp.prefix-ptr xp)
436 
+			      (xp.suffix-ptr xp)
437 
+			      (non-blank-prefix-ptr xp)
438 
+			      (xp.section-start-line xp))
439 
+		      (xp.pop-prefix-stack xp)))))))
440 
+    (format s ">")))
441 
+
442 
+
443 
+
444 
+;;; Allocation of XP structures
445 
+
446 
+;;; This maintains a list of XP structures.  We save them
447 
+;;; so that we don't have to create new ones all of the time.
448 
+;;; We have separate objects so that many can be in use at once
449 
+;;; (e.g. for printing to multiple streams).
450 
+
451 
+(define xp.free-xps '())
452 
+
453 
+(define (xp.get-pretty-print-stream stream)
454 
+  (xp.initialize-xp
455 
+      (if (not (null? xp.free-xps))
456 
+	  (pop xp.free-xps)
457 
+	  (xp.make-xp-structure))
458 
+      stream))
459 
+
460 
+
461 
+;;; If you call this, the xp-stream gets efficiently recycled.
462 
+
463 
+(define (xp.free-pretty-print-stream xp)
464 
+  (setf (xp.base-stream xp) '#f)
465 
+  (if (not (memq xp xp.free-xps))
466 
+      (push xp xp.free-xps)))
467 
+
468 
+
469 
+;;; This is called to initialize things when you start pretty printing.
470 
+
471 
+(define (xp.initialize-xp xp stream)
472 
+  (setf (xp.base-stream xp) stream)
473 
+  (setf (xp.linel xp)
474 
+	(max 0
475 
+	     (cond ((dynamic *print-right-margin*))
476 
+		   ((internal-output-width stream))
477 
+		   (else (dynamic *default-right-margin*)))))
478 
+  (setf (xp.line-limit xp) (dynamic *print-lines*))
479 
+  (setf (xp.line-no xp) 1)
480 
+  (setf (xp.char-mode xp) '#f)
481 
+  (setf (xp.char-mode-counter xp) 0)
482 
+  (setf (xp.depth-in-blocks xp) 0)
483 
+  (setf (xp.block-stack-ptr xp) 0)
484 
+  (setf (xp.charpos xp) (or (internal-output-position stream) 0))
485 
+  (setf (xp.section-start xp) 0)
486 
+  (setf (xp.buffer-ptr xp) 0)
487 
+  (setf (xp.buffer-offset xp) (xp.charpos xp))
488 
+  (setf (xp.qleft xp) 0)
489 
+  (setf (xp.qright xp) (- xp.queue-entry-size))
490 
+  (setf (xp.prefix-stack-ptr xp) (- xp.prefix-stack-entry-size))
491 
+  xp)
492 
+
493 
+
494 
+
495 
+;;; The char-mode stuff is a bit tricky.
496 
+;;; one can be in one of the following modes:
497 
+;;; NIL no changes to characters output.
498 
+;;; :UP CHAR-UPCASE used.
499 
+;;; :DOWN CHAR-DOWNCASE used.
500 
+;;; :CAP0 capitalize next alphanumeric letter then switch to :DOWN.
501 
+;;; :CAP1 capitalize next alphanumeric letter then switch to :CAPW
502 
+;;; :CAPW downcase letters.  When a word break letter found, switch to :CAP1.
503 
+;;; It is possible for ~(~) to be nested in a format string, but note that
504 
+;;; each mode specifies what should happen to every letter.  Therefore, inner
505 
+;;; nested modes never have any effect.  You can just ignore them.
506 
+
507 
+(define (xp.push-char-mode xp new-mode)
508 
+  (if (zero? (xp.char-mode-counter xp))
509 
+      (setf (xp.char-mode xp) new-mode))
510 
+  (incf (xp.char-mode-counter xp)))
511 
+
512 
+(define (xp.pop-char-mode xp)
513 
+  (decf (xp.char-mode-counter xp))
514 
+  (if (zero? (xp.char-mode-counter xp))
515 
+      (setf (xp.char-mode xp) '#f)))
516 
+
517 
+
518 
+;;; Assumes is only called when char-mode is non-nil
519 
+
520 
+(define (xp.handle-char-mode xp char)
521 
+  (case (xp.char-mode xp)
522 
+    ((CAP0)
523 
+     (cond ((not (or (char-alphabetic? char) (char-numeric? char))) char)
524 
+	   (else (setf (xp.char-mode xp) 'DOWN) (char-upcase char))))
525 
+    ((CAP1)
526 
+     (cond ((not (or (char-alphabetic? char) (char-numeric? char))) char)
527 
+	   (else (setf (xp.char-mode xp) 'CAPW) (char-upcase char))))
528 
+    ((CAPW)
529 
+     (cond ((or (char-alphabetic? char) (char-numeric? char))
530 
+	    (char-downcase char))
531 
+	   (else (setf (xp.char-mode xp) 'CAP1) char)))
532 
+    ((UP)
533 
+     (char-upcase char))
534 
+    (else
535 
+     (char-downcase char)))) ;DOWN
536 
+
537 
+
538 
+;;; All characters output are passed through the handler above.  However,
539 
+;;; it must be noted that on-each-line prefixes are only processed in the
540 
+;;; context of the first place they appear.  They stay the same later no
541 
+;;; matter what.  Also non-literal newlines do not count as word breaks.
542 
+
543 
+;;; This handles the basic outputting of characters.  note + suffix means that
544 
+;;; the stream is known to be an XP stream, all inputs are mandatory, and no
545 
+;;; error checking has to be done.  Suffix ++ additionally means that the
546 
+;;; output is guaranteed not to contain a newline char.
547 
+
548 
+(define (xp.write-char+ char xp)
549 
+  (if (eqv? char #\newline)
550 
+      (xp.pprint-newline+ 'unconditional xp)
551 
+      (xp.write-char++ char xp)))
552 
+
553 
+(define (xp.write-string+ mystring xp start end)
554 
+  (let ((next-newline (string-position #\newline mystring start end)))
555 
+    (if next-newline
556 
+	(begin
557 
+	  (xp.write-string++ mystring xp start next-newline)
558 
+	  (xp.pprint-newline+ 'unconditional xp)
559 
+	  (xp.write-string+ mystring xp (1+ next-newline) end))
560 
+	(xp.write-string++ mystring xp start end))))
561 
+
562 
+
563 
+;;; note this checks (> BUFFER-PTR LINEL) instead of (> (xp.lp<-bp) LINEL)
564 
+;;; this is important so that when things are longer than a line they
565 
+;;; end up getting printed in chunks of size LINEL.
566 
+
567 
+(define (xp.write-char++ char xp)
568 
+  (when (> (xp.buffer-ptr xp) (xp.linel xp))
569 
+    (xp.force-some-output xp))
570 
+  (let ((new-buffer-end (1+ (xp.buffer-ptr xp))))
571 
+    (xp.check-buffer-size xp new-buffer-end)
572 
+    (if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char)))
573 
+    (setf (string-ref (xp.buffer xp) (xp.buffer-ptr xp)) char)
574 
+    (setf (xp.buffer-ptr xp) new-buffer-end)))
575 
+
576 
+(define (xp.force-some-output xp)
577 
+  (xp.attempt-to-output xp '#f '#f)
578 
+  (when (> (xp.buffer-ptr xp) (xp.linel xp)) ;only if printing off end of line
579 
+    (xp.attempt-to-output xp '#t '#t)))
580 
+
581 
+(define (xp.write-string++ mystring xp start end)
582 
+  (when (> (xp.buffer-ptr xp) (xp.linel xp))
583 
+    (xp.force-some-output xp))
584 
+  (xp.write-string+++ mystring xp start end))
585 
+
586 
+
587 
+;;; never forces output; therefore safe to call from within xp.output-line.
588 
+
589 
+(define (xp.write-string+++ mystring xp start end)
590 
+  (let ((new-buffer-end (+ (xp.buffer-ptr xp) (- end start))))
591 
+    (xp.check-buffer-size xp new-buffer-end)
592 
+    (do ((buffer (xp.buffer xp))
593 
+	 (i (xp.buffer-ptr xp) (1+ i))
594 
+	 (j start (1+ j)))
595 
+	((= j end))
596 
+      (let ((char (string-ref mystring j)))
597 
+	(if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char)))
598 
+	(setf (string-ref buffer i) char)))
599 
+    (setf (xp.buffer-ptr xp) new-buffer-end)))
600 
+
601 
+
602 
+(define (xp.pprint-tab+ kind colnum colinc xp)
603 
+  (let ((indented? '#f)
604 
+	(relative? '#f))
605 
+    (case kind
606 
+      ((section) (setf indented? '#t))
607 
+      ((line-relative) (setf relative? '#t))
608 
+      ((section-relative) (setf indented? '#t) (setf relative? '#t)))
609 
+    (let* ((current
610 
+	     (if (not indented?)
611 
+		 (xp.lp<-bp xp)
612 
+		 (- (xp.tp<-bp xp) (xp.section-start xp))))
613 
+	   (new
614 
+	     (if (zero? colinc)
615 
+		 (if relative? (+ current colnum) (max colnum current))
616 
+		 (cond (relative?
617 
+			(* colinc
618 
+			   (quotient (+ current colnum colinc -1) colinc)))
619 
+		       ((> colnum current) colnum)
620 
+		       (else
621 
+			(+ colnum
622 
+			   (* colinc
623 
+			      (quotient (+ current (- colnum) colinc)
624 
+					colinc)))))))
625 
+	   (end (- new current)))
626 
+      (when (positive? end)
627 
+	(if (xp.char-mode xp) (xp.handle-char-mode xp #\space))
628 
+	(let ((end (+ (xp.buffer-ptr xp) end)))
629 
+	  (xp.check-buffer-size xp end)
630 
+	  (string-fill (xp.buffer xp) #\space (xp.buffer-ptr xp) end)
631 
+	  (setf (xp.buffer-ptr xp) end))))))
632 
+
633 
+
634 
+;;; note following is smallest number >= x that is a multiple of colinc
635 
+;;;  (* colinc (quotient (+ x (1- colinc)) colinc))
636 
+
637 
+
638 
+(define (xp.pprint-newline+ kind xp)
639 
+  (xp.enqueue xp 'newline kind)
640 
+  (do ((ptr (xp.qleft xp) (xp.qnext ptr)))    ;find sections we are ending
641 
+      ((not (< ptr (xp.qright xp))))	;all but last
642 
+    (when (and (not (xp.qend xp ptr))
643 
+	       (not (> (xp.depth-in-blocks xp) (xp.qdepth xp ptr)))
644 
+	       (memq (xp.qtype xp ptr) '(newline start-block)))
645 
+      (setf (xp.qend xp ptr) (- (xp.qright xp) ptr))))
646 
+  (setf (xp.section-start xp) (xp.tp<-bp xp))
647 
+  (when (and (memq kind '(fresh unconditional)) (xp.char-mode xp))
648 
+    (xp.handle-char-mode xp #\newline))
649 
+  (when (memq kind '(fresh unconditional mandatory))
650 
+    (xp.attempt-to-output xp '#t '#f)))
651 
+
652 
+
653 
+(define (xp.start-block xp prefix-string on-each-line? suffix-string)
654 
+  (xp.write-prefix-suffix prefix-string xp)
655 
+  (if (and (xp.char-mode xp) on-each-line?)
656 
+      (setf prefix-string
657 
+	    (substring (xp.buffer xp)
658 
+		       (- (xp.buffer-ptr xp) (string-length prefix-string))
659 
+		       (xp.buffer-ptr xp))))
660 
+  (xp.push-block-stack xp)
661 
+  (xp.enqueue xp 'start-block '#f
662 
+	   (if on-each-line? (cons suffix-string prefix-string) suffix-string))
663 
+  (incf (xp.depth-in-blocks xp))	      ;must be after enqueue
664 
+  (setf (xp.section-start xp) (xp.tp<-bp xp)))
665 
+
666 
+
667 
+(define (xp.end-block xp suffix)
668 
+  (unless (and (dynamic *xp.abbreviation-happened*)
669 
+	       (eqv? (dynamic *xp.abbreviation-happened*)
670 
+		     (dynamic *print-lines*)))
671 
+    (xp.write-prefix-suffix suffix xp)
672 
+    (decf (xp.depth-in-blocks xp))
673 
+    (xp.enqueue xp 'end-block '#f suffix)
674 
+    (block foundit
675 
+      (do ((ptr (xp.qleft xp) (xp.qnext ptr))) ;look for start of block we are ending
676 
+	  ((not (< ptr (xp.qright xp))))    ;all but last
677 
+	  (when (and (= (xp.depth-in-blocks xp) (xp.qdepth xp ptr))
678 
+		     (eq? (xp.qtype xp ptr) 'start-block)
679 
+		     (not (xp.qoffset xp ptr)))
680 
+	    (setf (xp.qoffset xp ptr) (- (xp.qright xp) ptr))
681 
+	    (return-from foundit '#f)))	;can only be 1
682 
+      )
683 
+    (xp.pop-block-stack xp)))
684 
+
685 
+(define (xp.write-prefix-suffix mystring xp)
686 
+  (when mystring
687 
+    (xp.write-string++ mystring xp 0 (string-length mystring))))
688 
+
689 
+(define (xp.pprint-indent+ kind n xp)
690 
+  (xp.enqueue xp 'ind kind n))
691 
+
692 
+
693 
+;;; attempt-to-output scans the queue looking for things it can do.
694 
+;;; it keeps outputting things until the queue is empty, or it finds
695 
+;;; a place where it cannot make a decision yet.
696 
+;;; If flush-out? is T and force-newlines? is NIL then the buffer,
697 
+;;; prefix-stack, and queue will be in an inconsistent state after the call.
698 
+;;; You better not call it this way except as the last act of outputting.
699 
+
700 
+
701 
+(define-local-syntax (xp.maybe-too-large xp Qentry)
702 
+  `(let ((limit (xp.linel ,xp)))
703 
+     (when (eqv? (xp.line-limit ,xp) (xp.line-no ,xp)) ;prevents suffix overflow
704 
+       (decf limit 2) ;3 for " .." minus 1 for space (heuristic)
705 
+       (when (not (negative? (xp.prefix-stack-ptr ,xp)))
706 
+	 (decf limit (xp.suffix-ptr ,xp))))
707 
+     (cond ((xp.qend ,xp ,Qentry)
708 
+	    (> (xp.lp<-tp ,xp (xp.qpos ,xp (+ ,Qentry (xp.qend ,xp ,Qentry)))) limit))
709 
+	   ((or force-newlines? (> (xp.lp<-bp ,xp) limit))
710 
+	    '#t)
711 
+	   (else ;wait until later to decide.
712 
+	    (return-from attempt-to-output '#f)))))
713 
+
714 
+(define-local-syntax (xp.misering? xp)
715 
+  `(and (dynamic *print-miser-width*)
716 
+	(<= (- (xp.linel ,xp) (initial-prefix-ptr ,xp))
717 
+	    (dynamic *print-miser-width*))))
718 
+
719 
+(define (xp.attempt-to-output xp force-newlines? flush-out?)
720 
+  (block attempt-to-output
721 
+    (do ()
722 
+	((> (xp.qleft xp) (xp.qright xp))
723 
+	 (setf (xp.qleft xp) 0)
724 
+	 (setf (xp.qright xp) (- xp.queue-entry-size))) ;saves shifting
725 
+      (case (xp.qtype xp (xp.qleft xp))
726 
+	    ((ind)
727 
+	     (unless (xp.misering? xp)
728 
+	       (xp.set-indentation-prefix
729 
+		   xp
730 
+		   (case (xp.qkind xp (xp.qleft xp))
731 
+			 ((block)
732 
+			  (+ (initial-prefix-ptr xp) (xp.qarg xp (xp.qleft xp))))
733 
+			 (else ; current
734 
+			  (+ (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp)))
735 
+			     (xp.qarg xp (xp.qleft xp)))))))
736 
+	     (setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
737 
+	    ((start-block)
738 
+	     (cond ((xp.maybe-too-large xp (xp.qleft xp))
739 
+		    (xp.push-prefix-stack xp)
740 
+		    (setf (initial-prefix-ptr xp) (xp.prefix-ptr xp))
741 
+		    (xp.set-indentation-prefix
742 
+		        xp (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp))))
743 
+		    (let ((arg (xp.qarg xp (xp.qleft xp))))
744 
+		      (when (pair? arg) (xp.set-prefix xp (cdr arg)))
745 
+		      (setf (initial-prefix-ptr xp) (xp.prefix-ptr xp))
746 
+		      (cond ((not (list? arg)) (xp.set-suffix xp arg))
747 
+			    ((car arg) (xp.set-suffix xp (car arg)))))
748 
+		    (setf (xp.section-start-line xp) (xp.line-no xp)))
749 
+		   (else (incf (xp.qleft xp) (xp.qoffset xp (xp.qleft xp)))))
750 
+	     (setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
751 
+	    ((end-block)
752 
+	     (xp.pop-prefix-stack xp)
753 
+	     (setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
754 
+	    (else ; newline
755 
+	     (when (case (xp.qkind xp (xp.qleft xp))
756 
+			 ((fresh) (not (zero? (xp.lp<-bp xp))))
757 
+			 ((miser) (xp.misering? xp))
758 
+			 ((fill) (or (xp.misering? xp)
759 
+				      (> (xp.line-no xp) (xp.section-start-line xp))
760 
+				      (xp.maybe-too-large xp (xp.qleft xp))))
761 
+			 (else '#t)) ;(linear unconditional mandatory)
762 
+	       (xp.output-line xp (xp.qleft xp))
763 
+	       (xp.setup-for-next-line xp (xp.qleft xp)))
764 
+	     (setf (xp.qleft xp) (xp.qnext (xp.qleft xp)))))))
765 
+  (when flush-out? (xp.flush xp)))
766 
+
767 
+
768 
+;;; this can only be called last!
769 
+
770 
+(define (xp.flush xp)
771 
+  (unless (dynamic *xp.locating-circularities*)
772 
+    (internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 (xp.buffer-ptr xp)))
773 
+  (incf (xp.buffer-offset xp) (xp.buffer-ptr xp))
774 
+  (incf (xp.charpos xp) (xp.buffer-ptr xp))
775 
+  (setf (xp.buffer-ptr xp) 0))
776 
+
777 
+
778 
+;;; This prints out a line of stuff.
779 
+
780 
+(define (xp.output-line xp Qentry)
781 
+  (let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry)))
782 
+	 (last-non-blank (string-position-not-from-end
783 
+			     #\space (xp.buffer xp) 0 out-point))
784 
+	 (end (cond ((memq (xp.qkind xp Qentry) '(fresh unconditional))
785 
+		     out-point)
786 
+		    (last-non-blank (1+ last-non-blank))
787 
+		    (else 0)))
788 
+	 (line-limit-exit (and (xp.line-limit xp)
789 
+			       (not (> (xp.line-limit xp) (xp.line-no xp))))))
790 
+    (when line-limit-exit
791 
+      (setf (xp.buffer-ptr xp) end)          ;truncate pending output.
792 
+      (xp.write-string+++ " .." xp 0 3)
793 
+      (string-nreverse (xp.suffix xp) 0 (xp.suffix-ptr xp))
794 
+      (xp.write-string+++ (xp.suffix xp) xp 0 (xp.suffix-ptr xp))
795 
+      (setf (xp.qleft xp) (xp.qnext (xp.qright xp)))
796 
+      (setf (dynamic *xp.abbreviation-happened*) (dynamic *print-lines*))
797 
+      (funcall (dynamic *xp.line-limit-abbreviation-exit*) '#t))
798 
+    (incf (xp.line-no xp))
799 
+    (unless (dynamic *xp.locating-circularities*)
800 
+      (internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 end)
801 
+      (newline (xp.base-stream xp)))))
802 
+
803 
+(define (xp.setup-for-next-line xp Qentry)
804 
+  (let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry)))
805 
+	 (prefix-end
806 
+	   (cond ((memq (xp.qkind xp Qentry) '(unconditional fresh))
807 
+		  (non-blank-prefix-ptr xp))
808 
+		 (else (xp.prefix-ptr xp))))
809 
+	 (change (- prefix-end out-point)))
810 
+    (setf (xp.charpos xp) 0)
811 
+    (when (positive? change)                  ;almost never happens
812 
+      (xp.check-buffer-size xp (+ (xp.buffer-ptr xp) change)))
813 
+    (string-replace (xp.buffer xp) (xp.buffer xp)
814 
+		    prefix-end out-point (xp.buffer-ptr xp))
815 
+    (string-replace (xp.buffer xp) (xp.prefix xp) 0 0 prefix-end)
816 
+    (incf (xp.buffer-ptr xp) change)
817 
+    (decf (xp.buffer-offset xp) change)
818 
+    (when (not (memq (xp.qkind xp Qentry) '(unconditional fresh)))
819 
+      (setf (xp.section-start-line xp) (xp.line-no xp)))))
820 
+
821 
+(define (xp.set-indentation-prefix xp new-position)
822 
+  (let ((new-ind (max (non-blank-prefix-ptr xp) new-position)))
823 
+    (setf (xp.prefix-ptr xp) (initial-prefix-ptr xp))
824 
+    (xp.check-prefix-size xp new-ind)
825 
+    (when (> new-ind (xp.prefix-ptr xp))
826 
+      (string-fill (xp.prefix xp) #\space (xp.prefix-ptr xp) new-ind))
827 
+    (setf (xp.prefix-ptr xp) new-ind)))
828 
+
829 
+(define (xp.set-prefix xp prefix-string)
830 
+  (let ((end  (string-length prefix-string)))
831 
+    (string-replace (xp.prefix xp) prefix-string
832 
+		    (- (xp.prefix-ptr xp) end) 0 end))
833 
+  (setf (non-blank-prefix-ptr xp) (xp.prefix-ptr xp)))
834 
+
835 
+(define (xp.set-suffix xp suffix-string)
836 
+  (let* ((end (string-length suffix-string))
837 
+	 (new-end (+ (xp.suffix-ptr xp) end)))
838 
+    (xp.check-suffix-size xp new-end)
839 
+    (do ((i (1- new-end) (1- i))
840 
+	 (j 0 (1+ j)))
841 
+	((= j end))
842 
+      (setf (string-ref (xp.suffix xp) i) (string-ref suffix-string j)))
843 
+    (setf (xp.suffix-ptr xp) new-end)))
844 
+
845 
+
846 
+;;;=====================================================================
847 
+;;; Basic interface functions
848 
+;;;=====================================================================
849 
+
850 
+;;; The internal functions in this file
851 
+;;; use the '+' forms of these functions directly (which is faster) because,
852 
+;;; they do not need error checking of fancy stream coercion.  The '++' forms
853 
+;;; additionally assume the thing being output does not contain a newline.
854 
+
855 
+(define (write object . maybe-stream)
856 
+  (let ((stream  (if (not (null? maybe-stream))
857 
+		     (car maybe-stream)
858 
+		     (current-output-port))))
859 
+    (cond ((xp.xp-structure-p stream)
860 
+	   (xp.write+ object stream))
861 
+	  ((xp.get-printer object)
862 
+	   (xp.initiate-xp-printing
863 
+	     (lambda (s o) (xp.write+ o s))
864 
+	     stream
865 
+	     object))
866 
+	  (else
867 
+	   (internal-write object stream)))))
868 
+
869 
+(define (xp.maybe-initiate-xp-printing fn stream . args)
870 
+  (if (xp.xp-structure-p stream)
871 
+      (apply fn stream args)
872 
+      (apply (function xp.initiate-xp-printing) fn stream args)))
873 
+
874 
+(define (xp.initiate-xp-printing fn stream . args)
875 
+  (dynamic-let ((*xp.abbreviation-happened*
876 
+		    '#f)
877 
+		(*xp.locating-circularities*
878 
+		    (if (dynamic *print-circle*)
879 
+			0
880 
+			'#f))
881 
+		(*xp.circularity-hash-table*
882 
+		    (if (dynamic *print-circle*)
883 
+			(make-table)
884 
+			'#f))
885 
+		(*xp.parents*
886 
+		    (if (not (dynamic *print-shared*))
887 
+			(list '#f)
888 
+			'()))			;*** is this right?
889 
+		(*xp.current-level*
890 
+		    0)
891 
+		(*xp.current-length*
892 
+		    0))
893 
+    (let ((result  (xp.xp-print fn stream args)))
894 
+      (when (dynamic *xp.abbreviation-happened*)
895 
+	(setf args (list-copy args))
896 
+	(setf (dynamic *last-abbreviated-printing*)
897 
+	      (lambda maybe-stream
898 
+		(let ((stream  (if (not (null? maybe-stream))
899 
+				   (car maybe-stream)
900 
+				   stream)))
901 
+		  (apply (function xp.maybe-initiate-xp-printing)
902 
+			 fn stream args)))))
903 
+      result)))
904 
+
905 
+(define (xp.xp-print fn stream args)
906 
+  (let ((result  (xp.do-xp-printing fn stream args)))
907 
+    (when (dynamic *xp.locating-circularities*)
908 
+      (setf (dynamic *xp.locating-circularities*) '#f)
909 
+      (setf (dynamic *xp.abbreviation-happened*) '#f)
910 
+      (setf (dynamic *xp.parents*) '())
911 
+      (setf result (xp.do-xp-printing fn stream args)))
912 
+    result))
913 
+
914 
+(define (xp.do-xp-printing fn stream args)
915 
+  (let ((xp (xp.get-pretty-print-stream stream))
916 
+	(result '#f))
917 
+    (dynamic-let ((*xp.current-level* 0))
918 
+      (let/cc catch
919 
+        (dynamic-let ((*xp.line-limit-abbreviation-exit* catch))
920 
+	  (xp.start-block xp '#f '#f '#f)
921 
+	  (setf result (apply fn xp args))
922 
+	  (xp.end-block xp '#f)))
923 
+      (when (and (dynamic *xp.locating-circularities*)
924 
+		 (zero? (dynamic *xp.locating-circularities*)) ;No circularities.
925 
+		 (= (xp.line-no xp) 1)	     	;Didn't suppress line.
926 
+		 (zero? (xp.buffer-offset xp)))	;Didn't suppress partial line.
927 
+	(setf (dynamic *xp.locating-circularities*) '#f))	;print what you have got.
928 
+      (when (let/cc catch
929 
+	      (dynamic-let ((*xp.line-limit-abbreviation-exit* catch))
930 
+	        (xp.attempt-to-output xp '#f '#t)
931 
+		'#f))
932 
+	(xp.attempt-to-output xp '#t '#t))
933 
+      (xp.free-pretty-print-stream xp)
934 
+      result)))
935 
+
936 
+
937 
+(define (xp.write+ object xp)
938 
+  (dynamic-let ((*xp.parents* (dynamic *xp.parents*)))
939 
+    (unless (and (dynamic *xp.circularity-hash-table*)
940 
+		 (eq? (xp.circularity-process xp object '#f) 'subsequent))
941 
+      (when (and (dynamic *xp.circularity-hash-table*) (pair? object))
942 
+	;; Must do this to avoid additional circularity detection by
943 
+        ;; pprint-logical-block; otherwise you get stuff like #1=#1#.
944 
+	(setf object (cons (car object) (cdr object))))
945 
+      (funcall (or (xp.get-printer object) (function xp.print-default))
946 
+	       object
947 
+	       xp))
948 
+    object))
949 
+
950 
+
951 
+
952 
+(define (xp.print-default object xp)
953 
+  (let ((stuff (internal-write-to-string object)))
954 
+    (xp.write-string+ stuff xp 0 (string-length stuff))))
955 
+
956 
+
957 
+;;; It is vital that this function be called EXACTLY once for each occurrence
958 
+;;;   of each thing in something being printed.
959 
+;;; Returns nil if printing should just continue on.
960 
+;;;   Either it is not a duplicate, or we are in the first pass and do not
961 
+;;;   know.
962 
+;;; returns :FIRST if object is first occurrence of a DUPLICATE.
963 
+;;;   (This can only be returned on a second pass.)
964 
+;;;   After an initial code (printed by this routine on the second pass)
965 
+;;;   printing should continue on for the object.
966 
+;;; returns :SUBSEQUENT if second or later occurrence.
967 
+;;;   Printing is all taken care of by this routine.
968 
+
969 
+;;; Note many (maybe most) lisp implementations have characters and small
970 
+;;; numbers represented in a single word so that the are always eq when
971 
+;;; they are equal and the reader takes care of properly sharing them
972 
+;;; (just as it does with symbols).  Therefore, we do not want circularity
973 
+;;; processing applied to them.  However, some kinds of numbers
974 
+;;; (e.g., bignums) undoubtedly are complex structures that the reader
975 
+;;; does not share.  However, they cannot have circular pointers in them
976 
+;;; and it is therefore probably a waste to do circularity checking on them.
977 
+;;; In any case, it is not clear that it easy to tell exactly what kinds of
978 
+;;; numbers a given implementation is going to have the reader
979 
+;;; automatically share.
980 
+
981 
+(define (xp.circularity-process xp object interior-cdr?)
982 
+  (unless (or (number? object)
983 
+	      (char? object)
984 
+	      (and (symbol? object) (not (gensym? object))))
985 
+    (let ((id (table-entry (dynamic *xp.circularity-hash-table*) object)))
986 
+      (if (dynamic *xp.locating-circularities*)
987 
+	  ;; This is the first pass.
988 
+	  (cond ((not id)	;never seen before
989 
+		 (when (not (null? (dynamic *xp.parents*)))
990 
+		   (push object (dynamic *xp.parents*)))
991 
+		 (setf (table-entry (dynamic *xp.circularity-hash-table*) object)
992 
+		       0)
993 
+		 '#f)
994 
+		((zero? id) ;possible second occurrence
995 
+		 (cond ((or (null? (dynamic *xp.parents*))
996 
+			    (memq object (dynamic *xp.parents*)))
997 
+			(setf (table-entry
998 
+			          (dynamic *xp.circularity-hash-table*) object)
999 
+			      (incf (dynamic *xp.locating-circularities*)))
1000 
+			'subsequent)
1001 
+		       (else '#f)))
1002 
+		(else 'subsequent));third or later occurrence
1003 
+	  ;; This is the second pass.
1004 
+	  (cond ((or (not id)	;never seen before (note ~@* etc. conses)
1005 
+		     (zero? id));no duplicates
1006 
+		 '#f)
1007 
+		((positive? id) ; first occurrence
1008 
+		 (cond (interior-cdr?
1009 
+			(decf (dynamic *xp.current-level*))
1010 
+			(xp.write-string++ ". #" xp 0 3))
1011 
+		       (else (xp.write-char++ #\# xp)))
1012 
+		 (xp.print-integer id xp)
1013 
+		 (xp.write-char++ #\= xp)
1014 
+		 (setf (table-entry (dynamic *xp.circularity-hash-table*) object)
1015 
+		       (- id))
1016 
+		 'first)
1017 
+		(else
1018 
+		 (if interior-cdr?
1019 
+		     (xp.write-string++ ". #" xp 0 3)
1020 
+		     (xp.write-char++ #\# xp))
1021 
+		 (xp.print-integer(- id) xp)
1022 
+		 (xp.write-char++ #\# xp)
1023 
+		 'subsequent))))))
1024 
+
1025 
+
1026 
+;;; Here are all the standard Common Lisp printing functions.
1027 
+
1028 
+(define (print object . maybe-stream)
1029 
+  (let ((stream  (if (not (null? maybe-stream))
1030 
+		     (car maybe-stream)
1031 
+		     (current-output-port))))
1032 
+    (dynamic-let ((*print-escape* '#t))
1033 
+      (terpri stream)
1034 
+      (write object stream)
1035 
+      (write-char #\space stream)
1036 
+      object)))
1037 
+
1038 
+(define (prin1 object . maybe-stream)
1039 
+  (let ((stream  (if (not (null? maybe-stream))
1040 
+		     (car maybe-stream)
1041 
+		     (current-output-port))))
1042 
+    (dynamic-let ((*print-escape* '#t))
1043 
+      (write object stream)
1044 
+      object)))
1045 
+
1046 
+(define (princ object . maybe-stream)
1047 
+  (let ((stream  (if (not (null? maybe-stream))
1048 
+		     (car maybe-stream)
1049 
+		     (current-output-port))))
1050 
+    (dynamic-let ((*print-escape* '#f))
1051 
+      (write object stream)
1052 
+      object)))
1053 
+
1054 
+(define (display object . maybe-stream)
1055 
+  (apply (function princ) object maybe-stream))
1056 
+
1057 
+
1058 
+(define (pprint object . maybe-stream)
1059 
+  (let ((stream  (if (not (null? maybe-stream))
1060 
+		     (car maybe-stream)
1061 
+		     (current-output-port))))
1062 
+    (dynamic-let ((*print-escape* '#t)
1063 
+		  (*print-pretty* '#t))
1064 
+      (terpri stream)
1065 
+      (write object stream)
1066 
+      (values))))
1067 
+
1068 
+(define (prin1-to-string object)
1069 
+  (call-with-output-string
1070 
+      (lambda (stream)
1071 
+	(dynamic-let ((*print-escape* '#t))
1072 
+	  (write object stream)))))
1073 
+
1074 
+(define (princ-to-string object)
1075 
+  (call-with-output-string
1076 
+      (lambda (stream)
1077 
+	(dynamic-let ((*print-escape* '#f))
1078 
+	  (write object stream)))))
1079 
+
1080 
+
1081 
+
1082 
+(define (write-char char . maybe-stream)
1083 
+  (let ((stream  (if (not (null? maybe-stream))
1084 
+		     (car maybe-stream)
1085 
+		     (current-output-port))))
1086 
+    (if (xp.xp-structure-p stream)
1087 
+	(xp.write-char+ char stream)
1088 
+	(internal-write-char char stream))
1089 
+    char))
1090 
+
1091 
+(define (write-string mystring . maybe-stream-start-end)
1092 
+  (let* ((stream  (if (not (null? maybe-stream-start-end))
1093 
+		      (car maybe-stream-start-end)
1094 
+		      (current-output-port)))
1095 
+	 (start   (if (not (null? (cdr maybe-stream-start-end)))
1096 
+		      (cadr maybe-stream-start-end)
1097 
+		      0))
1098 
+	 (end     (if (not (null? (cddr maybe-stream-start-end)))
1099 
+		      (caddr maybe-stream-start-end)
1100 
+		      (string-length mystring))))
1101 
+    (if (xp.xp-structure-p stream)
1102 
+	(xp.write-string+ mystring stream start end)
1103 
+	(internal-write-string mystring stream start end))
1104 
+    mystring))
1105 
+
1106 
+(define (write-line mystring . maybe-stream-start-end)
1107 
+  (let* ((stream  (if (not (null? maybe-stream-start-end))
1108 
+		      (car maybe-stream-start-end)
1109 
+		      (current-output-port)))
1110 
+	 (start   (if (not (null? (cdr maybe-stream-start-end)))
1111 
+		      (cadr maybe-stream-start-end)
1112 
+		      0))
1113 
+	 (end     (if (not (null? (cddr maybe-stream-start-end)))
1114 
+		      (caddr maybe-stream-start-end)
1115 
+		      (string-length mystring))))
1116 
+    (if (xp.xp-structure-p stream)
1117 
+	(begin
1118 
+	  (xp.write-string+ mystring stream start end)
1119 
+	  (xp.pprint-newline+ 'unconditional stream))
1120 
+	(begin
1121 
+	  (internal-write-string mystring stream start end)
1122 
+	  (internal-newline stream)))
1123 
+    mystring))
1124 
+
1125 
+(define (terpri . maybe-stream)
1126 
+  (let ((stream  (if (not (null? maybe-stream))
1127 
+		     (car maybe-stream)
1128 
+		     (current-output-port))))
1129 
+    (if (xp.xp-structure-p stream)
1130 
+	(xp.pprint-newline+ 'unconditional stream)
1131 
+	(internal-newline stream))
1132 
+    '#f))
1133 
+
1134 
+(define (newline . maybe-stream)
1135 
+  (apply (function terpri) maybe-stream))
1136 
+
1137 
+
1138 
+;;; This has to violate the XP data abstraction and fool with internal
1139 
+;;; stuff, in order to find out the right info to return as the result.
1140 
+
1141 
+(define (fresh-line . maybe-stream)
1142 
+  (let ((stream  (if (not (null? maybe-stream))
1143 
+		     (car maybe-stream)
1144 
+		     (current-output-port))))
1145 
+    (cond ((xp.xp-structure-p stream)
1146 
+	   (xp.attempt-to-output stream '#t '#t) ;ok because we want newline
1147 
+	   (when (not (zero? (xp.lp<-bp stream)))
1148 
+	     (xp.pprint-newline+ 'fresh stream)
1149 
+	     '#t))
1150 
+	  (else
1151 
+	   (internal-fresh-line stream)))))
1152 
+
1153 
+
1154 
+;;; Each of these causes the stream to be pessimistic and insert
1155 
+;;; newlines wherever it might have to, when forcing the partial output
1156 
+;;; out.  This is so that things will be in a consistent state if
1157 
+;;; output continues to the stream later.
1158 
+
1159 
+(define (finish-output . maybe-stream)
1160 
+  (let ((stream  (if (not (null? maybe-stream))
1161 
+		     (car maybe-stream)
1162 
+		     (current-output-port))))
1163 
+    (if (xp.xp-structure-p stream)
1164 
+	(xp.attempt-to-output stream '#t '#t)
1165 
+	(internal-finish-output stream))
1166 
+    '#f))
1167 
+
1168 
+(define (force-output . maybe-stream)
1169 
+  (let ((stream  (if (not (null? maybe-stream))
1170 
+		     (car maybe-stream)
1171 
+		     (current-output-port))))
1172 
+    (if (xp.xp-structure-p stream)
1173 
+	(xp.attempt-to-output stream '#t '#t)
1174 
+	(internal-force-output stream))
1175 
+    '#f))
1176 
+
1177 
+(define (clear-output . maybe-stream)
1178 
+  (let ((stream  (if (not (null? maybe-stream))
1179 
+		     (car maybe-stream)
1180 
+		     (current-output-port))))
1181 
+    (if (xp.xp-structure-p stream)
1182 
+	(dynamic-let ((*xp.locating-circularities* 0)) ;hack to prevent visible output
1183 
+	  (xp.attempt-to-output stream '#t '#t)
1184 
+	(internal-clear-output stream)))
1185 
+    '#f))
1186 
+
1187 
+
1188 
+
1189 
+
1190 
+;;;=====================================================================
1191 
+;;; Functional interface to dynamic formatting
1192 
+;;;=====================================================================
1193 
+
1194 
+;;; The internal functions in this file, and the (formatter "...") expansions
1195 
+;;; use the '+' forms of these functions directly (which is faster) because,
1196 
+;;; they do not need error checking or fancy stream coercion.  The '++' forms
1197 
+;;; additionally assume the thing being output does not contain a newline.
1198 
+
1199 
+(define-syntax (pprint-logical-block stream-symbol-stuff . body)
1200 
+  (let* ((stream-symbol    (car stream-symbol-stuff))
1201 
+	 (mylist             (cadr stream-symbol-stuff))
1202 
+	 (rest             (cddr stream-symbol-stuff))
1203 
+	 (prefix           (if (not (null? rest)) (pop rest) ""))
1204 
+	 (suffix           (if (not (null? rest)) (pop rest) ""))
1205 
+	 (per-line?        (if (not (null? rest)) (pop rest) '#f)))
1206 
+    `(xp.maybe-initiate-xp-printing
1207 
+       (lambda (,stream-symbol)
1208 
+	 (let ((+l ,mylist)
1209 
+	       (+p ,prefix)
1210 
+	       (+s ,suffix)
1211 
+	       (+x ,stream-symbol))
1212 
+	   (xp.pprint-logical-block+ (+x +l +p +s ,per-line? '#t '#f)
1213 
+	     ,@body
1214 
+	     '#f)))
1215 
+       ,stream-symbol)))
1216 
+
1217 
+
1218 
+;;; Assumes var and args must be variables.  Other arguments must be literals
1219 
+;;; or variables.
1220 
+
1221 
+(define-syntax (xp.pprint-logical-block+ stuff . body)
1222 
+  (let* ((var            (pop stuff))
1223 
+	 (args           (pop stuff))
1224 
+	 (prefix         (pop stuff))
1225 
+	 (suffix         (pop stuff))
1226 
+	 (per-line?      (pop stuff)))
1227 
+    `(unless (xp.check-abbreviation ,var ,args)
1228 
+       (dynamic-let ((*xp.current-level* (1+ (dynamic *xp.current-level*)))
1229 
+		     (*xp.current-length* -1)
1230 
+		     (*xp.parents* (dynamic *xp.parents*)))
1231 
+	 (block logical-block
1232 
+	   (if (dynamic *print-pretty*)
1233 
+	       (xp.start-block ,var ,prefix ,per-line? ,suffix)
1234 
+	       (xp.write-prefix-suffix ,prefix ,var))
1235 
+	   (unwind-protect
1236 
+	       (begin ,@body)
1237 
+	     (if (dynamic *print-pretty*)
1238 
+		 (xp.end-block ,var ,suffix)
1239 
+		 (xp.write-prefix-suffix ,suffix ,var))))))
1240 
+    ))
1241 
+
1242 
+(define (xp.check-abbreviation xp object)
1243 
+  (cond ((and (dynamic *print-level*)
1244 
+	      (>= (dynamic *xp.current-level*)
1245 
+		  (dynamic *print-level*)))
1246 
+	 (xp.write-char++ #\# XP)
1247 
+	 (setf (dynamic *xp.abbreviation-happened*) '#t)
1248 
+	 '#t)
1249 
+	((and (dynamic *xp.circularity-hash-table*)
1250 
+	      (eq? (xp.circularity-process xp object '#f) 'subsequent))
1251 
+	 '#t)
1252 
+	(else '#f)))
1253 
+
1254 
+
1255 
+(define-syntax (pprint-pop)
1256 
+  `(xp.pprint-pop+ +l +x))
1257 
+
1258 
+(define-syntax (xp.pprint-pop+ args xp)
1259 
+  `(if (xp.pprint-pop-check+ ,args ,xp)
1260 
+       (return-from logical-block '#f)
1261 
+       (if (null? ,args) '() (pop ,args))))
1262 
+
1263 
+(define (xp.pprint-pop-check+ args xp)
1264 
+  (incf (dynamic *xp.current-length*))
1265 
+  (cond ((not (or (pair? args) (null? args)))
1266 
+	 ;; must be first to supersede length abbreviation
1267 
+	 (xp.write-string++ ". " xp 0 2)
1268 
+	 (xp.write+ args xp)
1269 
+	 '#t)
1270 
+	((and (dynamic *print-length*)
1271 
+	      (not (< *xp.current-length* (dynamic *print-length*))))
1272 
+	 ;; must supersede circularity check
1273 
+	 (xp.write-string++ "..." xp 0 3)
1274 
+	 (setf (dynamic *xp.abbreviation-happened*) '#t)
1275 
+	 '#t)
1276 
+	((and (dynamic *xp.circularity-hash-table*)
1277 
+	      (not (zero? *xp.current-length*)))
1278 
+	 (case (xp.circularity-process xp args '#t)
1279 
+	       ((first)
1280 
+		(xp.write+ (cons (car args) (cdr args)) xp) '#t)
1281 
+	       ((subsequent)
1282 
+		'#t)
1283 
+	       (else
1284 
+		'#f)))
1285 
+	(else
1286 
+	 '#f)))
1287 
+
1288 
+(define-syntax (pprint-exit-if-list-exhausted)
1289 
+  `(xp.pprint-exit-if-list-exhausted+ +l))
1290 
+
1291 
+(define-syntax (xp.pprint-exit-if-list-exhausted+ mylist)
1292 
+  `(if (null? ,mylist) (return-from logical-block '#f)))
1293 
+
1294 
+
1295 
+(define (pprint-newline kind . maybe-stream)
1296 
+  (let ((stream  (if (not (null? maybe-stream))
1297 
+		     (car maybe-stream)
1298 
+		     (current-output-port))))
1299 
+    (when (not (memq kind '(linear miser fill mandatory)))
1300 
+      (error "Invalid KIND argument ~A to PPRINT-NEWLINE" kind))
1301 
+    (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
1302 
+      (xp.pprint-newline+ kind stream))
1303 
+    '#f))
1304 
+
1305 
+(define (pprint-indent relative-to n . maybe-stream)
1306 
+  (let ((stream  (if (not (null? maybe-stream))
1307 
+		     (car maybe-stream)
1308 
+		     (current-output-port))))
1309 
+    (when (not (memq relative-to '(block current)))
1310 
+      (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to))
1311 
+    (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
1312 
+      (xp.pprint-indent+ relative-to n stream))
1313 
+    '#f))
1314 
+
1315 
+(define (pprint-tab kind colnum colinc . maybe-stream)
1316 
+  (let ((stream  (if (not (null? maybe-stream))
1317 
+		     (car maybe-stream)
1318 
+		     (current-output-port))))
1319 
+    (when (not (memq kind '(line section line-relative section-relative)))
1320 
+      (error "Invalid KIND argument ~A to PPRINT-TAB" kind))
1321 
+    (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
1322 
+      (xp.pprint-tab+ kind colnum colinc stream))
1323 
+    '#f))
1324 
+
1325 
+
1326 
+
1327 
+
1328 
+;;;=====================================================================
1329 
+;;; Standard print dispatch function
1330 
+;;;=====================================================================
1331 
+
1332 
+
1333 
+(define (xp.print-null object xp)
1334 
+  (declare (ignore object))
1335 
+  (xp.write-string+ "()" xp 0 2))
1336 
+
1337 
+(define (xp.print-true object xp)
1338 
+  (declare (ignore object))
1339 
+  (xp.write-string+ "#t" xp 0 2))
1340 
+
1341 
+(define (xp.print-false object xp)
1342 
+  (declare (ignore object))
1343 
+  (xp.write-string+ "#f" xp 0 2))
1344 
+
1345 
+(define (xp.print-symbol object xp)
1346 
+  (if (dynamic *print-escape*)
1347 
+      (xp.print-default object xp)
1348 
+      (let ((mystring  (symbol->string object)))
1349 
+	(xp.write-string+ mystring xp 0 (string-length mystring)))))
1350 
+
1351 
+(define (xp.print-number object xp)
1352 
+  (if (and (integer? object)
1353 
+	   (eqv? (dynamic *print-base*) 10)
1354 
+	   (not (dynamic *print-radix*)))
1355 
+      (begin
1356 
+        (when (negative? object)
1357 
+	  (xp.write-char++ #\- xp)
1358 
+	  (setf object (- object)))
1359 
+	(xp.print-integer object xp))
1360 
+      (xp.print-default object xp)))
1361 
+
1362 
+(define (xp.print-integer n xp)
1363 
+  (let ((quot  (quotient n 10))
1364 
+	(rem   (remainder n 10)))
1365 
+    (unless (zero? quot)
1366 
+      (xp.print-integer quot xp))
1367 
+    (xp.write-char++ (string-ref "0123456789" rem) xp)))
1368 
+
1369 
+(define (xp.print-string object xp)
1370 
+  (if (dynamic *print-escape*)
1371 
+      (begin
1372 
+        (xp.write-char++ #\" xp)
1373 
+	(do ((i 0 (1+ i))
1374 
+	     (n (string-length object)))
1375 
+	    ((= i n))
1376 
+	    (let ((c  (string-ref object i)))
1377 
+	      (if (or (char=? c #\") (char=? c #\\))
1378 
+		  (xp.write-char++ #\\ xp))
1379 
+	      (xp.write-char++ c xp)))
1380 
+	(xp.write-char++ #\" xp))
1381 
+      (xp.write-string+ object xp 0 (string-length object))))
1382 
+
1383 
+(define (xp.print-character object xp)
1384 
+  (if (dynamic *print-escape*)
1385 
+      (let ((name  (char-name object)))
1386 
+        (xp.write-char++ #\# xp)
1387 
+	(xp.write-char++ #\\ xp)
1388 
+	(if name
1389 
+	    (xp.write-string++ name xp 0 (string-length name))
1390 
+	    (xp.write-char++ object xp)))
1391 
+      (xp.write-char+ object xp)))
1392 
+
1393 
+(define (xp.print-vector object xp)
1394 
+  (let* ((pretty?  (dynamic *print-pretty*))
1395 
+	 (end      (vector-length object)))
1396 
+    (pprint-logical-block (xp '() "#(" ")")
1397 
+      (do ((i 0 (1+ i)))
1398 
+	  ((eqv? i end) '#f)
1399 
+	  (when (not (eqv? i 0))
1400 
+	    (xp.write-char++ #\space xp)
1401 
+	    (if pretty?
1402 
+		(xp.pprint-newline+ 'fill xp)))
1403 
+	  (pprint-pop)
1404 
+	  (xp.write+ (vector-ref object i) xp)
1405 
+	  ))))
1406 
+
1407 
+(define (xp.print-table object xp)
1408 
+  (let ((pretty?  (dynamic *print-pretty*)))
1409 
+    (pprint-logical-block (xp '() "#<Table" ">")
1410 
+      (table-for-each
1411 
+        (lambda (key value)
1412 
+	  (xp.write-char++ #\space xp)
1413 
+	  (if pretty?
1414 
+	      (xp.pprint-newline+ 'fill xp))
1415 
+	  (pprint-pop)
1416 
+	  (xp.write+ (cons key value) xp))
1417 
+	object))))
1418 
+
1419 
+(define (xp.print-pair object xp)
1420 
+  (if (dynamic *print-pretty*)
1421 
+      (xp.pretty-print-list object xp)
1422 
+      (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1423 
+	(do ()
1424 
+	    ((null? object) '#f)
1425 
+	    (xp.write+ (xp.pprint-pop+ object xp) xp)
1426 
+	    (when (not (null? object)) (xp.write-char++ #\space xp))))))
1427 
+
1428 
+(define (xp.print-struct object xp)
1429 
+  (if (dynamic *print-structure*)
1430 
+      (print-structure-default object xp)
1431 
+      (funcall (get-structure-printer (struct-type-descriptor object))
1432 
+	       object xp)))
1433 
+
1434 
+(define (get-structure-printer td)
1435 
+  (or (td-printer td)
1436 
+      (if (eq? (td-name td) 'struct)
1437 
+          (function print-structure-default)
1438 
+          (get-structure-printer (td-parent-type td)))))
1439 
+
1440 
+
1441 
+
1442 
+(define (print-structure-default object xp)
1443 
+  (let* ((td       (struct-type-descriptor object))
1444 
+	 (slots    (td-slots td))
1445 
+	 (pretty?  (dynamic *print-pretty*)))
1446 
+    (pprint-logical-block (xp '() "#<Struct " ">")
1447 
+      (prin1 (td-name td) xp)
1448 
+      (when (dynamic *print-structure-slots*)
1449 
+	(dolist (s slots)
1450 
+	  (write-char #\space xp)
1451 
+	  (if pretty? (pprint-newline 'fill xp))
1452 
+	  (pprint-pop)
1453 
+	  (prin1 (sd-name s) xp)
1454 
+	  (write-char #\space xp)
1455 
+	  (write (funcall (sd-getter-function s) object) xp)))
1456 
+      )))
1457 
+
1458 
+
1459 
+;;; This table can't be initialized until after all the functions
1460 
+;;; have been defined.
1461 
+
1462 
+(define *standard-print-dispatch-table*
1463 
+  (list (cons (function null?)         (function xp.print-null))
1464 
+	(cons (lambda (x) (eq? x '#t)) (function xp.print-true))
1465 
+	(cons (function not)           (function xp.print-false))
1466 
+	(cons (function symbol?)       (function xp.print-symbol))
1467 
+	(cons (function number?)       (function xp.print-number))
1468 
+	(cons (function pair?)         (function xp.print-pair))
1469 
+	(cons (function string?)       (function xp.print-string))
1470 
+	(cons (function char?)         (function xp.print-character))
1471 
+	(cons (function struct?)       (function xp.print-struct))
1472 
+	(cons (function vector?)       (function xp.print-vector))
1473 
+	(cons (function table?)        (function xp.print-table))))
1474 
+
1475 
+(define (standard-print-dispatch object)
1476 
+  (standard-print-dispatch-aux
1477 
+     object (dynamic *standard-print-dispatch-table*)))
1478 
+
1479 
+(define (standard-print-dispatch-aux object table)
1480 
+  (cond ((null? table) (function xp.print-default))
1481 
+	((funcall (car (car table)) object)
1482 
+	 (cdr (car table)))
1483 
+	(else
1484 
+	 (standard-print-dispatch-aux object (cdr table)))))
1485 
+
1486 
+(setf (dynamic *print-dispatch*) (function standard-print-dispatch))
1487 
+
1488 
+
1489 
+
1490 
+;;;=====================================================================
1491 
+;;; Pretty printing formats for code
1492 
+;;;=====================================================================
1493 
+
1494 
+
1495 
+;;; The standard prettyprinters for lists dispatch off the CAR of the list.
1496 
+
1497 
+(define *xp.pair-dispatch-table* (make-table))
1498 
+
1499 
+(define (xp.pretty-print-list object xp)
1500 
+  (funcall (or (table-entry (dynamic *xp.pair-dispatch-table*) (car object))
1501 
+	       (if (symbol? (car object)) (function xp.fn-call) '#f)
1502 
+	       (lambda (object xp)
1503 
+		 (pprint-fill xp object)))
1504 
+	   object
1505 
+	   xp))
1506 
+
1507 
+
1508 
+;;; Must use pprint-logical-block (no +) in the following three, because they
1509 
+;;; are exported functions.
1510 
+;;; *** Note that the argument order on these is backwards; that's the
1511 
+;;; *** way it is in Common Lisp....
1512 
+
1513 
+(define (pprint-linear s object . moreargs)
1514 
+  (let* ((colon?  (if (not (null? moreargs)) (pop moreargs) '#t))
1515 
+	 (atsign? (if (not (null? moreargs)) (pop moreargs) '#f)))
1516 
+    (declare (ignore atsign?))
1517 
+    (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
1518 
+      (pprint-exit-if-list-exhausted)
1519 
+      (do () ('#f)
1520 
+	  (xp.write+ (pprint-pop) s)
1521 
+	  (pprint-exit-if-list-exhausted)
1522 
+	  (xp.write-char++ #\space s)
1523 
+	  (xp.pprint-newline+ 'linear s)))))
1524 
+
1525 
+(define (pprint-fill s object . moreargs)
1526 
+  (let* ((colon?  (if (not (null? moreargs)) (pop moreargs) '#t))
1527 
+	 (atsign? (if (not (null? moreargs)) (pop moreargs) '#f)))
1528 
+    (declare (ignore atsign?))
1529 
+    (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
1530 
+      (pprint-exit-if-list-exhausted)
1531 
+      (do () ('#f)
1532 
+	  (xp.write+ (pprint-pop) s)
1533 
+	  (pprint-exit-if-list-exhausted)
1534 
+	  (xp.write-char++ #\space s)
1535 
+	  (xp.pprint-newline+ 'fill s)))))
1536 
+
1537 
+(define (pprint-tabular s object . moreargs)
1538 
+  (let* ((colon?  (if (not (null? moreargs)) (pop moreargs) '#t))
1539 
+	 (atsign? (if (not (null? moreargs)) (pop moreargs) '#f))
1540 
+	(tabsize (or (and (not (null? moreargs)) (pop moreargs)) 16)))
1541 
+    (declare (ignore atsign?))
1542 
+    (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
1543 
+      (pprint-exit-if-list-exhausted)
1544 
+      (do () ('#f)
1545 
+	  (xp.write+ (pprint-pop) s)
1546 
+	  (pprint-exit-if-list-exhausted)
1547 
+	  (xp.write-char++ #\space s)
1548 
+	  (xp.pprint-tab+ 'section-relative 0 tabsize s)
1549 
+	  (xp.pprint-newline+ 'fill s)))))
1550 
+
1551 
+
1552 
+(define (xp.fn-call object xp)
1553 
+  ;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>")
1554 
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1555 
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
1556 
+    (xp.pprint-exit-if-list-exhausted+ object)
1557 
+    (xp.write-char++ #\space xp)
1558 
+    (xp.pprint-indent+ 'current 0 xp)
1559 
+    (xp.pprint-newline+ 'miser xp)
1560 
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
1561 
+    (do ()
1562 
+	((null? object) '#f)
1563 
+	(xp.write-char++ #\space xp)
1564 
+	(xp.pprint-newline+ 'linear xp)
1565 
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
1566 
+
1567 
+
1568 
+;;; Although idiosyncratic, I have found this very useful to avoid large
1569 
+;;; indentations when printing out code.
1570 
+
1571 
+(define (xp.alternative-fn-call object xp)
1572 
+  (if (> (string-length (symbol->string (car object))) 12)
1573 
+      ;; (formatter "~:<~1I~@{~W~^ ~_~}~:>")
1574 
+      (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1575 
+        (xp.pprint-indent+ 'block 1 xp)
1576 
+	(when (not (null? object))
1577 
+	  (xp.write+ (xp.pprint-pop+ object xp) xp)
1578 
+	  (do ()
1579 
+	      ((null? object) '#f)
1580 
+	      (xp.write-char++ #\space xp)
1581 
+	      (xp.pprint-newline+ 'linear xp)
1582 
+	      (xp.write+ (xp.pprint-pop+ object xp) xp))))
1583 
+      (xp.fn-call object xp)))
1584 
+
1585 
+
1586 
+(define (xp.bind-list object xp . args)
1587 
+  (declare (ignore args))
1588 
+  ;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>")
1589 
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1590 
+    (when (not (null? object))
1591 
+      (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)
1592 
+      (do ()
1593 
+	  ((null? object) '#f)
1594 
+	  (xp.write-char++ #\space xp)
1595 
+	  (xp.pprint-newline+ 'linear xp)
1596 
+	  (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)))))
1597 
+
1598 
+(define (xp.fbind-list object xp . args)
1599 
+  (declare (ignore args))
1600 
+  ;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>")
1601 
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1602 
+    (when (not (null? object))
1603 
+      (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)
1604 
+      (do ()
1605 
+	  ((null? object) '#f)
1606 
+	  (xp.write-char++ #\space xp)
1607 
+	  (xp.pprint-newline+ 'linear xp)
1608 
+	  (xp.block-like (xp.pprint-pop+ object xp) xp)))))
1609 
+
1610 
+
1611 
+(define (xp.block-like object xp . args)
1612 
+  (declare (ignore args))
1613 
+  ;; (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>")
1614 
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1615 
+    (xp.pprint-indent+ 'block 1 xp)
1616 
+    (xp.pprint-exit-if-list-exhausted+ object)
1617 
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
1618 
+    (xp.pprint-exit-if-list-exhausted+ object)
1619 
+    (xp.write-char++ #\space xp)
1620 
+    (xp.pprint-newline+ 'miser xp)
1621 
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
1622 
+    (xp.pprint-exit-if-list-exhausted+ object)
1623 
+    (do ()
1624 
+	((null? object) '#f)
1625 
+	(xp.write-char++ #\space xp)
1626 
+	(xp.pprint-newline+ 'linear xp)
1627 
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
1628 
+
1629 
+
1630 
+(define (xp.print-fancy-fn-call object xp template)
1631 
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1632 
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
1633 
+    (xp.pprint-indent+ 'current 1 xp)
1634 
+    (do ((i 0 (1+ i))
1635 
+	 (in-first-section '#t))
1636 
+	((null? object) '#f)
1637 
+	(xp.write-char++ #\space xp)
1638 
+	(when (eqv? i (car template))
1639 
+	  (xp.pprint-indent+ 'block (cadr template) xp)
1640 
+	  (setf template (cddr template))
1641 
+	  (setf in-first-section '#f))
1642 
+	(pprint-newline (cond ((zero? i) 'miser)
1643 
+			      (in-first-section 'fill)
1644 
+			      (else 'linear))
1645 
+			xp)
1646 
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
1647 
+
1648 
+(define (xp.let-print object xp)
1649 
+  ;; (formatter "~:<~1I~W~^ ~@_~/xp:xp.bind-list/~^~@{ ~_~W~^~}~:>")
1650 
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1651 
+    (xp.pprint-indent+ 'block 1 xp)
1652 
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
1653 
+    (xp.pprint-exit-if-list-exhausted+ object)
1654 
+    (xp.write-char++ #\space xp)
1655 
+    (xp.pprint-newline+ 'miser xp)
1656 
+    (xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f)
1657 
+    (xp.pprint-exit-if-list-exhausted+ object)
1658 
+    (do ()
1659 
+	((null? object) '#f)
1660 
+	(xp.write-char++ #\space xp)
1661 
+	(xp.pprint-newline+ 'linear xp)
1662 
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
1663 
+
1664 
+(define (xp.flet-print object xp)
1665 
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1666 
+    (xp.pprint-indent+ 'block 1 xp)
1667 
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
1668 
+    (xp.pprint-exit-if-list-exhausted+ object)
1669 
+    (xp.write-char++ #\space xp)
1670 
+    (xp.pprint-newline+ 'miser xp)
1671 
+    (xp.fbind-list (xp.pprint-pop+ object xp) xp '#f '#f)
1672 
+    (xp.pprint-exit-if-list-exhausted+ object)
1673 
+    (do ()
1674 
+	((null? object) '#f)
1675 
+	(xp.write-char++ #\space xp)
1676 
+	(xp.pprint-newline+ 'linear xp)
1677 
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
1678 
+
1679 
+(define (xp.cond-print object xp)
1680 
+  ;; (formatter "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>")
1681 
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1682 
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
1683 
+    (xp.pprint-exit-if-list-exhausted+ object)
1684 
+    (xp.write-char++ #\space xp)
1685 
+    (xp.pprint-indent+ 'current 0 xp)
1686 
+    (xp.pprint-newline+ 'miser xp)
1687 
+    (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f)
1688 
+    (do ()
1689 
+	((null? object) '#f)
1690 
+	(xp.write-char++ #\space xp)
1691 
+	(xp.pprint-newline+ 'linear xp)
1692 
+	(pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f))))
1693 
+
1694 
+(define (xp.do-print object xp)
1695 
+  ;; (formatter "~:<~W~^ ~:I~@_~/xp:xp.bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>")
1696 
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1697 
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
1698 
+    (xp.pprint-exit-if-list-exhausted+ object)
1699 
+    (xp.write-char++ #\space xp)
1700 
+    (xp.pprint-indent+ 'current 0 xp)
1701 
+    (xp.pprint-newline+ 'miser xp)
1702 
+    (xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f)
1703 
+    (xp.pprint-exit-if-list-exhausted+ object)
1704 
+    (xp.write-char++ #\space xp)
1705 
+    (xp.pprint-newline+ 'linear xp)
1706 
+    (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f)
1707 
+    (xp.write-char++ #\space xp)
1708 
+    (xp.pprint-indent+ 'block 1 xp)
1709 
+    (do ()
1710 
+	((null? object) '#f)
1711 
+	(xp.write-char++ #\space xp)
1712 
+	(xp.pprint-newline+ 'linear xp)
1713 
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
1714 
+
1715 
+(define (xp.mvb-print object xp)
1716 
+  (xp.print-fancy-fn-call object xp '(1 3 2 1)))
1717 
+
1718 
+(define (xp.setf-print object xp)
1719 
+  ;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>")
1720 
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
1721 
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
1722 
+    (xp.pprint-exit-if-list-exhausted+ object)
1723 
+    (xp.write-char++ #\space xp)
1724 
+    (xp.pprint-indent+ 'current 0 xp)
1725 
+    (xp.pprint-newline+ 'miser xp)
1726 
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
1727 
+    (do ()
1728 
+	((null? object) '#f)
1729 
+	(xp.write-char++ #\space xp)
1730 
+	(xp.pprint-newline+ 'fill xp)
1731 
+	(xp.write+ (xp.pprint-pop+ object xp) xp)
1732 
+	(when (not (null? object))
1733 
+	    (xp.write-char++ #\space xp)
1734 
+	    (xp.pprint-newline+ 'linear xp)
1735 
+	    (xp.write+ (xp.pprint-pop+ object xp) xp)))))
1736 
+
1737 
+(define (xp.quote-print object xp)
1738 
+  (if (and (pair? (cdr object)) (null? (cddr object)))
1739 
+      (begin
1740 
+         (xp.write-char++ #\' xp)
1741 
+	 (xp.write+ (cadr object) xp))
1742 
+      (pprint-fill xp object)))
1743 
+
1744 
+(define (xp.up-print object xp)
1745 
+  (xp.print-fancy-fn-call object xp '(0 3 1 1)))
1746 
+
1747 
+
1748 
+;;; Install printers for built-in macros and special forms into the
1749 
+;;; standard dispatch table.
1750 
+
1751 
+(define-local-syntax (define-printer symbol function)
1752 
+  `(setf (table-entry (dynamic *xp.pair-dispatch-table*) ',symbol)
1753 
+	 (function ,function)))
1754 
+
1755 
+
1756 
+;;; *** Missing support for backquote here.
1757 
+
1758 
+(define-printer quote xp.quote-print)
1759 
+(define-printer lambda xp.block-like)
1760 
+(define-printer when xp.block-like)
1761 
+(define-printer unless xp.block-like)
1762 
+(define-printer cond xp.cond-print)
1763 
+(define-printer case xp.block-like)
1764 
+(define-printer setf xp.setf-print)
1765 
+(define-printer set! xp.setf-print)
1766 
+(define-printer let xp.let-print)
1767 
+(define-printer let* xp.let-print)
1768 
+(define-printer letrec xp.let-print)
1769 
+(define-printer flet xp.flet-print)
1770 
+(define-printer labels xp.flet-print)
1771 
+(define-printer dynamic-let xp.let-print)
1772 
+(define-printer block xp.block-like)
1773 
+(define-printer do xp.do-print)
1774 
+(define-printer dolist xp.block-like)
1775 
+(define-printer dotimes xp.block-like)
1776 
+(define-printer multiple-value-bind xp.mvb-print)
1777 
+(define-printer let/cc xp.block-like)
1778 
+(define-printer unwind-protect xp.up-print)
1779 
+(define-printer define xp.block-like)
1780 
+(define-printer define-syntax xp.block-like)
1781 
+(define-printer define-local-syntax xp.block-like)
1782 
+(define-printer pprint-logical-block xp.block-like)
1783 
+(define-printer xp.pprint-logical-block+ xp.block-like)
1784 
+
1785 
+;;; Here are some hacks for struct macros.
1786 
+
1787 
+(define-printer update-slots xp.mvb-print)
1788 
+(define-printer make xp.block-like)
support/support.scm
History View file @ 4e98702
0 1789 
new file mode 100644
... ... 
@@ -0,0 +1,35 @@
1 
+;;; support.scm -- load support files shared by all systems
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  28 Oct 1991
5 
+;;;
6 
+;;;
7 
+
8 
+
9 
+;;; Keep track of all compilation units defined.
10 
+;;; This has to go here and not in compile.scm because we don't want this
11 
+;;; list reinitialized every time that file is loaded.
12 
+
13 
+(define compilation-units '())
14 
+
15 
+
16 
+;;; Load this file first; it defines the basic compilation system support.
17 
+;;; It doesn't matter if this ends up loading source because we'll compile
18 
+;;; and reload it below.
19 
+
20 
+(load "$Y2/support/compile.scm")
21 
+
22 
+
23 
+;;; Define a real compilation unit for shared support files.
24 
+
25 
+(define-compilation-unit support
26 
+  (source-filename "$Y2/support/")
27 
+  (unit compile (source-filename "compile.scm"))
28 
+  (unit utils   (source-filename "utils.scm"))
29 
+  (unit xp
30 
+	(unit pprint (source-filename "pprint.scm"))
31 
+	(unit format (source-filename "format.scm")
32 
+	      (require pprint)))
33 
+  )
34 
+
35 
+
support/system.scm
History View file @ 4e98702
0 36 
new file mode 100644
... ... 
@@ -0,0 +1,51 @@
1 
+;;; system.scm -- haskell system setup
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  22 Nov 1991
5 
+;;;
6 
+;;; This file loads in the compilation unit definition files for all
7 
+;;; of the components of the haskell system.
8 
+;;;
9 
+;;; (The compilation unit facility is defined in support/shared/compile.scm.)
10 
+
11 
+
12 
+;;; First load the files containing module definitions.
13 
+;;; *** Add more files to the end of this list.
14 
+
15 
+(load "$Y2/support/support")
16 
+(load "$Y2/ast/ast")
17 
+(load "$Y2/top/top")
18 
+(load "$Y2/util/haskell-utils")
19 
+(load "$Y2/printers/printers")
20 
+(load "$Y2/parser/parser")
21 
+(load "$Y2/import-export/ie.scm")
22 
+(load "$Y2/tdecl/tdecl.scm")
23 
+(load "$Y2/derived/derived.scm")
24 
+(load "$Y2/prec/prec.scm")
25 
+(load "$Y2/depend/depend.scm")
26 
+(load "$Y2/type/type.scm")
27 
+(load "$Y2/cfn/cfn.scm")
28 
+(load "$Y2/flic/flic.scm")
29 
+(load "$Y2/backend/backend.scm")
30 
+(load "$Y2/runtime/runtime.scm")
31 
+(load "$Y2/csys/csys")
32 
+(load "$Y2/command-interface/command-interface")
33 
+
34 
+;;; Define some functions to actually do the work.  The compilation unit
35 
+;;; facility has conveniently kept a list of all of the unit definitions,
36 
+;;; so we can just rip through them in sequence.
37 
+
38 
+(define (compile-haskell)
39 
+  (compile-and-load-unit-list compilation-units))
40 
+
41 
+(define (recompile-haskell)
42 
+  (unless (null? remaining-units)
43 
+    (compile-and-load-unit-list remaining-units)))
44 
+
45 
+
46 
+(define (load-haskell)
47 
+  (load-unit-list compilation-units))
48 
+
49 
+(define (reload-haskell)
50 
+  (unless (null? remaining-units)
51 
+    (load-unit-list remaining-units)))
support/utils.scm
History View file @ 4e98702
0 52 
new file mode 100644
... ... 
@@ -0,0 +1,408 @@
1 
+;;; utils.scm -- utility functions
2 
+;;;
3 
+;;; author :  Sandra Loosemore
4 
+;;; date   :  18 Nov 1991
5 
+;;;
6 
+;;; This file contains miscellaneous functions that are generally useful.
7 
+;;; If you find some missing feature from the base language, this is
8 
+;;; a good place to put it.  Common Lisp-style sequence functions are
9 
+;;; an example of the sort of thing found here.
10 
+
11 
+
12 
+;;;=====================================================================
13 
+;;; Sequence functions
14 
+;;;=====================================================================
15 
+
16 
+(define (vector-replace to-vec from-vec to start end)
17 
+  (declare (type fixnum to start end)
18 
+	   (type vector to-vec from-vec))
19 
+  (if (and (eq? to-vec from-vec)
20 
+	   (> to start))
21 
+      ;; Right shift in place
22 
+      (do ((from  (1- end) (1- from))
23 
+	   (to    (1- (+ to (- end start)))))
24 
+	  ((< from start) to-vec)
25 
+	  (declare (type fixnum from to))
26 
+	  (setf (vector-ref to-vec to) (vector-ref from-vec from))
27 
+	  (decf to))
28 
+      ;; Normal case, left-to-right
29 
+      (do ((from  start (1+ from)))
30 
+	  ((= from end) to-vec)
31 
+	  (declare (type fixnum from))
32 
+	  (setf (vector-ref to-vec to) (vector-ref from-vec from))
33 
+	  (incf to))))
34 
+
35 
+(define (string-replace to-vec from-vec to start end)
36 
+  (declare (type fixnum to start end)
37 
+	   (type string to-vec from-vec))
38 
+  (if (and (eq? to-vec from-vec)
39 
+	   (> to start))
40 
+      ;; Right shift in place
41 
+      (do ((from  (1- end) (1- from))
42 
+	   (to    (1- (+ to (- end start)))))
43 
+	  ((< from start) to-vec)
44 
+	  (declare (type fixnum from to))
45 
+	  (setf (string-ref to-vec to) (string-ref from-vec from))
46 
+	  (decf to))
47 
+      ;; Normal case, left-to-right
48 
+      (do ((from  start (1+ from)))
49 
+	  ((= from end) to-vec)
50 
+	  (declare (type fixnum from))
51 
+	  (setf (string-ref to-vec to) (string-ref from-vec from))
52 
+	  (incf to))))
53 
+
54 
+(define (string-fill string c start end)
55 
+  (declare (type fixnum start end)
56 
+	   (type string string)
57 
+	   (type char c))
58 
+  (do ((i start (1+ i)))
59 
+      ((= i end) string)
60 
+      (declare (type fixnum i))
61 
+      (setf (string-ref string i) c)))
62 
+
63 
+(define (string-position c string start end)
64 
+  (declare (type fixnum start end)
65 
+	   (type string string)
66 
+	   (type char c))
67 
+  (cond ((= start end) '#f)
68 
+	((char=? (string-ref string start) c) start)
69 
+	(else
70 
+	 (string-position c string (1+ start) end))))
71 
+
72 
+(define (string-position-not-from-end c string start end)
73 
+  (declare (type fixnum start end)
74 
+	   (type string string)
75 
+	   (type char c))
76 
+  (cond ((= start end) '#f)
77 
+	((not (char=? (string-ref string (setf end (1- end))) c))
78 
+	 end)
79 
+	(else
80 
+	 (string-position-not-from-end c string start end))))
81 
+
82 
+(define (string-nreverse string start end)
83 
+  (declare (type fixnum start end)
84 
+	   (type string string))
85 
+  (do ((i start (1+ i))
86 
+       (j (1- end) (1- j)))
87 
+      ((not (< i j)) string)
88 
+      (declare (type fixnum i j))
89 
+    (let ((c (string-ref string i)))
90 
+      (setf (string-ref string i) (string-ref string j))
91 
+      (setf (string-ref string j) c))))
92 
+
93 
+
94 
+(define (string-starts? s1 s2)  ; true is s1 begins s2
95 
+  (and (>= (string-length s2) (string-length s1))
96 
+       (string=? s1 (substring s2 0 (string-length s1)))))
97 
+
98 
+
99 
+;;;=====================================================================
100 
+;;; Table utilities
101 
+;;;=====================================================================
102 
+
103 
+
104 
+(define (table->list table)
105 
+  (let ((l '()))
106 
+       (table-for-each
107 
+	(lambda (key val) (push (cons key val) l)) table)
108 
+       l))
109 
+
110 
+(define (list->table l)
111 
+  (let ((table (make-table)))
112 
+     (dolist (p l)
113 
+	(setf (table-entry table (car p)) (cdr p)))
114 
+     table))
115 
+
116 
+
117 
+
118 
+;;;=====================================================================
119 
+;;; Tuple utilities
120 
+;;;=====================================================================
121 
+
122 
+;;; For future compatibility with a typed language, define 2 tuples with
123 
+;;; a few functions:  (maybe add 3 tuples someday!)
124 
+
125 
+(define-integrable (tuple x y)
126 
+  (cons x y))
127 
+
128 
+(define-integrable (tuple-2-1 x) (car x))  ; Flic-like notation
129 
+(define-integrable (tuple-2-2 x) (cdr x))
130 
+
131 
+(define (map-tuple-2-1 f l)
132 
+  (map (lambda (x) (tuple (funcall f (tuple-2-1 x)) (tuple-2-2 x))) l))
133 
+
134 
+(define (map-tuple-2-2 f l)
135 
+  (map (lambda (x) (tuple (tuple-2-1 x) (funcall f (tuple-2-2 x)))) l))
136 
+
137 
+
138 
+;;;=====================================================================
139 
+;;; List utilities
140 
+;;;=====================================================================
141 
+
142 
+;;; This does an assq using the second half of the tuple as the key.
143 
+
144 
+(define (rassq x l)
145 
+  (if (null? l)
146 
+      '#f
147 
+      (if (eq? x (tuple-2-2 (car l)))
148 
+	  (car l)
149 
+	  (rassq x (cdr l)))))
150 
+
151 
+;;; This is an assoc with an explicit test
152 
+
153 
+(define (assoc/test test-fn x l)
154 
+  (if (null? l)
155 
+      '#f
156 
+      (if (funcall test-fn x (tuple-2-1 (car l)))
157 
+	  (car l)
158 
+	  (assoc/test test-fn x (cdr l)))))
159 
+
160 
+
161 
+
162 
+
163 
+;;; Stupid position function works only on lists, uses eqv?
164 
+
165 
+(define (position item list)
166 
+  (position-aux item list 0))
167 
+
168 
+(define (position-aux item list index)
169 
+  (declare (type fixnum index))
170 
+  (cond ((null? list)
171 
+	 '#f)
172 
+	((eqv? item (car list))
173 
+	 index)
174 
+	(else
175 
+	 (position-aux item (cdr list) (1+ index)))
176 
+	))
177 
+
178 
+
179 
+;;; Destructive delete-if function
180 
+
181 
+(define (list-delete-if f l)
182 
+  (list-delete-if-aux f l l '#f))
183 
+
184 
+(define (list-delete-if-aux f head next last)
185 
+  (cond ((null? next)
186 
+	 ;; No more elements.
187 
+	 head)
188 
+	((not (funcall f (car next)))
189 
+	 ;; Leave this element and do the next.
190 
+	 (list-delete-if-aux f head (cdr next) next))
191 
+	(last
192 
+	 ;; Delete element from middle of list.
193 
+	 (setf (cdr last) (cdr next))
194 
+	 (list-delete-if-aux f head (cdr next) last))
195 
+	(else
196 
+	 ;; Delete element from head of list.
197 
+	 (list-delete-if-aux f (cdr next) (cdr next) last))))
198 
+
199 
+
200 
+;;; Same as the haskell function
201 
+
202 
+(define (concat lists)
203 
+  (if (null? lists)
204 
+      '()
205 
+      (append (car lists) (concat (cdr lists)))))
206 
+
207 
+
208 
+;;; This is a quick & dirty list sort function.
209 
+
210 
+(define (sort-list l compare-fn)
211 
+  (if (or (null? l) (null? (cdr l)))
212 
+      l
213 
+      (insert-sorted compare-fn (car l) (sort-list (cdr l) compare-fn))))
214 
+
215 
+(define (insert-sorted compare-fn e l)
216 
+  (if (null? l)
217 
+      (list e)
218 
+      (if (funcall compare-fn e (car l))
219 
+	  (cons e l)
220 
+	  (cons (car l) (insert-sorted compare-fn e (cdr l))))))
221 
+
222 
+(define (find-duplicates l)
223 
+  (cond ((null? l)
224 
+	 '())
225 
+	((memq (car l) (cdr l))
226 
+	 (cons (car l)
227 
+	       (find-duplicates (cdr l))))
228 
+	(else (find-duplicates (cdr l)))))
229 
+
230 
+;;;  A simple & slow topsort routine.
231 
+;;;  Input:  A list of lists.  Each list is a object consed onto the
232 
+;;;          list of objects it preceeds.
233 
+;;;  Output: Two values: SORTED / CYCLIC & a list of either sorted objects
234 
+;;;                      or a set of components containing the cycle.
235 
+
236 
+(define (topsort l)
237 
+  (let ((changed? '#t)
238 
+	(sorted '())
239 
+	(next '()))
240 
+    (do () ((not changed?)
241 
+	    (if (null? next)
242 
+		(values 'sorted (nreverse sorted))
243 
+		(values 'cyclic (map (function car) next))))
244 
+      (setf changed? '#f)
245 
+      (setf next '())
246 
+      (dolist (x l)
247 
+        (cond ((topsort-aux (cdr x) sorted)
248 
+	       (push (car x) sorted)
249 
+	       (setf changed? '#t))
250 
+	      (else
251 
+	       (push x next))))
252 
+      (setf l next))))
253 
+
254 
+
255 
+;;; Returns true if x doesn't contain any elements that aren't in sorted.
256 
+;;; equivalent to (null? (set-intersection x sorted)), but doesn't cons
257 
+;;; and doesn't traverse the whole list in the failure case.
258 
+
259 
+(define (topsort-aux x sorted)
260 
+  (cond ((null? x)
261 
+	 '#t)
262 
+	((memq (car x) sorted)
263 
+	 (topsort-aux (cdr x) sorted))
264 
+	(else
265 
+	 '#f)))
266 
+
267 
+(define (set-intersection s1 s2)
268 
+  (if (null? s1)
269 
+      '()
270 
+      (let ((rest (set-intersection (cdr s1) s2)))
271 
+	(if (memq (car s1) s2)
272 
+	    (cons (car s1) rest)
273 
+	    rest))))
274 
+
275 
+;;; remove s2 elements from s1
276 
+
277 
+(define (set-difference s1 s2)
278 
+  (if (null? s1)
279 
+      '()
280 
+      (let ((rest (set-difference (cdr s1) s2)))
281 
+	(if (memq (car s1) s2)
282 
+	    rest
283 
+	    (cons (car s1) rest)))))
284 
+
285 
+
286 
+(define (set-union s1 s2)
287 
+  (if (null? s2)
288 
+      s1
289 
+      (if (memq (car s2) s1)
290 
+	  (set-union s1 (cdr s2))
291 
+	  (cons (car s2) (set-union s1 (cdr s2))))))
292 
+
293 
+
294 
+;;; Destructive list splitter
295 
+
296 
+(define (split-list list n)
297 
+  (declare (type fixnum n))
298 
+  (let ((tail1  (list-tail list (1- n))))
299 
+    (if (null? tail1)
300 
+	(values list '())
301 
+	(let ((tail2  (cdr tail1)))
302 
+	  (setf (cdr tail1) '())
303 
+	  (values list tail2)))))
304 
+
305 
+
306 
+;;; Some string utils
307 
+
308 
+(define (mem-string s l)
309 
+  (and (not (null? l)) (or (string=? s (car l))
310 
+			   (mem-string s (cdr l)))))
311 
+
312 
+(define (ass-string k l)
313 
+  (cond ((null? l)
314 
+	 '#f)
315 
+	((string=? k (caar l))
316 
+	 (car l))
317 
+	(else
318 
+	 (ass-string k (cdr l)))))
319 
+
320 
+
321 
+;;;=====================================================================
322 
+;;; Syntax extensions
323 
+;;;=====================================================================
324 
+
325 
+;;; The mlet macro combines let* and multiple-value-bind into a single
326 
+;;; syntax.
327 
+
328 
+(define-syntax (mlet binders . body)
329 
+  (mlet-body binders body))
330 
+
331 
+(define (mlet-body binders body)
332 
+  (if (null? binders)
333 
+      `(begin ,@body)
334 
+      (let* ((b (car binders))
335 
+	     (var (car b))
336 
+	     (init (cadr b))
337 
+	     (inner-body (mlet-body (cdr binders) body)))
338 
+	(if (pair? var)
339 
+	    (multiple-value-bind (new-vars ignore-decl)
340 
+				 (remove-underlines var)
341 
+	       `(multiple-value-bind ,new-vars
342 
+				     ,init ,@ignore-decl ,inner-body))
343 
+	    `(let ((,var ,init)) ,inner-body)))))
344 
+
345 
+(define (remove-underlines vars)
346 
+  (if (null? vars)
347 
+      (values '() '())
348 
+      (multiple-value-bind (rest ignore-decl) (remove-underlines (cdr vars))
349 
+	(if (not (eq? (car vars) '_))
350 
+	    (values (cons (car vars) rest) ignore-decl)
351 
+	    (let ((var (gensym)))
352 
+	      (values (cons var rest)
353 
+		      `((declare (ignore ,var)) ,@ignore-decl)))))))
354 
+
355 
+
356 
+
357 
+
358 
+;;;=====================================================================
359 
+;;; Other utilities
360 
+;;;=====================================================================
361 
+
362 
+(define (add-extension name ext)
363 
+  (assemble-filename (filename-place name) (filename-name name) ext))
364 
+
365 
+(define (time-execution thunk)
366 
+  (let* ((start-time (get-run-time))
367 
+	 (res (funcall thunk))
368 
+	 (end-time (get-run-time)))
369 
+    (values res (- end-time start-time))))
370 
+
371 
+(define (pprint-flatten code . maybe-port)
372 
+  (pprint-flatten-aux
373 
+    code
374 
+    (if (null? maybe-port) (current-output-port) (car maybe-port))))
375 
+
376 
+(define (pprint-flatten-aux code port)
377 
+  (if (and (pair? code)
378 
+	   (eq? (car code) 'begin))
379 
+      (dolist (c (cdr code))
380 
+	(pprint-flatten-aux c port))
381 
+      (pprint*-aux code port)))
382 
+
383 
+(define (print-flatten code port)
384 
+  (if (and (pair? code)
385 
+	   (eq? (car code) 'begin))
386 
+      (dolist (c (cdr code))
387 
+	(print-flatten c port))
388 
+      (begin
389 
+	(internal-write code port)
390 
+	(internal-newline port))))
391 
+
392 
+
393 
+;;; Like pprint, but print newline after instead of before.
394 
+
395 
+(define (pprint* object . maybe-port)
396 
+  (pprint*-aux
397 
+    object
398 
+    (if (null? maybe-port) (current-output-port) (car maybe-port))))
399 
+
400 
+(define (pprint*-aux object port)
401 
+  (dynamic-let ((*print-pretty*  '#t))
402 
+    (prin1 object port))
403 
+  (terpri port))
404 
+
405 
+;;; This reads stuff from a string.  (Better error checks needed!)
406 
+
407 
+(define (read-lisp-object str)
408 
+  (call-with-input-string str (lambda (port) (read port))))
tdecl/README
History View file @ 4e98702
0 409 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+This directory contains code to convert type-related declarations to
2 
+definition form.
tdecl/alg-syn.scm
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,228 @@
1 
+
2 
+;;; Description: Convert algdata & synonym from ast to definition form.
3 
+;;;              Lots of error checking.
4 
+
5 
+;;;  Algdata:
6 
+;;;   Errors detected:
7 
+;;;    Types & classes (deriving & context) resolved
8 
+;;;    context tyvars must be parameters
9 
+;;;    all parameter tyvars must be referenced
10 
+;;;    only parameter tyvars must be referenced
11 
+
12 
+(define (algdata->def data-decl)
13 
+  (remember-context data-decl
14 
+   (with-slots data-decl (context simple constrs deriving annotations) data-decl
15 
+      (let* ((def (tycon-def simple))
16 
+	     (tyvars (simple-tyvar-list simple))
17 
+	     (enum? '#t)
18 
+	     (tag 0)
19 
+	     (derived-classes '())
20 
+	     (tyvars-referenced '())
21 
+	     (all-con-vars '())
22 
+	     (all-strict? (process-alg-strictness-annotation annotations))
23 
+	     (constr-defs
24 
+	      (map (lambda (constr)
25 
+		     (with-slots constr (constructor types) constr
26 
+		       (let ((constr-def (con-ref-con constructor))
27 
+			     (c-arity (length types))
28 
+			     (con-vars '())
29 
+			     (all-types '())
30 
+			     (strictness '()))
31 
+			 (when (not (eqv? c-arity 0))
32 
+			   (setf enum? '#f))
33 
+			 (dolist (type types)
34 
+			   (let* ((ty (tuple-2-1 type))
35 
+				  (anns (tuple-2-2 type))
36 
+				  (tyvars1 (resolve-type ty)))
37 
+			     (push ty all-types)
38 
+			     (push (get-constr-strictness anns all-strict?)
39 
+				   strictness)
40 
+			     (dolist (v tyvars1)
41 
+			       (if (not (memq v tyvars))
42 
+				   (signal-bad-algdata-tyvar v)))
43 
+			     (setf con-vars (append tyvars1 tyvars-referenced))
44 
+			     (setf tyvars-referenced
45 
+				   (append tyvars1 tyvars-referenced))))
46 
+			 (push (tuple constr con-vars) all-con-vars)
47 
+			 (update-slots con constr-def
48 
+		           (arity c-arity)
49 
+			   (types (reverse all-types))
50 
+			   (tag tag)
51 
+			   (alg def)
52 
+			   (infix? (con-ref-infix? constructor))
53 
+			   (slot-strict? (reverse strictness)))
54 
+			 (incf tag)
55 
+			 constr-def)))
56 
+		   constrs)))
57 
+	(dolist (class deriving)
58 
+	  (if (eq? (class-ref-name class) '|Printers|)
59 
+	      (setf (class-ref-class class) *printer-class*)
60 
+	      (resolve-class class))
61 
+	  (when (not (eq? (class-ref-class class) *undefined-def*))
62 
+	    (push (class-ref-class class) derived-classes)))
63 
+	(when (not (null? constrs))
64 
+	   (dolist (tyvar tyvars)
65 
+	      (when (not (memq tyvar tyvars-referenced))
66 
+		 (signal-unreferenced-tyvar-arg tyvar))))
67 
+	(resolve-signature-aux tyvars context)
68 
+	;; This computes a signature for the datatype as a whole.
69 
+	(let ((gtype (ast->gtype context simple)))
70 
+	  ;; This sets the signatures for the constructors
71 
+	  (dolist (con constr-defs)
72 
+	    (let* ((con-type (**arrow-type/l (append (con-types con)
73 
+						     (list simple))))
74 
+		   (con-context (restrict-context
75 
+				 context (tuple-2-2 (assq con all-con-vars))))
76 
+		   (con-signature (ast->gtype con-context con-type)))
77 
+	      (setf (con-signature con) con-signature)))
78 
+	  (update-slots algdata def
79 
+	    (n-constr (length constrs))
80 
+	    (constrs constr-defs)
81 
+	    (context context)
82 
+	    (tyvars tyvars)
83 
+	    (signature gtype)
84 
+	    (classes '())
85 
+	    (enum? enum?)
86 
+	    (tuple? (and (not (null? constrs)) (null? (cdr constrs))))
87 
+	    (real-tuple? '#f)
88 
+	    (deriving derived-classes)
89 
+	    ))
90 
+	(process-alg-annotations def)
91 
+	def))))
92 
+
93 
+
94 
+(define (process-alg-strictness-annotation anns)
95 
+  (let ((res '#f))
96 
+    (dolist (a anns)
97 
+     (if (and (annotation-value? a)
98 
+	      (eq? (annotation-value-name a) '|STRICT|)
99 
+	      (null? (annotation-value-args a)))
100 
+	 (setf res '#t)
101 
+	 (signal-unknown-annotation a)))
102 
+    res))
103 
+
104 
+(define (get-constr-strictness anns all-strict?)
105 
+  (let ((res all-strict?))
106 
+    (dolist (a anns)
107 
+       (cond ((annotation-value? a)
108 
+	      (if (and (eq? (annotation-value-name a) '|STRICT|)
109 
+		       (null? (annotation-value-args a)))
110 
+		  (setf res '#t)
111 
+		  (signal-unknown-annotation a)))
112 
+	     (else (signal-unknown-annotation a))))
113 
+    res))
114 
+
115 
+(define (process-alg-annotations alg)
116 
+  (dolist (a (module-annotations *module*))
117 
+    (when (and (annotation-value? a)
118 
+	       (or (eq? (annotation-value-name a) '|ImportLispType|)
119 
+		   (eq? (annotation-value-name a) '|ExportLispType|))
120 
+	       (assq (def-name alg) (car (annotation-value-args a))))
121 
+      (if (eq? (annotation-value-name a) '|ImportLispType|)
122 
+	  (setf (algdata-implemented-by-lisp? alg) '#t)
123 
+	  (setf (algdata-export-to-lisp? alg) '#t))
124 
+      (let ((constrs (tuple-2-2 (assq (def-name alg)
125 
+				      (car (annotation-value-args a))))))
126 
+	(dolist (c constrs)
127 
+          (process-annotated-constr
128 
+	   alg
129 
+	   (lookup-alg-constr (tuple-2-1 c) (algdata-constrs alg))
130 
+	   (tuple-2-2 c)))))))
131 
+
132 
+(define (lookup-alg-constr name constrs)
133 
+  (if (null? constrs)
134 
+      (fatal-error 'bad-constr-name "Constructor ~A not in algdata~%"
135 
+		   name)
136 
+      (if (eq? name (def-name (car constrs)))
137 
+	  (car constrs)
138 
+	  (lookup-alg-constr name (cdr constrs)))))
139 
+
140 
+(define (process-annotated-constr alg con lisp-fns)
141 
+  ;; For nullary tuples, allow a single annotation to represent a constant
142 
+  ;; and generate the test function by default.
143 
+  (when (and (eqv? (con-arity con) 0)
144 
+	     lisp-fns
145 
+	     (null? (cdr lisp-fns)))
146 
+	(push `(lambda (x) (eq? x ,(car lisp-fns))) lisp-fns))
147 
+  ;; Insert an implicit test function for tuples (never used anyway!)
148 
+  (when (and (algdata-tuple? alg)
149 
+	     (eqv? (+ 1 (con-arity con)) (length lisp-fns)))
150 
+	(push '(lambda (x) '#t) lisp-fns))
151 
+  (when (or (not (null? (con-lisp-fns con)))
152 
+	    (not (eqv? (length lisp-fns) (+ 2 (con-arity con)))))
153 
+      (fatal-error 'bad-constr-annotation
154 
+		   "Bad annotation for ~A in ~A~%" con alg))
155 
+  (setf (con-lisp-fns con) lisp-fns))
156 
+
157 
+(define (signal-unknown-annotation a)
158 
+  (recoverable-error 'bad-annotation "Bad or misplaced annotation: ~A%"
159 
+      a))
160 
+
161 
+(define (restrict-context context vars)
162 
+  (if (null? context)
163 
+      '()
164 
+      (let ((rest (restrict-context (cdr context) vars)))
165 
+	(if (memq (context-tyvar (car context)) vars)
166 
+	    (cons (car context) rest)
167 
+	    rest))))
168 
+
169 
+(define (signal-bad-algdata-tyvar tyvar)
170 
+  (phase-error 'bad-algdata-tyvar
171 
+    "~a is referenced on the right-hand side of a data type declaration,~%~
172 
+     but is not bound as a type variable."
173 
+    tyvar))
174 
+
175 
+(define (signal-unreferenced-tyvar-arg tyvar)
176 
+  (phase-error 'unreferenced-tyvar-arg
177 
+    "~a is bound as a type variable in a data type declaration,~%~
178 
+     but is not referenced on the right-hand side."
179 
+    tyvar))
180 
+
181 
+;;; Synonyms
182 
+
183 
+;;; Errors detected:
184 
+
185 
+(define (synonym->def synonym-decl)
186 
+ (remember-context synonym-decl
187 
+  (with-slots synonym-decl (simple body) synonym-decl
188 
+    (let* ((def (tycon-def simple))
189 
+	   (tyvars (simple-tyvar-list simple))
190 
+	   (tyvars-referenced (resolve-type body)))
191 
+      (dolist (v tyvars)
192 
+	(if (not (memq v tyvars-referenced))
193 
+	  (signal-unreferenced-synonym-arg v)))
194 
+      (dolist (v tyvars-referenced)
195 
+	(if (not (memq v tyvars))
196 
+	    (signal-bad-synonym-tyvar v)))
197 
+      (update-slots synonym def
198 
+	 (args tyvars)
199 
+	 (body body))
200 
+      (push (cons def (gather-synonyms body '())) *synonym-refs*)
201 
+      def))))
202 
+
203 
+(define (signal-bad-synonym-tyvar tyvar)
204 
+  (phase-error 'bad-synonym-tyvar
205 
+    "~a is referenced on the right-hand side of a type synonym declaration,~%~
206 
+     but is not bound as a type variable."
207 
+    tyvar))
208 
+
209 
+(define (signal-unreferenced-synonym-arg tyvar)
210 
+  (haskell-warning 'unreferenced-synonym-arg
211 
+    "~a is bound as a type variable in a type synonym declaration,~%~
212 
+     but is not referenced on the right-hand side."
213 
+    tyvar))
214 
+
215 
+(define (gather-synonyms type acc)
216 
+  (cond ((tyvar? type)
217 
+	 acc)
218 
+	((and (synonym? (tycon-def type))
219 
+	      (eq? *unit* (def-unit (tycon-def type))))
220 
+	 (gather-synonyms/list (tycon-args type)
221 
+			       (cons (tycon-def type) acc)))
222 
+	(else
223 
+	 (gather-synonyms/list (tycon-args type) acc))))
224 
+
225 
+(define (gather-synonyms/list types acc)
226 
+  (if (null? types)
227 
+      acc
228 
+      (gather-synonyms/list (cdr types) (gather-synonyms (car types) acc))))
tdecl/class.scm
History View file @ 4e98702
0 229 
new file mode 100644
... ... 
@@ -0,0 +1,258 @@
1 
+;;; Before classes are converted, the super class relation is computed.
2 
+;;; This sets up the super and super* field of each class and
3 
+;;; checks for the following errors:
4 
+;;;  Wrong tyvar in context
5 
+;;;  cyclic class structure
6 
+;;;  Non-class in context
7 
+
8 
+(define (compute-super-classes modules)
9 
+  (let ((all-classes '()))
10 
+    (walk-modules modules
11 
+     (lambda ()
12 
+      (dolist (c (module-classes *module*))
13 
+       (remember-context c
14 
+	(with-slots class-decl (super-classes class class-var) c
15 
+	  (let* ((def (class-ref-class class))
16 
+		 (local-ctxts '())
17 
+		 (super '()))
18 
+	    (dolist (context super-classes)
19 
+              (with-slots context (class tyvar) context
20 
+		(when (not (eq? class-var tyvar))
21 
+		  (signal-super-class-tyvar-error class class-var tyvar))
22 
+		(resolve-class class)
23 
+		(let ((super-def (class-ref-class class)))
24 
+		  (when (not (eq? super-def *undefined-def*))
25 
+		    (push super-def super)
26 
+		    (when (eq? *unit* (def-unit super-def))
27 
+		      (push super-def local-ctxts))))))
28 
+	    (update-slots class def
29 
+	       (super super)
30 
+	       (tyvar class-var))
31 
+	    (push (cons def local-ctxts) all-classes)))))))
32 
+    (multiple-value-bind (status sorted) (topsort all-classes)
33 
+      (when (eq? status 'cyclic)
34 
+	(signal-cyclic-class-structure sorted))
35 
+      (dolist (c sorted)
36 
+        (let* ((super (class-super c))
37 
+	       (super* super))
38 
+	   (dolist (s super)
39 
+	     (setf super* (set-union super* (class-super* s)))
40 
+	     (setf (class-super* c) super*)))))))
41 
+
42 
+(define (signal-super-class-tyvar-error class class-var tyvar)
43 
+  (recoverable-error 'super-class-tyvar-error
44 
+    "The context for class ~A must only refer to type variable ~A.~%~
45 
+     Type variable ~A cannot be used here."
46 
+    (class-ref-name class) class-var tyvar))
47 
+
48 
+(define (signal-cyclic-class-structure classes)
49 
+  (fatal-error 'cyclic-class-structure
50 
+    "There is a cycle in the superclass relation involving these classes:~%~a"
51 
+    classes))
52 
+
53 
+
54 
+;;;  This sets up the following fields in the class entry:
55 
+;;;    instances '()
56 
+;;;    defaults = ast for defaults
57 
+;;;    kind
58 
+;;;    methods
59 
+;;;    signatures
60 
+;;;    method-vars
61 
+;;;    selectors
62 
+;;;  Each method is initialized with
63 
+;;;    class
64 
+;;;    signature
65 
+;;;    type
66 
+;;;  Errors detected:
67 
+;;;   signature doesnt reference class
68 
+
69 
+(define (class->def class-decl)
70 
+ (remember-context class-decl
71 
+   (let* ((class (class-ref-class (class-decl-class class-decl)))
72 
+	  (decls (class-decl-decls class-decl)))
73 
+     (setf (class-instances class) '())
74 
+     (setf (class-kind class) (find-class-kind class))
75 
+     (init-methods class decls)  ; sets up defaults, method signatures
76 
+     (setf (class-n-methods class) (length (class-method-vars class)))
77 
+     (setf (class-dict-size class)
78 
+	   (+ (class-n-methods class) (length (class-super* class))))
79 
+     class)))
80 
+
81 
+(define (find-class-kind class)
82 
+  (cond ((not (module-prelude? *module*))
83 
+	 'other)
84 
+	((memq class
85 
+	       (list (core-symbol "Eq") (core-symbol "Ord")
86 
+		     (core-symbol "Text") (core-symbol "Binary")
87 
+		     (core-symbol "Ix") (core-symbol "Enum")))
88 
+	 'Standard)
89 
+	((memq class
90 
+	       (list (core-symbol "Num") (core-symbol "Real")
91 
+		     (core-symbol "Integral") (core-symbol "Fractional")
92 
+		     (core-symbol "Floating") (core-symbol "RealFrac")
93 
+		     (core-symbol "RealFloat")))
94 
+		     'Numeric)
95 
+	(else
96 
+	 'other)))
97 
+
98 
+(define (init-methods class decls)
99 
+ (let* ((tyvar (class-tyvar class))
100 
+        (class-context (**context (**class/def class) tyvar)))
101 
+  (dolist (decl decls)
102 
+   (remember-context decl
103 
+    (cond ((is-type? 'signdecl decl)
104 
+	   (let* ((signature (signdecl-signature decl))
105 
+		  (vars (resolve-signature signature)))
106 
+	     (when (not (memq tyvar vars))
107 
+	       (signal-class-sig-ignores-type signature))
108 
+	     ;; Note: signature does not include defined class yet
109 
+	     (dolist (context (signature-context signature))
110 
+               (when (eq? tyvar (context-tyvar context))
111 
+		 (signal-method-constrains-class-tyvar context)))
112 
+	     (setf signature (rename-class-sig-vars signature tyvar))
113 
+	     (let ((gtype (ast->gtype (cons class-context
114 
+					    (signature-context signature))
115 
+				      (signature-type signature))))
116 
+ 	       (dolist (var-ref (signdecl-vars decl))
117 
+	         (let ((var (var-ref-var var-ref)))
118 
+		   (setf (var-type var) gtype)
119 
+		   (setf (method-var-method-signature var) signature))))))
120 
+	  (else  ; decl must be a default definition
121 
+	   (let ((vars (collect-pattern-vars (valdef-lhs decl))))
122 
+	     (dolist (var-ref vars)
123 
+	       (resolve-var var-ref)
124 
+               (let* ((method-name (var-ref-name var-ref))
125 
+		      (method-var (var-ref-var var-ref)))
126 
+		 (when (not (eq? method-var *undefined-def*))
127 
+		  (if (and (method-var? method-var)
128 
+			   (eq? (method-var-class method-var) class))
129 
+		   (let ((default-var
130 
+			   (make-new-var
131 
+			     (string-append
132 
+			       "default-"
133 
+			       (symbol->string (def-name method-var))))))
134 
+		     (setf (var-ref-var var-ref) default-var)
135 
+		     (setf (var-ref-name var-ref) (def-name default-var))
136 
+		     (when (not (eq? (method-var-default method-var) '#f))
137 
+		       (signal-multiple-definition-of-default method-name))
138 
+		     (setf (method-var-default method-var) default-var)
139 
+		     (let* ((sig (method-var-method-signature method-var))
140 
+			    (context (cons class-context
141 
+					   (signature-context sig)))
142 
+			    (new-sig (**signature context
143 
+						  (signature-type sig))))
144 
+		       (add-new-module-signature default-var new-sig)))
145 
+		   (signal-default-not-in-class method-var class)))))
146 
+	     (add-new-module-decl decl))))))))
147 
+
148 
+(define (signal-class-sig-ignores-type signature)
149 
+  (phase-error 'class-sig-ignores-type
150 
+    "The method signature ~a does not reference the overloaded type."
151 
+    signature))
152 
+
153 
+
154 
+;;; *** I don't understand this message.
155 
+
156 
+(define (signal-method-constrains-class-tyvar context)
157 
+  (phase-error 'method-constrains-class-tyvar
158 
+    "Individual methods may not further constrain a class: ~A" context))
159 
+
160 
+
161 
+;;; *** I don't understand this message.
162 
+
163 
+(define (signal-multiple-definition-of-default method-name)
164 
+  (phase-error 'multiple-definition-of-default
165 
+   "More that one default for ~A."
166 
+   method-name))
167 
+
168 
+
169 
+;;; *** I don't understand this message.
170 
+
171 
+(define (signal-default-not-in-class method-var class)
172 
+  (phase-error 'default-not-in-class
173 
+	       "~A is not a method in class ~A."
174 
+	       method-var class))
175 
+
176 
+
177 
+(define (create-selector-functions class)
178 
+  (let ((res '()))
179 
+    (dolist (c (cons class (class-super* class)))
180 
+      (dolist (m (class-method-vars c))
181 
+	(let* ((var (make-new-var
182 
+	        (string-append "sel-"
183 
+			       (symbol->string (def-name class))
184 
+			       "/"
185 
+			       (symbol->string (def-name m)))))
186 
+	       (sel-body (create-selector-code class m)))
187 
+	  (setf (var-selector-fn? var) '#t)
188 
+	  (push (tuple m var) res)
189 
+	  (when (not (eq? (module-type *module*) 'interface))
190 
+	     (add-new-module-def var sel-body)))))
191 
+    res))
192 
+
193 
+(define (create-selector-code c m)
194 
+  (let ((var (create-local-definition '|d|)))
195 
+    (setf (var-force-strict? var) '#t)
196 
+    (let ((body (create-selector-code-1 c m (**var/def var))))
197 
+      (**lambda/pat (list (**var-pat/def var)) body))))
198 
+
199 
+(define (create-selector-code-1 class method d)
200 
+  (let ((mcl (method-var-class method)))
201 
+    (cond ((eq? mcl class)
202 
+	   (**dsel/method class method d))
203 
+	  (else
204 
+	   (**dsel/method mcl method (**dsel/dict class mcl d))))))
205 
+
206 
+;;; The following code is for the alpha conversion of method
207 
+;;; signatures.  The class tyvar is unchanged; all others are renamed.
208 
+;;; This is needed because all method types are combined to form the
209 
+;;; dictionary signature and aliasing among different tyvars should be
210 
+;;; prevented.
211 
+
212 
+(define (rename-class-sig-vars signature tyvar)
213 
+  (mlet (((new-context env1)
214 
+	  (rename-context-vars (signature-context signature)
215 
+			       (list (tuple tyvar tyvar))))
216 
+	 ((new-type _)
217 
+	  (rename-type-vars (signature-type signature) env1)))
218 
+      (**signature new-context new-type)))
219 
+
220 
+(define (rename-context-vars contexts env)
221 
+  (if (null? contexts)
222 
+      (values '() env)
223 
+      (mlet (((new-tyvar env1)
224 
+	      (rename-sig-tyvar (context-tyvar (car contexts)) env))
225 
+	     ((rest env2)
226 
+	      (rename-context-vars (cdr contexts) env1)))
227 
+       (values (cons (**context (context-class (car contexts)) new-tyvar) rest)
228 
+	       env2))))
229 
+
230 
+(define (rename-type-vars type env)
231 
+  (if (tyvar? type)
232 
+      (mlet (((tyvar env1)
233 
+	      (rename-sig-tyvar (tyvar-name type) env)))
234 
+	 (values (**tyvar tyvar) env1))
235 
+      (mlet (((new-types env1) (rename-type-vars/l (tycon-args type) env)))
236 
+        (values (**tycon/def (tycon-def type) new-types) env1))))
237 
+
238 
+(define (rename-type-vars/l types env)
239 
+  (if (null? types)
240 
+      (values '() env)
241 
+      (mlet (((type1 env1) (rename-type-vars (car types) env))
242 
+	     ((new-types env2) (rename-type-vars/l (cdr types) env1)))
243 
+          (values (cons type1 new-types) env2))))
244 
+
245 
+(define (rename-sig-tyvar tyvar env)
246 
+  (let ((res (assq tyvar env)))
247 
+    (if (eq? res '#f)
248 
+	(let ((new-tyvar (gentyvar (symbol->string tyvar))))
249 
+	  (values new-tyvar (cons (tuple tyvar new-tyvar) env)))
250 
+	(values (tuple-2-2 res) env))))
251 
+
252 
+(define *tyvar-counter* 0)
253 
+
254 
+;;; This generates a new interned tyvar name
255 
+
256 
+(define (gentyvar root)
257 
+  (incf *tyvar-counter*)
258 
+  (string->symbol (format '#f "~A-~A" root *tyvar-counter*)))
tdecl/instance.scm
History View file @ 4e98702
0 259 
new file mode 100644
... ... 
@@ -0,0 +1,296 @@
1 
+;;; tdecl/instance.scm
2 
+
3 
+;;; Convert an instance decl to a definition
4 
+
5 
+;;; The treatment of instances is more complex than the treatment of other
6 
+;;; type definitions due to the possibility of derived instances.
7 
+;;; Here's the plan:
8 
+;;;  a) instance-decls are converted to instance structures.  The type
9 
+;;;     information is verified but the decls are unchanged.
10 
+;;;  b) All instances are linked into the associated classes.
11 
+;;;  c) Derived instances are generated.
12 
+;;;  d) Instance dictionaries are generated from the decls in the instances.
13 
+;;;
14 
+
15 
+;;; Instances-decl to instance definition conversion
16 
+;;; Errors detected:
17 
+;;;  Class must be a class
18 
+;;;  Data type must be an alg
19 
+;;;  Tyvars must be distinct
20 
+;;;  Correct number of tyvars
21 
+;;;  Context applies only to tyvars in simple
22 
+;;;  C-T restriction
23 
+
24 
+;;; Needs work for interface files.
25 
+
26 
+(define (instance->def inst-decl)
27 
+ (recover-errors '#f
28 
+  (remember-context inst-decl
29 
+    (with-slots instance-decl (context class simple decls) inst-decl
30 
+      (resolve-type simple)
31 
+      (resolve-class class)
32 
+      (let ((alg-def (tycon-def simple))
33 
+	    (class-def (class-ref-class class)))
34 
+        (when (not (algdata? (tycon-def simple)))
35 
+	  (signal-datatype-required (tycon-def simple)))
36 
+        (let ((tyvars (simple-tyvar-list simple)))
37 
+	  (resolve-signature-aux tyvars context)
38 
+	  (when (and (not (eq? *module-name* (def-module alg-def)))
39 
+		     (not (eq? *module-name* (def-module class-def))))
40 
+	    (signal-c-t-rule-violation class-def alg-def))
41 
+	  (let ((old-inst (lookup-instance alg-def class-def)))
42 
+	    (when (and (not (eq? old-inst '#f))
43 
+		       (not (instance-special? old-inst)))
44 
+	    (signal-multiple-instance class-def alg-def))
45 
+	    (let ((inst (new-instance class-def alg-def tyvars)))
46 
+	      (setf (instance-context inst) context)
47 
+	      (setf (instance-decls inst) decls)
48 
+	      (setf (instance-ok? inst) '#t)
49 
+	      inst))))))))
50 
+
51 
+(define (signal-datatype-required def)
52 
+  (phase-error 'datatype-required
53 
+    "The synonym type ~a cannot be declared as an instance."
54 
+    (def-name def)))
55 
+
56 
+(define (signal-c-t-rule-violation class-def alg-def)
57 
+  (phase-error 'c-t-rule-violation
58 
+    "Instance declaration does not appear in the same module as either~%~
59 
+     the class ~a or type ~a."
60 
+    class-def alg-def))
61 
+
62 
+(define (signal-multiple-instance class-def alg-def)
63 
+  (phase-error 'multiple-instance
64 
+    "The type ~a has already been declared to be an instance of class ~a."
65 
+    alg-def class-def))
66 
+
67 
+;;; This generates the dictionary for each instance and makes a few final
68 
+;;; integrity checks in the instance context.  This happens after derived
69 
+;;; instances are inserted.
70 
+
71 
+(define (expand-instance-decls inst)
72 
+  (when (instance-ok? inst)
73 
+    (check-inst-type inst)
74 
+    (with-slots instance (class algdata dictionary decls context tyvars) inst
75 
+     (let ((simple (**tycon/def algdata (map (function **tyvar) tyvars))))
76 
+      (setf (instance-gcontext inst)
77 
+	    (gtype-context (ast->gtype/inst context simple)))
78 
+      (with-slots class (super* method-vars) class
79 
+	;; Before computing signatures uniquify tyvar names to prevent
80 
+        ;; collision with method tyvar names
81 
+	(let ((new-tyvars (map (lambda (tyvar) (tuple tyvar (gentyvar "tv")))
82 
+			       (instance-tyvars inst))))
83 
+	  (setf (instance-tyvars inst) (map (function tuple-2-2) new-tyvars))
84 
+	  (setf (instance-context inst)
85 
+   	    (map (lambda (c)
86 
+                  (**context (context-class c)
87 
+			     (tuple-2-2 (assq (context-tyvar c) new-tyvars))))
88 
+		 (instance-context inst))))
89 
+	;; Now walk over the decls & rename each method with a unique name
90 
+	;; generated by combining the class, type, and method.  Watch for
91 
+	;; multiple defs of methods and add defaults after all decls have
92 
+	;; been scanned.
93 
+	(let ((methods-used '())
94 
+	      (new-instance-vars (map (lambda (m)
95 
+					(tuple m (method-def-var m inst)))
96 
+				      method-vars)))
97 
+          (dolist (decl decls)
98 
+            (setf methods-used
99 
+  	      (process-instance-decl decl new-instance-vars methods-used)))
100 
+	  ;; now add defaults when needed
101 
+	  (dolist (m-v new-instance-vars)
102 
+           (let* ((method-var (tuple-2-1 m-v))
103 
+		  (definition-var (tuple-2-2 m-v))
104 
+		  (signature (generate-method-signature inst method-var '#t)))
105 
+            (if (memq method-var methods-used)
106 
+		(add-new-module-signature definition-var signature)
107 
+		(let ((method-body
108 
+		       (if (eq? (method-var-default method-var) '#f)
109 
+			   (**abort (format '#f
110 
+     "No method declared for method ~A in instance ~A(~A)."
111 
+                              method-var class algdata))
112 
+			   (**var/def (method-var-default method-var)))))
113 
+		  (add-new-module-def definition-var method-body)
114 
+		  (add-new-module-signature definition-var signature)))))
115 
+	  (setf (instance-methods inst) new-instance-vars)
116 
+	  (add-new-module-def dictionary
117 
+	     (**tuple/l (append (map (lambda (m-v)
118 
+				       (dict-method-ref
119 
+					(tuple-2-1 m-v)	(tuple-2-2 m-v)	inst))
120 
+				     new-instance-vars)
121 
+				(map (lambda (c)
122 
+				       (get-class-dict algdata c))
123 
+				     super*))))
124 
+	  (let ((dict-sig (generate-dictionary-signature inst)))
125 
+	    (add-new-module-signature dictionary dict-sig))
126 
+	  (setf (instance-decls inst) '())))))))
127 
+
128 
+(define (dict-method-ref method-var inst-var inst)
129 
+  (if (null? (signature-context (method-var-method-signature method-var)))
130 
+      (**var/def inst-var)
131 
+      (let* ((sig (generate-method-signature inst method-var '#f))
132 
+	     (ctxt (signature-context sig))
133 
+	     (ty (signature-type sig)))
134 
+	(make overloaded-var-ref
135 
+	      (sig (ast->gtype ctxt ty))
136 
+	      (var inst-var)))))
137 
+
138 
+(define (get-class-dict algdata class)
139 
+  (let ((inst (lookup-instance algdata class)))
140 
+    (if (eq? inst '#f)
141 
+	(**abort "Missing super class")
142 
+	(**var/def (instance-dictionary inst)))))
143 
+
144 
+(define (process-instance-decl decl new-instance-vars methods-used)
145 
+  (if (valdef? decl)
146 
+      (rename-instance-decl decl new-instance-vars methods-used)
147 
+      (begin
148 
+       (dolist (a (annotation-decls-annotations decl))
149 
+	(cond ((annotation-value? a)
150 
+	       (recoverable-error 'misplaced-annotation
151 
+		      "Misplaced annotation: ~A~%" a))
152 
+	      (else
153 
+	       (dolist (name (annotation-decl-names a))
154 
+                 (attach-method-annotation
155 
+		  name (annotation-decl-annotations a) new-instance-vars)))))
156 
+       methods-used)))
157 
+
158 
+(define (attach-method-annotation name annotations vars)
159 
+  (cond ((null? vars)
160 
+	 (signal-no-method name))
161 
+	((eq? name (def-name (tuple-2-1 (car vars))))
162 
+	 (setf (var-annotations (tuple-2-2 (car vars)))
163 
+	       (append annotations (var-annotations (tuple-2-2 (car vars))))))
164 
+	(else (attach-method-annotation name annotations (cdr vars)))))
165 
+
166 
+(define (signal-no-method name)
167 
+  (recoverable-error 'no-method "~A is not a method in this class.~%"
168 
+      name))
169 
+
170 
+(define (rename-instance-decl decl new-instance-vars methods-used)
171 
+  (let ((decl-vars (collect-pattern-vars (valdef-lhs decl))))
172 
+    (dolist (var decl-vars)
173 
+      (resolve-var var)
174 
+      (let ((method (var-ref-var var)))
175 
+        (when (not (eq? method *undefined-def*))
176 
+         (let ((m-v (assq method new-instance-vars)))
177 
+          (cond ((memq method methods-used)
178 
+		 (signal-multiple-instance-def method))
179 
+		((eq? m-v '#f)
180 
+		 (signal-not-in-class method))
181 
+		(else
182 
+		 (setf (var-ref-name var) (def-name (tuple-2-2 m-v)))
183 
+		 (setf (var-ref-var var) (tuple-2-2 m-v))
184 
+		 (push (tuple-2-1 m-v) methods-used)))))))
185 
+    (add-new-module-decl decl)
186 
+    methods-used))
187 
+
188 
+(define (signal-multiple-instance-def method)
189 
+  (phase-error 'multiple-instance-def
190 
+    "The instance declaration has multiple definitions of the method ~a."
191 
+     method))
192 
+
193 
+(define (signal-not-in-class method)
194 
+  (phase-error 'not-in-class
195 
+    "The instance declaration includes a definition for ~a,~%~
196 
+     which is not one of the methods for this class."
197 
+    method))
198 
+
199 
+
200 
+(define (method-def-var method-var inst)
201 
+  (make-new-var
202 
+    (string-append "i-"
203 
+		   (symbol->string (print-name (instance-class inst))) "-"
204 
+		   (symbol->string (print-name (instance-algdata inst))) "-"
205 
+		   (symbol->string (def-name method-var)))))
206 
+
207 
+(define (generate-method-signature inst method-var keep-method-context?)
208 
+  (let* ((simple-type (make-instance-type inst))
209 
+	 (class-context (instance-context inst))
210 
+	 (class-tyvar (class-tyvar (instance-class inst)))
211 
+	 (signature (method-var-method-signature method-var)))
212 
+    (make signature
213 
+	  (context (if keep-method-context?
214 
+		       (append class-context (signature-context signature))
215 
+		       class-context))
216 
+	  (type (substitute-tyvar (signature-type signature) class-tyvar
217 
+				  simple-type)))))
218 
+
219 
+(define (make-instance-type inst)
220 
+  (**tycon/def (instance-algdata inst)
221 
+	       (map (function **tyvar) (instance-tyvars inst))))
222 
+
223 
+(define (generate-dictionary-signature inst)
224 
+  (**signature (sort-inst-context-by-tyvar
225 
+		(instance-context inst) (instance-tyvars inst))
226 
+	       (generate-dictionary-type inst (make-instance-type inst))))
227 
+
228 
+(define (sort-inst-context-by-tyvar ctxt tyvars)
229 
+  (concat (map (lambda (tyvar)
230 
+		 (extract-single-context tyvar ctxt)) tyvars)))
231 
+
232 
+(define (extract-single-context tyvar ctxt)
233 
+  (if (null? ctxt)
234 
+      '()
235 
+      (let ((rest (extract-single-context tyvar (cdr ctxt))))
236 
+	(if (eq? tyvar (context-tyvar (car ctxt)))
237 
+	    (cons (car ctxt) rest)
238 
+	    rest))))
239 
+
240 
+(define (generate-dictionary-type inst simple)
241 
+  (let* ((class (instance-class inst))
242 
+	 (algdata (instance-algdata inst))
243 
+	 (tyvar (class-tyvar class)))
244 
+    (**tuple-type/l (append (map (lambda (method-var)
245 
+				   ;; This ignores the context associated
246 
+				   ;; with a method
247 
+				   (let ((sig (method-var-method-signature
248 
+					        method-var)))
249 
+				     (substitute-tyvar (signature-type sig)
250 
+						       tyvar
251 
+						       simple)))
252 
+				 (class-method-vars class))
253 
+			    (map (lambda (super-class)
254 
+				   (generate-dictionary-type
255 
+				    (lookup-instance algdata super-class)
256 
+				    simple))
257 
+				 (class-super* class))))))
258 
+
259 
+;;; Checks performed here:
260 
+;;;  Instance context must include the following:
261 
+;;;     Context associated with data type
262 
+;;;     Context associated with instances for each super class
263 
+;;;  All super class instances must exist
264 
+
265 
+(define (check-inst-type inst)
266 
+   (let* ((class (instance-class inst))
267 
+	  (algdata (instance-algdata inst))
268 
+	  (inst-context (instance-gcontext inst))
269 
+	  (alg-context (gtype-context (algdata-signature algdata))))
270 
+     (when (not (full-context-implies? inst-context alg-context))
271 
+       (signal-instance-context-needs-alg-context algdata))
272 
+     (dolist (super-c (class-super class))
273 
+       (let ((super-inst (lookup-instance algdata super-c)))
274 
+	 (cond ((eq? super-inst '#f)
275 
+		(signal-no-super-class-instance class algdata super-c))
276 
+	       (else
277 
+		(when (not (full-context-implies?
278 
+			     inst-context (instance-context super-inst)))
279 
+		  (signal-instance-context-insufficient-for-super
280 
+		    class algdata super-c))))))
281 
+     ))
282 
+
283 
+(define (signal-instance-context-needs-alg-context algdata)
284 
+  (phase-error 'instance-context-needs-alg-context
285 
+    "The instance context needs to include context defined for data type ~A."
286 
+    algdata))
287 
+
288 
+(define (signal-no-super-class-instance class algdata super-c)
289 
+  (fatal-error 'no-super-class-instance
290 
+    "The instance ~A(~A) requires that the instance ~A(~A) be provided."
291 
+    class algdata super-c algdata))
292 
+
293 
+(define (signal-instance-context-insufficient-for-super class algdata super-c)
294 
+  (phase-error 'instance-context-insufficient-for-super
295 
+    "Instance ~A(~A) does not imply super class ~A instance context."
296 
+    class algdata super-c))
tdecl/tdecl-utils.scm
History View file @ 4e98702
0 297 
new file mode 100644
... ... 
@@ -0,0 +1,16 @@
1 
+;;; This file contains routines which generate the code for the
2 
+;;; dictionaries used in the class system.
3 
+
4 
+(define (make-sel-node size i)
5 
+  (**lambda '(x)
6 
+     (if (eqv? size 1)
7 
+	 (**var 'x)
8 
+	 (**sel (tuple-constructor size) (**var 'x) i))))
9 
+
10 
+(define (make-compose f1 f2)
11 
+  (**lambda '(x)
12 
+      (**app f1 (**app f2 (**var 'x)))))
13 
+
14 
+(define (make-new-var name)  ; name is a string
15 
+  (create-definition *module* (string->symbol name) 'var))
16 
+
tdecl/tdecl.scm
History View file @ 4e98702
0 17 
new file mode 100644
... ... 
@@ -0,0 +1,18 @@
1 
+;;; -- compilation unit definition for type declaration analysis
2 
+;;;
3 
+;;; author :  John
4 
+;;;
5 
+
6 
+(define-compilation-unit tdecl
7 
+  (source-filename "$Y2/tdecl/")
8 
+  (require global)
9 
+  (unit type-declaration-analysis
10 
+    (source-filename "type-declaration-analysis.scm"))
11 
+  (unit tdecl-utils
12 
+    (source-filename "tdecl-utils.scm"))
13 
+  (unit alg-syn
14 
+    (source-filename "alg-syn.scm"))
15 
+  (unit class
16 
+    (source-filename "class.scm"))
17 
+  (unit instance
18 
+    (source-filename "instance.scm")))
tdecl/type-declaration-analysis.scm
History View file @ 4e98702
0 19 
new file mode 100644
... ... 
@@ -0,0 +1,72 @@
1 
+;;; This processes type declarations (data, type, instance, class)
2 
+;;; Static errors in type declarations are detected and type decls
3 
+;;; are replaced by type definitions.  All code (class and instance
4 
+;;; definitions) is moved to the module decls.
5 
+
6 
+(define *synonym-refs* '())
7 
+
8 
+(predefine (add-derived-instances modules)) ; in derived/derived-instances.scm
9 
+
10 
+(define (process-type-declarations modules)
11 
+;;; Convert data & type decls to definitions
12 
+ (let ((interface? (eq? (module-type (car modules)) 'interface)))
13 
+  (setf *synonym-refs* '())
14 
+  (walk-modules modules
15 
+   (lambda ()
16 
+     (setf (module-alg-defs *module*)
17 
+	   (map (function algdata->def) (module-algdatas *module*)))
18 
+     (setf (module-synonym-defs *module*)
19 
+	   (map (function synonym->def) (module-synonyms *module*)))
20 
+     (when (not interface?)
21 
+	(dolist (ty (default-decl-types (module-default *module*)))
22 
+		(resolve-type ty))))
23 
+   ;; A test to see that ty is in Num and is a monotype is needed here.
24 
+   )
25 
+  (multiple-value-bind (ty vals) (topsort *synonym-refs*)
26 
+    (when (eq? ty 'cyclic) (signal-recursive-synonyms vals)))
27 
+  ;; Build the class heirarchy
28 
+  (compute-super-classes modules)
29 
+  ;; Convert class declarations and instance declarations to definitions.
30 
+  (walk-modules modules
31 
+   (lambda ()
32 
+     (setf (module-class-defs *module*)
33 
+	   (map (function class->def) (module-classes *module*)))))
34 
+  (walk-modules modules
35 
+   (lambda ()
36 
+     (dolist (class (module-class-defs *module*))
37 
+	(setf (class-selectors class) (create-selector-functions class)))))
38 
+  (walk-modules modules
39 
+    (lambda ()
40 
+     (setf (module-instance-defs *module*) '())
41 
+     (dolist (inst-decl (module-instances *module*))
42 
+       (let ((inst (instance->def inst-decl)))
43 
+	 (when (not (eq? inst '#f))
44 
+            (push inst (module-instance-defs *module*)))))))
45 
+  (add-derived-instances modules)
46 
+  (walk-modules modules
47 
+   (lambda ()
48 
+     (dolist (inst (module-instance-defs *module*))
49 
+       (expand-instance-decls inst))))
50 
+  (when (not interface?)
51 
+   (walk-modules modules
52 
+    (lambda ()
53 
+     (dolist (ty (default-decl-types (module-default *module*)))
54 
+	(resolve-type ty)))))
55 
+   ))
56 
+
57 
+
58 
+(define (signal-recursive-synonyms vals)
59 
+  (fatal-error 'recursive-synonyms
60 
+    "There is a cycle in type synonym definitions involving these types:~%~a"
61 
+    vals))
62 
+
63 
+(define (add-new-module-decl decl)
64 
+  (setf (module-decls *module*) (cons decl (module-decls *module*))))
65 
+
66 
+(define (add-new-module-def var value)
67 
+  (add-new-module-decl
68 
+   (**define var '() value)))
69 
+
70 
+(define (add-new-module-signature var signature)
71 
+  (add-new-module-decl
72 
+   (**signdecl/def (list var) signature)))
top/README
History View file @ 4e98702
0 73 
new file mode 100644
... ... 
@@ -0,0 +1,12 @@
1 
+This directory contains the top level of the compiler.
2 
+Files found here:
3 
+
4 
+phases - the top level calls to the compiler phases; compilation init code
5 
+errors - general error handlers
6 
+globals - global variable definitions
7 
+core-symbols - defines core symbols
8 
+system-init - code to run once after the compiler is loaded.
9 
+driver - top level functions which drive the compiler.  There are called
10 
+         from the command interface or directly from the user.
11 
+
12 
+
top/core-definitions.scm
History View file @ 4e98702
0 13 
new file mode 100644
... ... 
@@ -0,0 +1,149 @@
1 
+;;; This file defines core symbols - those in PreludeCore and
2 
+;;; other Prelude symbols used in compilation.
3 
+
4 
+;;; This part is constructed from the export table of PreludeCore
5 
+;;; by 'top/prelude-core-syms' and has been pasted in here.
6 
+
7 
+
8 
+(DEFINE *haskell-prelude-vars*
9 
+  '((CLASSES "Num"
10 
+             "Integral"
11 
+             "Eq"
12 
+             "Text"
13 
+             "Fractional"
14 
+             "RealFloat"
15 
+             "RealFrac"
16 
+             "Enum"
17 
+             "Ix"
18 
+             "Floating"
19 
+             "Ord"
20 
+             "Real"
21 
+             "Binary")
22 
+    (METHODS "fromInteger"
23 
+             "signum"
24 
+             "abs"
25 
+             "negate"
26 
+             "*"
27 
+             "-"
28 
+             "+"
29 
+             "toInteger"
30 
+             "odd"
31 
+             "even"
32 
+             "divMod"
33 
+             "quotRem"
34 
+             "mod"
35 
+             "div"
36 
+             "rem"
37 
+             "quot"
38 
+             "/="
39 
+             "=="
40 
+             "showList"
41 
+             "readList"
42 
+             "showsPrec"
43 
+             "readsPrec"
44 
+             "fromRational"
45 
+             "recip"
46 
+             "/"
47 
+             "scaleFloat"
48 
+             "significand"
49 
+             "exponent"
50 
+             "encodeFloat"
51 
+             "decodeFloat"
52 
+             "floatRange"
53 
+             "floatDigits"
54 
+             "floatRadix"
55 
+             "floor"
56 
+             "ceiling"
57 
+             "round"
58 
+             "truncate"
59 
+             "properFraction"
60 
+             "enumFromThenTo"
61 
+             "enumFromTo"
62 
+             "enumFromThen"
63 
+             "enumFrom"
64 
+             "inRange"
65 
+             "index"
66 
+             "range"
67 
+             "atanh"
68 
+             "acosh"
69 
+             "asinh"
70 
+             "tanh"
71 
+             "cosh"
72 
+             "sinh"
73 
+             "atan"
74 
+             "acos"
75 
+             "asin"
76 
+             "tan"
77 
+             "cos"
78 
+             "sin"
79 
+             "logBase"
80 
+             "**"
81 
+             "sqrt"
82 
+             "log"
83 
+             "exp"
84 
+             "pi"
85 
+             "min"
86 
+             "max"
87 
+             ">"
88 
+             ">="
89 
+             "<="
90 
+             "<"
91 
+             "toRational"
92 
+             "showBin"
93 
+             "readBin")
94 
+    (TYPES "Char"
95 
+           "Complex"
96 
+           "Integer"
97 
+           "Double"
98 
+           "Bin"
99 
+           "Array"
100 
+           "Float"
101 
+           "Bool"
102 
+           "Int"
103 
+           "Assoc"
104 
+           "Ratio"
105 
+           "SystemState"
106 
+           "IOResult")
107 
+    (CONSTRUCTORS ":+" "True" "False" ":=" ":")
108 
+    (SYNONYMS "ShowS" "ReadS" "String" "Rational" "IO")
109 
+    (VALUES)))
110 
+
111 
+;;; Non PreludeCore stuff
112 
+
113 
+;;; This table defines all symbols in the core used internally by the
114 
+;;; compiler.
115 
+
116 
+(define *haskell-noncore-vars* '(
117 
+  (types
118 
+     "List"
119 
+     "Arrow"
120 
+     "Request"
121 
+     "Response"
122 
+     "UnitType"
123 
+     "TupleDicts")
124 
+  (constructors
125 
+     "MkFloat"
126 
+     "MkDouble"
127 
+     "MkChar"
128 
+     "MkInteger"
129 
+     "MkInt"
130 
+     "Nil"
131 
+     "UnitConstructor")
132 
+  (values
133 
+    "&&"  "||"  "primPlusInt"
134 
+    "++" "take" "drop" "." "showChar" "shows" "showString"
135 
+    "showParen" "lex" "readParen" "reads"
136 
+    "primShowBinInt" "primReadBinSmallInt"
137 
+    "error"
138 
+    "primIntegerToInt" "primIntToInteger"
139 
+    "primRationalToFloat" "primRationalToDouble"
140 
+    "primNegInt" "primNegInteger" "primNegFloat" "primNegDouble"
141 
+    "foldr" "build" "inlineFoldr" "inlineBuild"
142 
+    "primAppend" "primStringEq"
143 
+    "dictSel" "tupleEqDict" "tupleOrdDict" "tupleIxDict"
144 
+    "tupleTextDict" "tupleBinaryDict")))
145 
+
146 
+
147 
+
148 
+
149 
+
top/core-init.scm
History View file @ 4e98702
0 150 
new file mode 100644
... ... 
@@ -0,0 +1,14 @@
1 
+
2 
+
3 
+(define *core-symbols* '())
4 
+(define *prelude-core-symbols* '())
5 
+
6 
+; expands into lots of (define *core-??* '())
7 
+
8 
+(define-core-variables)
9 
+
10 
+(define (init-core-symbols)
11 
+  (setf *core-symbols* (make-table))
12 
+  (setf *prelude-core-symbols* (make-table))
13 
+  (create-core-globals))
14 
+
top/core-symbols.scm
History View file @ 4e98702
0 15 
new file mode 100644
... ... 
@@ -0,0 +1,126 @@
1 
+;;; This defines all core symbols.
2 
+
3 
+;;; Core symbols are stored in global variables.  The core-symbol
4 
+;;; macro just turns a string into a variable name.
5 
+
6 
+(define-syntax (core-symbol str)
7 
+  (make-core-symbol-name str))
8 
+
9 
+(define (make-core-symbol-name str)
10 
+  (string->symbol (string-append "*core-" str "*")))
11 
+
12 
+(define (symbol->core-var name)
13 
+  (make-core-symbol-name (symbol->string name)))
14 
+
15 
+(define (get-core-var-names vars type)
16 
+  (let ((res (assq type vars)))
17 
+    (if (eq? res '#f)
18 
+	'()
19 
+	(map (function string->symbol) (tuple-2-2 res)))))
20 
+
21 
+;;; This is just used to create a define for each var without a
22 
+;;; value.
23 
+
24 
+(define-syntax (define-core-variables)
25 
+  `(begin
26 
+     ,@(define-core-variables-1 *haskell-prelude-vars*)
27 
+     ,@(define-core-variables-1 *haskell-noncore-vars*)))
28 
+
29 
+(define (define-core-variables-1 vars)
30 
+  (concat (map (lambda (ty)
31 
+		 (map (function init-core-symbol)
32 
+		      (get-core-var-names vars ty)))
33 
+	       '(classes methods types constructors synonyms values))))
34 
+
35 
+(define (init-core-symbol sym)
36 
+  `(define ,(symbol->core-var sym) '()))
37 
+
38 
+(define-syntax (create-core-globals)
39 
+  `(begin
40 
+     (begin ,@(create-core-defs *haskell-prelude-vars* '#t))
41 
+     (begin ,@(create-core-defs *haskell-noncore-vars* '#f))))
42 
+
43 
+(define (create-core-defs defs prelude-core?)
44 
+  `(,@(map (lambda (x) (define-core-value x prelude-core?))
45 
+	   (get-core-var-names defs 'values))
46 
+     ,@(map (lambda (x) (define-core-method x prelude-core?))
47 
+	   (get-core-var-names defs 'methods))
48 
+     ,@(map (lambda (x) (define-core-synonym x prelude-core?))
49 
+	   (get-core-var-names defs 'synonyms))
50 
+     ,@(map (lambda (x) (define-core-class x prelude-core?))
51 
+	   (get-core-var-names defs 'classes))
52 
+     ,@(map (lambda (x) (define-core-type x prelude-core?))
53 
+	    (get-core-var-names defs 'types))
54 
+     ,@(map (lambda (x) (define-core-constr x prelude-core?))
55 
+	    (get-core-var-names defs 'constructors))))
56 
+
57 
+
58 
+(define (define-core-value name pc?)
59 
+    `(setf ,(symbol->core-var name)
60 
+	   (make-core-value-definition ',name ',pc?)))
61 
+
62 
+(define (make-core-value-definition name pc?)
63 
+  (install-core-sym
64 
+    (make var (name name) (module '|*Core|) (unit '|*Core|))
65 
+    name
66 
+    pc?))
67 
+
68 
+(define (define-core-method name pc?)
69 
+    `(setf ,(symbol->core-var name)
70 
+	   (make-core-method-definition ',name ',pc?)))
71 
+
72 
+(define (make-core-method-definition name pc?)
73 
+  (install-core-sym
74 
+    (make method-var (name name) (module '|*Core|) (unit '|*Core|))
75 
+    name
76 
+    pc?))
77 
+
78 
+(define (define-core-class name pc?)
79 
+    `(setf ,(symbol->core-var name)
80 
+	   (make-core-class-definition ',name ',pc?)))
81 
+
82 
+(define (make-core-class-definition name pc?)
83 
+  (install-core-sym
84 
+    (make class (name name) (module '|*Core|) (unit '|*Core|))
85 
+    name
86 
+    pc?))
87 
+
88 
+(define (define-core-synonym name pc?)
89 
+    `(setf ,(symbol->core-var name)
90 
+	   (make-core-synonym-definition ',name ',pc?)))
91 
+
92 
+(define (make-core-synonym-definition name pc?)
93 
+  (install-core-sym
94 
+    (make synonym (name name) (module '|*Core|) (unit '|*Core|))
95 
+    name
96 
+    pc?))
97 
+
98 
+(define (define-core-type name pc?)
99 
+    `(setf ,(symbol->core-var name)
100 
+	   (make-core-type-definition ',name ',pc?)))
101 
+
102 
+(define (make-core-type-definition name pc?)
103 
+  (install-core-sym
104 
+    (make algdata (name name) (module '|*Core|) (unit '|*Core|))
105 
+    name
106 
+    pc?))
107 
+
108 
+(define (define-core-constr name pc?)
109 
+    `(setf ,(symbol->core-var name)
110 
+	   (make-core-constr-definition ',name ',pc?)))
111 
+
112 
+(define (make-core-constr-definition name pc?)
113 
+  (setf name (add-con-prefix/symbol name))
114 
+  (install-core-sym
115 
+    (make con (name name) (module '|*Core|) (unit '|*Core|))
116 
+    name
117 
+    pc?))
118 
+
119 
+(define (install-core-sym def name preludecore?)
120 
+  (setf (def-core? def) '#t)
121 
+  (when preludecore?
122 
+    (setf (def-prelude? def) '#t))
123 
+  (setf (table-entry (dynamic *core-symbols*) name) def)
124 
+  (when preludecore?
125 
+    (setf (table-entry (dynamic *prelude-core-symbols*) name) def))
126 
+  def)
top/errors.scm
History View file @ 4e98702
0 127 
new file mode 100644
... ... 
@@ -0,0 +1,119 @@
1 
+;;; This file contains general error handling routines.
2 
+
3 
+;;; This is the general error handler.  It has three arguments: an
4 
+;;; id, error type, and an error message.  The message is a list of
5 
+;;; format, arglist combinations.
6 
+
7 
+;;; The error types are:
8 
+;;;   warning       -> control returns and compilation proceeds
9 
+;;;                    The message may be suppressed
10 
+;;;   recoverable   -> control returns and compilation proceeds
11 
+;;;   phase         -> control returns but compilation is aborted
12 
+;;;                         after the phase in *abort-point*.
13 
+;;;   fatal         -> control goes back to the top level
14 
+;;;   internal      -> enters the break loop or does a fatal error
15 
+
16 
+;;; Two globals control error behavior:
17 
+;;;   *break-on-error?* enter the break loop on any error
18 
+;;;   *never-break?* never enter the break loop, even for internal errors.
19 
+
20 
+;;; The global *error-output-port* controls where errors are printer.
21 
+
22 
+;;; The strategy here is to first write a banner message based on the id and
23 
+;;; type, write out the messages, and then take action depending on the type.
24 
+
25 
+(define *in-error-handler?* '#f)
26 
+
27 
+(define (haskell-error id type messages)
28 
+  (format *error-output-port* "~&[~A] ~A in phase ~A:~%"
29 
+	  id (err-type->banner type) (dynamic *phase*))
30 
+  (dolist (m messages)
31 
+    (apply (function format) *error-output-port* m)
32 
+    (fresh-line *error-output-port*))
33 
+  (maybe-show-context (dynamic *context*))
34 
+  (if (dynamic *in-error-handler?*)
35 
+      (error "Recursive error in haskell-error.")
36 
+      (begin
37 
+        (dynamic-let ((*in-error-handler?*  '#t))
38 
+	  (cond (*break-on-error?*
39 
+		 (haskell-breakpoint))
40 
+		((eq? type 'internal)
41 
+		 (if *never-break?*
42 
+		     (abort-compilation)
43 
+		     (haskell-breakpoint)))
44 
+		((eq? type 'fatal)
45 
+		 (abort-compilation))
46 
+		((eq? type 'phase)
47 
+		 (halt-compilation))))
48 
+	(when (and (memq type '(recoverable phase))
49 
+		   (dynamic *recoverable-error-handler*))
50 
+	  (funcall (dynamic *recoverable-error-handler*)))
51 
+	'ok)))
52 
+
53 
+(define (err-type->banner err-type)
54 
+  (cond ((eq? err-type 'warning)
55 
+	 "Warning")
56 
+	((eq? err-type 'recoverable)
57 
+	 "Recoverable error")
58 
+	((eq? err-type 'phase)
59 
+	 "Phase error")
60 
+	((eq? err-type 'fatal)
61 
+	 "Fatal error")
62 
+	((eq? err-type 'internal)
63 
+	 "Internal-error")
64 
+	(else "???")))
65 
+
66 
+(define (maybe-show-context context)
67 
+  (when context
68 
+    (with-slots source-pointer (line file) (ast-node-line-number context)
69 
+      (fresh-line *error-output-port*)
70 
+      (format *error-output-port* "Error occurred at line ~A in file ~A.~%"
71 
+         line (filename-name file)))))
72 
+
73 
+;;; A few entry points into the error system.
74 
+;;; As a matter of convention, there should be a signaling function defined
75 
+;;; for each specific error condition that calls one of these functions.
76 
+;;; Error messages should be complete sentences with proper punctuation
77 
+;;; and capitalization.  The signaling function should use the message
78 
+;;; to report the error and not do any printing of its own.
79 
+
80 
+(define (fatal-error id . msg)
81 
+ (haskell-error id 'fatal (list msg)))
82 
+
83 
+(define (haskell-warning id . msg)
84 
+ (haskell-error id 'warning (list msg)))
85 
+
86 
+(define (recoverable-error id . msg)
87 
+ (haskell-error id 'recoverable (list msg)))
88 
+
89 
+(define (compiler-error id . msg)
90 
+ (haskell-error id 'internal (list msg)))
91 
+
92 
+(define (phase-error id . msg)
93 
+ (haskell-error id 'phase (list msg)))
94 
+
95 
+;;; This function puts the compiler into the lisp breakloop.  this may
96 
+;;; want to fiddle the programming envoronment someday.
97 
+
98 
+(define (haskell-breakpoint)
99 
+ (error "Haskell breakpoint."))
100 
+
101 
+
102 
+;;; This deals with error at runtime
103 
+
104 
+(define (haskell-runtime-error msg)
105 
+  (format '#t "~&Haskell runtime abort.~%~A~%" msg)
106 
+  (funcall (dynamic *runtime-abort*)))
107 
+
108 
+;; Some common error handlers
109 
+
110 
+(define (signal-unknown-file-type filename)
111 
+  (fatal-error 'unknown-file-type
112 
+    "The filename ~a has an unknown file type."
113 
+    filename))
114 
+
115 
+(define (signal-file-not-found filename)
116 
+  (fatal-error 'file-not-found
117 
+    "The file ~a doesn't exist."
118 
+    filename))
119 
+
top/globals.scm
History View file @ 4e98702
0 120 
new file mode 100644
... ... 
@@ -0,0 +1,75 @@
1 
+;;; These are global variables used throughout the compiler.
2 
+
3 
+;;; Configuration stuff
4 
+
5 
+(define *prelude-unit-filename* "$PRELUDE/Prelude.hu")
6 
+
7 
+(define *haskell-compiler-version* "Y2.0.5")
8 
+(define *haskell-compiler-update* "")
9 
+
10 
+
11 
+;;; Control over the init process
12 
+(define *haskell-initialized?* '#f)
13 
+
14 
+;;; Error control
15 
+(define *break-on-error?* '#f)
16 
+(define *never-break?* '#f)
17 
+
18 
+(define *runtime-abort* '())
19 
+
20 
+(define *recoverable-error-handler* '())
21 
+(define *error-output-port* '())  ; initialized later
22 
+
23 
+(define *context* '#f)  ; ast node being compiled.
24 
+
25 
+(define *unit* '())
26 
+
27 
+(define *standard-module-default* '())
28 
+
29 
+(define *undefined-def* '())
30 
+(define *printer-class* '())
31 
+(define *printers* '(phase-time))
32 
+
33 
+(define *all-printers*
34 
+  '(phase-time time compiling loading reading extension
35 
+    parse import type-decl scope depend
36 
+    type cfn depend2
37 
+    flic optimize optimize-extra strictness codegen codegen-flic
38 
+    dumper dump-stat))
39 
+
40 
+;;; Global context stuff
41 
+;;; ***This variable is actually only used by the parser.
42 
+
43 
+(define *current-file* '())
44 
+
45 
+(define *printed-tyvars* '())
46 
+
47 
+
48 
+;;; Used by the symbol table routines
49 
+
50 
+(define *modules* '())  ; maps module name -> module structure
51 
+(define *module* '())   ; current module
52 
+(define *module-name* '())
53 
+(define *symbol-table* '())  ; part of the current module
54 
+(define *inverted-symbol-table* '())  ; maps def -> localname
55 
+(define *fixity-table* '())  ; name -> fixity
56 
+(define *suffix-table* '())  ; name -> int (for uniquifying names)
57 
+
58 
+(define *special-parse-for-type-macros* '#f)
59 
+
60 
+;;; These are for diagnostic purposes only
61 
+
62 
+(define *big-let* '())
63 
+
64 
+(define *show-end-of-phase* '#f)
65 
+
66 
+;;; This is used to configure error messages & responses.
67 
+
68 
+(define *emacs-mode* '#f)
69 
+
70 
+;;; This is used to stash the Prelude symbol environment
71 
+
72 
+(define *prelude-symbol-table* '())
73 
+(define *prelude-fixity-table* '())
74 
+(define *prelude-inverted-symbol-table* '())
75 
+
top/has-macros.scm
History View file @ 4e98702
0 76 
new file mode 100644
... ... 
@@ -0,0 +1,57 @@
1 
+;;; General macros for the Haskell compiler
2 
+
3 
+(define-syntax (remember-context exp . body)
4 
+  (let ((temp  (gensym)))
5 
+    `(let ((,temp  ,exp))
6 
+       (dynamic-let ((*context* (if (ast-node-line-number ,temp)
7 
+				    ,temp
8 
+				    (dynamic *context*))))
9 
+         ,@body))))
10 
+
11 
+(define-syntax (maybe-remember-context exp . body)
12 
+  (let ((temp  (gensym)))
13 
+    `(let ((,temp  ,exp))
14 
+       (if (ast-node-line-number ,temp)
15 
+	   (dynamic-let ((*context* ,temp)) ,@body)
16 
+	   (begin ,@body)))))
17 
+
18 
+(define-syntax (recover-errors error-value . body)
19 
+  (let ((local-handler (gensym)))
20 
+    `(let/cc ,local-handler
21 
+       (dynamic-let ((*recoverable-error-handler*
22 
+		       (lambda () (funcall ,local-handler ,error-value))))
23 
+         ,@body))))
24 
+
25 
+;;; This is for iterating a list of contexts over a list of types.
26 
+
27 
+(define-syntax (do-contexts cbinder tbinder . body)
28 
+  (let ((cvar (car cbinder))
29 
+	(cinit (cadr cbinder))
30 
+	(tvar (car tbinder))
31 
+	(tinit (cadr tbinder))
32 
+	(cv (gensym))
33 
+	(tv (gensym)))
34 
+    `(do ((,cv ,cinit (cdr ,cv))
35 
+	  (,tv ,tinit (cdr ,tv)))
36 
+	 ((null? ,cv))
37 
+       (let ((,tvar (car ,tv)))
38 
+	 (dolist (,cvar (car ,cv))
39 
+	   ,@body)))))
40 
+
41 
+;; dolist for 2 lists at once.
42 
+
43 
+(define-syntax (dolist2 a1 a2 . body)
44 
+  (let ((a1var (car a1))
45 
+	(a1init (cadr a1))
46 
+	(a2var (car a2))
47 
+	(a2init (cadr a2))
48 
+	(a1l (gensym))
49 
+	(a2l (gensym)))
50 
+    `(do ((,a1l ,a1init (cdr ,a1l))
51 
+	  (,a2l ,a2init (cdr ,a2l)))
52 
+	 ((null? ,a1l))
53 
+       (let ((,a1var (car ,a1l))
54 
+	     (,a2var (car ,a2l)))
55 
+	 ,@body))))
56 
+
57 
+
0 58 
\ No newline at end of file
top/has-utils.scm
History View file @ 4e98702
1 59 
new file mode 100644
... ... 
@@ -0,0 +1,21 @@
1 
+;;; These utilities are specific to the Haskell language.
2 
+
3 
+(define (add-con-prefix str)  ; should be in some utility file
4 
+  (string-append ";" str))
5 
+
6 
+(define (remove-con-prefix string)
7 
+  (substring string 1 (string-length string)))
8 
+
9 
+(define (has-con-prefix? string)
10 
+  (char=? (string-ref string 0) '#\;))
11 
+
12 
+(define (add-con-prefix/symbol sym)
13 
+  (string->symbol (add-con-prefix (symbol->string sym))))
14 
+
15 
+(define (remove-con-prefix/symbol sym)
16 
+  (string->symbol (remove-con-prefix (symbol->string sym))))
17 
+
18 
+(define (has-con-prefix/symbol? sym)
19 
+  (has-con-prefix? (symbol->string sym)))
20 
+
21 
+
top/phases.scm
History View file @ 4e98702
0 22 
new file mode 100644
... ... 
@@ -0,0 +1,226 @@
1 
+
2 
+;;; This is the top-level phase structure of the compiler.
3 
+
4 
+;;; Compilation phase support
5 
+
6 
+(define *phase* '#f)
7 
+(define *abort-phase* '#f)         ; abort when this phase completes
8 
+(define *abort-compilation*
9 
+  (lambda ()
10 
+    (error "No error continuation defined here!")))
11 
+
12 
+(define *module-asts* '())   ; a global only for debugging purposes
13 
+
14 
+;;; Later add the printing and timing stuff here
15 
+
16 
+(define-local-syntax (phase-body phase-name body printer)
17 
+  `(dynamic-let ((*phase*       ',phase-name))
18 
+     (when (memq ',phase-name (dynamic *printers*))
19 
+       (format '#t "~%Phase ~a:~%" ',phase-name)
20 
+       (force-output))
21 
+     (let* ((phase-start-time (get-run-time))
22 
+	    (result ,body)
23 
+	    (current-time  (get-run-time)))
24 
+       (when (eq? (dynamic *abort-phase*) ',phase-name)
25 
+	 (abort-compilation))
26 
+       ,@(if (eq? printer '#f)
27 
+	     '()
28 
+	     `((when (memq ',phase-name (dynamic *printers*))
29 
+		 (funcall ,printer result)
30 
+		 (force-output))))
31 
+       (when (memq 'phase-time *printers*)
32 
+	 (let ((elapsed-time (- current-time phase-start-time)))
33 
+	   (format '#t "~&~A complete: ~A seconds~%"
34 
+		   ',phase-name elapsed-time)
35 
+	   (force-output)))
36 
+       result)))
37 
+
38 
+
39 
+
40 
+;;; Returns 2 values: module ast's and lisp code.
41 
+
42 
+(define (compile-haskell-files files)
43 
+  (dynamic-let ((*abort-phase*                '#f))
44 
+     (let ((all-mods       (haskell-parse-files files))
45 
+	   (interface-mods '())
46 
+	   (regular-mods   '()))
47 
+       (dolist (m all-mods)
48 
+	 (if (eq? (module-type m) 'interface)
49 
+	     (push m interface-mods)
50 
+	     (push m regular-mods)))
51 
+       (dynamic-let ((*unit*  (module-name (car all-mods))))
52 
+	 (values
53 
+	   all-mods
54 
+	   `(begin
55 
+	      ,(if interface-mods
56 
+		   (compile-interface-modules (nreverse interface-mods))
57 
+		   '#f)
58 
+	      ,(if regular-mods
59 
+		   (compile-modules (nreverse regular-mods))
60 
+		   '#f))
61 
+	   )))))
62 
+
63 
+
64 
+
65 
+(define (compile-modules mods)
66 
+  (dynamic-let ((*context*                    '#f)
67 
+		(*recoverable-error-handler*  '#f)
68 
+		(*abort-phase*                '#f)
69 
+		(*unique-name-counter*        1)
70 
+		(*suffix-table*               (make-table)))
71 
+  	  (haskell-import-export mods '#f)
72 
+	  (haskell-process-type-declarations mods)
73 
+	  (haskell-scope mods)
74 
+	  (let ((big-let (haskell-dependency-analysis mods)))
75 
+	    (cond ((not (void? big-let))
76 
+		   (haskell-type-check big-let mods)
77 
+		   (setf big-let (haskell-cfn big-let))
78 
+		   (setf big-let (haskell-dependency-reanalysis big-let))
79 
+		   (setf big-let (haskell-ast-to-flic big-let))
80 
+		   (setf big-let (haskell-optimize big-let))
81 
+		   (setf big-let (haskell-strictness big-let))
82 
+		   (haskell-codegen big-let mods))
83 
+		  (else
84 
+		   ''#f)
85 
+		  ))))
86 
+
87 
+
88 
+(define (modules->lisp-code modules)
89 
+  (dynamic-let ((*unit* (module-name (car modules))))
90 
+    (compile-modules modules)))
91 
+
92 
+
93 
+(predefine (notify-error))  ; in command-interface/command-utils.scm
94 
+
95 
+(define (abort-compilation)
96 
+  (notify-error)
97 
+  (funcall (dynamic *abort-compilation*)))
98 
+
99 
+(define (halt-compilation)
100 
+  (setf (dynamic *abort-phase*) (dynamic *phase*)))
101 
+
102 
+
103 
+;;; Here are the actual phase bodies
104 
+
105 
+(predefine (parse-files files))
106 
+
107 
+(define (haskell-parse-files filenames)
108 
+  (phase-body parse
109 
+    (let ((mods (parse-files filenames)))
110 
+      mods)
111 
+    #f))
112 
+
113 
+(predefine (import-export modules))  ; in import-export/import-export.scm
114 
+(predefine (import-export/interface modules))
115 
+
116 
+(define (haskell-import-export modules interface?)
117 
+  (phase-body import
118 
+    (if interface?
119 
+	(import-export/interface modules)
120 
+	(import-export modules))
121 
+    #f))
122 
+
123 
+
124 
+(predefine (process-type-declarations modules))
125 
+    ; in tdecl/type-declaration-analysis.scm
126 
+
127 
+(define (haskell-process-type-declarations modules)
128 
+  (phase-body type-decl
129 
+    (begin
130 
+      (process-type-declarations modules))
131 
+    #f))
132 
+
133 
+
134 
+(predefine (scope-modules x))  ; in prec/scope.scm
135 
+(predefine (print-full-module x . maybe-stream)) ; in the printers
136 
+
137 
+(define (haskell-scope modules)
138 
+  (phase-body scope
139 
+    (scope-modules modules)
140 
+    (lambda (result)
141 
+      (declare (ignore result))
142 
+      (dolist (m modules) (print-full-module m)))
143 
+    ))
144 
+
145 
+
146 
+(predefine (do-dependency-analysis x))  ; in depend/dependency-analysis.scm
147 
+
148 
+(define (haskell-dependency-analysis modules)
149 
+  (phase-body depend
150 
+    (do-dependency-analysis modules)
151 
+    (function pprint*)))
152 
+
153 
+
154 
+(predefine (do-haskell-type-check big-let mods))
155 
+
156 
+(define (haskell-type-check big-let modules)
157 
+  (phase-body type
158 
+    (do-haskell-type-check big-let modules)
159 
+    #f))
160 
+
161 
+(predefine (cfn-ast x))  ; in cfn/main.scm
162 
+
163 
+(define (haskell-cfn big-let)
164 
+  (phase-body cfn
165 
+    (cfn-ast big-let)
166 
+    (function pprint*)))
167 
+
168 
+
169 
+(predefine (analyze-dependency-top x))  ; in depend/dependency-analysis.scm
170 
+
171 
+(define (haskell-dependency-reanalysis big-let)
172 
+  (phase-body depend2
173 
+    (begin
174 
+      (analyze-dependency-top big-let)
175 
+      big-let)
176 
+    (function pprint*)))
177 
+
178 
+
179 
+(predefine (ast-to-flic x))		; in flic/ast-to-flic.scm
180 
+
181 
+(define (haskell-ast-to-flic big-let)
182 
+  (phase-body flic
183 
+    (ast-to-flic big-let)
184 
+    (function pprint*)))
185 
+
186 
+
187 
+(predefine (optimize-top x))  ; in backend/optimize.scm
188 
+
189 
+(define (haskell-optimize big-let)
190 
+  (phase-body optimize
191 
+    (optimize-top big-let)
192 
+    (function pprint*)))
193 
+
194 
+(predefine (strictness-analysis-top x)) ; in backend/strictness.scm
195 
+(predefine (strictness-analysis-printer x))
196 
+
197 
+(define (haskell-strictness big-let)
198 
+  (phase-body strictness
199 
+    (strictness-analysis-top big-let)
200 
+    (function strictness-analysis-printer)))
201 
+
202 
+
203 
+(predefine (codegen-top x))  ; in backend/codegen.scm
204 
+(predefine (codegen-exported-types x)) ; "
205 
+(predefine (codegen-prim-entries x))  ; ditto
206 
+
207 
+(define (haskell-codegen big-let mods)
208 
+  (phase-body codegen
209 
+    `(begin
210 
+       ,(codegen-exported-types mods)
211 
+       ,(codegen-top big-let))
212 
+    #f))
213 
+
214 
+
215 
+;;; This is for interface modules.
216 
+
217 
+(predefine (haskell-codegen/interface mods))
218 
+
219 
+(define (compile-interface-modules mods)
220 
+ (dynamic-let ((*context*                    '#f)
221 
+	       (*recoverable-error-handler*  '#f)
222 
+	       (*abort-phase*                '#f))
223 
+     (haskell-import-export mods '#t)
224 
+     (haskell-process-type-declarations mods)
225 
+     (haskell-scope mods)
226 
+     (haskell-codegen/interface mods)))
top/prelude-core-syms.scm
History View file @ 4e98702
0 227 
new file mode 100644
... ... 
@@ -0,0 +1,57 @@
1 
+;;; This should be used to create core symbols for every name exported
2 
+;;; by PreludeCore.  This only needs to run when the Prelude definition
3 
+;;; changes.
4 
+
5 
+(define (def->name-string x)
6 
+  (symbol->string (def-name x)))
7 
+
8 
+
9 
+(define (generate-prelude-core-symbols)
10 
+  (initialize-compilation)
11 
+  (load-compilation-unit *prelude-unit-filename* '#t '#f '#f '#f)
12 
+  (let* ((core (table-entry *modules* '|PreludeCore|))
13 
+	 (export-table (module-export-table core))
14 
+	 (vars '())
15 
+	 (classes '())
16 
+	 (types '())
17 
+	 (constrs '())
18 
+	 (syns '())
19 
+	 (methods '()))
20 
+    (table-for-each
21 
+      (lambda (k v)
22 
+	(declare (ignore k))
23 
+	(let ((def (tuple-2-2 (car v))))
24 
+	  (cond ((var? def)
25 
+		 (push (def->name-string def) vars))
26 
+		((synonym? def)
27 
+		 (push (def->name-string def) syns))
28 
+		((algdata? def)
29 
+		 (push (def->name-string def) types)
30 
+		 (dolist (x (cdr v))
31 
+		     (push (remove-con-prefix (def->name-string (tuple-2-2 x)))
32 
+			   constrs)))
33 
+		((class? def)
34 
+		 (push (def->name-string def) classes)
35 
+		 (dolist (x (cdr v))
36 
+		     (push (def->name-string (tuple-2-2 x))
37 
+			   methods)))
38 
+		(else (error "? strange def")))))
39 
+      export-table)
40 
+  (call-with-output-file "/tmp/prelude-syms"
41 
+      (lambda (port)
42 
+	(pprint `(define *haskell-prelude-vars*
43 
+		   '((classes ,@classes)
44 
+		     (methods ,@methods)
45 
+		     (types ,@types)
46 
+		     (constructors ,@constrs)
47 
+		     (synonyms ,@syns)
48 
+		     (values ,@vars)))
49 
+		port)))))
50 
+
51 
+
52 
+
53 
+(define (create-prelude-init-code defs)
54 
+  (let* ((name (def-name def))
55 
+	 (sym-name (make-core-symbol-name name)))
56 
+    `(define sym-name '())))
57 
+
top/symbol-table.scm
History View file @ 4e98702
0 58 
new file mode 100644
... ... 
@@ -0,0 +1,412 @@
1 
+;;; These routines deal with the global symbol table.  The symbol table
2 
+;;; is represented in two stages: a module table which maps module names
3 
+;;; onto module structures and local tables within each module which
4 
+;;; map names (symbols) to definitions.
5 
+
6 
+;;; The following functions deal with the module table (*modules*):
7 
+
8 
+;;;  (initialize-module-table) - this clears out all modules from the
9 
+;;;      symbol table.  Every compilation should start with this.
10 
+;;;  (add-module-to-module-table module) - this takes a module ast,
11 
+;;;      either from a .exp file or previous compilation with the same
12 
+;;;      incarnation of the compiler and adds it to the set of `known'
13 
+;;;      modules.  Incomplete module ast's in the process of compilation
14 
+;;;      are also added to this table.
15 
+
16 
+
17 
+(define (initialize-module-table)
18 
+  (setf *modules* (make-table)))
19 
+
20 
+(define (add-module-to-symbol-table module)
21 
+  (let* ((name (module-name module))
22 
+	 (old-module (table-entry *modules* name)))
23 
+    (when (not (eq? old-module '#f))
24 
+      (if (eq? *unit* (module-unit old-module))
25 
+	  (signal-module-double-definition name)
26 
+	  (signal-module-already-defined name)))
27 
+    (setf (table-entry *modules* name) module)))
28 
+
29 
+(define (remove-module-from-symbol-table module)
30 
+  (let ((name (module-name module)))
31 
+    (setf (table-entry *modules* name) '#f)))
32 
+
33 
+(define (locate-module name)
34 
+  (table-entry *modules* name))
35 
+
36 
+;;;  (walk-modules fn mod-list) - this calls fn for each module in the
37 
+;;;      mod-list.  It also binds the global variable *module* to the
38 
+;;;      current module, *symbol-table* to the local symbol
39 
+;;;      table.  The fixity table is also placed in a global.
40 
+
41 
+(define (walk-modules mods fn)
42 
+  (dolist (mod mods)
43 
+    (dynamic-let ((*module* mod)
44 
+		  (*module-name* (module-name mod))
45 
+		  (*symbol-table* (module-symbol-table mod))
46 
+		  (*fixity-table* (module-fixity-table mod))
47 
+		  (*inverted-symbol-table* (module-inverted-symbol-table mod)))
48 
+       (funcall fn))))
49 
+
50 
+;;; create-definition makes a new definition object
51 
+
52 
+(define (create-definition module name type)
53 
+  (cond ((module-prelude? module)
54 
+	 (let ((def (table-entry *core-symbols* name)))
55 
+	   (cond ((eq? def '#f)
56 
+		  (create-definition/non-core module name type))
57 
+		 (else
58 
+		  (setf (def-unit def) *unit*)
59 
+		  (setf (def-module def) (module-name module))
60 
+		  ;; *** Should any other properties be reinitialized here?
61 
+		  (cond ((or (eq? type 'var) (eq? type 'method-var))
62 
+			 (setf (var-fixity def) '#f)
63 
+			 (setf (var-signature def) '#f))
64 
+			((eq? type 'con)
65 
+			 (setf (con-fixity def) '#f)))
66 
+		  def))))
67 
+	(else (create-definition/non-core module name type))))
68 
+
69 
+;(define (create-definition/non-core module name type)
70 
+;  (create-definition/new module name type)
71 
+;      (let* ((interface (module-interface-module module))
72 
+;	     (old-def (table-entry (module-symbol-table interface) name)))
73 
+;	(if (eq? old-def '#f)
74 
+;	    (create-definition/new module name type)
75 
+;	    (cond ((eq? type 'var)
76 
+;		   (unless (var? old-def)
77 
+;		       (def-conflict module name type old-def))
78 
+;		   (setf (var-interface-type old-def) (var-type old-def)))
79 
+;		  ((eq? type 'con)
80 
+;		   (unless (con? old-def)
81 
+;		      (def-conflict module name type old-def)))
82 
+;		  ((eq? type 'synonym)
83 
+;		   (unless (synonym? old-def)
84 
+;		      (def-conflict module name type old-def)))
85 
+;		  ((eq? type 'algdata)
86 
+;		   (unless (algdata? old-def)
87 
+;		      (def-conflict module name type old-def)))
88 
+;		  ((eq? type 'class)
89 
+;		   (unless (class? old-def)
90 
+;		      (def-conflict module name type old-def)))
91 
+;		  ((eq? type 'method-var)
92 
+;		   (unless (method-var? old-def)
93 
+;		      (def-conflict module name type old-def)))))
94 
+;	(setf (def-unit old-def) *unit*)
95 
+;	old-def)))
96 
+;
97 
+;(define (def-conflict module name type def)
98 
+;  (phase-error 'interface-conflict
99 
+;    "The ~A ~A in module ~A was defined as a ~A in an interface."
100 
+;    (cond ((var? def) "variable")
101 
+;	  ((class? def) "class")
102 
+;	  ((algdata? def) "data type")
103 
+;	  ((synonym? def) "synonym")
104 
+;	  ((con? def) "constructor")
105 
+;	  (else "widgit"))
106 
+;    name (module-name module) type))
107 
+
108 
+(define (create-definition/non-core module name type)
109 
+  (let ((mname  (module-name module)))
110 
+    (when (eq? (module-type *module*) 'interface)
111 
+       (mlet (((mod name1) (rename-interface-symbol name)))
112 
+         (setf mname mod)
113 
+	 (setf name name1)))
114 
+    (create-definition/inner mname name type)))
115 
+
116 
+(define (create-definition/inner mname name type)
117 
+    (cond ((eq? type 'var)
118 
+	   (make var (name name) (module mname) (unit *unit*)))
119 
+	  ((eq? type 'con)
120 
+	   (make con (name name) (module mname) (unit *unit*)))
121 
+	  ((eq? type 'synonym)
122 
+	   (make synonym (name name) (module mname) (unit *unit*)))
123 
+	  ((eq? type 'algdata)
124 
+	   (make algdata (name name) (module mname) (unit *unit*)))
125 
+	  ((eq? type 'class)
126 
+	   (make class (name name) (module mname) (unit *unit*)))
127 
+	  ((eq? type 'method-var)
128 
+	   (make method-var (name name) (module mname) (unit *unit*)))
129 
+	  (else
130 
+	   (error "Bad type argument ~s." type))))
131 
+
132 
+
133 
+(define (create-top-definition name type)
134 
+  (let ((def (create-definition *module* name type)))
135 
+    (insert-top-definition name def)
136 
+    def))
137 
+
138 
+;;; Interfaces have a special table which resolves imports in the
139 
+;;; interface.  Given a name in an interface module this returns the
140 
+;;; corresponding full name: a (module,original-name) pair.  Symbols not
141 
+;;; imported are assumed to be defined in the interface.
142 
+
143 
+(define (rename-interface-symbol name)
144 
+  (let ((res (assq name (module-interface-imports *module*))))
145 
+    (if (eq? res '#f)
146 
+	(values *module-name* name)
147 
+	(values (tuple-2-1 (tuple-2-2 res))
148 
+		(tuple-2-2 (tuple-2-2 res))))))
149 
+
150 
+;;; This creates a locally defined var node.
151 
+
152 
+(define (create-local-definition name)
153 
+  (let ((var     (make var (name name) (module *module-name*) (unit *unit*))))
154 
+    (setf (var-fixity var) (table-entry *fixity-table* name))
155 
+    var))
156 
+
157 
+
158 
+;;; This function creates a new variable.
159 
+;;; The "root" may be either a symbol or a string.
160 
+;;; *unit* defines the home module of the variable.
161 
+
162 
+;;; *** Maybe it would be possible to hack this so that it doesn't
163 
+;;; *** create any symbol at all until the name is demanded by something,
164 
+;;; *** but that seems like a rather sweeping change.
165 
+
166 
+(define (create-temp-var root)
167 
+  (let* ((name   (gensym (if (symbol? root) (symbol->string root) root)))
168 
+	 (module  *unit*))
169 
+    (make var (name name) (module module) (unit *unit*))))
170 
+
171 
+
172 
+;;; The following routines install top level definitions into the symbol
173 
+;;; table.
174 
+
175 
+(predefine (signal-multiple-name-conflict name old-local-name def))
176 
+    ; in import-export/ie-errors.scm
177 
+
178 
+(define (insert-top-definition name def)
179 
+  (let ((old-definition (resolve-toplevel-name name)))
180 
+    (cond ((eq? old-definition '#f)
181 
+	   (when (not (def-prelude? def))
182 
+	       (setf (table-entry *symbol-table* name) def))
183 
+	   (when (and (var? def) (not (eq? (var-fixity def) '#f)))
184 
+             (setf (table-entry *fixity-table* name)
185 
+		   (var-fixity def)))
186 
+	   (when (and (con? def) (not (eq? (con-fixity def) '#f)))
187 
+             (setf (table-entry *fixity-table* name)
188 
+		   (con-fixity def)))
189 
+	   (when (not (def-prelude? def))
190 
+ 	    (if (eq? (local-name def) '#f)
191 
+		(setf (table-entry *inverted-symbol-table* def) name)
192 
+		(signal-multiple-name-conflict name (local-name def) def))))
193 
+	  ((eq? old-definition def)
194 
+	   'OK)
195 
+	  ((def-prelude? old-definition)
196 
+	   (signal-core-redefinition name))
197 
+	  ((and (module-uses-standard-prelude? *module*)
198 
+		(table-entry *prelude-symbol-table* name))
199 
+	   (if (eq? (def-module def) *module-name*)
200 
+	       (signal-prelude-redefinition name)
201 
+	       (signal-prelude-reimport name (def-module def))))
202 
+	  ((eq? (def-module def) *module-name*)
203 
+	   (signal-multiple-definition-in-module name *module-name*))
204 
+	  ((eq? (def-module old-definition) *module-name*)
205 
+	   (signal-redefinition-by-imported-symbol name *module-name*))
206 
+	  (else
207 
+	   (signal-multiple-import name *module-name*)))))
208 
+
209 
+;;; Gets the fixity of a name.
210 
+
211 
+(define (get-local-fixity name)
212 
+  (table-entry *fixity-table* name))
213 
+
214 
+;;; These routines support general scoping issues.  Only vars have local
215 
+;;; definitions - all other names are resolved from the global symbol table.
216 
+
217 
+;;; This is used when the name must be in the top symbols.
218 
+
219 
+(define (fetch-top-def name type)
220 
+  (let ((def (resolve-toplevel-name name)))
221 
+    (cond ((eq? def '#f)
222 
+	   (cond ((eq? (module-type *module*) 'interface)
223 
+		  (mlet (((mod name1) (rename-interface-symbol name)))
224 
+		    (if (eq? mod *module-name*)
225 
+			(undefined-topsym name)
226 
+			(let ((new-def (create-definition/inner
227 
+					mod name1 type)))
228 
+			  (insert-top-definition name1 new-def)
229 
+			  (cond ((algdata? new-def)
230 
+				 (setf (algdata-n-constr new-def) 0)
231 
+				 (setf (algdata-constrs new-def) '())
232 
+				 (setf (algdata-context new-def) '())
233 
+				 (setf (algdata-tyvars new-def) '())
234 
+				 (setf (algdata-classes new-def) '#f)
235 
+				 (setf (algdata-enum? new-def) '#f)
236 
+				 (setf (algdata-tuple? new-def) '#f)
237 
+				 (setf (algdata-real-tuple? new-def) '#f)
238 
+				 (setf (algdata-deriving new-def) '()))
239 
+				((class? new-def)
240 
+				 (setf (class-method-vars new-def) '())
241 
+				 (setf (class-super new-def) '())
242 
+				 (setf (class-super* new-def) '())
243 
+				 (setf (class-tyvar new-def) '|a|)
244 
+				 (setf (class-instances new-def) '())
245 
+				 (setf (class-kind new-def) 'other)
246 
+				 (setf (class-n-methods new-def) 0)
247 
+				 (setf (class-dict-size new-def) 0)
248 
+				 (setf (class-selectors new-def) '())))
249 
+			  new-def))))
250 
+		 (else
251 
+		  (undefined-topsym name))))
252 
+	  (else def))))
253 
+
254 
+(define (undefined-topsym name)
255 
+  (signal-undefined-symbol name)
256 
+  *undefined-def*)
257 
+
258 
+
259 
+(define (resolve-toplevel-name name)
260 
+  (let ((pc (table-entry *prelude-core-symbols* name)))
261 
+    (cond ((not (eq? pc '#f))
262 
+	   pc)
263 
+	  ((module-uses-standard-prelude? *module*)
264 
+	   (let ((res (table-entry *prelude-symbol-table* name)))
265 
+	     (if (eq? res '#f)
266 
+		 (resolve-toplevel-name-1 name)
267 
+		 res)))
268 
+	  (else
269 
+	   (resolve-toplevel-name-1 name)))))
270 
+
271 
+(define (resolve-toplevel-name-1 name)
272 
+  (cond ((eq? (module-inherited-env *module*) '#f)
273 
+	 (table-entry *symbol-table* name))
274 
+	(else
275 
+	 (let ((res (search-inherited-tables
276 
+		     name (module-inherited-env *module*))))
277 
+	   (if (eq? res '#f)
278 
+	       (table-entry *symbol-table* name)
279 
+	       res)))))
280 
+
281 
+(define (search-inherited-tables name mod)
282 
+  (if (eq? mod '#f)
283 
+      '#f
284 
+      (let ((res (table-entry (module-symbol-table mod) name)))
285 
+	(if (eq? res '#f)
286 
+	    (search-inherited-tables name (module-inherited-env mod))
287 
+	    res))))
288 
+
289 
+;;; Con-ref's are special in that the naming convention (;Name) ensures
290 
+;;; that if a def is found it must be a con.
291 
+
292 
+(define (resolve-con con-ref)
293 
+  (when (eq? (con-ref-con con-ref) *undefined-def*)
294 
+    (remember-context con-ref
295 
+      (let ((def (fetch-top-def (con-ref-name con-ref) 'con)))
296 
+	(setf (con-ref-con con-ref) def)))))
297 
+
298 
+(define (resolve-class class-ref)
299 
+  (when (eq? (class-ref-class class-ref) *undefined-def*)
300 
+    (remember-context class-ref
301 
+      (let ((def (fetch-top-def (class-ref-name class-ref) 'class)))
302 
+	(when (not (class? def))
303 
+	  (signal-class-name-required def (class-ref-name class-ref)))
304 
+	(setf (class-ref-class class-ref) def)))))
305 
+
306 
+
307 
+(define (resolve-tycon tycon)
308 
+  (when (eq? (tycon-def tycon) *undefined-def*)
309 
+    (remember-context tycon
310 
+      (let ((def (fetch-top-def (tycon-name tycon) 'algdata)))
311 
+	(when (class? def)
312 
+	  (signal-tycon-name-required (tycon-name tycon)))
313 
+	(setf (tycon-def tycon) def)))))
314 
+
315 
+
316 
+;;; This should be used after the local environment has been searched.
317 
+;;; Other routines dealing with variable scoping are elsewhere.
318 
+
319 
+(define (resolve-var var-ref)
320 
+  (when (eq? (var-ref-var var-ref) *undefined-def*)
321 
+    (remember-context var-ref
322 
+      (let ((def (fetch-top-def (var-ref-name var-ref) 'var)))
323 
+	(setf (var-ref-var var-ref) def)))))
324 
+
325 
+
326 
+;;; *** The inverted-symbol-table is the only table in the whole
327 
+;;; *** system that is not keyed off of symbols.  If this is a problem,
328 
+;;; *** things that use it could probably be rewritten to do something
329 
+;;; *** else, like store an a-list on the def itself.
330 
+
331 
+;;; This does not need to consult the inherited-env flag because when this
332 
+;;; is used in extensions only new symbols get inserted.
333 
+
334 
+(define (local-name def)
335 
+  (cond ((def-prelude? def)
336 
+	 (def-name def))
337 
+	((module-uses-standard-prelude? *module*)
338 
+	 (let ((res (table-entry *prelude-inverted-symbol-table* def)))
339 
+	   (if (eq? res '#f)
340 
+	    (table-entry *inverted-symbol-table* def)
341 
+	    res)))
342 
+	(else
343 
+	 (table-entry *inverted-symbol-table* def))))
344 
+
345 
+(define (print-name x)
346 
+  (let ((res (local-name x)))
347 
+    (if (eq? res '#f)
348 
+	(def-name x)
349 
+	res)))
350 
+
351 
+
352 
+;;; Error signalling routines.
353 
+
354 
+(define (signal-module-double-definition name)
355 
+  (fatal-error 'module-double-definition
356 
+    "Module ~s is defined more than once."
357 
+    name))
358 
+
359 
+(define (signal-module-already-defined name)
360 
+  (fatal-error 'module-already-defined
361 
+    "Module ~a is defined more than once in the current unit."
362 
+    name))
363 
+
364 
+(define (signal-multiple-definition-in-module name modname)
365 
+ (if (eq? (module-type *module*) 'extension)
366 
+     (phase-error 'cant-redefine-in-extension
367 
+        "An extension for module ~A cannot redefine the symbol ~A"
368 
+	modname name)
369 
+     (phase-error 'multiple-definition-in-module
370 
+        "There is more than one definition for the name ~a in module ~a."
371 
+	name modname)))
372 
+
373 
+(define (signal-redefinition-by-imported-symbol name modname)
374 
+  (phase-error 'redefinition-by-imported-symbol
375 
+    "The name ~a is defined in module ~a, and cannot be imported."
376 
+    name modname))
377 
+
378 
+(define (signal-core-redefinition name)
379 
+  (phase-error 'prelude-redefinition
380 
+    "The name ~a is defined in the prelude core and cannot be redefined."
381 
+    name))
382 
+
383 
+(define (signal-prelude-redefinition name)
384 
+  (phase-error 'prelude-redefinition
385 
+    "The name ~a is defined in the prelude.~%You must hide it if you wish to use this name."
386 
+    name))
387 
+
388 
+(define (signal-prelude-reimport name modname)
389 
+  (phase-error 'prelude-redefinition
390 
+    "The name ~a is both imported from ~A and defined in the prelude.~%"
391 
+    name modname))
392 
+
393 
+(define (signal-multiple-import name modname)
394 
+  (phase-error 'multiple-import
395 
+    "The name ~a is imported into module ~a multiple times."
396 
+    name modname))
397 
+
398 
+(define (signal-undefined-symbol name)
399 
+  (phase-error 'undefined-symbol
400 
+    "The name ~A is undefined."
401 
+    name))
402 
+
403 
+(define (signal-class-name-required name def)
404 
+  (phase-error 'class-name-required
405 
+    "The name ~A defines a ~A, but a class name is required."
406 
+    name
407 
+    (if (synonym? def) "synonym" "data type")))
408 
+
409 
+(define (signal-tycon-name-required name)
410 
+  (phase-error 'tycon-required
411 
+    "The name ~A defines a class, but a type constructor name is required."
412 
+    name))
top/system-init.scm
History View file @ 4e98702
0 413 
new file mode 100644
... ... 
@@ -0,0 +1,41 @@
1 
+
2 
+(define (initialize-haskell-system)
3 
+  (when (not *haskell-initialized?*)
4 
+    (initialize-haskell-system/forced))
5 
+  'haskell-ready)
6 
+
7 
+(predefine (**tycon/def def args))  ; in util/constructors.scm
8 
+(predefine (init-cse-structs))      ; in csys/dump-cse.scm
9 
+
10 
+(define (initialize-haskell-system/forced)
11 
+  (setf *haskell-initialized?* '#t)
12 
+  (setf *error-output-port* (current-output-port))
13 
+  (init-core-symbols)
14 
+  (init-tuples)
15 
+  (setf *standard-module-default*
16 
+	(make default-decl
17 
+	      (types (list
18 
+		      (**tycon/def (core-symbol "Int") '())
19 
+		      (**tycon/def (core-symbol "Double") '())))))
20 
+  (setf *undefined-def*
21 
+	(make def
22 
+	      (name '*undefined*)
23 
+	      (unit '*undefined*)
24 
+	      (module '*undefined*)))
25 
+  (setf *printer-class*
26 
+	(make class
27 
+	      (name '|Printers|)
28 
+	      (module '|*Core|) (unit '|*Core|)))
29 
+  (init-cse-structs))
30 
+
31 
+;;; This should be called in the system restart code generated by a
32 
+;;; disk save
33 
+
34 
+(define (load-init-files)
35 
+ (load-init-file "$HASKELL/.yhaskell")
36 
+ (load-init-file "~/.yhaskell"))
37 
+
38 
+(define (load-init-file name)
39 
+  (when (file-exists? name)
40 
+    (load name)))
41 
+
top/top.scm
History View file @ 4e98702
0 42 
new file mode 100644
... ... 
@@ -0,0 +1,46 @@
1 
+;;; top.scm -- compilation unit definition for the top level
2 
+
3 
+;;; Global includes the ast definitions and all global data structures
4 
+;;; used in the compiler.
5 
+
6 
+(define-compilation-unit global
7 
+  (source-filename "$Y2/top/")
8 
+  (require ast)
9 
+  (unit has-utils
10 
+    (source-filename "has-utils.scm"))
11 
+  (unit core-definitions
12 
+    (require has-utils)
13 
+    (source-filename "core-definitions.scm"))
14 
+  (unit core-symbols
15 
+    (require core-definitions)
16 
+    (source-filename "core-symbols.scm"))
17 
+  (unit core-init
18 
+    (require core-symbols)
19 
+    (source-filename "core-init.scm"))
20 
+  (unit globals
21 
+    (require core-init)
22 
+    (source-filename "globals.scm"))
23 
+  (unit has-macros
24 
+    (source-filename "has-macros.scm"))
25 
+  )
26 
+
27 
+
28 
+;;; These files do not need to be required by other units
29 
+
30 
+(define-compilation-unit top-level
31 
+  (source-filename "$Y2/top/")
32 
+  (require global)
33 
+  (unit phases
34 
+    (source-filename "phases.scm"))
35 
+  (unit system-init
36 
+    (source-filename "system-init.scm"))
37 
+  (unit errors
38 
+    (source-filename "errors.scm"))
39 
+  (unit tuple
40 
+    (source-filename "tuple.scm"))
41 
+  (unit symbol-table
42 
+    (source-filename "symbol-table.scm"))
43 
+  )
44 
+
45 
+
46 
+
top/tuple.scm
History View file @ 4e98702
0 47 
new file mode 100644
... ... 
@@ -0,0 +1,87 @@
1 
+;;; This file creates type definitions for tuples of arbitrary size.
2 
+
3 
+(define *tuple-definitions* '())
4 
+
5 
+(define (init-tuples)
6 
+  (setf *tuple-definitions* '()))
7 
+
8 
+(define (tuple-tycon k)
9 
+  (let ((tycon (assq k *tuple-definitions*)))
10 
+    (if (eq? tycon '#f)
11 
+	(new-tuple-tycon k)
12 
+	(tuple-2-2 tycon))))
13 
+
14 
+(define (tuple-constructor k)
15 
+  (car (algdata-constrs (tuple-tycon k))))
16 
+
17 
+(define (is-tuple-constructor? x)
18 
+  (and (con? x) (is-tuple-tycon? (con-alg x))))
19 
+
20 
+(define (is-tuple-tycon? x)
21 
+  (and (algdata? x) (algdata-real-tuple? x)))
22 
+
23 
+(define (tuple-constructor-arity x)
24 
+  (con-arity x))
25 
+
26 
+(predefine (ast->gtype c t))          ; in util/type-utils.scm
27 
+(predefine (**arrow-type/l args))     ; in util/constructors.scm
28 
+(predefine (**tyvar x))               ; in util/constructors.scm
29 
+
30 
+(define (new-tuple-tycon k)
31 
+  (cond ((eqv? k 0)
32 
+	 (core-symbol "UnitType"))
33 
+	(else
34 
+	 (let* ((name (string->symbol (format '#f "Tuple~A" k)))
35 
+		(cname (string->symbol (format '#f ";MkTuple~A" k)))
36 
+		(dummy-vars (gen-dummy-names k))
37 
+		(algdata (make algdata
38 
+			       (name name)
39 
+			       (module '*core*)
40 
+			       (unit '*core*)
41 
+			       (exported? '#t)
42 
+			       (arity k)
43 
+			       (n-constr 1)
44 
+			       (context '())
45 
+			       (tyvars dummy-vars)
46 
+			       (classes '())  ;; filled in later
47 
+			       (enum? '#f)
48 
+			       (tuple? '#t)
49 
+			       (real-tuple? '#t)
50 
+			       (deriving '())))
51 
+		(constr (make con
52 
+			      (name cname)
53 
+			      (module '*core*)
54 
+			      (unit '*core*)
55 
+			      (exported? '#t)
56 
+			      (arity k)
57 
+			      (types (map (function **tyvar) dummy-vars))
58 
+			      (tag 0)
59 
+			      (alg algdata)
60 
+			      (slot-strict? '())
61 
+			      (infix? '#f)))
62 
+		(tyvars (map (function **tyvar) dummy-vars))
63 
+		(tuple-type (**tycon/def algdata tyvars)))
64 
+	   (dotimes (i k)
65 
+	      (push '#f (con-slot-strict? constr)))
66 
+	   (setf (algdata-signature algdata)
67 
+		 (ast->gtype '() tuple-type))
68 
+	   (setf (con-signature constr)
69 
+		 (ast->gtype '() (**arrow-type/l
70 
+				  (append tyvars (list tuple-type)))))
71 
+	   (setf (algdata-constrs algdata)
72 
+		 (list constr))
73 
+	   (push (tuple k algdata) *tuple-definitions*)
74 
+	   algdata))))
75 
+
76 
+(define (gen-dummy-names n)
77 
+  (gen-dummy-names-1 n '()))
78 
+
79 
+(define (gen-dummy-names-1 n l)
80 
+  (if (eqv? n 0)
81 
+      l
82 
+      (gen-dummy-names-1 (1- n)
83 
+			 (cons (string->symbol (format '#f "a~A" n)) l))))
84 
+
85 
+
86 
+
87 
+
type/README
History View file @ 4e98702
0 88 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+This directory contains the type inference phase.
type/default.scm
History View file @ 4e98702
0 2 
new file mode 100644
... ... 
@@ -0,0 +1,47 @@
1 
+;;; This handles the default rule.
2 
+
3 
+(define (maybe-default-ambiguous-tyvar type def module)
4 
+  (let ((classes (ntyvar-context type)))
5 
+   (and (not (null? classes)) ; this happens only during cleanup after an error
6 
+    (let ((non-standard? '#f)
7 
+	  (numeric? '#f))
8 
+      (dolist (class classes)
9 
+	(cond ((eq? (class-kind class) 'numeric)
10 
+	       (setf numeric? '#t))
11 
+	      ((not (eq? (class-kind class) 'standard))
12 
+	       (setf non-standard? '#t))))
13 
+      (cond ((or non-standard? (not numeric?))
14 
+	     (remember-context def
15 
+ 	       (phase-error 'Non-defaultable-ambiguous-context
16 
+"An ambiguous context, ~A, cannot be defaulted.~%Ambiguity in call to ~A~%"
17 
+                  classes def))
18 
+	     '#f)
19 
+	    (else
20 
+	     (find-default-type type classes classes
21 
+			(tuple-2-2 (assq module *default-decls*)))))))))
22 
+
23 
+(define (find-default-type tyvar classes all-classes defaults)
24 
+  (cond ((null? defaults)
25 
+	 (phase-error 'no-default-applies
26 
+	    "Ambiguous context: ~A~%No default applies.~%"
27 
+	    all-classes)
28 
+	 '#f)
29 
+	((null? classes)
30 
+	 (instantiate-tyvar tyvar (car defaults))
31 
+	 '#t)
32 
+	((type-in-class? (car defaults) (car classes))
33 
+	 (find-default-type tyvar (cdr classes) all-classes defaults))
34 
+	(else
35 
+	 (find-default-type tyvar all-classes all-classes (cdr defaults)))))
36 
+
37 
+(define (type-in-class? ntype class)
38 
+  (let* ((ntype (expand-ntype-synonym ntype))
39 
+	 (alg (ntycon-tycon ntype))
40 
+	 (inst (lookup-instance alg class)))
41 
+    (if (eq? inst '#f)
42 
+	'#f
43 
+	(let ((res '#t))
44 
+	  (do-contexts (c (instance-context inst)) (ty (ntycon-args ntype))
45 
+	    (when (not (type-in-class? ty c))
46 
+	      (setf res '#f)))
47 
+	  res))))
type/dictionary.scm
History View file @ 4e98702
0 48 
new file mode 100644
... ... 
@@ -0,0 +1,229 @@
1 
+
2 
+;;; type/dictionary.scm
3 
+
4 
+;;; This function supports dictionary conversion.  It creates lambda
5 
+;;; variables to bind to the dictionary args needed by the context.
6 
+;;; The actual conversion to lambda is done in the cfn.  Each tyvar in
7 
+;;; the context has an associated mapping from class to dictionary
8 
+;;; variable.  This mapping depends on the decl containing the placeholder
9 
+;;; since different recursive decls share common tyvars.  The mapping is
10 
+;;; two levels: decl -> class -> var.
11 
+
12 
+;;; Due to language restrictions this valdef must be a simple variable
13 
+;;; definition.
14 
+
15 
+(define (dictionary-conversion/definition valdef tyvars)
16 
+  (let* ((var (decl-var valdef))
17 
+	 (type (var-type var))
18 
+	 (context (gtype-context type))
19 
+	 (dict-param-vars '()))
20 
+    (dolist (c context)
21 
+      (let ((tyvar (car tyvars))
22 
+	    (dparams '()))
23 
+       (when (not (null? c))
24 
+	(dolist (class c)
25 
+          (let ((var (create-temp-var
26 
+		      (string-append "d_"
27 
+				     (symbol->string (def-name class))))))
28 
+	    (setf (var-force-strict? var) '#t)
29 
+	    (push (tuple class var) dparams)
30 
+	    (push var dict-param-vars)))
31 
+	(push (tuple valdef dparams) (ntyvar-dict-params tyvar)))
32 
+       (setf tyvars (cdr tyvars))))
33 
+    (setf (valdef-dictionary-args valdef) (nreverse dict-param-vars))))
34 
+
35 
+;;; These routines deal with dict-var processing.
36 
+
37 
+;;; This discharges the tyvars associated with dictionaries.  The dict-vars
38 
+;;; to be processed at the next level are returned.
39 
+
40 
+(define (process-placeholders placeholders deferred decls)
41 
+  (if (null? placeholders)
42 
+      deferred
43 
+      (let ((d1 (process-placeholder (car placeholders) deferred decls)))
44 
+	(process-placeholders (cdr placeholders) d1 decls))))
45 
+
46 
+;;; This processes a placeholder.  The following cases arise:
47 
+;;;  a) the variable has already been processed (no placeholders remain) -
48 
+;;;     ignore it.  placeholders may contain duplicates so this is likely.
49 
+;;;  b) the type variable is from an outer type environment (in ng-list)
50 
+;;;     and should just be passed up to the next level (added to old-placeholders)
51 
+;;;  c) the type variable is associated with a dictionary parameter
52 
+;;;  d) the type variable is instantiated to a type constructor
53 
+;;;  e) the type variable is ambiguous (none of the above)
54 
+
55 
+(define (process-placeholder p deferred decls)
56 
+  (let* ((tyvar (placeholder-tyvar p))
57 
+	 (type (prune tyvar)))
58 
+    (cond ((ntycon? type)
59 
+	   (process-instantiated-tyvar
60 
+	    (expand-ntype-synonym type) p deferred decls))
61 
+	  ((non-generic? type)
62 
+	   (cons p deferred))
63 
+	  ((not (null? (ntyvar-dict-params type)))
64 
+	   (if (dict-placeholder? p)
65 
+	       (placeholder->dict-param p (ntyvar-dict-params type) decls)
66 
+	       (placeholder->method p (ntyvar-dict-params type) decls))
67 
+	   deferred)
68 
+	  (else
69 
+	   ;; Since default types are monotypes, no new vars will
70 
+	   ;; be added to old-placeholders
71 
+	   (when (maybe-default-ambiguous-tyvar
72 
+		  type (placeholder-overloaded-var p)
73 
+		  (valdef-module (car (placeholder-enclosing-decls p))))
74 
+	      (process-placeholder p deferred decls))
75 
+	   deferred))))
76 
+
77 
+;;; The type variable is associated with a dictionary parameter.  The only
78 
+;;; complication here is that the class needed may not be directly available -
79 
+;;; it may need to be obtained from the super classes of the parameter
80 
+;;; dictionaries.
81 
+
82 
+(define (placeholder->dict-param p param-vars decls)
83 
+  (let ((class (dict-placeholder-class p))
84 
+	(edecls (dict-placeholder-enclosing-decls p)))
85 
+    (setf (placeholder-exp p)
86 
+	  (dict-reference-code class (locate-params param-vars edecls decls)))))
87 
+
88 
+(define (dict-reference-code class param-vars)
89 
+  (let ((var (assq class param-vars)))
90 
+    (if (not (eq? var '#f))
91 
+	(**var/def (tuple-2-2 var))
92 
+	(search-superclasses class param-vars))))
93 
+
94 
+(define (locate-params param-vars enclosing-decls decls)
95 
+  (if (null? (cdr param-vars))
96 
+      (tuple-2-2 (car param-vars))
97 
+      (let ((decl (search-enclosing-decls enclosing-decls decls)))
98 
+	(tuple-2-2 (assq decl param-vars)))))
99 
+
100 
+;;; This finds the first dictionary containing the needed class in its
101 
+;;; super classes and generates a selector to get the needed dictionary.
102 
+
103 
+(define (search-superclasses class param-vars)
104 
+  (let ((pclass (tuple-2-1 (car param-vars))))
105 
+    (if (memq class (class-super* pclass))
106 
+	(**dsel/dict pclass class (**var/def (tuple-2-2 (car param-vars))))
107 
+	(search-superclasses class (cdr param-vars)))))
108 
+
109 
+(define (placeholder->method p param-vars decls)
110 
+  (let* ((method (method-placeholder-method p))
111 
+	 (class (method-var-class method))
112 
+	 (edecls (placeholder-enclosing-decls p))
113 
+	 (params (locate-params param-vars edecls decls)))
114 
+    (setf (placeholder-exp p)
115 
+	  (method-reference-code method class params))))
116 
+
117 
+(define (method-reference-code m c param-vars)
118 
+ (let ((pclass (tuple-2-1 (car param-vars))))
119 
+  (if (or (eq? c pclass)
120 
+	  (memq c (class-super* pclass)))
121 
+      (let* ((msel (assq m (class-selectors pclass)))
122 
+	     (mvar (tuple-2-2 msel)))
123 
+	(**app (**var/def mvar) (**var/def (tuple-2-2 (car param-vars)))))
124 
+      (method-reference-code m c (cdr param-vars)))))
125 
+
126 
+;;; This is for tyvars instantiated to a tycon.  A reference to the
127 
+;;; appropriate dictionary is generated.  This reference must be recursively
128 
+;;; dictionary converted since dictionaries may need subdictionaries
129 
+;;; when referenced.
130 
+
131 
+(define (process-instantiated-tyvar tycon p deferred decls)
132 
+  (let* ((alg (ntycon-tycon tycon))
133 
+	 (edecls (placeholder-enclosing-decls p))
134 
+	 (var (placeholder-overloaded-var p))
135 
+	 (class (if (dict-placeholder? p)
136 
+		    (dict-placeholder-class p)
137 
+		    (method-var-class (method-placeholder-method p))))
138 
+	 (instance (lookup-instance alg class)))
139 
+    (if (dict-placeholder? p)
140 
+	(mlet (((code def1)
141 
+		(generate-dict-ref instance tycon deferred decls edecls var)))
142 
+	   (setf (placeholder-exp p) code)
143 
+	   (setf deferred def1))
144 
+	(let ((method (method-placeholder-method p)))
145 
+	  (if (every (function null?) (instance-gcontext instance))
146 
+	      (let ((mvar (tuple-2-2
147 
+			   (assq method (instance-methods instance)))))
148 
+		(setf (placeholder-exp p) (**var/def mvar)))
149 
+	      (mlet (((code def1)
150 
+		      (generate-dict-ref
151 
+		         instance tycon deferred decls edecls var))
152 
+		     (sel (tuple-2-2 (assq method (class-selectors class)))))
153 
+		(setf (method-placeholder-exp p) (**app (**var/def sel) code))
154 
+		(setf deferred def1)))))
155 
+    deferred))
156 
+
157 
+;;; This generates a reference to a specific dictionary and binds
158 
+;;; needed subdictionaries.  Since subdictionaries may be part of the outer
159 
+;;; type environment new placeholders may be generated for later resolution.
160 
+
161 
+(define (generate-dict-ref instance type deferred decls edecls var)
162 
+  (let* ((ctxt (instance-gcontext instance))
163 
+	 (dict (dict-ref-code instance)))
164 
+    (do-contexts (class ctxt) (ty (ntycon-args type))
165 
+      (let ((ntype (prune ty)))
166 
+	(cond
167 
+	 ((ntycon? ntype)
168 
+	  (mlet ((ntype (expand-ntype-synonym ntype))
169 
+		 (alg (ntycon-tycon ntype))
170 
+		 (instance (lookup-instance alg class))
171 
+		 ((code dv1)
172 
+		  (generate-dict-ref
173 
+		    instance ntype deferred decls edecls var)))
174 
+	      (setf dict (**app dict code))
175 
+	      (setf deferred dv1)))
176 
+	 ((non-generic? ntype)
177 
+	  (let ((p (**dict-placeholder
178 
+		    class ntype edecls var)))
179 
+	    (setf dict (**app dict p))
180 
+	    (push p deferred)))
181 
+	 ((null? (ntyvar-dict-params ntype))
182 
+	  (let ((ref-code (**dict-placeholder
183 
+			   class ntype edecls var)))
184 
+	     (when (maybe-default-ambiguous-tyvar
185 
+		    ntype var (valdef-module (car edecls)))
186 
+		(process-placeholder ref-code '() decls))
187 
+	     (setf dict (**app dict ref-code))))
188 
+	 (else
189 
+	  (let ((p (locate-params (ntyvar-dict-params ntype) edecls decls)))
190 
+	    (setf dict (**app dict (dict-reference-code class p))))))))
191 
+    (values dict deferred)))
192 
+
193 
+;;; The following routines deal with recursive placeholders.  The basic
194 
+;;; strategy is to pass the entire context as a parameter with each
195 
+;;; recursive call (this could be optimized later to make use of an
196 
+;;; internal entry point).  The basic complication is that the context
197 
+;;; of each function in a letrec may be arranged differently.
198 
+
199 
+;;; This generates a call inside decl 'from' to the var 'to'.  Vmap is an
200 
+;;; alist from vars to a list of vars corresponding to the gtyvars of
201 
+;;; the decl signature.
202 
+
203 
+(define (recursive-call-code from to vmap)
204 
+  (let ((exp (**var/def to))
205 
+	(tyvars (tuple-2-2 (assq to vmap)))
206 
+	(contexts (gtype-context (var-type to))))
207 
+    (do-contexts (class contexts) (tyvar tyvars)
208 
+       (setf exp (**app exp (locate-param-var tyvar class from))))
209 
+    exp))
210 
+
211 
+(define (locate-param-var tyvar class decl)
212 
+  (let ((vmap (tuple-2-2 (assq decl (ntyvar-dict-params tyvar)))))
213 
+    (**var/def (tuple-2-2 (assq class vmap)))))
214 
+
215 
+;;; This is used to get the code for a specific dictionary reference.
216 
+
217 
+(define (dict-ref-code instance)
218 
+  (**var/def (instance-dictionary instance)))
219 
+
220 
+;;; This is used to locate the correct enclosing decl.
221 
+
222 
+(define (search-enclosing-decls decl-list decls)
223 
+  (cond ((null? decl-list)
224 
+	 (error "Lost decl in search-enclosing-decls!"))
225 
+	((memq (car decl-list) decls)
226 
+	 (car decl-list))
227 
+	(else
228 
+	 (search-enclosing-decls (cdr decl-list) decls))))
229 
+
type/expression-typechecking.scm
History View file @ 4e98702
0 230 
new file mode 100644
... ... 
@@ -0,0 +1,364 @@
1 
+;;; This file contains typecheckers for all expressions except vars and
2 
+;;; declarations.
3 
+
4 
+;;; From valdef-structs:
5 
+;;;   valdef, single-fun-def are in type-decls
6 
+
7 
+(define-type-checker guarded-rhs
8 
+  (type-check guarded-rhs rhs rhs-type
9 
+    (type-check guarded-rhs guard guard-type
10 
+      (type-unify guard-type *bool-type*
11 
+          (type-mismatch/fixed (guarded-rhs-guard object)
12 
+	   "Guards must be of type Bool" guard-type))
13 
+      (return-type object rhs-type))))
14 
+
15 
+;;; These type checkers deal with patterns.
16 
+
17 
+(define-type-checker as-pat
18 
+  (type-check as-pat pattern as-type
19 
+    (setf (var-type (var-ref-var (as-pat-var object))) as-type)
20 
+    (return-type object as-type)))
21 
+
22 
+(define-type-checker irr-pat
23 
+  (type-check irr-pat pattern pattern-type
24 
+    (return-type object pattern-type)))
25 
+
26 
+(define-type-checker var-pat
27 
+  (fresh-type var-type
28 
+    (setf (var-type (var-ref-var (var-pat-var object))) var-type)
29 
+    (return-type object var-type)))
30 
+
31 
+(define-type-checker wildcard-pat
32 
+ (fresh-type pat-type
33 
+    (return-type object pat-type)))
34 
+
35 
+;;; Constant patterns create a piece of code to actually to the
36 
+;;; match: ((==) k), where k is the constant.  This code is placed in the
37 
+;;; match-fn slot of the const-pat and is used by the cfn.
38 
+
39 
+(define-type-checker const-pat
40 
+ (let* ((val (const-pat-value object))
41 
+	(match-fn (**app (**var/def (core-symbol "==")) val)))
42 
+   (setf (const-pat-match-fn object) match-fn)
43 
+   (type-check const-pat match-fn match-type
44 
+     (fresh-type res-type
45 
+       (type-unify match-type (**arrow res-type *bool-type*) #f)
46 
+       (return-type object res-type)))))
47 
+
48 
+(define-type-checker plus-pat
49 
+  (let* ((kp (**int (plus-pat-k object)))
50 
+	 (km (**int (- (plus-pat-k object))))
51 
+	 (match-fn (**app (**var/def (core-symbol "<=")) kp))
52 
+	 (bind-fn (**app (**var/def (core-symbol "+")) km)))
53 
+    (setf (plus-pat-match-fn object) match-fn)
54 
+    (setf (plus-pat-bind-fn object) bind-fn)
55 
+    (fresh-type res-type
56 
+      (setf (ntyvar-context res-type) (list (core-symbol "Integral")))
57 
+      (type-check plus-pat match-fn match-type
58 
+        (type-check plus-pat bind-fn bind-type
59 
+          (type-check plus-pat pattern pat-type
60 
+	    (type-unify match-type (**arrow pat-type *bool-type*) #f)
61 
+	    (type-unify bind-type (**arrow pat-type pat-type) #f)
62 
+	    (type-unify res-type pat-type #f)
63 
+	    (return-type object res-type)))))))
64 
+
65 
+(define-type-checker pcon
66 
+ (type-check/list pcon pats arg-types
67 
+   (fresh-type res-type
68 
+     (let ((con-type (instantiate-gtype (con-signature (pcon-con object)))))
69 
+       (type-unify con-type (**arrow/l-2 arg-types res-type) #f)
70 
+       (return-type object res-type)))))
71 
+
72 
+(define-type-checker list-pat
73 
+  (if (null? (list-pat-pats object))
74 
+      (return-type object (instantiate-gtype
75 
+			     (algdata-signature (core-symbol "List"))))
76 
+      (type-check/unify-list list-pat pats element-type
77 
+	   (type-mismatch/list object
78 
+	     "List elements have different types")
79 
+	(return-type object (**list-of element-type)))))
80 
+
81 
+;;; These are in the order defined in exp-structs.scm
82 
+
83 
+(define-type-checker lambda
84 
+ (with-new-tyvars
85 
+  (fresh-monomorphic-types (length (lambda-pats object)) arg-vars
86 
+    (type-check/list lambda pats arg-types
87 
+     (unify-list arg-types arg-vars)
88 
+     (type-check lambda body body-type
89 
+      (return-type object (**arrow/l-2 arg-vars body-type)))))))
90 
+
91 
+(define-type-checker let
92 
+  (type-check/decls let decls
93 
+    (type-check let body let-type
94 
+      (return-type object let-type))))
95 
+
96 
+(define-type-checker if
97 
+  (type-check if test-exp test-type
98 
+    (type-unify test-type *bool-type*
99 
+        (type-mismatch/fixed object
100 
+	 "The test in an if statement must be of type Bool"
101 
+	 test-type))
102 
+    (type-check if then-exp then-type
103 
+      (type-check if else-exp else-type
104 
+        (type-unify then-type else-type
105 
+              (type-mismatch object
106 
+		   "then and else clauses have different types"
107 
+		   then-type else-type))
108 
+	(return-type object then-type)))))
109 
+
110 
+(define-type-checker case
111 
+ (with-new-tyvars
112 
+  (let ((case-exp object))  ; needed since object is rebound later
113 
+   (fresh-monomorphic-type arg-type
114 
+    (type-check case exp exp-type
115 
+      (type-unify arg-type exp-type #f) ; just to make it monomorphic
116 
+      (fresh-type res-type
117 
+	(dolist (object (case-alts object))
118 
+	  (recover-type-error ;;; %%% Needs work
119 
+	   (type-check alt pat pat-type
120 
+	     (type-unify pat-type arg-type
121 
+                 (type-mismatch case-exp
122 
+		  "Case patterns type conflict."
123 
+		  pat-type arg-type))
124 
+	     (type-check/decls alt where-decls
125 
+	       (type-check/unify-list alt rhs-list rhs-type
126 
+                 (type-mismatch/list case-exp
127 
+		     "Guarded expressions must have the same type")
128 
+		 (type-unify rhs-type res-type
129 
+			      (type-mismatch case-exp
130 
+		   "Case expression alternatives must have the same type"
131 
+		                 rhs-type res-type)))))))
132 
+	(return-type case-exp res-type)))))))
133 
+
134 
+;;; Expressions with signatures are transformed into let expressions
135 
+;;; with signatures.
136 
+
137 
+;;;    exp :: type   is rewritten as
138 
+;;;    let temp = exp
139 
+;;;        temp :: type
140 
+;;;     in temp
141 
+
142 
+(define-type-checker exp-sign
143 
+ (type-rewrite
144 
+  (let* ((temp-var (create-temp-var "TC"))
145 
+	 (decl (**valdef (**var-pat/def temp-var) '() (exp-sign-exp object)))
146 
+	 (let-exp (**let (list decl) (**var/def temp-var)))
147 
+	 (signature (exp-sign-signature object)))
148 
+      (setf (var-signature temp-var)
149 
+	    (ast->gtype (signature-context signature)
150 
+			(signature-type signature)))
151 
+      let-exp)))
152 
+
153 
+;;; Rather than complicate the ast structure with a new node for dictSel
154 
+;;; we recognize the dictSel primitive as an application and treat it
155 
+;;; specially.
156 
+
157 
+(define-type-checker app
158 
+ (if (and (var-ref? (app-fn object))
159 
+	  (eq? (var-ref-var (app-fn object)) (core-symbol "dictSel")))
160 
+  (type-check-dict-sel (app-arg object))
161 
+  (type-check app fn fn-type
162 
+    (type-check app arg arg-type
163 
+      (fresh-type res-type
164 
+        (fresh-type arg-type-1
165 
+          (type-unify fn-type (**arrow arg-type-1 res-type)
166 
+              (type-mismatch/fixed object
167 
+		       "Attempt to call a non-function"
168 
+		       fn-type))
169 
+	  (type-unify arg-type-1 arg-type
170 
+              (type-mismatch object
171 
+		 "Argument type mismatch" arg-type-1 arg-type))
172 
+	  (return-type object res-type)))))))
173 
+
174 
+;;; This is a special hack for typing dictionary selection as used in
175 
+;;; generic tuple functions.  This extracts a dictionary from a TupleDict
176 
+;;; object and uses is to resolve the overloading of a designated
177 
+;;; expression.  The expresion must generate exactly one new context.
178 
+
179 
+(define (type-check-dict-sel arg)
180 
+  (when (or (not (app? arg))
181 
+	    (not (app? (app-fn arg))))
182 
+     (dict-sel-error))
183 
+  (let* ((exp (app-fn (app-fn arg)))
184 
+	 (dict-var (app-arg (app-fn arg)))
185 
+	 (i (app-arg arg))
186 
+	 (p (dynamic *placeholders*)))
187 
+    (mlet (((object exp-type) (dispatch-type-check exp)))
188 
+	  ; check for exactly one new context
189 
+      (when (or (eq? (dynamic *placeholders*) p)
190 
+		(not (eq? (cdr (dynamic *placeholders*)) p)))
191 
+	 (dict-sel-error))
192 
+	(mlet ((placeholder (car (dynamic *placeholders*)))
193 
+	       (tyvar (placeholder-tyvar placeholder))
194 
+	       ((dict-var-ast dict-var-type) (dispatch-type-check dict-var))
195 
+	       ((index-ast index-type) (dispatch-type-check i)))
196 
+	   (setf (ntyvar-context tyvar) '())  ; prevent context from leaking out
197 
+	   (setf (dynamic *placeholders*) p)
198 
+           (type-unify dict-var-type
199 
+			  (**ntycon (core-symbol "TupleDicts") '()) #f)
200 
+	   (type-unify index-type *int-type* #f)
201 
+	   (cond ((method-placeholder? placeholder)
202 
+		  (dict-sel-error))  ; I am lazy.  This means that
203 
+		 ; dictSel must not be passed a method
204 
+		 (else
205 
+		  (setf (placeholder-exp placeholder)
206 
+			(**app (**var/def (core-symbol "dictSel"))
207 
+			       dict-var-ast index-ast))))
208 
+	   (return-type object exp-type)))))
209 
+
210 
+(define (dict-sel-error)
211 
+  (fatal-error 'dict-sel-error "Bad dictSel usage."))
212 
+
213 
+(define-type-checker con-ref
214 
+  (return-type object (instantiate-gtype (con-signature (con-ref-con object)))))
215 
+
216 
+(define-type-checker integer-const
217 
+  (cond ((const-overloaded? object)
218 
+	 (setf (const-overloaded? object) '#f)
219 
+	 (type-rewrite (**fromInteger object)))
220 
+	(else
221 
+	 (return-type object *Integer-type*))))
222 
+
223 
+(define-type-checker float-const
224 
+  (cond ((const-overloaded? object)
225 
+	 (setf (const-overloaded? object) '#f)
226 
+	 (type-rewrite (**fromRational object)))
227 
+	(else
228 
+	 (return-type object *Rational-type*))))
229 
+
230 
+(define-type-checker char-const
231 
+  (return-type object *char-type*))
232 
+
233 
+(define-type-checker string-const
234 
+  (return-type object *string-type*))
235 
+
236 
+(define-type-checker list-exp
237 
+  (if (null? (list-exp-exps object))
238 
+      (return-type object (instantiate-gtype
239 
+			     (algdata-signature (core-symbol "List"))))
240 
+      (type-check/unify-list list-exp exps element-type
241 
+	      (type-mismatch/list object
242 
+		 "List elements do not share a common type")
243 
+	(return-type object (**list-of element-type)))))
244 
+
245 
+(define-type-checker sequence
246 
+  (type-rewrite (**enumFrom (sequence-from object))))
247 
+
248 
+(define-type-checker sequence-to
249 
+  (type-rewrite (**enumFromTo (sequence-to-from object)
250 
+			      (sequence-to-to object))))
251 
+
252 
+(define-type-checker sequence-then
253 
+  (type-rewrite (**enumFromThen (sequence-then-from object)
254 
+				(sequence-then-then object))))
255 
+
256 
+(define-type-checker sequence-then-to
257 
+  (type-rewrite (**enumFromThenTo (sequence-then-to-from object)
258 
+				  (sequence-then-to-then object)
259 
+				  (sequence-then-to-to object))))
260 
+
261 
+(define-type-checker list-comp
262 
+ (with-new-tyvars
263 
+  (dolist (object (list-comp-quals object))
264 
+    (if (is-type? 'qual-generator object)
265 
+	(fresh-type pat-type
266 
+	 (push pat-type (dynamic *non-generic-tyvars*))
267 
+	 (type-check qual-generator pat pat-type-1
268 
+	   (type-unify pat-type pat-type-1 #f)
269 
+	   (type-check qual-generator exp qual-exp-type
270 
+	     (type-unify (**list-of pat-type) qual-exp-type
271 
+                            (type-mismatch/fixed object
272 
+		 "Generator expression is not a list" qual-exp-type)))))
273 
+	 (type-check qual-filter exp filter-type
274 
+	   (type-unify filter-type *bool-type*
275 
+              (type-mismatch/fixed object
276 
+		"Filter must have type Bool" filter-type)))))
277 
+  (type-check list-comp exp exp-type
278 
+     (return-type object (**list-of exp-type)))))
279 
+
280 
+(define-type-checker section-l
281 
+  (type-check section-l op op-type
282 
+    (type-check section-l exp exp-type
283 
+      (fresh-type a-type
284 
+        (fresh-type b-type
285 
+          (fresh-type c-type
286 
+            (type-unify op-type (**arrow a-type b-type c-type)
287 
+                (type-mismatch/fixed object
288 
+		     "Binary function required in section" op-type))
289 
+	    (type-unify b-type exp-type
290 
+                  (type-mismatch object
291 
+		      "Argument type mismatch" b-type exp-type))
292 
+	    (return-type object (**arrow a-type c-type))))))))
293 
+
294 
+(define-type-checker section-r
295 
+  (type-check section-r op op-type
296 
+    (type-check section-r exp exp-type
297 
+      (fresh-type a-type
298 
+        (fresh-type b-type
299 
+          (fresh-type c-type
300 
+            (type-unify op-type (**arrow a-type b-type c-type)
301 
+                  (type-mismatch/fixed object
302 
+			 "Binary function required" op-type))
303 
+	    (type-unify exp-type a-type
304 
+                    (type-mismatch object
305 
+			 "Argument type mismatch" a-type exp-type))
306 
+	    (return-type object (**arrow b-type c-type))))))))
307 
+
308 
+(define-type-checker omitted-guard
309 
+  (return-type object *bool-type*))
310 
+
311 
+(define-type-checker con-number
312 
+  (let ((arg-type (instantiate-gtype
313 
+		   (algdata-signature (con-number-type object)))))
314 
+    (type-check con-number value arg-type1
315 
+      (type-unify arg-type arg-type1 #f)
316 
+      (return-type object *int-type*))))
317 
+
318 
+(define-type-checker sel
319 
+  (let ((con-type (instantiate-gtype
320 
+		   (con-signature (sel-constructor object)))))
321 
+    (mlet (((res-type exp-type1) (get-ith-type con-type (sel-slot object))))
322 
+      (type-check sel value exp-type
323 
+        (type-unify exp-type exp-type1 #f)
324 
+	(return-type object res-type)))))
325 
+
326 
+(define (get-ith-type type i)
327 
+ (let ((args (ntycon-args type)))  ; must be an arrow
328 
+  (if (eq? i 0)
329 
+      (values (car args) (get-ith-type/last (cadr args)))
330 
+      (get-ith-type (cadr args) (1- i)))))
331 
+
332 
+(define (get-ith-type/last type)
333 
+  (if (eq? (ntycon-tycon type) (core-symbol "Arrow"))
334 
+      (get-ith-type/last (cadr (ntycon-args type)))
335 
+      type))
336 
+
337 
+(define-type-checker is-constructor
338 
+  (let ((alg-type (instantiate-gtype
339 
+		   (algdata-signature
340 
+		    (con-alg (is-constructor-constructor object))))))
341 
+    (type-check is-constructor value arg-type
342 
+      (type-unify arg-type alg-type #f)
343 
+      (return-type object *bool-type*))))
344 
+
345 
+(define-type-checker cast
346 
+  (type-check cast exp _
347 
+    (fresh-type res
348 
+      (return-type object res))))
349 
+
350 
+;;; This is used for overloaded methods.  The theory is to avoid supplying
351 
+;;; the context at the class level.  This type checks the variable as if it had
352 
+;;; the supplied signature.
353 
+
354 
+(define-type-checker overloaded-var-ref
355 
+  (let* ((var (overloaded-var-ref-var object))
356 
+	 (gtype (overloaded-var-ref-sig object))
357 
+	 (ovar-type (var-type var)))
358 
+    (when (recursive-type? ovar-type)
359 
+	 (error
360 
+	  "Implementation error: overloaded method found a recursive type"))
361 
+    (mlet (((ntype new-vars) (instantiate-gtype/newvars gtype))
362 
+	   (object1 (insert-dict-placeholders
363 
+		     (**var/def var) new-vars object)))
364 
+	  (return-type object1 ntype))))
type/pattern-binding.scm
History View file @ 4e98702
0 365 
new file mode 100644
... ... 
@@ -0,0 +1,38 @@
1 
+;;; This implements the pattern binding rule.
2 
+
3 
+(define (apply-pattern-binding-rule? decls)
4 
+ (not
5 
+  (every (lambda (decl)
6 
+	   (or (function-binding? decl)
7 
+	       (simple-pattern-binding-with-signature? decl)))
8 
+	 decls)))
9 
+
10 
+(define (function-binding? decl)
11 
+  (let ((defs (valdef-definitions decl)))
12 
+    (not (null? (single-fun-def-args (car defs))))))
13 
+
14 
+(define (simple-pattern-binding-with-signature? decl)
15 
+  (let ((lhs (valdef-lhs decl))
16 
+	(defs (valdef-definitions decl)))
17 
+    (and (is-type? 'var-pat lhs)
18 
+	 (null? (single-fun-def-args (car defs)))
19 
+	 (not (eq? (var-signature (var-ref-var (var-pat-var lhs))) '#f)))))
20 
+
21 
+(define (do-pattern-binding-rule decls necessary-tyvars ng-list)
22 
+  (setf ng-list (append necessary-tyvars ng-list))
23 
+  (find-exported-pattern-bindings decls)
24 
+  ng-list)
25 
+
26 
+(define (find-exported-pattern-bindings decls)
27 
+  (dolist (decl decls)
28 
+    (dolist (var-ref (collect-pattern-vars (valdef-lhs decl)))
29 
+     (let ((var (var-ref-var var-ref)))
30 
+      (when (def-exported? var)
31 
+	(recoverable-error 'exported-pattern-binding
32 
+           "Can't export pattern binding of ~A~%" var-ref))
33 
+      (when (not (eq? (var-signature var) '#f))
34 
+         (recoverable-error 'entire-group-needs-signature
35 
+           "Variable ~A signature declaration ignored~%" var-ref))))))
36 
+
37 
+
38 
+
type/type-decl.scm
History View file @ 4e98702
0 39 
new file mode 100644
... ... 
@@ -0,0 +1,337 @@
1 
+;;; This deals with declarations (let & letrec).  The input is a list of
2 
+;;; declarations (valdefs) which may contain recursive-decl-groups, as
3 
+;;; introduced in dependency analysis.  This function alters the list
4 
+;;; of non-generic type variables.  Expressions containing declarations
5 
+;;; need to rebind the non-generic list around the decls and all expressions
6 
+;;; within their scope.
7 
+
8 
+;;; This returns an updated decl list with recursive decl groups removed.
9 
+
10 
+(define (type-decls decls)
11 
+  (cond ((null? decls)
12 
+	 '())
13 
+	((is-type? 'recursive-decl-group (car decls))
14 
+	 (let ((d (recursive-decl-group-decls (car decls))))
15 
+ 	   (type-recursive d)
16 
+	   (append d (type-decls (cdr decls)))))
17 
+	(else
18 
+	 (type-non-recursive (car decls))
19 
+	 (cons (car decls)
20 
+	       (type-decls (cdr decls))))))
21 
+
22 
+;;; This typechecks a mutually recursive group of declarations (valdefs).
23 
+;;; Generate a monomorphic variable for each declaration and unify it with
24 
+;;; the lhs of the decl.  The variable all-vars collects all variables defined
25 
+;;; by the declaration group.  Save the values of placeholders and ng-list
26 
+;;; before recursing.
27 
+
28 
+;;; The type of each variable is marked as recursive.
29 
+
30 
+(define (type-recursive decls)
31 
+  (let ((old-ng (dynamic *non-generic-tyvars*))
32 
+	(old-placeholders (dynamic *placeholders*))
33 
+	(all-vars '())
34 
+	(new-tyvars '())
35 
+	(decls+tyvars '()))
36 
+    ;; on a type error set all types to `a' and give up.
37 
+    (setf (dynamic *placeholders*) '())
38 
+    (recover-type-error
39 
+       (lambda (r)
40 
+	 (make-dummy-sigs decls)
41 
+	 (setf (dynamic *dict-placeholders*) old-placeholders)
42 
+	 (funcall r))
43 
+       ;; Type the lhs of each decl and then mark each variable bound
44 
+       ;; in the decl as recursive.
45 
+       (dolist (d decls)
46 
+        (fresh-type lhs-type
47 
+	  (push lhs-type (dynamic *non-generic-tyvars*))
48 
+	  (push lhs-type new-tyvars)
49 
+	  (type-decl-lhs d lhs-type)
50 
+	  (push (tuple d lhs-type) decls+tyvars))
51 
+	(dolist (var-ref (collect-pattern-vars (valdef-lhs d)))
52 
+	  (let ((var (var-ref-var var-ref)))
53 
+	    (push var all-vars)
54 
+	    (setf (var-type var)
55 
+		  (make recursive-type (type (var-type var))
56 
+			(placeholders '()))))))
57 
+
58 
+;;; This types the decl right hand sides.  Each rhs type is unified with the
59 
+;;; tyvar corresponding to the lhs.  Before checking the signatures, the
60 
+;;; ng-list is restored.
61 
+
62 
+       (dolist (d decls+tyvars)
63 
+	 (let ((rhs-type (type-decl-rhs (tuple-2-1 d)))
64 
+	       (lhs-type (tuple-2-2 d)))
65 
+	   (type-unify lhs-type rhs-type
66 
+		 (type-mismatch (tuple-2-1 d)
67 
+			  "Decl type mismatch" lhs-type rhs-type))))
68 
+       (setf (dynamic *non-generic-tyvars*) old-ng)
69 
+       (let ((sig-contexts (check-user-signatures all-vars)))
70 
+
71 
+;;; This generalizes the signatures of recursive decls.  First, the
72 
+;;; context of the declaration group is computed.  Any tyvar in the
73 
+;;; bodies with a non-empty context must appear in all signatures that
74 
+;;; are non-ambiguous.
75 
+
76 
+	 (let* ((all-tyvars (collect-tyvars/l new-tyvars))
77 
+		(overloaded-tyvars '()))
78 
+	   (dolist (tyvar all-tyvars)
79 
+	      (when (and (ntyvar-context tyvar) (not (non-generic? tyvar)))
80 
+		 (push tyvar overloaded-tyvars)))
81 
+	   (reconcile-sig-contexts overloaded-tyvars sig-contexts)
82 
+	 ;; We should probably also emit a warning about inherently
83 
+	 ;; ambiguous decls.
84 
+	   (when (and overloaded-tyvars
85 
+		      (apply-pattern-binding-rule? decls))
86 
+		 (setf (dynamic *non-generic-tyvars*)
87 
+		       (do-pattern-binding-rule
88 
+			decls overloaded-tyvars old-ng))
89 
+		 (setf overloaded-tyvars '()))
90 
+	 ;; The next step is to compute the signatures of the defined
91 
+	 ;; variables and to define all recursive placeholders.  When
92 
+	 ;; there is no context the placeholders become simple var refs.
93 
+	 ;; and the types are simply converted.
94 
+	   (cond ((null? overloaded-tyvars)
95 
+		  (dolist (var all-vars)
96 
+		    (let ((r (var-type var)))
97 
+		      (setf (var-type var) (recursive-type-type (var-type var)))
98 
+		      (dolist (p (recursive-type-placeholders r))
99 
+		        (setf (recursive-placeholder-exp p)
100 
+			      (**var/def var)))
101 
+		      (generalize-type var))))
102 
+	 ;; When the declaration has a context things get very hairy.
103 
+	 ;; First, grap the recursive placeholders before generalizing the
104 
+	 ;; types.
105 
+		 (else
106 
+		  ;; Mark the overloaded tyvars as read-only.  This prevents
107 
+		  ;; signature unification from changing the set of tyvars
108 
+		  ;; defined in the mapping.
109 
+		  (dolist (tyvar overloaded-tyvars)
110 
+		     (setf (ntyvar-read-only? tyvar) '#t))
111 
+		  (let ((r-placeholders '()))
112 
+		    (dolist (var all-vars)
113 
+		     (let ((rt (var-type var)))
114 
+		      (dolist (p (recursive-type-placeholders rt))
115 
+			(push p r-placeholders))
116 
+		      (setf (var-type var) (recursive-type-type rt))))
117 
+	 ;; Now compute a signature for each definition and do dictionary
118 
+	 ;; conversion.  The var-map defines the actual parameter associated
119 
+	 ;; with each of the overloaded tyvars.
120 
+		    (let ((var-map (map (lambda (decl)
121 
+					 (tuple (decl-var decl)
122 
+					  (generalize-overloaded-type
123 
+					   decl overloaded-tyvars)))
124 
+					decls)))
125 
+	 ;; Finally discharge each recursive placeholder.
126 
+		      (dolist (p r-placeholders)
127 
+			(let ((ref-to (recursive-placeholder-var p))
128 
+			      (decl-from
129 
+			       (search-enclosing-decls
130 
+				 (recursive-placeholder-enclosing-decls p)
131 
+				 decls)))
132 
+			  (setf (recursive-placeholder-exp p)
133 
+				(recursive-call-code decl-from ref-to var-map)))
134 
+			)))))
135 
+	   (setf (dynamic *placeholders*)
136 
+		 (process-placeholders
137 
+		  (dynamic *placeholders*) old-placeholders decls)))))))
138 
+
139 
+;;; Non-recursive decls are easier.  Save the placeholders, use a fresh type
140 
+;;; for the left hand side, check signatures, and generalize.
141 
+
142 
+(define (type-non-recursive decl)
143 
+ (remember-context decl
144 
+  (fresh-type lhs-type
145 
+    (let ((old-placeholders (dynamic *placeholders*))
146 
+	  (all-vars (map (lambda (x) (var-ref-var x))
147 
+			    (collect-pattern-vars (valdef-lhs decl)))))
148 
+     (setf (dynamic *placeholders*) '())
149 
+     (recover-type-error
150 
+      (lambda (r)
151 
+        (make-dummy-sigs (list decl))
152 
+	(setf (dynamic *placeholders*) old-placeholders)
153 
+        (funcall r))
154 
+      (type-decl-lhs decl lhs-type)
155 
+      (let ((rhs-type (type-decl-rhs decl)))
156 
+	(type-unify lhs-type rhs-type
157 
+           (type-mismatch decl
158 
+	       "Decl type mismatch" lhs-type rhs-type)))
159 
+      (check-user-signatures all-vars)
160 
+      (let ((all-tyvars (collect-tyvars lhs-type))
161 
+	    (overloaded-tyvars '()))
162 
+	(dolist (tyvar all-tyvars)
163 
+	  (when (ntyvar-context tyvar)
164 
+	     (push tyvar overloaded-tyvars)))
165 
+	(when (and overloaded-tyvars
166 
+		   (apply-pattern-binding-rule? (list decl)))
167 
+	 (setf (dynamic *non-generic-tyvars*)
168 
+	   (do-pattern-binding-rule
169 
+	    (list decl) overloaded-tyvars (dynamic *non-generic-tyvars*)))
170 
+	 (setf overloaded-tyvars '()))
171 
+	(if (null? overloaded-tyvars)
172 
+	    (dolist (var all-vars)
173 
+	      (generalize-type var))
174 
+	    (generalize-overloaded-type decl '()))
175 
+	(setf (dynamic *placeholders*)
176 
+	      (process-placeholders
177 
+	       (dynamic *placeholders*) old-placeholders (list decl)))))))))
178 
+
179 
+;;; These functions type check definition components.
180 
+
181 
+;;; This unifies the type of the lhs pattern with a type variable.
182 
+
183 
+(define (type-decl-lhs object type)
184 
+ (dynamic-let ((*enclosing-decls* (cons object (dynamic *enclosing-decls*))))
185 
+  (remember-context object
186 
+   (type-check valdef lhs pat-type
187 
+    (type-unify type pat-type #f)))))
188 
+
189 
+
190 
+;;; This types the right hand side.  The *enclosing-decls* variable is
191 
+;;; used to keep track of which decl the type checker is inside.  This
192 
+;;; is needed for both defaulting (to find which module defaults apply)
193 
+;;; and recursive types to keep track of the dictionary parameter variables
194 
+;;; for recursive references.
195 
+
196 
+(define (type-decl-rhs object)
197 
+ (dynamic-let ((*enclosing-decls* (cons object (dynamic *enclosing-decls*))))
198 
+  (remember-context object
199 
+   (type-check/unify-list valdef definitions res-type
200 
+       (type-mismatch/list object
201 
+	   "Right hand sides have different types")
202 
+       res-type))))
203 
+
204 
+
205 
+;;; This is similar to typing lambda.
206 
+
207 
+(define-type-checker single-fun-def
208 
+  (fresh-monomorphic-types (length (single-fun-def-args object)) tyvars
209 
+    (type-check/list single-fun-def args arg-types
210 
+      (unify-list tyvars arg-types)
211 
+      (type-check/decls single-fun-def where-decls
212 
+        (type-check/unify-list single-fun-def rhs-list rhs-type
213 
+           (type-mismatch/list object
214 
+			"Bodies have incompatible types")
215 
+	  (return-type object (**arrow/l-2 arg-types rhs-type)))))))
216 
+
217 
+
218 
+;;; These functions are part of the generalization process.
219 
+
220 
+;;; This function processes user signature declarations for the set of
221 
+;;; variables defined in a declaration.  Since unification of one signature
222 
+;;; may change the type associated with a previously verified signature,
223 
+;;; signature unification is done twice unless only one variable is
224 
+;;; involved.  The context of the signatures is returned to compare
225 
+;;; with the overall context of the declaration group.
226 
+
227 
+(define (check-user-signatures vars)
228 
+  (cond ((null? (cdr vars))
229 
+	 (let* ((var (car vars))
230 
+		(sig (var-signature var)))
231 
+	   (if (eq? sig '#f)
232 
+	       '()
233 
+	       (list (tuple var (check-var-signature var sig))))))
234 
+	(else
235 
+	 (let ((sigs '()))
236 
+	   (dolist (var vars)
237 
+	     (let ((sig (var-signature var)))
238 
+	       (unless (eq? sig '#f)
239 
+		 (check-var-signature var sig))))
240 
+	   (dolist (var vars)
241 
+	     (let ((sig (var-signature var)))
242 
+	       (unless (eq? sig '#f)
243 
+		 (push (tuple var (check-var-signature var sig)) sigs))))
244 
+	   sigs))))
245 
+
246 
+
247 
+(define (check-var-signature var sig)
248 
+  (mlet (((sig-type sig-vars) (instantiate-gtype/newvars sig)))
249 
+    (dolist (tyvar sig-vars)
250 
+      (setf (ntyvar-read-only? tyvar) '#t))
251 
+    (type-unify (remove-recursive-type (var-type var)) sig-type
252 
+	     (signature-mismatch var))
253 
+    (dolist (tyvar sig-vars)
254 
+      (setf (ntyvar-read-only? tyvar) '#f))
255 
+    sig-vars))
256 
+
257 
+;;; Once the declaration context is computed, it must be compared to the
258 
+;;; contexts given by the user.  All we need to check is that all tyvars
259 
+;;; constrained in the user signatures are also in the decl-context.
260 
+;;; All user supplied contexts are correct at this point - we just need
261 
+;;; to see if some ambiguous portion of the context exists.
262 
+
263 
+;;; This error message needs work.  We need to present the contexts.
264 
+
265 
+(define (reconcile-sig-contexts overloaded-tyvars sig-contexts)
266 
+  (dolist (sig sig-contexts)
267 
+    (let ((sig-vars (tuple-2-2 sig)))
268 
+      (dolist (d overloaded-tyvars)
269 
+	(when (not (memq d sig-vars))
270 
+	  (type-error
271 
+"Declaration signature has insufficiant context in declaration~%~A~%"
272 
+            (tuple-2-1 sig)))))))
273 
+
274 
+;;; This is used for noisy type inference
275 
+
276 
+(define (report-typing var)
277 
+ (when (memq 'type (dynamic *printers*))
278 
+  (let* ((name (symbol->string (def-name var))))
279 
+    (when (not (or (string-starts? "sel-" name)
280 
+		   (string-starts? "i-" name)
281 
+		   (string-starts? "default-" name)
282 
+		   (string-starts? "dict-" name)))
283 
+      (format '#t "~A :: ~A~%" var (var-type var))))))
284 
+
285 
+;;; This is used during error recovery.  When a type error occurs, all
286 
+;;; variables defined in the enclosing declaration are set to type `a'
287 
+;;; and typing is resumed.
288 
+
289 
+(define (make-dummy-sigs decls)
290 
+  (let ((dummy-type (make gtype (context '(()))
291 
+			        (type (**gtyvar 0)))))
292 
+    (dolist (d decls)
293 
+      (dolist (var-ref (collect-pattern-vars (valdef-lhs d)))
294 
+        (let ((var (var-ref-var var-ref)))
295 
+	  (setf (var-type var) dummy-type))))))
296 
+
297 
+
298 
+;;; This is used to generalize the variable signatures.  If there is
299 
+;;; an attached signature, the signature is used.  Otherwise the ntype
300 
+;;; is converted to a gtype.
301 
+
302 
+(define (generalize-type var)
303 
+  (if (eq? (var-signature var) '#f)
304 
+      (setf (var-type var) (ntype->gtype (var-type var)))
305 
+      (setf (var-type var) (var-signature var)))
306 
+  (report-typing var))
307 
+
308 
+;;; For overloaded types, it is necessary to map the declaration context
309 
+;;; onto the generalized type.  User signatures may provide different but
310 
+;;; equivilant contexts for different declarations in a decl goup.
311 
+
312 
+;;; The overloaded-vars argument allows ambiguous contexts.  This is not
313 
+;;; needed for non-recursive vars since the context cannot be ambiguous.
314 
+
315 
+(define (generalize-overloaded-type decl overloaded-vars)
316 
+  (let* ((var (decl-var decl))
317 
+	 (sig (var-signature var))
318 
+	 (new-tyvars '()))
319 
+    (cond ((eq? sig '#f)
320 
+	   (mlet (((gtype tyvars)
321 
+		   (ntype->gtype/env (var-type var) overloaded-vars)))
322 
+	      (setf (var-type var) gtype)
323 
+	      (setf new-tyvars tyvars)))
324 
+	  (else
325 
+	   (mlet (((ntype tyvars) (instantiate-gtype/newvars sig)))
326 
+	     (unify ntype (var-type var))
327 
+	     (setf (var-type var) sig)
328 
+	     (setf new-tyvars (prune/l tyvars)))))
329 
+    (report-typing var)
330 
+    (dictionary-conversion/definition decl new-tyvars)
331 
+    new-tyvars))
332 
+
333 
+(define (remove-recursive-type ty)
334 
+  (if (recursive-type? ty)
335 
+      (recursive-type-type ty)
336 
+      ty))
337 
+
type/type-error-handlers.scm
History View file @ 4e98702
0 338 
new file mode 100644
... ... 
@@ -0,0 +1,40 @@
1 
+;;; This file contains error handlers for the type checker.
2 
+
3 
+(define (type-error msg . args)
4 
+  (apply (function phase-error) `(type-error ,msg ,@args))
5 
+  (report-non-local-type-error)
6 
+  (continue-from-type-error))
7 
+
8 
+(define (report-non-local-type-error)
9 
+  (when (pair? (dynamic *type-error-handlers*))
10 
+     (funcall (car (dynamic *type-error-handlers*)))))
11 
+
12 
+(define (continue-from-type-error)
13 
+  (funcall (car (dynamic *type-error-recovery*))))
14 
+
15 
+(define (type-mismatch/fixed object msg type)
16 
+  (format '#t "While typing ~A:~%~A~%Type: ~A~%" object msg type))
17 
+
18 
+(define (type-mismatch object msg type1 type2)
19 
+  (format '#t "While type checking~%~A~%~A~%Types: ~A~%       ~A~%"
20 
+	  object msg type1 type2))
21 
+
22 
+(define (type-mismatch/list types object msg)
23 
+  (format '#t "While typing ~A:~%~A~%Types: ~%" object msg)
24 
+  (dolist (type types)
25 
+     (format '#t "~A~%" type)))
26 
+
27 
+;;; Error handlers
28 
+
29 
+(define (signature-mismatch var)
30 
+  (format '#t
31 
+      "Signature mismatch for ~A~%Inferred type: ~A~%Declared type: ~A~%"
32 
+      var
33 
+      (remove-type-wrapper (ntype->gtype (var-type var)))
34 
+      (var-signature var)))
35 
+
36 
+(define (remove-type-wrapper ty)
37 
+  (if (recursive-type? ty) (recursive-type-type ty) ty))
38 
+
39 
+
40 
+
0 41 
\ No newline at end of file
type/type-macros.scm
History View file @ 4e98702
1 42 
new file mode 100644
... ... 
@@ -0,0 +1,159 @@
1 
+
2 
+;;; This file also contains some random globals for the type checker:
3 
+
4 
+(define-walker type ast-td-type-walker)
5 
+
6 
+;;; Some pre-defined types
7 
+(define *bool-type* '())
8 
+(define *char-type* '())
9 
+(define *string-type* '())
10 
+(define *int-type* '())
11 
+(define *integer-type* '())
12 
+(define *rational-type* '())
13 
+
14 
+;;; These two globals are used throughout the typechecker to avoid
15 
+;;; passing lots of stuff in each function call.
16 
+
17 
+(define *placeholders* '())
18 
+(define *non-generic-tyvars* '())
19 
+(define *enclosing-decls* '())
20 
+
21 
+;;; Used by the defaulting mechanism
22 
+
23 
+(define *default-decls* '())
24 
+
25 
+;;; Used in error handling & recovery
26 
+
27 
+(define *type-error-handlers* '())
28 
+(define *type-error-recovery* '())
29 
+
30 
+
31 
+;;; This associates a type checker function with an ast type.  The variable
32 
+;;; `object' is bound to the value being types.
33 
+
34 
+(define-syntax (define-type-checker ast-type . cont)
35 
+  `(define-walker-method type ,ast-type (object)
36 
+     ,@cont))
37 
+
38 
+;;; This recursively type checks a structure slot in the current object.
39 
+;;; This updates the ast in the slot (since type checking rewrites the ast)
40 
+;;; and binds the computed type to a variable.  The slot must contain an
41 
+;;; expression.
42 
+
43 
+(define-syntax (type-check struct slot var . cont)
44 
+  `(mlet ((($$$ast$$$ ,var)
45 
+	   (dispatch-type-check (struct-slot ',struct ',slot object))))
46 
+	 (setf (struct-slot ',struct ',slot object) $$$ast$$$)
47 
+	 ,@cont))
48 
+
49 
+;;; This is used to scope decls.
50 
+
51 
+(define-syntax (with-new-tyvars . cont)
52 
+  `(dynamic-let ((*non-generic-tyvars* (dynamic *non-generic-tyvars*)))
53 
+     ,@cont))
54 
+
55 
+
56 
+;;; Similar to type-check, the slot must contain a list of decls.
57 
+;;; This must be done before any reference to a variable defined in the
58 
+;;; decls is typechecked.
59 
+
60 
+(define-syntax (type-check/decls struct slot . cont)
61 
+  `(with-new-tyvars
62 
+    (let (($$$decls$$$
63 
+	  (type-decls (struct-slot ',struct ',slot object))))
64 
+     (setf (struct-slot ',struct ',slot object) $$$decls$$$)
65 
+     ,@cont)))
66 
+
67 
+;;; The type checker returns an expression / type pair.  This
68 
+;;; abstracts the returned value.
69 
+
70 
+(define-syntax (return-type object type)
71 
+  `(values ,object ,type))
72 
+
73 
+;;; When an ast slot contains a list of expressions, there are two
74 
+;;; possibilities: the expressions all share the same type or each has
75 
+;;; an independant type.  In the first case, a single type (computed
76 
+;;; by unifying all types in the list) is bound to a variable.
77 
+
78 
+(define-syntax (type-check/unify-list struct slot var error-handler . cont)
79 
+  `(mlet ((($$$ast$$$ $$$types$$$)
80 
+	   (do-type-check/list (struct-slot ',struct ',slot object))))
81 
+    (setf (struct-slot ',struct ',slot object) $$$ast$$$)
82 
+    (with-type-error-handler ,error-handler ($$$types$$$)
83 
+       (unify-list/single-type $$$types$$$)
84 
+       (let ((,var (car $$$types$$$)))
85 
+	 ,@cont))))
86 
+
87 
+;;; When a list of expressions does not share a common type, the result is
88 
+;;; a list of types.
89 
+
90 
+(define-syntax (type-check/list struct slot var . cont)
91 
+  `(mlet ((($$$ast$$$ ,var)
92 
+	   (do-type-check/list (struct-slot ',struct ',slot object))))
93 
+    (setf (struct-slot ',struct ',slot object) $$$ast$$$)
94 
+    ,@cont))
95 
+
96 
+;;; This creates a fresh tyvar and binds it to a variable.
97 
+
98 
+(define-syntax (fresh-type var . cont)
99 
+  `(let ((,var (**ntyvar)))
100 
+     ,@cont))
101 
+
102 
+;;; This drives the unification routine.  Two types are unified and the
103 
+;;; context is updated.  Currently no error handling is implemented to
104 
+;;; deal with unification errors.
105 
+
106 
+(define-syntax (type-unify type1 type2 error-handler)
107 
+  `(with-type-error-handler ,error-handler ()
108 
+     (unify ,type1 ,type2)))
109 
+
110 
+;;; This generates a fresh set of monomorphic type variables.
111 
+
112 
+(define-syntax (fresh-monomorphic-types n vars . cont)
113 
+  `(with-new-tyvars
114 
+     (let ((,vars '()))
115 
+       (dotimes (i ,n)
116 
+	   (let ((tv (**ntyvar)))
117 
+	     (push tv ,vars)
118 
+	     (push tv (dynamic *non-generic-tyvars*))))
119 
+       ,@cont)))
120 
+
121 
+;;; This creates a single monomorphic type variable.
122 
+
123 
+(define-syntax (fresh-monomorphic-type var . cont)
124 
+  `(let* ((,var (**ntyvar)))
125 
+     (with-new-tyvars
126 
+       (push ,var (dynamic *non-generic-tyvars*))
127 
+       ,@cont)))
128 
+
129 
+;;; This is used to rewrite the current ast as a new ast and then
130 
+;;; recursively type check the new ast.  The original ast is saved for
131 
+;;; error message printouts.
132 
+
133 
+(define-syntax (type-rewrite ast)
134 
+  `(mlet (((res-ast type) (dispatch-type-check ,ast))
135 
+	  (res (**save-old-exp object res-ast)))
136 
+      (return-type res type)))
137 
+
138 
+;;; These are the type error handlers
139 
+
140 
+(define-syntax (recover-type-error error-handler . body)
141 
+ (let ((temp (gensym))
142 
+       (err-fn (gensym)))
143 
+  `(let/cc ,temp
144 
+    (let ((,err-fn ,error-handler))
145 
+     (dynamic-let ((*type-error-recovery*
146 
+		    (cons (lambda ()
147 
+			    (funcall ,err-fn ,temp))
148 
+			  (dynamic *type-error-recovery*))))
149 
+        ,@body)))))
150 
+
151 
+(define-syntax (with-type-error-handler handler extra-args . body)
152 
+  (if (eq? handler '#f)
153 
+      `(begin ,@body)
154 
+      `(dynamic-let ((*type-error-handlers*
155 
+		      (cons (lambda ()
156 
+			     (,(car handler) ,@extra-args ,@(cdr handler)))
157 
+			    (dynamic *type-error-handlers*))))
158 
+	    ,@body)))
159 
+
type/type-main.scm
History View file @ 4e98702
0 160 
new file mode 100644
... ... 
@@ -0,0 +1,56 @@
1 
+
2 
+;;; This is the main entry point to the type checker.
3 
+
4 
+
5 
+(define (do-haskell-type-check object modules)
6 
+  (type-init modules)
7 
+  (when (is-type? 'let object) ; may be void
8 
+    (dynamic-let ((*non-generic-tyvars* '())
9 
+		  (*placeholders* '())
10 
+		  (*enclosing-decls* '()))
11 
+      (type-check/decls let decls
12 
+	 (setf (dynamic *non-generic-tyvars*) '())
13 
+         (process-placeholders (dynamic *placeholders*) '() '()))))
14 
+  'done)
15 
+
16 
+;;; This is the main recursive entry to the type checker.
17 
+
18 
+(define (dispatch-type-check exp)
19 
+ (remember-context exp
20 
+  (call-walker type exp)))
21 
+
22 
+(define (do-type-check/list exps)
23 
+  (if (null? exps)
24 
+      (values '() '())
25 
+      (mlet (((obj1 type1) (dispatch-type-check (car exps)))
26 
+	     ((objs types) (do-type-check/list (cdr exps))))
27 
+	(values (cons obj1 objs) (cons type1 types)))))
28 
+
29 
+(define (type-init modules)
30 
+  ;; Built in types
31 
+  (setf *char-type* (**ntycon (core-symbol "Char") '()))
32 
+  (setf *string-type* (**ntycon (core-symbol "List")
33 
+				(list *char-type*)))
34 
+  (setf *bool-type* (**ntycon (core-symbol "Bool") '()))
35 
+  (setf *int-type* (**ntycon (core-symbol "Int") '()))
36 
+  (setf *integer-type* (**ntycon (core-symbol "Integer") '()))
37 
+  (setf *rational-type* (**ntycon (core-symbol "Ratio")
38 
+				  (list *integer-type*)))
39 
+  (setf *default-decls* '())
40 
+  (dolist (m modules)
41 
+    (let ((default-types '()))
42 
+      (dolist (d (default-decl-types (module-default m)))
43 
+        (let* ((ty (ast->gtype '() d))
44 
+	       (ntype (gtype-type ty)))
45 
+	  (cond ((not (null? (gtype-context ty)))
46 
+		 (recoverable-error 'not-monotype
47 
+		   "~A is not a monotype in default decl" ty))
48 
+		((not (type-in-class? ntype (core-symbol "Num")))
49 
+		 (recoverable-error 'not-Num-class
50 
+		   "~A is not in class Num" ty))
51 
+		(else
52 
+		 (push ntype default-types)))))
53 
+      (push (tuple (module-name m) (reverse default-types)) *default-decls*))))
54 
+
55 
+(define (remember-placeholder placeholder)
56 
+  (push placeholder (dynamic *placeholders*)))
type/type-vars.scm
History View file @ 4e98702
0 57 
new file mode 100644
... ... 
@@ -0,0 +1,60 @@
1 
+;;; This type checks a variable.  Possible cases:
2 
+;;;  a) recursive variables
3 
+;;;  b) method variables
4 
+;;;  c) generalized variables
5 
+;;;  d) other variables
6 
+
7 
+(define-type-checker var-ref
8 
+ (let* ((var (var-ref-var object))
9 
+	(type (var-type var)))
10 
+   (cond ((method-var? var)
11 
+;;; The context of a method variable always has the carrier class
12 
+;;; first.
13 
+	  (mlet (((ntype new-tyvars) (instantiate-gtype/newvars type))
14 
+		 (carrier-tyvar (car new-tyvars))
15 
+		 (extra-context (cdr new-tyvars))
16 
+		 (p (**method-placeholder
17 
+		     var carrier-tyvar (dynamic *enclosing-decls*) object))
18 
+		 (new-object (insert-dict-placeholders p extra-context object)))
19 
+	    (remember-placeholder p)
20 
+	    (return-type (**save-old-exp object new-object) ntype)))
21 
+	 ((recursive-type? type)
22 
+	  (let ((placeholder (**recursive-placeholder
23 
+			      var (dynamic *enclosing-decls*))))
24 
+	    (push placeholder (recursive-type-placeholders type))
25 
+	    (return-type placeholder (recursive-type-type type))))
26 
+	 ((gtype? type)
27 
+	  (mlet (((ntype new-vars) (instantiate-gtype/newvars type))
28 
+		 (object1 (insert-dict-placeholders object new-vars object)))
29 
+            (return-type (if (eq? object1 object)
30 
+			     object
31 
+			     (**save-old-exp object object1))
32 
+			 ntype)))
33 
+	 (else
34 
+	  (return-type object type)))))
35 
+
36 
+;;; This takes an expression and a context and returns an updated
37 
+;;; expression containing placeholders for the context information
38 
+;;; implied by the context.  Tyvars in the context are added to dict-vars.
39 
+
40 
+(define (insert-dict-placeholders object tyvars var)
41 
+  (cond ((null? tyvars)
42 
+	 object)
43 
+	((null? (ntyvar-context (car tyvars)))
44 
+	 (insert-dict-placeholders object (cdr tyvars) var))
45 
+	(else
46 
+	 (let ((tyvar (car tyvars)))
47 
+	   (insert-dict-placeholders
48 
+	    (insert-dict-placeholders/tyvar
49 
+	     tyvar (ntyvar-context tyvar) object var)
50 
+	    (cdr tyvars)
51 
+	    var)))))
52 
+
53 
+(define (insert-dict-placeholders/tyvar tyvar classes object var)
54 
+  (if (null? classes)
55 
+      object
56 
+      (let ((p (**dict-placeholder
57 
+		 (car classes) tyvar (dynamic *enclosing-decls*) var)))
58 
+	(remember-placeholder p)
59 
+	(insert-dict-placeholders/tyvar tyvar (cdr classes)
60 
+					(**app object p) var))))
type/type.scm
History View file @ 4e98702
0 61 
new file mode 100644
... ... 
@@ -0,0 +1,32 @@
1 
+(define-compilation-unit type
2 
+  (source-filename "$Y2/type/")
3 
+  (require ast haskell-utils)
4 
+  (unit type-macros
5 
+        (source-filename "type-macros.scm"))
6 
+  (unit unify
7 
+	(require type-macros)
8 
+	(source-filename "unify.scm"))
9 
+  (unit type-main
10 
+	(require type-macros)
11 
+	(source-filename "type-main.scm"))
12 
+  (unit type-decl
13 
+	(require type-macros)
14 
+	(source-filename "type-decl.scm"))
15 
+  (unit dictionary
16 
+	(require type-macros)
17 
+	(source-filename "dictionary.scm"))
18 
+  (unit default
19 
+	(require type-macros)
20 
+	(source-filename "default.scm"))
21 
+  (unit pattern-binding
22 
+	(require type-macros)
23 
+	(source-filename "pattern-binding.scm"))
24 
+  (unit type-vars
25 
+	(require type-macros)
26 
+	(source-filename "type-vars.scm"))
27 
+  (unit expression-typechecking
28 
+	(require type-macros)
29 
+	(source-filename "expression-typechecking.scm"))
30 
+  (unit type-error-handlers
31 
+	(require type-macros)
32 
+	(source-filename "type-error-handlers.scm")))
type/unify.scm
History View file @ 4e98702
0 33 
new file mode 100644
... ... 
@@ -0,0 +1,154 @@
1 
+
2 
+;;; File: type/unify.scm   Author: John
3 
+
4 
+;;; This is the basic unification algorithm used in type checking.
5 
+
6 
+;;; Unification failure invokes the current type error handler
7 
+
8 
+;;; Start by removing instantiated type variables from the type.
9 
+
10 
+(define (unify type1 type2)
11 
+  (unify-1 (prune type1) (prune type2)))
12 
+
13 
+;;; The only real tweak here is the read-only bit on type variables.
14 
+;;; The rule is that a RO tyvar can be unified only with a generic
15 
+;;; non-RO tyvar which has the same or more general context.
16 
+
17 
+;;; Aside from this, this is standard unification except that context
18 
+;;; propagation is needed when a tyvar with a non-empty context is
19 
+;;; instantiated.
20 
+
21 
+;;; If type2 is a tyvar and type1 is not they are switched.
22 
+
23 
+(define (unify-1 type1 type2)
24 
+    (cond ((eq? type1 type2)  ;; this catches variable to variable unify
25 
+	   'OK)
26 
+	  ((ntyvar? type1)
27 
+	   (cond ((occurs-in-type type1 type2)
28 
+		  (type-error "Circular type: cannot unify ~A with ~A"
29 
+			      type1 type2))
30 
+		 ((ntyvar-read-only? type1)
31 
+		  (cond ((or (not (ntyvar? type2)) (ntyvar-read-only? type2))
32 
+			 (type-error
33 
+			  "Signature too general: cannot unify ~A with ~A"
34 
+			  type1 type2))
35 
+			(else
36 
+			 (unify-1 type2 type1))))
37 
+		 ((and (ntyvar? type2)
38 
+		       (ntyvar-read-only? type2)
39 
+		       (non-generic? type1))
40 
+		  (type-error
41 
+ "Type signature cannot be used: monomorphic type variables present."))
42 
+		 (else
43 
+		  (instantiate-tyvar type1 type2)
44 
+		  (let ((classes (ntyvar-context type1)))
45 
+		    (if (null? classes)
46 
+			'OK
47 
+			(propagate-contexts/ntype type1 type2 classes))))))
48 
+	  ((ntyvar? type2)
49 
+	   (unify-1 type2 type1))
50 
+	  ((eq? (ntycon-tycon type1) (ntycon-tycon type2))
51 
+	   (unify-list (ntycon-args type1) (ntycon-args type2)))
52 
+	  (else
53 
+	   (let ((etype1 (expand-ntype-synonym type1))
54 
+		 (etype2 (expand-ntype-synonym type2)))
55 
+	    (if (same-tycon? (ntycon-tycon etype1) (ntycon-tycon etype2))
56 
+		(unify-list (ntycon-args etype1) (ntycon-args etype2))
57 
+		;; This error message should probably show both the original
58 
+		;; and the expanded types for clarity.
59 
+		(type-error
60 
+		      "Type conflict: type ~A does not match ~A"
61 
+			    etype1 etype2))))))
62 
+
63 
+
64 
+(define-integrable (instantiate-tyvar tyvar val)
65 
+  (setf (ntyvar-value tyvar) val))
66 
+
67 
+;;; This is needed since interface files may leave multiple def's
68 
+;;; for the same tycon sitting around.
69 
+
70 
+(define (same-tycon? ty1 ty2)
71 
+  (or (eq? ty1 ty2)
72 
+      (and (eq? (def-name ty1) (def-name ty2))
73 
+	   (eq? (def-module ty1) (def-module ty2)))))
74 
+
75 
+
76 
+;;; unifies two lists of types pairwise.  Used for tycon args.
77 
+
78 
+(define (unify-list args1 args2)
79 
+  (if (null? args1)
80 
+      'OK
81 
+      (begin (unify-list (cdr args1) (cdr args2))
82 
+	     (unify (car args1) (car args2)))))
83 
+
84 
+;;; combines a list of types into a single type.  Used in constructs
85 
+;;; such as [x,y,z] and case expressions.
86 
+
87 
+(define (unify-list/single-type types)
88 
+  (when (not (null? types))
89 
+    (let ((type (car types)))
90 
+      (dolist (type2 (cdr types))
91 
+        (unify type type2)))))
92 
+
93 
+;;; This propagates the context from a just instantiated tyvar to the
94 
+;;; instantiated value.  If the value is a tycon, instances must be
95 
+;;; looked up.  If the value is a tyvar, the context is added to that of
96 
+;;; other tyvar.
97 
+
98 
+;;; This is used to back out of the unification on errors.  This is a
99 
+;;; poor mans trail stack!  Without this, error messages get very
100 
+;;; obscure.
101 
+
102 
+(define *instantiated-tyvar* '())
103 
+
104 
+(define (propagate-contexts/ntype tyvar type classes)
105 
+ (dynamic-let ((*instantiated-tyvar* tyvar))
106 
+    (propagate-contexts/inner type classes)))
107 
+
108 
+(define (propagate-contexts/inner type classes)
109 
+ (let ((type (prune type)))
110 
+  (if (ntyvar? type)
111 
+      (if (ntyvar-read-only? type)
112 
+	  (if (context-implies? (ntyvar-context type) classes)
113 
+	      'OK ; no need for context propagation here
114 
+	      (begin
115 
+		(setf (ntyvar-value (dynamic *instantiated-tyvar*)) '#f)
116 
+		(type-error "Signature context is too general")))
117 
+	  (if (null? (ntyvar-context type))
118 
+	      (setf (ntyvar-context type) classes)
119 
+	      (setf (ntyvar-context type)
120 
+		    (merge-contexts classes (ntyvar-context type)))))
121 
+      (propagate-contexts-1 (expand-ntype-synonym type) classes))))
122 
+
123 
+;;; The type has now been expanded.  This propagates each class constraint
124 
+;;; in turn.
125 
+
126 
+(define (propagate-contexts-1 type classes)
127 
+  (dolist (class classes)
128 
+     (propagate-single-class type class)))
129 
+
130 
+;;; Now we have a single class & data type.  Either an instance decl can
131 
+;;; be found or a type error should be signalled.  Once the instance
132 
+;;; decl is found, contexts are propagated to the component types.
133 
+
134 
+(define (propagate-single-class type class)
135 
+  (let ((instance (lookup-instance (ntycon-tycon type) class)))
136 
+    (cond ((eq? instance '#f)
137 
+	   ;; This remove the instantiation which caused the type
138 
+	   ;; error - perhaps stop error propagation & make
139 
+	   ;; error message better.
140 
+	   (setf (ntyvar-value (dynamic *instantiated-tyvar*)) '#f)
141 
+	   (type-error "Type ~A is not in class ~A" type class))
142 
+	  (else
143 
+	   ;; The instance contains a list of class constraints for
144 
+	   ;; each argument.  This loop pairs the argument to the
145 
+	   ;; type constructor with the context required by the instance
146 
+	   ;; decl.
147 
+	   (dolist2 (classes (instance-gcontext instance))
148 
+		    (arg (ntycon-args type))
149 
+	     (propagate-contexts/inner arg classes)))))
150 
+  'OK)
151 
+
152 
+;;; The routines which handle contexts (merge-contexts and context-implies?)
153 
+;;; are in type-utils.  The occurs check is also there.
154 
+
util/README
History View file @ 4e98702
0 155 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+This directory contains random utilities that are used in various places
2 
+around the compiler.
util/annotation-utils.scm
History View file @ 4e98702
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,41 @@
1 
+
2 
+;;; Some general utilities for dealing with annotations
3 
+
4 
+;;; Lookup an annotation on a var
5 
+
6 
+(define (lookup-annotation var aname)
7 
+  (lookup-annotation-1 (var-annotations var) aname))
8 
+
9 
+(define (lookup-annotation-1 a aname)
10 
+  (if (null? a)
11 
+      '#f
12 
+      (if (eq? aname (annotation-value-name (car a)))
13 
+	  (car a)
14 
+	  (lookup-annotation-1 (cdr a) aname))))
15 
+
16 
+;;; This parses a string denoting a strictness property into a list
17 
+;;; of booleans.   "S,N,S" -> (#t #f #t)
18 
+
19 
+(define (parse-strictness str)
20 
+  (parse-strictness-1 str 0))
21 
+
22 
+(define (parse-strictness-1 str i)
23 
+  (if (>= i (string-length str))
24 
+      (signal-bad-strictness-annotation str)
25 
+      (let* ((ch (char-downcase (string-ref str i)))
26 
+	     (s (cond ((char=? ch '#\s)
27 
+		       '#t)
28 
+		      ((char=? ch '#\n)
29 
+		       '#f)
30 
+		      (else
31 
+		       (signal-bad-strictness-annotation str)))))
32 
+	(cond ((eqv? (1+ i) (string-length str))
33 
+	       (list s))
34 
+	      ((char=? (string-ref str (1+ i)) '#\,)
35 
+	       (cons s (parse-strictness-1 str (+ i 2))))
36 
+	      (else
37 
+	       (signal-bad-strictness-annotation str))))))
38 
+
39 
+(define (signal-bad-strictness-annotation str)
40 
+  (fatal-error 'bad-strictness "Bad strictness annotation: ~A~%" str))
41 
+
util/constructors.scm
History View file @ 4e98702
0 42 
new file mode 100644
... ... 
@@ -0,0 +1,339 @@
1 
+;;; This file contains ast construction functions.  These
2 
+;;; functions are supplied for commonly used ast structures to
3 
+;;; avoid the longer `make' normally required.
4 
+
5 
+;;; Function names are the type names with a `**' prefix.  For reference
6 
+;;; nodes, the /def for builds the node from a definition instead of a name.
7 
+
8 
+;;; Note: maybe these should be made automagicly someday.
9 
+
10 
+;;; from exp-structs:
11 
+
12 
+(define (**lambda args body)
13 
+  (**lambda/pat (map (function **pat) args) body))
14 
+
15 
+(define (**lambda/pat pats body)
16 
+  (if (null? pats)
17 
+      body
18 
+      (make lambda (pats pats) (body body))))
19 
+
20 
+
21 
+
22 
+;;; Make a case expression.
23 
+
24 
+(define (**case exp alts)
25 
+  (make case (exp exp) (alts alts)))
26 
+
27 
+(define (**alt/simple pat exp)
28 
+  (**alt pat
29 
+	 (list (make guarded-rhs
30 
+		     (guard (make omitted-guard))
31 
+		     (rhs exp)))
32 
+	 '()))
33 
+
34 
+(define (**alt pat rhs-list where-decls)
35 
+  (make alt (pat pat) (rhs-list rhs-list) (where-decls where-decls)))
36 
+
37 
+
38 
+
39 
+
40 
+(define (**let decls body)
41 
+  (if decls
42 
+      (make let (decls decls) (body body))
43 
+      body))
44 
+
45 
+(define (**if test then-exp else-exp)
46 
+  (make if (test-exp test) (then-exp then-exp) (else-exp else-exp)))
47 
+
48 
+(define (**app fn . args)  ; any number of args
49 
+  (**app/l fn args))
50 
+
51 
+(define (**app/l fn args)  ; second args is a list
52 
+  (if (null? args)
53 
+      fn
54 
+      (**app/l (make app (fn fn) (arg (car args)))
55 
+	       (cdr args))))
56 
+
57 
+(define (**var name)
58 
+  (make var-ref (name name) (var (dynamic *undefined-def*)) (infix? '#f)))
59 
+
60 
+(define (**var/def def)  ; arg is an entry
61 
+  (make var-ref (var def) (name (def-name def)) (infix? '#f)))
62 
+
63 
+(define (**con/def def)
64 
+  (make con-ref (name (def-name def)) (con def) (infix? '#f)))
65 
+
66 
+(define (**int x)
67 
+  (make integer-const (value x)))
68 
+
69 
+(define (**char x)
70 
+  (make char-const (value x)))
71 
+
72 
+(define (**string x)
73 
+  (make string-const (value x)))
74 
+
75 
+(define (**listcomp exp quals)
76 
+  (make list-comp (exp exp) (quals quals)))
77 
+
78 
+(define (**gen pat exp)
79 
+  (make qual-generator (pat (**pat pat)) (exp exp)))
80 
+
81 
+(define (**omitted-guard)
82 
+  (make omitted-guard))
83 
+
84 
+(define (**con-number exp algdata)
85 
+  (make con-number (type algdata) (value exp)))
86 
+
87 
+(define (**sel con exp i)
88 
+  (make sel (constructor con) (value exp) (slot i)))
89 
+
90 
+(define (**is-constructor exp con)
91 
+  (make is-constructor (value exp) (constructor con)))
92 
+
93 
+;;; From valdef-structs
94 
+
95 
+(define (**signdecl vars type)
96 
+  (make signdecl (vars (map (function **var) vars)) (signature type)))
97 
+
98 
+(define (**signdecl/def vars type)
99 
+  (make signdecl (vars (map (function **var/def) vars)) (signature type)))
100 
+
101 
+(define (**define name args val)
102 
+  (**valdef (**pat name) (map (function **pat) args) val))
103 
+
104 
+(define (**valdef/def var exp)
105 
+  (**valdef/pat (**var-pat/def var) exp))
106 
+
107 
+(define (**valdef/pat pat exp)
108 
+  (**valdef pat '() exp))
109 
+
110 
+(define (**valdef lhs args rhs)
111 
+  (make valdef
112 
+	(lhs lhs)
113 
+	(definitions
114 
+	  (list (make single-fun-def
115 
+		      (args args)
116 
+		      (rhs-list
117 
+		        (list (make guarded-rhs
118 
+				    (guard (**omitted-guard))
119 
+				    (rhs rhs))))
120 
+		      (where-decls '())
121 
+		      (infix? '#f))))))
122 
+
123 
+
124 
+;;; Patterns (still in valdef-structs)
125 
+
126 
+;;; The **pat function converts a very simple lisp-style pattern representation
127 
+;;; into corresponding ast structure.  The conversion:
128 
+;;;   a) _ => wildcard
129 
+;;;   b) a symbol => Var pattern
130 
+;;;   c) an integer / string => const pattern
131 
+;;;   d) a list of pats starting with 'tuple => Pcon
132 
+;;;   e) a list of pats starting with a con definition => Pcon
133 
+
134 
+(define (**pat v)
135 
+  (cond ((eq? v '_) (**wildcard-pat))
136 
+	((symbol? v)
137 
+	 (make var-pat (var (**var v))))
138 
+	((var? v)
139 
+	 (make var-pat (var (**var/def v))))
140 
+	((integer? v)
141 
+	 (make const-pat (value (**int v))))
142 
+	((string? v)
143 
+	 (make const-pat (value (**string v))))
144 
+	((and (pair? v) (eq? (car v) 'tuple))
145 
+	 (**pcon/tuple (map (function **pat) (cdr v))))
146 
+	((and (pair? v) (con? (car v)))
147 
+	 (**pcon/def (car v) (map (function **pat) (cdr v))))
148 
+	(else
149 
+	 (error "Bad pattern in **pat: ~A~%" v))))
150 
+
151 
+(define (**pcon name pats)
152 
+  (make pcon (name (add-con-prefix/symbol name))
153 
+	     (con (dynamic *undefined-def*)) (pats pats) (infix? '#f)))
154 
+
155 
+(define (**pcon/def def pats)
156 
+  (make pcon (name (def-name def)) (con def) (pats pats) (infix? '#f)))
157 
+
158 
+(define (**pcon/tuple pats)
159 
+  (**pcon/def (tuple-constructor (length pats)) pats))
160 
+
161 
+;;; Make a variable pattern from the var
162 
+
163 
+(define (**var-pat/def var)
164 
+  (make var-pat
165 
+	(var (**var/def var))))
166 
+
167 
+(define (**wildcard-pat)
168 
+  (make wildcard-pat))
169 
+
170 
+
171 
+;;; Either make a tuple, or return the single element of a list.
172 
+
173 
+(define (**tuple-pat pats)
174 
+  (cond ((null? pats)
175 
+	 (**pcon/def (core-symbol "UnitConstructor") '()))
176 
+	((null? (cdr pats))
177 
+	 (car pats))
178 
+	(else
179 
+	 (**pcon/tuple pats))))
180 
+
181 
+
182 
+;;; From type-structs.scm
183 
+
184 
+(define (**tycon name args)
185 
+  (make tycon (name name) (args args) (def (dynamic *undefined-def*))))
186 
+
187 
+(define (**tycon/def def args)
188 
+  (make tycon (name (def-name def)) (def def) (args args)))
189 
+
190 
+(define (**tyvar name)
191 
+  (make tyvar (name name)))
192 
+
193 
+(define (**signature context type)
194 
+  (make signature (context context) (type type)))
195 
+
196 
+(define (**class/def def)
197 
+  (make class-ref (name (def-name def)) (class def)))
198 
+
199 
+(define (**context tycls tyvar)
200 
+  (make context (class tycls) (tyvar tyvar)))
201 
+
202 
+;;; From tc-structs
203 
+
204 
+(define (**ntyvar)
205 
+  (make ntyvar (value '#f) (context '()) (dict-params '())))
206 
+
207 
+(define (**ntycon tycon args)
208 
+  (make ntycon (tycon tycon) (args args)))
209 
+
210 
+(define (**arrow . args)
211 
+  (**arrow/l args))
212 
+
213 
+(define (**arrow/l args)
214 
+  (if (null? (cdr args))
215 
+      (car args)
216 
+      (**ntycon (core-symbol "Arrow")
217 
+		(list (car args) (**arrow/l (cdr args))))))
218 
+
219 
+(define (**arrow/l-2 args final-val)
220 
+  (if (null? args)
221 
+      final-val
222 
+      (**ntycon (core-symbol "Arrow")
223 
+		(list (car args) (**arrow/l-2 (cdr args) final-val)))))
224 
+
225 
+(define (**list-of arg)
226 
+  (**ntycon (core-symbol "List") (list arg)))
227 
+
228 
+(define (**recursive-placeholder var edecls)
229 
+  (make recursive-placeholder (var var) (exp '#f)
230 
+	(enclosing-decls edecls)))
231 
+
232 
+(define (**dict-placeholder class tyvar edecls var)
233 
+  (make dict-placeholder
234 
+	(class class) (exp '#f) (overloaded-var var)
235 
+	(tyvar tyvar) (enclosing-decls edecls)))
236 
+
237 
+(define (**method-placeholder method tyvar edecls var)
238 
+  (make method-placeholder
239 
+	(method method) (exp '#f) (overloaded-var var)
240 
+	(tyvar tyvar) (enclosing-decls edecls)))
241 
+
242 
+;;; Some less primitive stuff
243 
+
244 
+(define (**tuple-sel n i exp)  ;; 0 <= i < n
245 
+  (if (eqv? n 1)
246 
+      exp
247 
+      (**sel (tuple-constructor n) exp i)))
248 
+
249 
+(define (**abort msg)
250 
+  (**app (**var/def (core-symbol "error"))
251 
+	 (**string msg)))
252 
+
253 
+(define (**tuple/l args)
254 
+  (cond ((null? args)
255 
+	 (**con/def (core-symbol "UnitConstructor")))
256 
+	((null? (cdr args))
257 
+	 (car args))
258 
+	(else
259 
+	 (**app/l (**con/def (tuple-constructor (length args)))
260 
+		  args))))
261 
+
262 
+(define (**tuple . args)
263 
+  (**tuple/l args))
264 
+
265 
+(define (**tuple-type/l args)
266 
+  (cond ((null? args)
267 
+	 (**tycon/def (core-symbol "UnitConstructor") '()))
268 
+	((null? (cdr args))
269 
+	 (car args))
270 
+	(else
271 
+	 (**tycon/def (tuple-tycon (length args)) args))))
272 
+
273 
+(define (**tuple-type . args)
274 
+  (**tuple-type/l args))
275 
+
276 
+(define (**arrow-type . args)
277 
+  (**arrow-type/l args))
278 
+
279 
+(define (**arrow-type/l args)
280 
+  (if (null? (cdr args))
281 
+      (car args)
282 
+      (**tycon/def (core-symbol "Arrow") (list (car args)
283 
+					       (**arrow-type/l (cdr args))))))
284 
+
285 
+(define (**fromInteger x)
286 
+  (**app (**var/def (core-symbol "fromInteger")) x))
287 
+
288 
+(define (**fromRational x)
289 
+  (**app (**var/def (core-symbol "fromRational")) x))
290 
+
291 
+(define (**gtyvar n)
292 
+  (make gtyvar (varnum n)))
293 
+
294 
+(define (**gtype context type)
295 
+  (make gtype (context context) (type type)))
296 
+
297 
+(define (**fixity a p)
298 
+  (make fixity (associativity a) (precedence p)))
299 
+
300 
+(define (**ntycon/tuple . args)
301 
+  (let ((arity  (length args)))
302 
+    (**ntycon (tuple-tycon arity) args)))
303 
+
304 
+(define (**ntycon/arrow . args)
305 
+  (**ntycon/arrow-l args))
306 
+
307 
+(define (**ntycon/arrow-l args)
308 
+  (let ((arg (if (integer? (car args))
309 
+		 (**gtyvar (car args))
310 
+		 (car args))))
311 
+    (if (null? (cdr args))
312 
+	arg
313 
+	(**arrow arg (**ntycon/arrow-l (cdr args))))))
314 
+
315 
+(define (**save-old-exp old new)
316 
+  (make save-old-exp (old-exp old) (new-exp new)))
317 
+
318 
+
319 
+
320 
+;;; These are used by the CFN.
321 
+
322 
+(define (**case-block block-name exps)
323 
+  (make case-block
324 
+	(block-name block-name)
325 
+	(exps exps)))
326 
+
327 
+(define (**return-from block-name exp)
328 
+  (make return-from
329 
+	(block-name block-name)
330 
+	(exp exp)))
331 
+
332 
+(define (**and-exp . exps)
333 
+  (cond ((null? exps)
334 
+	 (**con/def (core-symbol "True")))
335 
+	((null? (cdr exps))
336 
+	 (car exps))
337 
+	(else
338 
+	 (make and-exp (exps exps)))))
339 
+
util/haskell-utils.scm
History View file @ 4e98702
0 340 
new file mode 100644
... ... 
@@ -0,0 +1,22 @@
1 
+(define-compilation-unit haskell-utils
2 
+  (source-filename "$Y2/util/")
3 
+  (require global)
4 
+  (unit constructors
5 
+    (source-filename "constructors.scm"))
6 
+  (unit prec-utils
7 
+    (source-filename "prec-utils.scm"))
8 
+  (unit walk-ast
9 
+    (source-filename "walk-ast.scm"))
10 
+  (unit pattern-vars
11 
+    (source-filename "pattern-vars.scm")
12 
+    (require walk-ast))
13 
+  (unit instance-manager
14 
+    (source-filename "instance-manager.scm"))
15 
+  (unit signature
16 
+    (source-filename "signature.scm"))
17 
+  (unit type-utils
18 
+    (source-filename "type-utils.scm"))
19 
+  (unit annotation-utils
20 
+    (source-filename "annotation-utils.scm"))
21 
+  )
22 
+
util/instance-manager.scm
History View file @ 4e98702
0 23 
new file mode 100644
... ... 
@@ -0,0 +1,161 @@
1 
+
2 
+;;; This file has some random utilities dealing with instances.
3 
+
4 
+;;; Right now, this is a linear search off the class.
5 
+
6 
+(define (lookup-instance alg-def class-def)
7 
+  (let ((res (lookup-instance-1 alg-def (class-instances class-def))))
8 
+    (if (and (eq? res '#f) (algdata-real-tuple? alg-def))
9 
+	(lookup-possible-tuple-instances alg-def class-def)
10 
+	res)))
11 
+
12 
+(define (lookup-instance-1 alg-def instances)
13 
+  (cond ((null? instances)
14 
+	 '#f)
15 
+	((eq? (instance-algdata (car instances)) alg-def)
16 
+	 (if (instance-ok? (car instances))
17 
+	     (car instances)
18 
+	     '#f))
19 
+	(else
20 
+	 (lookup-instance-1 alg-def (cdr instances)))))
21 
+
22 
+(define (lookup-possible-tuple-instances alg-def class-def)
23 
+  (cond ((eq? class-def (core-symbol "Eq"))
24 
+	 (get-tuple-eq-instance alg-def))
25 
+	((eq? class-def (core-symbol "Ord"))
26 
+	 (get-tuple-ord-instance alg-def))
27 
+	((eq? class-def (core-symbol "Ix"))
28 
+	 (get-tuple-ix-instance alg-def))
29 
+	((eq? class-def (core-symbol "Text"))
30 
+	 (get-tuple-text-instance alg-def))
31 
+	((eq? class-def (core-symbol "Binary"))
32 
+	 (get-tuple-binary-instance alg-def))
33 
+	(else '#f)))
34 
+
35 
+(define *saved-eq-instances* '())
36 
+(define *saved-ord-instances* '())
37 
+(define *saved-ix-instances* '())
38 
+(define *saved-text-instances* '())
39 
+(define *saved-binary-instances* '())
40 
+
41 
+(define (get-tuple-eq-instance tpl)
42 
+  (let ((res (assq tpl *saved-eq-instances*)))
43 
+    (if (not (eq? res '#f))
44 
+	(tuple-2-2 res)
45 
+	(let ((inst (make-tuple-instance
46 
+		     tpl (core-symbol "Eq") (core-symbol "tupleEqDict"))))
47 
+	  (push (tuple tpl inst) *saved-eq-instances*)
48 
+	  inst))))
49 
+
50 
+(define (get-tuple-ord-instance tpl)
51 
+  (let ((res (assq tpl *saved-ord-instances*)))
52 
+    (if (not (eq? res '#f))
53 
+	(tuple-2-2 res)
54 
+	(let ((inst (make-tuple-instance
55 
+		     tpl (core-symbol "Ord") (core-symbol "tupleOrdDict"))))
56 
+	  (push (tuple tpl inst) *saved-ord-instances*)
57 
+	  inst))))
58 
+
59 
+(define (get-tuple-ix-instance tpl)
60 
+  (let ((res (assq tpl *saved-ix-instances*)))
61 
+    (if (not (eq? res '#f))
62 
+	(tuple-2-2 res)
63 
+	(let ((inst (make-tuple-instance
64 
+		     tpl (core-symbol "Ix") (core-symbol "tupleIxDict"))))
65 
+	  (push (tuple tpl inst) *saved-ix-instances*)
66 
+	  inst))))
67 
+
68 
+(define (get-tuple-text-instance tpl)
69 
+  (let ((res (assq tpl *saved-text-instances*)))
70 
+    (if (not (eq? res '#f))
71 
+	(tuple-2-2 res)
72 
+	(let ((inst (make-tuple-instance
73 
+		     tpl (core-symbol "Text") (core-symbol "tupleTextDict"))))
74 
+	  (push (tuple tpl inst) *saved-text-instances*)
75 
+	  inst))))
76 
+
77 
+(define (get-tuple-binary-instance tpl)
78 
+  (let ((res (assq tpl *saved-binary-instances*)))
79 
+    (if (not (eq? res '#f))
80 
+	(tuple-2-2 res)
81 
+	(let ((inst (make-tuple-instance
82 
+		     tpl (core-symbol "Binary")
83 
+		     (core-symbol "tupleBinaryDict"))))
84 
+	  (push (tuple tpl inst) *saved-binary-instances*)
85 
+	  inst))))
86 
+
87 
+(define (make-tuple-instance algdata class dict)
88 
+  (let* ((size (tuple-size algdata))
89 
+	 (tyvars (gen-symbols size))
90 
+	 (context (map (lambda (tyvar)
91 
+			  (**context (**class/def class) tyvar))
92 
+			tyvars))
93 
+	 (sig (**tycon/def algdata (map (lambda (x) (**tyvar x)) tyvars)))
94 
+	 (gcontext (gtype-context (ast->gtype context sig))))
95 
+    (make instance
96 
+	  (algdata algdata)
97 
+	  (tyvars tyvars)
98 
+	  (class class)
99 
+	  (context context)
100 
+	  (gcontext gcontext)
101 
+	  (methods '())
102 
+	  (dictionary dict)
103 
+	  (ok? '#t)
104 
+	  (special? '#t))))
105 
+
106 
+;;; I know these are somewhere else too ...
107 
+
108 
+(define (tuple-size alg)
109 
+  (con-arity (car (algdata-constrs alg))))
110 
+
111 
+(define (gen-symbols n)
112 
+  (gen-symbols-1 n '(|a| |b| |c| |d| |e| |f| |g| |h| |i| |j| |k| |l| |m|
113 
+		     |n| |o| |p| |q| |r| |s| |t| |u| |v| |w| |x| |y| |z|)))
114 
+
115 
+(define (gen-symbols-1 n vars)
116 
+  (if (eqv? n 0)
117 
+      '()
118 
+      (if (null? vars)
119 
+	  (cons (string->symbol (format '#f "x~A" n))
120 
+		(gen-symbols-1 (1- n) '()))
121 
+	  (cons (car vars) (gen-symbols-1 (1- n) (cdr vars))))))
122 
+
123 
+;;; This handles the dynamic linking of instances into classes
124 
+
125 
+(define (link-instances modules)
126 
+  (dolist (m modules)
127 
+    ;; clear out any instances sitting around from old compiles
128 
+    (dolist (class (module-class-defs m))
129 
+      (setf (class-instances class) '())))
130 
+  (dolist (m modules)
131 
+    (dolist (inst (module-instance-defs m))
132 
+       (link-instance inst)))
133 
+  )
134 
+
135 
+(define (link-instance inst)  ; links an instance into the associated class
136 
+  (push inst (class-instances (instance-class inst))))
137 
+
138 
+;;; This creates a new instance object and installs it.
139 
+
140 
+(predefine (make-new-var name))  ; in tdecl/tdecl-utils.scm
141 
+
142 
+(define (new-instance class algdata tyvars)
143 
+ (let* ((dict-name
144 
+	 (string-append "dict-"
145 
+			(symbol->string (print-name class)) "-"
146 
+			(symbol->string (print-name algdata))))
147 
+	(inst (make instance (algdata algdata)
148 
+			     (tyvars tyvars)
149 
+		             (class class)
150 
+			     (gcontext '())
151 
+			     (context '())
152 
+			     (dictionary (make-new-var dict-name)))))
153 
+   (link-instance inst)
154 
+   inst))
155 
+
156 
+
157 
+
158 
+
159 
+
160 
+
161 
+
util/pattern-vars.scm
History View file @ 4e98702
0 162 
new file mode 100644
... ... 
@@ -0,0 +1,40 @@
1 
+;;; This collects the vars bound in a pattern.
2 
+
3 
+(define-walker collect-pattern-vars ast-td-collect-pattern-vars-walker)
4 
+
5 
+(define (collect-pattern-vars x)
6 
+  (collect-pattern-vars-1 x '()))
7 
+
8 
+(define (collect-pattern-vars-1 x vars-so-far)
9 
+  (call-walker collect-pattern-vars x vars-so-far))
10 
+
11 
+(define (collect-pattern-vars/list l vars-so-far)
12 
+  (if (null? l)
13 
+      vars-so-far
14 
+      (collect-pattern-vars/list (cdr l)
15 
+		        (collect-pattern-vars-1 (car l) vars-so-far))))
16 
+
17 
+(define-local-syntax (collect-pattern-vars-processor
18 
+		        slot type object-form accum-form)
19 
+  (let ((stype  (sd-type slot))
20 
+	(sname  (sd-name slot)))
21 
+    (cond ((eq? stype 'var-ref)
22 
+	   `(cons (struct-slot ',type ',sname ,object-form) ,accum-form))
23 
+	  ((eq? stype 'pattern)
24 
+	   `(collect-pattern-vars-1
25 
+	       (struct-slot ',type ',sname ,object-form)
26 
+	       ,accum-form))
27 
+	  ((equal? stype '(list pattern))
28 
+	   `(collect-pattern-vars/list
29 
+	       (struct-slot ',type ',sname ,object-form) ,accum-form))
30 
+	  (else
31 
+;	   (format '#t "Collect-pattern-vars: skipping slot ~A in ~A~%"
32 
+;		   sname
33 
+;		   type)
34 
+	   accum-form)
35 
+	  )))
36 
+
37 
+(define-collecting-walker-methods collect-pattern-vars
38 
+  (as-pat irr-pat var-pat wildcard-pat const-pat plus-pat pcon list-pat
39 
+	  pp-pat-list pp-pat-plus pp-pat-negated)
40 
+  collect-pattern-vars-processor)
util/prec-utils.scm
History View file @ 4e98702
0 41 
new file mode 100644
... ... 
@@ -0,0 +1,115 @@
1 
+;;; prec-util.scm -- utilities for precedence parsing and printing of
2 
+;;;                  expressions
3 
+;;;
4 
+;;; author :  Sandra Loosemore
5 
+;;; date   :  15 Feb 1992
6 
+;;;
7 
+;;; The functions in this file are used by the expression printers
8 
+;;; and by precedence parsing.
9 
+
10 
+
11 
+;;; Uncurry the function application, looking for a con-ref as the
12 
+;;; actual function being applied.  Return the con-ref-con and a list
13 
+;;; of the arguments.
14 
+
15 
+(define (extract-constructor fn args)
16 
+  (cond ((is-type? 'con-ref fn)
17 
+	 (values (con-ref-con fn) args))
18 
+	((is-type? 'app fn)
19 
+	 (extract-constructor (app-fn fn) (cons (app-arg fn) args)))
20 
+	(else
21 
+	 (values '#f '()))))
22 
+
23 
+
24 
+;;; If this is an infix operator application, there are really two nested
25 
+;;; applications that we handle at once.  The "fn" on the outer app
26 
+;;; points to a nested app which is a var-ref or con-ref with the infix?
27 
+;;; slot set to T.
28 
+;;; Returns three values: the fixity info, the operator, and the first
29 
+;;; argument (the arg to the outer application is the second argument).
30 
+
31 
+(define (extract-infix-operator fn)
32 
+  (if (is-type? 'app fn)
33 
+      (let* ((new-fn  (app-fn  fn))
34 
+	     (arg     (app-arg fn))
35 
+	     (fixity  (operator-fixity new-fn)))
36 
+	(if fixity
37 
+	    (values fixity new-fn arg)
38 
+	    (values '#f '#f '#f)))
39 
+      (values '#f '#f '#f)))
40 
+
41 
+
42 
+;;; Return the fixity info for a reference to a var or con.
43 
+;;; If it doesn't have an explicit fixity, use the default of
44 
+;;; left associativity and precedence 9.
45 
+
46 
+(define default-fixity
47 
+  (make fixity (associativity 'l) (precedence 9)))
48 
+
49 
+(define (operator-fixity fn)
50 
+  (if (is-type? 'save-old-exp fn)
51 
+      (operator-fixity (save-old-exp-old-exp fn))
52 
+      (or (and (is-type? 'var-ref fn)
53 
+	       (var-ref-infix? fn)
54 
+	       (or (and (var-ref-var fn)
55 
+			(not (eq? (var-ref-var fn) *undefined-def*))
56 
+			(var-fixity (var-ref-var fn)))
57 
+		   default-fixity))
58 
+	  (and (is-type? 'con-ref fn)
59 
+	       (con-ref-infix? fn)
60 
+	       (or (and (con-ref-con fn)
61 
+			(not (eq? (con-ref-con fn) *undefined-def*))
62 
+			(con-fixity (con-ref-con fn)))
63 
+		   default-fixity))
64 
+	  (and (is-type? 'pcon fn)
65 
+	       (pcon-infix? fn)
66 
+	       (or (and (pcon-con fn)
67 
+			(not (eq? (pcon-con fn) *undefined-def*))
68 
+			(con-fixity (pcon-con fn)))
69 
+		   default-fixity))
70 
+	  '#f)))
71 
+
72 
+
73 
+
74 
+;;; Determine the precedence of an expression.
75 
+;;; *** What about unary -?
76 
+
77 
+(define (precedence-of-exp exp associativity)
78 
+  (cond ((is-type? 'save-old-exp exp)
79 
+	 (precedence-of-exp (save-old-exp-old-exp exp) associativity))
80 
+	((is-type? 'aexp exp) 10)
81 
+	((is-type? 'app exp)
82 
+	 (multiple-value-bind (fixity op arg1)
83 
+	     (extract-infix-operator (app-fn exp))
84 
+	   (declare (ignore op arg1))
85 
+	   (if fixity
86 
+	       (if (eq? associativity (fixity-associativity fixity))
87 
+		   (1+ (fixity-precedence fixity))
88 
+		   (fixity-precedence fixity))
89 
+	       10)))
90 
+	((is-type? 'lambda exp) 10)
91 
+	((is-type? 'let exp) 10)
92 
+	((is-type? 'if exp) 10)
93 
+	((is-type? 'case exp) 10)
94 
+	((pp-exp-list-section? exp) 10)
95 
+	((is-type? 'negate exp) 10)  ; hack, hack
96 
+	(else
97 
+	 0)))
98 
+
99 
+
100 
+;;; Determine whether a pp-exp-list is really a section -- the
101 
+;;; first or last exp in the list is really an infix op.
102 
+
103 
+(define (pp-exp-list-section? object)
104 
+  (if (is-type? 'pp-exp-list object)
105 
+      (let ((exps  (pp-exp-list-exps object)))
106 
+	(or (infix-var-or-con? (car exps))
107 
+	    (infix-var-or-con? (list-ref exps (1- (length exps))))))
108 
+      '#f))
109 
+
110 
+(define (infix-var-or-con? object)
111 
+  (or (and (is-type? 'var-ref object)
112 
+	   (var-ref-infix? object))
113 
+      (and (is-type? 'con-ref object)
114 
+	   (con-ref-infix? object))))
115 
+
util/signature.scm
History View file @ 4e98702
0 116 
new file mode 100644
... ... 
@@ -0,0 +1,90 @@
1 
+;;; This file handles the scoping and error checking of signatures.
2 
+
3 
+;;; Possible errors:
4 
+;;;  Wrong arity in a tycon
5 
+;;;  Ambiguous context
6 
+
7 
+;;; Other errors may be present; these are detected at a higher level.
8 
+;;; The list of variables used in the signature is returned.
9 
+
10 
+(define (resolve-signature signature)
11 
+  (with-slots signature (context type) signature
12 
+    (let ((tyvars (resolve-type type)))
13 
+      (resolve-signature-aux tyvars context)
14 
+      tyvars)))
15 
+
16 
+(define (resolve-signature-aux tyvars context)
17 
+  (dolist (ctxt context)
18 
+    (with-slots context (class tyvar) ctxt
19 
+      (when (not (memq tyvar tyvars))
20 
+	(signal-ambiguous-context tyvar))
21 
+      (resolve-class class))))
22 
+
23 
+(define (resolve-type type)
24 
+  (resolve-type-1 type '()))
25 
+
26 
+(define (resolve-type-1 type vars)
27 
+  (cond ((tyvar? type)
28 
+	 (cons (tyvar-name type) vars))
29 
+	(else
30 
+	 (resolve-tycon type)
31 
+	 (with-slots tycon (name def args) type
32 
+	   (when (not (eq? def *undefined-def*))
33 
+	     (if (eqv? (tycon-def-arity def) -1)
34 
+		 (setf (tycon-def-arity def) (length args))
35 
+		 (when (not (eqv? (length args) (tycon-def-arity def)))
36 
+		     (signal-tycon-arity name type))))
37 
+	   (resolve-type/list args vars)))))
38 
+
39 
+(define (resolve-type/list args vars)
40 
+  (if (null? args)
41 
+      vars
42 
+      (resolve-type/list (cdr args) (resolve-type-1 (car args) vars))))
43 
+
44 
+;;; This returns the names of the tyvars in a simple tycon
45 
+
46 
+(define (simple-tyvar-list simple)
47 
+  (remember-context simple
48 
+    (let* ((res (map (lambda (x) (tyvar-name x)) (tycon-args simple)))
49 
+	   (dups (find-duplicates res)))
50 
+      (when (not (null? dups))
51 
+	(signal-non-linear-type-vars simple))
52 
+      res)))
53 
+
54 
+;;; This is used to build the class dictionary signature.
55 
+
56 
+(define (substitute-tyvar type tyvar new)
57 
+  (cond ((tyvar? type)
58 
+	 (if (eq? (tyvar-name type) tyvar)
59 
+	     new
60 
+	     (**tyvar (tyvar-name type))))
61 
+	((tycon? type)
62 
+	 (with-slots tycon (name def args) type
63 
+	   (make tycon (name name) (def def)
64 
+		       (args (map (lambda (x) (substitute-tyvar x tyvar new))
65 
+				  args)))))
66 
+	(else
67 
+	 (**signature (signature-context type)
68 
+		      (substitute-tyvar (signature-type type) tyvar new)))))
69 
+
70 
+
71 
+
72 
+;;; Error signalling routines
73 
+
74 
+(define (signal-ambiguous-context tyvar)
75 
+  (phase-error 'ambiguous-context
76 
+    "~a is referenced in a context, but is not bound as a type variable."
77 
+    tyvar))
78 
+
79 
+(define (signal-tycon-arity name type)
80 
+  (phase-error 'tycon-arity
81 
+    "The wrong number of arguments are supplied to the constructor ~a~%~
82 
+     in the type ~a."
83 
+    name type))
84 
+
85 
+
86 
+(define (signal-non-linear-type-vars simple)
87 
+  (phase-error 'non-linear-type-vars
88 
+    "There are duplicate type variables in ~s."
89 
+    simple))
90 
+
util/type-utils.scm
History View file @ 4e98702
0 91 
new file mode 100644
... ... 
@@ -0,0 +1,308 @@
1 
+
2 
+;;; The `prune' function removes instantiated type variables at the
3 
+;;; top level of a type.
4 
+
5 
+;;; It returns an uninstantiated type variable or a type constructor.
6 
+
7 
+(define-integrable (prune ntype)
8 
+  (if (ntyvar? ntype)
9 
+      (if (instantiated? ntype)
10 
+	  (prune-1 (ntyvar-value ntype))
11 
+	  ntype)
12 
+      ntype))
13 
+
14 
+;;; This is because lucid can't hack inlining recursive fns.
15 
+
16 
+(define (prune-1 x) (prune x))
17 
+
18 
+(define-integrable (instantiated? ntyvar)
19 
+  (ntyvar-value ntyvar))
20 
+;  (not (eq? (ntyvar-value ntyvar) '#f)))  ;*** Lucid compiler bug?
21 
+
22 
+(define (prune/l l)
23 
+  (map (function prune) l))
24 
+
25 
+
26 
+;;; These functions convert between AST types and gtypes.  Care is taken to
27 
+;;; ensure that the gtyvars are in the same order that they appear in the
28 
+;;; context.  This is needed to make dictionary conversion work right.
29 
+
30 
+(define (ast->gtype context type)
31 
+  (mlet (((gcontext env) (context->gcontext context '() '()))
32 
+	 ((type env1) (type->gtype type env))
33 
+	 (gcontext-classes (arrange-gtype-classes env1 gcontext)))
34 
+    (**gtype gcontext-classes type)))
35 
+
36 
+;;; This is similar except that the ordering of the tyvars is as defined in
37 
+;;; the data type.  This is used only for instance declarations and allows
38 
+;;; for simple context implication checks.  It also used by the signature
39 
+;;; of the dictionary variable.
40 
+
41 
+(define (ast->gtype/inst context type)
42 
+  (mlet (((type env) (type->gtype type '()))
43 
+	 ((gcontext env1) (context->gcontext context '() env))
44 
+	 (gcontext-classes (arrange-gtype-classes env1 gcontext)))
45 
+    (**gtype gcontext-classes type)))
46 
+
47 
+;;; This converts a context into gtype form [[class]]: a list of classes
48 
+;;; for each gtyvar.  This returns the context and the gtyvar environment.
49 
+
50 
+(define (context->gcontext context gcontext env)
51 
+  (if (null? context)
52 
+      (values gcontext env)
53 
+      (mlet ((sym (context-tyvar (car context)))
54 
+	     (class (class-ref-class (context-class (car context))))
55 
+	     ((n new-env) (ast->gtyvar sym env))
56 
+	     (old-context (get-gtyvar-context n gcontext))
57 
+	     (new-context (merge-single-class class old-context))
58 
+	     (new-gcontext (cons (tuple n new-context) gcontext)))
59 
+	(context->gcontext (cdr context) new-gcontext new-env))))
60 
+
61 
+;;; This assigns a gtyvar number to a tyvar name.
62 
+
63 
+(define (ast->gtyvar sym env)
64 
+  (let ((res (assq sym env)))
65 
+    (if (eq? res '#f)
66 
+	(let ((n (length env)))
67 
+	  (values n (cons (tuple sym n) env)))
68 
+	(values (tuple-2-2 res) env))))
69 
+
70 
+(define (get-gtyvar-context n gcontext)
71 
+  (cond ((null? gcontext)
72 
+	 '())
73 
+	((eqv? n (tuple-2-1 (car gcontext)))
74 
+	 (tuple-2-2 (car gcontext)))
75 
+	(else (get-gtyvar-context n (cdr gcontext)))))
76 
+
77 
+(define (type->gtype type env)
78 
+  (if (tyvar? type)
79 
+      (mlet (((n env1) (ast->gtyvar (tyvar-name type) env)))
80 
+	(values (**gtyvar n) env1))
81 
+      (mlet (((types env1) (type->gtype/l (tycon-args type) env)))
82 
+	(values (**ntycon (tycon-def type) types) env1))))
83 
+
84 
+(define (type->gtype/l types env)
85 
+  (if (null? types)
86 
+      (values '() env)
87 
+      (mlet (((type env1) (type->gtype (car types) env))
88 
+	     ((other-types env2) (type->gtype/l (cdr types) env1)))
89 
+	 (values (cons type other-types) env2))))
90 
+
91 
+(define (arrange-gtype-classes env gcontext)
92 
+  (arrange-gtype-classes-1 0 (length env) env gcontext))
93 
+
94 
+(define (arrange-gtype-classes-1 m n env gcontext)
95 
+  (if (equal? m n)
96 
+      '()
97 
+      (cons (get-gtyvar-context m gcontext)
98 
+	    (arrange-gtype-classes-1 (1+ m) n env gcontext))))
99 
+
100 
+;;; These routines convert gtypes back to ordinary types.
101 
+
102 
+(define (instantiate-gtype g)
103 
+ (mlet (((gtype _) (instantiate-gtype/newvars g)))
104 
+    gtype))
105 
+
106 
+(define (instantiate-gtype/newvars g)
107 
+  (if (null? (gtype-context g))
108 
+      (values (gtype-type g) '())
109 
+      (let ((new-tyvars (create-new-tyvars (gtype-context g))))
110 
+	(values (copy-gtype (gtype-type g) new-tyvars) new-tyvars))))
111 
+
112 
+(define (create-new-tyvars ctxts)
113 
+  (if (null? ctxts)
114 
+      '()
115 
+      (let ((tyvar (**ntyvar)))
116 
+	(setf (ntyvar-context tyvar) (car ctxts))
117 
+	(cons tyvar (create-new-tyvars (cdr ctxts))))))
118 
+
119 
+(define (copy-gtype g env)
120 
+  (cond ((ntycon? g)
121 
+	 (**ntycon (ntycon-tycon g)
122 
+		   (map (lambda (g1) (copy-gtype g1 env))
123 
+			(ntycon-args g))))
124 
+	((ntyvar? g)
125 
+	 g)
126 
+	((gtyvar? g)
127 
+	 (list-ref env (gtyvar-varnum g)))
128 
+	((const-type? g)
129 
+	 (const-type-type g))))
130 
+
131 
+;;; ntypes may contain synonyms.  These are expanded here.  Only the
132 
+;;; top level synonym is expanded.
133 
+
134 
+(define (expand-ntype-synonym type)
135 
+  (if (and (ntycon? type)
136 
+	   (synonym? (ntycon-tycon type)))
137 
+      (let ((syn (ntycon-tycon type)))
138 
+	(expand-ntype-synonym
139 
+  	  (expand-ntype-synonym-1 (synonym-body syn)
140 
+				  (map (lambda (var val)
141 
+					 (tuple var val))
142 
+				       (synonym-args syn)
143 
+				       (ntycon-args type)))))
144 
+      type))
145 
+
146 
+(define (expand-ntype-synonym-1 type env)
147 
+  (if (tyvar? type)
148 
+      (tuple-2-2 (assq (tyvar-name type) env))
149 
+      (**ntycon (tycon-def type)
150 
+		(map (lambda (ty) (expand-ntype-synonym-1 ty env))
151 
+		     (tycon-args type)))))
152 
+
153 
+;;; This is used in generalization.  Note that ntyvars will remain when
154 
+;;; non-generic tyvars are encountered.
155 
+
156 
+(define (ntype->gtype ntype)
157 
+  (mlet (((res _) (ntype->gtype/env ntype '())))
158 
+    res))
159 
+
160 
+(define (ntype->gtype/env ntype required-vars)
161 
+  (mlet (((gtype env) (ntype->gtype-1 ntype required-vars)))
162 
+   (values
163 
+    (make gtype (type gtype) (context (map (lambda (x) (ntyvar-context x))
164 
+					  env)))
165 
+    env)))
166 
+
167 
+(define (ntype->gtype-1 ntype env)
168 
+ (let ((ntype (prune ntype)))
169 
+  (cond ((ntycon? ntype)
170 
+	 (mlet (((args env1) (ntype->gtype/l (ntycon-args ntype) env)))
171 
+	   (values (**ntycon (ntycon-tycon ntype) args) env1)))
172 
+	(else
173 
+	 (ntyvar->gtyvar ntype env)))))
174 
+
175 
+(define (ntype->gtype/l types env)
176 
+  (if (null? types)
177 
+      (values '() env)
178 
+      (mlet (((type env1) (ntype->gtype-1 (car types) env))
179 
+	     ((types2 env2) (ntype->gtype/l (cdr types) env1)))
180 
+	(values (cons type types2) env2))))
181 
+
182 
+(define (ntyvar->gtyvar ntyvar env)
183 
+  (if (non-generic? ntyvar)
184 
+      (values ntyvar env)
185 
+      (let ((l (list-pos ntyvar env)))
186 
+	(if (eq? l '#f)
187 
+	    (values (**gtyvar (length env)) (append env (list ntyvar)))
188 
+	    (values (**gtyvar l) env)))))
189 
+
190 
+(define (list-pos x l)
191 
+  (list-pos-1 x l 0))
192 
+
193 
+(define (list-pos-1 x l n)
194 
+  (cond ((null? l)
195 
+	 '#f)
196 
+	((eq? x (car l))
197 
+	 n)
198 
+	(else
199 
+	 (list-pos-1 x (cdr l) (1+ n)))))
200 
+
201 
+
202 
+;;; These utils are used in dictionary conversion.
203 
+
204 
+(define (**dsel/method class method dict-code)
205 
+  (let ((pos (locate-in-list method (class-method-vars class) 0)))
206 
+    (**tuple-sel (class-dict-size class) pos dict-code)))
207 
+
208 
+(define (**dsel/dict class dict-class dict-code)
209 
+  (let ((pos (locate-in-list
210 
+	      dict-class (class-super* class) (class-n-methods class))))
211 
+    (**tuple-sel (class-dict-size class) pos dict-code)))
212 
+
213 
+(define (locate-in-list var l pos)
214 
+  (if (null? l)
215 
+      (error "Locate in list failed")
216 
+      (if (eq? var (car l))
217 
+	  pos
218 
+	  (locate-in-list var (cdr l) (1+ pos)))))
219 
+
220 
+;;; These routines deal with contexts.  A context is a list classes.
221 
+
222 
+;;; A context is normalized whenever class is a superclass of another.
223 
+
224 
+(define (merge-contexts ctxt1 ctxt2)
225 
+  (if (null? ctxt1)
226 
+      ctxt2
227 
+      (merge-single-class (car ctxt1) (merge-contexts (cdr ctxt1) ctxt2))))
228 
+
229 
+;;; This could perhaps avoid some consing but I don't imagine it would
230 
+;;; make much difference.
231 
+
232 
+(define (merge-single-class class ctxt)
233 
+  (cond ((null? ctxt)
234 
+	 (list class))
235 
+	((eq? class (car ctxt))
236 
+	 ctxt)
237 
+	((memq class (class-super* (car ctxt)))
238 
+	 ctxt)
239 
+	((memq (car ctxt) (class-super* class))
240 
+	 (merge-single-class class (cdr ctxt)))
241 
+	(else
242 
+	 (cons (car ctxt) (merge-single-class class (cdr ctxt))))))
243 
+
244 
+;;; This determines if ctxt2 is contained in ctxt1.
245 
+
246 
+(define (context-implies? ctxt1 ctxt2)
247 
+  (or (null? ctxt2)
248 
+      (and (single-class-implies? ctxt1 (car ctxt2))
249 
+	   (context-implies? ctxt1 (cdr ctxt2)))))
250 
+
251 
+(define (single-class-implies? ctxt class)
252 
+  (and (not (null? ctxt))
253 
+       (or (memq class ctxt)
254 
+	   (super-class-implies? ctxt class))))
255 
+
256 
+(define (super-class-implies? ctxt class)
257 
+  (and (not (null? ctxt))
258 
+       (or (memq class (class-super* (car ctxt)))
259 
+	   (super-class-implies? (cdr ctxt) class))))
260 
+
261 
+;;; This looks at the context of a full signature.
262 
+
263 
+(define (full-context-implies? ctxt1 ctxt2)
264 
+  (or (null? ctxt1)
265 
+      (and (context-implies? (car ctxt1) (car ctxt2))
266 
+	   (full-context-implies? (cdr ctxt1) (cdr ctxt2)))))
267 
+
268 
+;;; This is used to avoid type circularity on unification.
269 
+
270 
+(define (occurs-in-type tyvar type) ; Cardelli algorithm
271 
+  (let ((type (prune type)))
272 
+    (if (ntyvar? type)
273 
+	(eq? type tyvar)
274 
+	(occurs-in-type/l tyvar (ntycon-args type)))))
275 
+
276 
+; Does a tyvar occur in a list of types?
277 
+(define (occurs-in-type/l tyvar types)
278 
+  (if (null? types)
279 
+      '#f
280 
+      (or (occurs-in-type tyvar (car types))
281 
+	  (occurs-in-type/l tyvar (cdr types)))))
282 
+
283 
+(define-integrable (non-generic? tyvar)
284 
+  (occurs-in-type/l tyvar (dynamic *non-generic-tyvars*)))
285 
+
286 
+(define (collect-tyvars ntype)
287 
+  (collect-tyvars-1 ntype '()))
288 
+
289 
+(define (collect-tyvars-1 ntype vars)
290 
+ (let ((ntype (prune ntype)))
291 
+  (if (ntyvar? ntype)
292 
+      (if (or (memq ntype vars) (non-generic? ntype))
293 
+	  vars
294 
+	  (cons ntype vars))
295 
+      (collect-tyvars/l-1 (ntycon-args ntype) vars))))
296 
+
297 
+(define (collect-tyvars/l types)
298 
+  (collect-tyvars/l-1 types '()))
299 
+
300 
+(define (collect-tyvars/l-1 types vars)
301 
+  (if (null? types)
302 
+      vars
303 
+      (collect-tyvars/l-1 (cdr types) (collect-tyvars-1 (car types) vars))))
304 
+
305 
+;;; Random utilities
306 
+
307 
+(define (decl-var decl)
308 
+  (var-ref-var (var-pat-var (valdef-lhs decl))))
util/walk-ast.scm
History View file @ 4e98702
0 309 
new file mode 100644
... ... 
@@ -0,0 +1,156 @@
1 
+;;; walk-ast.scm -- general-purpose walkers for AST structures.
2 
+;;;
3 
+;;; author :  Sandra & John
4 
+;;; date   :  30 Jan 1992
5 
+;;;
6 
+;;;
7 
+
8 
+;;;=====================================================================
9 
+;;; Basic support, macros
10 
+;;;=====================================================================
11 
+
12 
+
13 
+;;; Here is a macro for accessing the walker function for a particular
14 
+;;; type.
15 
+;;; The walk-type names the walker.
16 
+;;; If an accessor argument is provided, it must name a SETF'able function
17 
+;;; or macro that takes a type descriptor as an argument.  This is used to
18 
+;;; do the lookup of the walker function for the given type.
19 
+;;; If no explicit accessor is provided, one will be created.  It will
20 
+;;; use a hash table keyed off the type names to store the walker functions.
21 
+;;; In either case, the mapping between the walker name and accessor is
22 
+;;; stored in the hash table ast-walker-table.
23 
+
24 
+(define ast-walker-table (make-table))
25 
+
26 
+(define-syntax (define-walker walk-type . maybe-accessor)
27 
+  (let ((accessor-name  (if (null? maybe-accessor)
28 
+			    (symbol-append walk-type '-walker)
29 
+			    (car maybe-accessor))))
30 
+    (setf (table-entry ast-walker-table walk-type) accessor-name)
31 
+	`(begin
32 
+	   ,@(if (null? maybe-accessor)
33 
+		 (let ((accessor-table (symbol-append '* walk-type '-table*)))
34 
+		   `((define ,accessor-table (make-table))
35 
+		     (define-syntax (,accessor-name td)
36 
+		       (list 'table-entry
37 
+			     ',accessor-table
38 
+			     (list 'td-name td)))))
39 
+		 '())
40 
+	   (setf (table-entry ast-walker-table ',walk-type)
41 
+		 ',accessor-name)
42 
+	   ',walk-type)))
43 
+
44 
+(define-syntax (ast-walker walk-type td)
45 
+  (let ((accessor  (table-entry ast-walker-table walk-type)))
46 
+    `(,accessor ,td)))
47 
+
48 
+
49 
+;;; This macro dispatches a walker on an object of type ast-node.
50 
+
51 
+(define-syntax (call-walker walk-type object . args)
52 
+  (let ((temp (gensym "OBJ")))
53 
+    `(let ((,temp ,object))
54 
+       (funcall (or (ast-walker ,walk-type (struct-type-descriptor ,temp))
55 
+		    (walker-not-found-error ',walk-type ,temp))
56 
+		,temp
57 
+		,@args))
58 
+    ))
59 
+
60 
+(define (walker-not-found-error walk-type object)
61 
+  (error "There is no ~a walker for structure ~A defined."
62 
+	 walk-type (td-name (struct-type-descriptor object))))
63 
+
64 
+
65 
+
66 
+;;; Define an individual walker for a particular type.  The body should
67 
+;;; return either the original object or a replacement for it.
68 
+
69 
+(define-syntax (define-walker-method walk-type type args . body)
70 
+  (let ((function-name  (symbol-append walk-type '- type)))
71 
+    `(begin
72 
+       (define (,function-name ,@args) ,@body)
73 
+       (setf (ast-walker ,walk-type (lookup-type-descriptor ',type))
74 
+	     (function ,function-name))
75 
+       ',function-name)))
76 
+
77 
+
78 
+
79 
+;;;=====================================================================
80 
+;;; Support for default walker methods
81 
+;;;=====================================================================
82 
+
83 
+;;; Two kinds of walkers are supported: a collecting walker, which
84 
+;;; walks over a tree collecting some sort of returned result while
85 
+;;; not changing the tree itself, and a rewriting walker which maps
86 
+;;; ast to ast.
87 
+
88 
+;;; The basic template for a collecting walk is:
89 
+;;; (define-walker-method walk-type type (object accum)
90 
+;;;   (sf1 (sf2 object ... (sfn accum)))
91 
+;;; where sfi = slot function for the ith slot.
92 
+;;;
93 
+;;; The slot-processor should be the name of a macro that is called with four
94 
+;;; arguments:  a slot descriptor, the object type name, a form
95 
+;;; representing the object being traversed, and a form representing the
96 
+;;; accumulated value.
97 
+;;; If the slot does not participate in the walk, this last argument should
98 
+;;; be returned unchanged as the expansion of the macro.
99 
+
100 
+(define-syntax (define-collecting-walker-methods walk-type types
101 
+		 slot-processor)
102 
+  `(begin
103 
+     ,@(map (lambda (type)
104 
+	      (make-collecting-walker-method walk-type type slot-processor))
105 
+	    types)))
106 
+
107 
+(define (make-collecting-walker-method walk-type type slot-processor)
108 
+  `(define-walker-method ,walk-type ,type (object accum)
109 
+     object   ; prevent possible unreferenced variable warning
110 
+     ,(make-collecting-walker-method-body
111 
+       'accum
112 
+       type
113 
+       (td-slots (lookup-type-descriptor type))
114 
+       slot-processor)))
115 
+
116 
+(define (make-collecting-walker-method-body base type slots slot-processor)
117 
+  (if (null? slots)
118 
+      base
119 
+      `(,slot-processor ,(car slots) ,type object
120 
+		 ,(make-collecting-walker-method-body
121 
+		     base type (cdr slots) slot-processor))))
122 
+
123 
+
124 
+
125 
+;;; A rewriting walker traverses the ast modifying various subtrees.
126 
+;;; The basic template here is:
127 
+;;; (define-walker-method walker type (object . args)
128 
+;;;   (setf (slot1 object) (walk (slot1 object)))
129 
+;;;   (setf (slot2 object) (walk (slot2 object)))
130 
+;;;   ...
131 
+;;;   object)
132 
+
133 
+;;; The basic macro to generate default walkers is as above except
134 
+;;; that the slot-processor macro is called with only
135 
+;;; two arguments, the slot and object type.
136 
+;;; The `args' is the actual lambda-list for the methods, and bindings
137 
+;;; can be referenced inside the code returned by the macro.
138 
+;;; If a slot participates in the walk, the macro should return code
139 
+;;; to SETF the slot, as in the template above.  Otherwise, the macro
140 
+;;; should just return #f.
141 
+
142 
+(define-syntax (define-modify-walker-methods walk-type types args
143 
+		 slot-processor)
144 
+  `(begin
145 
+     ,@(map (lambda (type)
146 
+	      (make-modify-walker-method walk-type type args
147 
+					 slot-processor))
148 
+	    types)))
149 
+
150 
+(define (make-modify-walker-method walk-type type args slot-processor)
151 
+  `(define-walker-method ,walk-type ,type ,args
152 
+     ,@(cdr args)  ; prevent possible unreferenced variable warnings
153 
+     ,@(map (lambda (slot)
154 
+	      `(,slot-processor ,slot ,type))
155 
+	    (td-slots (lookup-type-descriptor type)))
156 
+     ,(car args)))