diff options
| author | Yale AI Dept <ai@nebula.cs.yale.edu> | 1993-07-14 13:08:00 -0500 |
|---|---|---|
| committer | Duncan McGreggor <duncan.mcgreggor@rackspace.com> | 1993-07-14 13:08:00 -0500 |
| commit | 4e987026148fe65c323afbc93cd560c07bf06b3f (patch) | |
| tree | 26ae54177389edcbe453d25a00c38c2774e8b7d4 | |
Import to github.
390 files changed, 60154 insertions, 0 deletions
diff --git a/Copyright b/Copyright new file mode 100644 index 0000000..cb40c96 --- /dev/null +++ b/Copyright @@ -0,0 +1,18 @@ +Copyright (c) 1991 Yale University Computer Science Department + +Yale Haskell System Version 2.0-beta + +Permission to copy this software, to redistribute it, and to use it for any +purpose is granted, subject to the following restrictions and understandings. + +1. Any copy made of this software must include this copyright notice in full. +2. All materials developed as a consequence of the use of this software + shall duly acknowledge such use, in accordance with the usual standards + of acknowledging credit in academic research. +3. Yale has made no warrantee or representation that the operation of + this software will be error-free, and Yale is under no obligation to + provide any services, by way of maintenance, update, or otherwise. +4. In conjunction with products arising from the use of this material, + there shall be no use of the name of the Yale University nor of any + adaptation thereof in any advertising, promotional, or sales literature + without prior written consent from Yale in each case. @@ -0,0 +1,37 @@ +This is the main directory for the 2.x release of Yale Haskell. This +file contains some basic information about how the system is organized +and put together. + +You should set the variable $HASKELL and source the haskell-setup +script in this directory before attempting to use Yale Haskell. + +If you are rebuilding from the source release, see the scripts and +README files in the $HASKELL/com area. You also need to modify +the haskell-development script. + +Yale-specific information: + +Source files in this directory area are under RCS control. Use the +`rci' and `rco' aliases (from haskell-development) to check things in +and out. By convention, each directory containing source files should +have subdirectories named RCS (for RCS files), t (for compiled T +files), lucid (for compiled Lucid CL files), and cmu (for compiled CMU +CL files). + +Each subdirectory containing source files should also have a file that +defines a compilation unit for that subdirectory. (See +support/compile.scm for information about the compilation unit +utility.) support/system.scm loads all the compilation unit definitions. + +To load the system into Common Lisp, you need to load the file +support/cl-support/cl-init.lisp. This will automagically compile any +outdated or missing files. However, you need to type in an +(in-package "MUMBLE-USER") once it finishes. + +Don't try to load the system into T. It's broken! See +support/t-support/t-init.t. + +All system-dependent code goes in either support/cl-support or +support/t-support. For information about the mumble compatibility +package used as the implementation language for the rest of the +system, see support/mumble.txt. diff --git a/ast/README b/ast/README new file mode 100644 index 0000000..ed2497d --- /dev/null +++ b/ast/README @@ -0,0 +1,29 @@ +This directory defines the primary data structures used in the compiler +using the `define-struct' macro defined in the struct directory. + +Structures are divided into the following catagories: + +Basic structures: (basic-structs) + References to variables, data constructors, classes, type constructors + All references contain the name of the object referred to and a + field that will receive the actual definition object when scoping + has been resolved. + Fixity: (l | n | r, Int) + +Module structures: (module-structs) + The module ast, import & export related ast's, and fixity definition. + +Type system structures: (type-structs) + The representation of data types and the type related declarations: + type, data, class, and instance. + +Value declarations: (valdef-structs) + +Expressions: (expr-structs) + +Definitions: (definition-structs) + +Flic structures: (flic-structs) + + + diff --git a/ast/ast-td.scm b/ast/ast-td.scm new file mode 100644 index 0000000..cf70016 --- /dev/null +++ b/ast/ast-td.scm @@ -0,0 +1,20 @@ +;;; ast-td.scm -- define ast type descriptor object +;;; +;;; author : Sandra Loosemore +;;; date : 6 Oct 1992 +;;; + + +;;; Give the type descriptors for AST nodes extra slots to hold walker +;;; functions. + +(define-struct ast-td + (include type-descriptor) + (slots + (cfn-walker (type (maybe procedure)) (default '#f)) + (cfn-simple-transform-walker (type (maybe procedure)) (default '#f)) + (depend-walker (type (maybe procedure)) (default '#f)) + (ast-to-flic-walker (type (maybe procedure)) (default '#f)) + (scope-walker (type (maybe procedure)) (default '#f)) + (type-walker (type (maybe procedure)) (default '#f)) + (collect-pattern-vars-walker (type (maybe procedure)) (default '#f)))) diff --git a/ast/ast.scm b/ast/ast.scm new file mode 100644 index 0000000..9169677 --- /dev/null +++ b/ast/ast.scm @@ -0,0 +1,33 @@ +;;; ast.scm -- compilation unit definition for ast definitions +;;; +;;; author : John +;;; date : 10 Dec 1991 +;;; + + +(define-compilation-unit ast + (source-filename "$Y2/ast/") + (unit ast-td + (source-filename "ast-td")) + (unit modules + (source-filename "modules.scm") + (require ast-td)) + (unit type-structs + (source-filename "type-structs.scm") + (require ast-td modules)) + (unit tc-structs + (source-filename "tc-structs.scm") + (require ast-td modules)) + (unit valdef-structs + (source-filename "valdef-structs.scm") + (require ast-td modules)) + (unit definitions + (source-filename "definitions.scm") + (require ast-td modules)) + (unit exp-structs + (source-filename "exp-structs.scm") + (require ast-td modules)) + (unit predicates + (require ast-td modules type-structs valdef-structs definitions + exp-structs tc-structs) + (source-filename "predicates.scm"))) diff --git a/ast/definitions.scm b/ast/definitions.scm new file mode 100644 index 0000000..9184b13 --- /dev/null +++ b/ast/definitions.scm @@ -0,0 +1,209 @@ +;;; File: ast/definitions.scm Author: John + +;;; this file contains definitions for the named entities in the +;;; system. These are used in both the front and back ends of the +;;; compiler. These are created early in the compilation process +;;; (import/export) and filled in during compilation. Binary interface +;;; files are just tables mapping names to definitions. + +;;; All definitions have these fields for managing name spaces. All +;;; names are uniquified; this requires adding `;' to the front of data +;;; constructors to separate them from type constructors. Module names +;;; do not have a `definition' data structure - the `module' structure +;;; serves the same purpose. + +;;; Definitions are found in two places: the symbol tables which are part of +;;; the module structure and the -ref nodes in the ast structure. The -ref +;;; nodes have two fields: a name (from the parser) and a field which will +;;; point to the associated definition after name resolution. Name resolution +;;; happens in a number of different places: top level definitions are +;;; resolved during import-export, type declarations are resolved during +;;; type declaration analysis, and everything else is resolved during scoping +;;; (alpha conversion). The parser generates pre-resolved -ref nodes when +;;; parsing some constructs. These refs denote pre-defined language +;;; constructs, such as lists, tuples, or prelude functions. + +;;; A special set of definitions constitutes the `core' of Haskell. These +;;; definitions are pre-allocated and are filled in during the compilation +;;; of the Prelude. This allows the bootstrap of the system. + + +;;; All defs require name, unit, and module args to make. +;;; Other slots should all have appropriate defaults. + +(define-struct def + (slots + ;; the uniquified name (from the definition) + (name (type symbol)) + ;; compilation unit defined in + (unit (type symbol)) + ;; name of the defining module + (module (type symbol)) + ;; used by the closure check + (exported? (type bool) (default '#f) (bit #t)) + ;; for symbols in `core' Haskell; special case for IO + (core? (type bool) (default '#f) (bit #t)) + ;; Always a core sym. Used to avoid putting in sym table + (prelude? (type bool) (default '#f) (bit #t)) + )) + + + +;;; Variable information + +(define-struct var + (include def) + (predicate var?) + (slots + ;; inferred during type inference + (type (type (maybe ntype)) (default '#f)) + ;; type affixed by sign-decl or class decl + (signature (type (maybe ntype)) (default '#f)) + (interface-type (type (maybe ntype)) (default '#f)) + ;; most variables have no fixity information. + (fixity (type (maybe fixity)) (default '#f)) + ;; The following attributes are used by the backend + (selector-fn? (type bool) (default '#f) (bit #t)) + (force-strict? (type bool) (default '#f) (bit #t)) + (force-inline? (type bool) (default '#f) (bit #t)) + (toplevel? (type bool) (default '#f) (bit #t)) + (simple? (type bool) (default '#f) (bit #t)) + (strict? (type bool) (default '#f) (bit #t)) + (optimized-refs? (type bool) (default '#f) (bit #t)) + (standard-refs? (type bool) (default '#f) (bit #t)) + (single-ref (type (maybe int)) (default '#f)) + (arity (type int) (default 0)) + (referenced (type int) (default 0)) + (value (type (maybe flic-exp)) (default '#f)) + (fullname (type (maybe symbol)) (default '#f)) + (inline-value (type (maybe flic-exp)) (default '#f)) + ;; Only function bindings use these slots + (strictness (type (list bool)) (default '())) + (complexity (type (maybe int)) (default '#f)) + (optimized-entry (type (maybe symbol)) (default '#f)) + (annotations (type (list annotation-value)) (default '())) + (fn-referenced (type int) (default 0)) + (arg-invariant-value (type (maybe flic-exp)) (default '#f)) + (arg-invariant? (type bool) (default '#f) (bit #t)) + )) + + +;;; This defines an individual class method + +(define-struct method-var + (include var) + (predicate method-var?) + (slots + (class (type class) (uninitialized? #t)) + (default (type (maybe var)) (uninitialized? #t)) + (method-signature (type signature) (uninitialized? #t)))) + + +;;; A data constructor + +(define-struct con + (include def) + (predicate con?) + (slots + ;; These slots are initialized in the type declaration phase + (arity (type int) (uninitialized? #t)) + (types (type (list type)) (uninitialized? #t)) + (slot-strict? (type (list bool)) (default '())) + (tag (type int) (uninitialized? #t)) + (alg (type algdata) (uninitialized? #t)) + (infix? (type bool) (bit #t) (default '#f)) + (signature (type ntype) (uninitialized? #t)) + ;; Assigned during import-export phase + (fixity (type (maybe fixity)) (default '#f)) + (lisp-fns (type t) (default '())) + )) + + +;;; Definitions used by the type system. + +(define-struct tycon-def + (include def) + (slots + (arity (type integer) (default -1)))) + +(define-struct synonym + (include tycon-def) + (predicate synonym?) + (slots + ;; These slots are explicitly initialized in the type declaration phase. + (args (type (list symbol)) (uninitialized? #t)) + (body (type type) (uninitialized? #t)) ; stored in ast form + )) + +(define-struct algdata + (include tycon-def) + (predicate algdata?) + (slots + ;; These slots are initialized explicitly in the type declaration phase + ;; number of constructors + (n-constr (type int) (uninitialized? #t)) + (constrs (type (list con)) (uninitialized? #t)) + (context (type (list context)) (uninitialized? #t)) + ;; arguments to tycon + (tyvars (type (list symbol)) (uninitialized? #t)) + ;; signature for the type as a whole + (signature (type (maybe ntype)) (default '#f)) + ;; classes this algdata is an instance of + (classes (type (list class)) (uninitialized? #t)) + ;; true if all constructors have 0 arity + (enum? (type bool) (bit #t) (uninitialized? #t)) + ;; true when only constructor + (tuple? (type bool) (bit #t) (uninitialized? #t)) + ;; true for `tuple-syntax' tuples. + (real-tuple? (type bool) (bit #t) (uninitialized? #t)) + ;; instances to derive + (deriving (type (list class)) (uninitialized? #t)) + (export-to-lisp? (type bool) (default '#f) (bit #t)) + (implemented-by-lisp? (type bool) (default '#f) (bit #t)) + )) + +(define-struct class + (include def) + (predicate class?) + (slots + ;; These slots are initialized in the import-export phase + (method-vars (type (list method-var)) (uninitialized? #t)) + ;; These slots are explicitly initialized in the type declaration phase + ;; immediate superclasses + (super (type (list class)) (uninitialized? #t)) + ;; all superclasses + (super* (type (list class)) (uninitialized? #t)) + ;; name of class type variable + (tyvar (type symbol) (uninitialized? #t)) + (instances (type (list instance)) (uninitialized? #t)) + (kind (type (enum standard numeric other)) (uninitialized? #t)) + (n-methods (type int) (uninitialized? #t)) + (dict-size (type int) (uninitialized? #t)) + (selectors (type (list (tuple method-var var))) (uninitialized? #t)) + )) + +;;; Since instances are not named there is no need to include def. + +(define-struct instance + (include ast-node) + (slots + ;; These slots always have initializers supplied with MAKE. + (algdata (type algdata)) + (tyvars (type (list symbol))) + (class (type class)) + (context (type (list context))) + (gcontext (type (list (list class)))) + (dictionary (type var)) + + ;; Explicitly initialized during the type declaration phase. + (methods (type (list (tuple method-var var))) (uninitialized? #t)) + + ;; These slots usually default on creation. + (decls (type (list decl)) (default '())) + ;; used during verification of derived instances + (ok? (type bool) (bit #t) (default #f)) + ;; marks magically generated tuple instances + (special? (type bool) (bit #t) (default #f)) + (suppress-readers? (type bool) (bit #t) (default #f)) + )) + diff --git a/ast/exp-structs.scm b/ast/exp-structs.scm new file mode 100644 index 0000000..847723d --- /dev/null +++ b/ast/exp-structs.scm @@ -0,0 +1,386 @@ +;;; File: ast/exp-structs Author: John + +;;; These ast structures define the expression syntax + + +;;; This is simplified; there are additional rules for associativity and +;;; precedence. +;;; +;;; <exp> -> <lambda-exp> +;;; -> <let-exp> +;;; -> <if-exp> +;;; -> <case-exp> +;;; -> <signature-exp> +;;; -> <exp> <op> <exp> ; treated like <fn-app> +;;; -> - <exp> +;;; -> <fn-app> +;;; -> <aexp> +;;; + +(define-struct exp + (include ast-node)) + + +;;; <lambda-exp> -> \ <apat> ... <apat> -> <exp> + +(define-struct lambda + (include exp) + (slots + (pats (type (list pattern))) + (body (type exp)))) + +;;; <let-exp> -> let { <decls> [;] } in <exp> + +(define-struct let + (include exp) + (slots + (decls (type (list decl))) + (body (type exp)))) + +;;; <if-exp> -> if <exp> then <exp> else <exp> + +(define-struct if + (include exp) + (slots + (test-exp (type exp)) + (then-exp (type exp)) + (else-exp (type exp)))) + + +;;; <case-exp> -> case <exp> of { <alts> [;] } +;;; +;;; <alts> -> <alt> ; ... ; <alt> +;;; +;;; <alt> -> <pat> -> exp [where { <decls> [;] } ] +;;; -> <pat> <gdpat> [where { <decls> [;] } ] + +(define-struct case + (include exp) + (slots + (exp (type exp)) + (alts (type (list alt))))) + +(define-struct alt + (include ast-node) + (slots + (pat (type pattern)) + ;; defined in valdef-structs + (rhs-list (type (list guarded-rhs))) + (where-decls (type (list decl))) + ;; used internally by cfn + (test (type (maybe exp)) (default '#f)) + )) + +;;; <signature-exp> -> <exp> :: [<context> =>] <atype> + +(define-struct exp-sign + (include exp) + (slots + (exp (type exp)) + (signature (type signature)))) + + +;;; <fn-app> -> <exp> <aexp> + +(define-struct app + (include exp) + (predicate app?) + (slots + (fn (type exp)) + (arg (type exp)))) + +;;; <aexp> -> <var> var-ref +;;; -> <con> con-ref +;;; -> <literal> const +;;; -> () constructor is Unit +;;; -> ( <exp> ) +;;; -> ( <exp> , ... , <exp> ) constructor is a tuple +;;; -> [ <exp> , ... , <exp> ] list +;;; -> <sequence> +;;; -> [exp> | <qual> , ... , <qual>] list-comp +;;; -> ( <exp> <op> ) section-r +;;; -> ( <op> <exp> ) section-l +;;; + +(define-struct aexp + (include exp)) + + +(define-struct var-ref + (include aexp) + (predicate var-ref?) + (slots + (name (type symbol)) + (var (type def)) + (infix? (type bool) (bit #t)))) + +(define-struct con-ref + (include aexp) + (predicate con-ref?) + (slots + (name (type symbol)) + (con (type def)) + (infix? (type bool) (bit #t)))) + +(define-struct const + (include aexp) + (slots + (overloaded? (type bool) (default '#t) (bit #t)))) + +(define-struct integer-const + (include const) + (predicate integer-const?) + (slots + (value (type integer)))) + +(define-struct float-const + (include const) + (predicate float-const?) + (slots + (numerator (type integer)) + (denominator (type integer)) + (exponent (type integer)))) + +(define-struct char-const + (include const) + (predicate char-const?) + (slots + (value (type char)))) + +(define-struct string-const + (include const) + (predicate string-const?) + (slots + (value (type string)))) + +(define-struct list-exp + (include aexp) + (slots + (exps (type (list exp))))) + + +;;; <sequence> -> [ <exp> .. ] sequence +;;; -> [ <exp>, <exp> .. ] sequence-then +;;; -> [ <exp> .. <exp> ] sequence-to +;;; -> [ <exp>, <exp> .. <exp> ] sequence-then-to + +(define-struct sequence + (include aexp) + (slots + (from (type exp)))) + +(define-struct sequence-to + (include aexp) + (slots + (from (type exp)) + (to (type exp)))) + + +(define-struct sequence-then + (include aexp) + (slots + (from (type exp)) + (then (type exp)))) + +(define-struct sequence-then-to + (include aexp) + (slots + (from (type exp)) + (then (type exp)) + (to (type exp)))) + +(define-struct list-comp + (include aexp) + (slots + (exp (type exp)) + (quals (type (list qual))))) + +;;; Op on left +(define-struct section-l + (include aexp) + (slots + (exp (type exp)) + (op (type exp)))) ; either con-ref or var-ref + +(define-struct section-r + (include aexp) + (slots + (exp (type exp)) + (op (type exp)))) ; either con-ref or var-ref + +;;; <qual> -> <pat> <- <exp> +;;; -> <exp> + +(define-struct qual + (include ast-node)) + +(define-struct qual-generator + (include qual) + (slots + (pat (type pattern)) + (exp (type exp)))) + +(define-struct qual-filter + (include qual) + (slots + (exp (type exp)))) + + +;;; This is used as the guard slot in a guarded-rhs to represent lack of a +;;; guard. This is the same as True. + +(define-struct omitted-guard ; same as True; should print in the guardless form + (include exp)) + + +;;; These structures are used by the precedence parser. + +(define-struct pp-exp-list ; list of expressions & ops for the prec parser + (include exp) + (slots + (exps (type (list exp))))) + +;; This is a place holder for unary negation in pp-exp expressions. It is +;; changed to call the negate function by the prec parser + +(define-struct negate + (include exp) + (predicate negate?)) + +;; Note: operators are var / con structures with infix? set to #t + +;;; The following ast nodes do not directly correspond to Haskell syntax. +;;; They are generated during internal code transformations. + +;;; This returns a number (an Int) associated with the constructor of a +;;; value. + +(define-struct con-number + (include exp) + (slots + (type (type algdata)) + (value (type exp)))) + +;;; This selects a value (denoted by the Int in slot) from a data object +;;; created by a specified constructor. + +(define-struct sel + (include exp) + (slots + (constructor (type con)) + (slot (type int)) + (value (type exp)))) + +;;; This returns True if the data value was built with the designated +;;; constructor + +(define-struct is-constructor + (include exp) + (slots + (constructor (type con)) + (value (type exp)))) + +;;; this is for the type checker only. It turns off +;;; type checking for the argument. + +(define-struct cast + (include exp) + (slots + (exp (type exp)))) + +;; this is used as the body of the let generated by +;; dependency analysis + +(define-struct void + (include exp) + (predicate void?)) + + +;;; These structures are for the type checker. They serve as a placeholder +;;; for values which will evaluate to methods or dictionaries. + +(define-struct placeholder + (include exp) + (predicate placeholder?) + (slots + (exp (type (maybe exp))) + (tyvar (type ntype)) + (overloaded-var (type exp)) + (enclosing-decls (type (list decl))))) + +(define-struct method-placeholder + (include placeholder) + (predicate method-placeholder?) + (slots + ;; the method to be dispatched + (method (type method-var)) + )) + +(define-struct dict-placeholder + (include placeholder) + (predicate dict-placeholder?) + (slots + ;; the class of dictionary needed + (class (type class)))) + +(define-struct recursive-placeholder + (include exp) + (slots + (var (type var)) + (enclosing-decls (type (list decl))) + ;; this holds the code associated with recursive + ;; functions or variables. This code instantiates + ;; the recursive context if necessary. + (exp (type (maybe exp))) + )) + +;;; This is used in primitive modules only. It holds the definition of +;;; a lisp level primitive. + +(define-struct prim-definition + (include exp) + (slots + (lisp-name (type symbol)) + (atts (type (list (tuple symbol t)))))) + +;;; This is used by the type checker to hang on to the original +;;; version of a program for message printing. This is removed by +;;; the cfn pass. + +(define-struct save-old-exp + (include exp) + (slots + (old-exp (type exp)) + (new-exp (type exp)))) + + +;;; This is used for type checking overloaded methods. + +(define-struct overloaded-var-ref + (include exp) + (slots + (var (type var)) + (sig (type ntype)))) + + + +;;; These are used by the CFN. + + +(define-struct case-block + (include exp) + (slots + (block-name (type symbol)) + (exps (type (list exp))))) + +(define-struct return-from + (include exp) + (slots + (block-name (type symbol)) + (exp (type exp)))) + +(define-struct and-exp + (include exp) + (slots + (exps (type (list exp))))) + diff --git a/ast/modules.scm b/ast/modules.scm new file mode 100644 index 0000000..e445444 --- /dev/null +++ b/ast/modules.scm @@ -0,0 +1,252 @@ +;;; File: ast/module-structs Author: John + +;;; This contains AST structures which define the basic module structure. +;;; This is just the skeleton module structure: module, imports, exports, +;;; fixity, and default decls. + +;;; AST nodes defined in the file: +;;; module import-decl entity entity-module entity-var entity-con +;;; entity-class entity-abbreviated entity-datatype fixity-decl + + + +;;; All AST structs inherit from ast-node. Not instantiated directly. +;;; The line-number is a back pointer to the source code. + +(define-struct ast-node + (type-template ast-td) + (slots + (line-number (type (maybe source-pointer)) (default '#f)))) + +(define-struct source-pointer + (slots + (line (type int)) + (file (type string)))) + +;;; <module> -> module <modid> [<exports>] where <body> +;;; -> <body> +;;; +;;; <exports> -> ( <export>, ... <export> ) +;;; +;;; <body> -> { [<impdecls>;] [[<fixdecls>;] <topdecls> [;]] } +;;; -> { <impdecls> [;] } +;;; +;;; <impdecls> -> <impdecl> ; ... ; <impdecl> +;;; +;;; <fixdecls> -> <fix> ; ... ; <fix> +;;; +;;; <topdecls> -> <topdecl> ; ... ; <topdecl> +;;; +;;; <topdecl> -> <synonym-decl> +;;; -> <algdata-decl> +;;; -> <class-decl> +;;; -> <instance-decl> +;;; -> <default-decl> +;;; -> <sign-decl> +;;; -> <valdef> + +;;; The module struct is used to represent the program internally. Binary +;;; files containing interface information contain these structures. +;;; Most compiler passes operate on this structure. A table maps module +;;; names to this structure. Within the module structure, local names are +;;; mapped to definitions. + +;;; Modules are also used to represent interfaces & primitives. +;;; Some of the module fields may be blank for non-standard modules. + +(define-struct module + (include ast-node) + (slots + + ;; These slots are required. + + (name (type symbol)) + (type (type (enum standard interface extension))) + (prelude? (type bool) (default '#f)) ; True when symbols define the core + (interface-module (type (maybe module)) (default '#f)) + ; link to previously compiled interface + + ;; The unit is filled in by the compilation system + + (unit (type symbol) (default '*undefined*)) + + ;; The following slots are defined at parse time. + ;; After a module is dumped, these are all empty. + + ;; <exports>, list of exported names + (exports (type (list entity)) (default '())) + ;; <impdecls>, local import decls + (imports (type (list import-decl)) (default '())) + ;; <fixdecls>, local fixity decls + (fixities (type (list fixity-decl)) (default '())) + ;; <synonym-decl>, local type synonym decls + (synonyms (type (list synonym-decl)) (default '())) + ;; <algdata-decl>, local data decls + (algdatas (type (list data-decl)) (default '())) + ;; <class-decl>, local class decls + (classes (type (list class-decl)) (default '())) + ;; <instance-decl>, local instance decls + (instances (type (list instance-decl)) (default '())) + ;; <default-decl>, default types + (annotations (type (list annotation)) (default '())) + (default (type (maybe default-decl)) (default '#f)) + ;; signatures, pattern, function bindings + (decls (type (list decl)) (default '())) + + ;; These slots are filled in by the type-declaration-analysis phase + ;; after conversion to definition form + + (synonym-defs (type (list synonym)) (default '())) + (alg-defs (type (list algdata)) (default '())) + (class-defs (type (list class)) (default '())) + (instance-defs (type (list instance)) (default '())) + + + ;; The import-export stage creates a set of tables which are used for + ;; imports and exports and local name resolution. All of these tables + ;; are indexed by names. These tables always deal with definitions. + ;; Every variable, type, class, instance, and synonym is converted into + ;; a definition. Blank definitions are created early (in import/export) + ;; and different aspects of the definitions are filled in as compilation + ;; progresses. The type-related definitions are filled in during + ;; declaration analysis. Only definitions are saved when a module is + ;; written to a file; the ast information is not retained. + + ;; Used to avoid copy of Prelude symbols. + (uses-standard-prelude? (type bool) (default '#f)) + ;; maps symbols in scope to definitions + (symbol-table (type (table symbol def)) (default (make-table))) + ;; maps names onto groups. + (export-table (type (table symbol (list (tuple symbol def)))) + (default (make-table))) + ;; Note: symbol groups are found in classes and data decls. An + ;; entire group is denoted by the (..) abbreviation in an entity. + ;; maps local names onto declared fixities + (fixity-table (type (table symbol fixity)) (default (make-table))) + ;; maps defs to local names + (inverted-symbol-table (type (table symbol symbol)) (default (make-table))) + ;; Used internally during import-export + (fresh-exports (type (list (list (tuple symbol def)))) (default '())) + (exported-modules (type (list module)) (default '())) + + ;; These slots are used to support incremental compilation. + + ;; vars defined in the module + (vars (type (list var)) (default '())) + ;; for incremental compilation + (inherited-env (type (maybe module)) (default '#f)) + ;; The following slots are for interfaces only + ;; These store renaming mappings defined in the import decls of + ;; the interface. Maps local name onto (module, original name). + (interface-imports (type (list (tuple symbol (typle symbol symbol)))) + (default '())) + (interface-codefile (type (list string)) (default '())) + )) + + +;;; <impdecl> -> import <modid> [<impspec>] [renaming <renamings>] +;;; +;;; <impspec> -> ( <import> , ... , <import> ) +;;; -> hiding ( <import> , ... , <import> ) +;;; +;;; <import> -> <entity> +;;; +;;; <renamings> -> ( <renaming>, ... , <renaming> ) +;;; +;;; <renaming> -> <varid> to <varid> +;;; -> <conid> to <conid> + +(define-struct import-decl + (include ast-node) + (slots + ;; <modid>, module imported from + (module-name (type symbol)) + ;; all: import Foo; by-name: import Foo(x) import Foo() + (mode (type (enum all by-name))) + ;; <impspec>, for mode = all this is the hiding list + (specs (type (list entity))) + ;; <renamings>, alist maps symbol -> symbol + (renamings (type (list renaming))) + ;; place to put corresponding module-ast; filled in by import/export. + (module (type module) (uninitialized? #t)) + )) + + +;;; <entity> -> <modid> .. entity-module +;; -> <varid> entity-var +;;; -> <tycon> entity-con +;;; -> <tycon> (..) entity-abbreviated +;;; -> <tycon> ( <conid> , ... , <conid>) entity-datatype +;;; -> <tycls> (..) entity-abbreviated +;;; note: this is indistinguishable from tycon (..) +;;; -> <tycls> ( <varid> , ... , <varid>) entity-class + +(define-struct entity + (include ast-node) + (slots + (name (type symbol)))) + +(define-struct entity-module + (include entity) + (predicate entity-module?) + (slots + ;; a direct pointer to the referenced module added later + (module (type module) (uninitialized? #t)) + )) + +(define-struct entity-var + (include entity) + (predicate entity-var?)) + +(define-struct entity-con + (include entity) + (predicate entity-con?)) + +(define-struct entity-abbreviated + (include entity) + (predicate entity-abbreviated?)) + +(define-struct entity-class + (include entity) + (predicate entity-class?) + (slots + (methods (type (list symbol))))) + +(define-struct entity-datatype + (include entity) + (predicate entity-datatype?) + (slots + (constructors (type (list symbol))))) + +(define-struct renaming + (include ast-node) + (slots + (from (type symbol)) + (to (type symbol)) + (referenced? (type bool)))) + + +;;; <fix> -> infixl [<digit>] <ops> +;;; -> infixr [<digit>] <ops> +;;; -> infix [<digit>] <ops> +;;; +;;; <ops> -> <op> , ... , <op> +;;; +;;; <op> -> <varop> +;;; -> <conop> + +;;; Not sure where to put this decl - jcp +(define-struct fixity + (include ast-node) + (slots + (associativity (type (enum l n r))) + (precedence (type int)))) + +(define-struct fixity-decl + (include ast-node) + (slots + (fixity (type fixity)) + ;; <ops> + (names (type (list symbol))) + )) + diff --git a/ast/predicates.scm b/ast/predicates.scm new file mode 100644 index 0000000..20dfc13 --- /dev/null +++ b/ast/predicates.scm @@ -0,0 +1,18 @@ +;;; predicates.scm -- various useful predicates, collected from other places +;;; +;;; author : Sandra Loosemore +;;; date : 19 Mar 1992 +;;; + + +;;; Some predicates on patterns (used by CFN) + +(define-integrable (var-or-wildcard-pat? p) + (or (is-type? 'wildcard-pat p) + (is-type? 'var-pat p))) + +(define-integrable (irrefutable-pat? p) + (or (is-type? 'wildcard-pat p) + (is-type? 'var-pat p) + (is-type? 'irr-pat p))) + diff --git a/ast/tc-structs.scm b/ast/tc-structs.scm new file mode 100644 index 0000000..1433082 --- /dev/null +++ b/ast/tc-structs.scm @@ -0,0 +1,62 @@ +;;; These structures are used by the type checker for the internal +;;; representation of type information. These are referred to in +;;; general as `ntype' structures. Conversions are required between +;;; ast types and ntypes. + +(define-struct ntype + (include ast-node)) + +(define-struct ntycon + (include ntype) + (predicate ntycon?) + (slots + (tycon (type def)) + (args (type (list ntype))))) + +(define-struct ntyvar + (include ntype) + (predicate ntyvar?) + (slots + ;; non-instantiated tyvars use #f for a value. + (value (type (maybe ntype))) + ;; could be encoded in value. + (context (type (list class)) (default ())) + (read-only? (type bool) (default #f) (bit #t)) + (dict-params (type (list (tuple valdef (list (tuple class var)))))) + )) + +;;; This is used only at the top level of a type during letrec type +;;; checking. + +(define-struct recursive-type + (include ntype) + (predicate recursive-type?) + (slots + (type (type ntype)) + (placeholders (type (list exp))))) + +;;; Gtypes are generalized types which can be copied quickly & stored in +;;; interfaces. They may contain monomorphic type variables which will not +;;; be copied. + +(define-struct gtype + (include ntype) + (predicate gtype?) + (slots + (context (type (list (list class)))) + (type (type ntype)))) + +;;; These tyvars just index a list of pre-allocated tyvars. + +(define-struct gtyvar + (include ntype) + (predicate gtyvar?) + (slots + (varnum (type int)))) + +(define-struct const-type + (include ntype) + (predicate const-type?) + (slots + (type (type ntype)))) + diff --git a/ast/type-structs.scm b/ast/type-structs.scm new file mode 100644 index 0000000..0ba4705 --- /dev/null +++ b/ast/type-structs.scm @@ -0,0 +1,159 @@ +;;; File: ast/type-structs Author: John + +;;; This contains AST structures for the type-related declarations, +;;; including `data', `class', `instance', and `type' decls. Basic type +;;; syntax is also defined here. + +;;; Structures declared here: +;;; type type-var type-con context signature synonym-decl +;;; data-decl class-decl instance-decl + + +;;; <type> -> <atype> +;;; -> <type> -> <type> *** +;;; -> <tycon> <atype> ... <atype> tycon +;;; +;;; <atype> -> <tyvar> tyvar +;;; -> <tycon> tycon +;;; -> () *** +;;; -> ( <type> ) grouping syntax +;;; -> ( <type> , ... , <type>) *** +;;; -> [ <type> ] *** +;;; *** Special <tycon> cases + +;;; Type with no context - either a tyvar or a constructor +(define-struct type + (include ast-node)) + +(define-struct tyvar + (include type) + (predicate tyvar?) + (slots + (name (type symbol)))) + +(define-struct tycon + (include type) + (predicate tycon?) + (slots + (name (type symbol)) + (def (type def)) + (args (type (list type))))) + +;;; <signature> -> [<context> =>] <type> +;;; +;;; <context> -> <class> +;;; -> (<class> , ... , <class>) + +;;; A single class, variable pair +(define-struct context + (include ast-node) + (slots + (class (type class-ref)) + (tyvar (type symbol)))) + + +;;; Type + context +(define-struct signature + (include type) + (slots + (context (type (list context))) + (type (type type)))) + + +;;; Major type declarations. Note: no explicit structures for <simple> +;;; or <inst> are needed - these are just special cases of type. + +;;; <synonym-decl> -> type <simple> = <type> +;;; +;;; <simple> -> <tycon> <tyvar> ... <tyvar> + +(define-struct synonym-decl + (include ast-node) + (slots + (simple (type type)) + (body (type type)))) + + +;;; <aldata-decl> -> data [<context> => ] <simple> = <constrs> +;;; [deriving <tycls> | ( <tycls> , ... <tycls>) ] +;;; +;;; <constrs> -> <constr> | ... | <constr> +;;; + +(define-struct data-decl + (include ast-node) + (slots + (context (type (list context))) + (simple (type type)) + (constrs (type (list constr))) + (deriving (type (list class-ref))) + (annotations (type (list annotation-value))))) + +;;; <constr> -> <con> <atype> ... <atype> +;;; -> <type> <conop> <type> + +(define-struct constr + (include ast-node) + (slots + (constructor (type con-ref)) ; this con-ref has an infix? flag. + (types (type (list (tuple type (list annotation-value))))))) + + +;;; <class-decl> -> class [<context> => ] <class> [where { <cbody> [;] } ] +;;; +;;; <cbody> -> [<csigns> ; ] [ <valdefs> ] +;;; +;;; <csigns> -> <signdecl> ; ... ; <signdecl> + +(define-struct class-decl + (include ast-node) + (slots + (class (type class-ref)) + (super-classes (type (list context))) + (class-var (type symbol)) ; name of type var for this class in decls + (decls (type (list decl))))) ; <cbody> + + +;;; <instance-decl> -> instance [<context> =>] <tycls> <inst> +;;; [where { <valdefs> [;] } ] +;;; +;;; <inst> -> <tycon> +;;; -> ( <tycon> <tyvar> ... <tyvar> ) +;;; -> ( <tyvar> , ... , <tyvar>) +;;; -> () +;;; -> [ <tyvar> ] +;;; -> ( <tyvar> -> <tyvar>) +;;; + +(define-struct instance-decl + (include ast-node) + (slots + ;; <context> + (context (type (list context))) + ;; <tycls> + (class (type class-ref)) + ;; + (simple (type type)) + ;; <valdefs> + (decls (type (list valdef))) + )) + + + +;;; <default-decl> -> default <type> +;;; -> default ( <type> , ... , <type> ) + +(define-struct default-decl + (include ast-node) + (slots + (types (type (list type))))) + + +;;; <tycls> -> <aconid> + +(define-struct class-ref + (include ast-node) + (slots + (name (type symbol)) + (class (type def)))) + diff --git a/ast/valdef-structs.scm b/ast/valdef-structs.scm new file mode 100644 index 0000000..eb0dc88 --- /dev/null +++ b/ast/valdef-structs.scm @@ -0,0 +1,276 @@ +;;; File: ast/valdef-structs Author: John + +;;; Ast structure for local declarations + +;;; <decl> -> <signdecl> +;;; -> <valdef> + +;;; decl contains value declarations and type signatures.( +;;; type related decls are topdecls and are separated from +;;; these decls. + +(define-struct decl + (include ast-node)) + + + +;;; <signdecl> -> <vars> :: [<context> =>] <type> +;;; +;;; <vars> -> <var> , ... , <var> +;;; + +(define-struct signdecl ; this affixes a signature to a list of variables + (include decl) + (predicate signdecl?) + (slots + (vars (type (list var-ref))) + (signature (type signature)))) + +;;; This is introduced into decl lists by dependency analysis +(define-struct recursive-decl-group + (include decl) + (slots + ;; none of these are recursive decl groups + (decls (type (list decl))) + )) + +;;; <valdef> -> <lhs> = <exp> [where { <decls> [;] }] +;;; -> <lhs> <gdrhs> [where { <decls> [;] }] +;;; +;;; <lhs> -> <apat> +;;; -> <funlhs> +;;; +;;; <funlhs> -> <afunlhs> +;;; -> <pat> <varop> <pat> +;;; -> <lpat> <varop> <pat> +;;; -> <pat> <varop> <rpat> +;;; +;;; <afunlhs> -> <var> <apat> +;;; -> ( <funlhs> ) <apat> (infix operator with more than 2 args) +;;; -> <afunlhs> <apat> (multiple argument pattern) + +(define-struct valdef ; this defines values. + (include decl) + (predicate valdef?) + (slots + ;; this pattern contains all new variables defined. + ;; For a function definition the pattern will always + ;; be a simple variable. + (lhs (type pattern)) + ;; this is a list of right hand sides. + ;; for a pattern definition, this list is always a singleton. For + ;; a function definition, there is a member for every successive + ;; alternative for the function. + (definitions (type (list single-fun-def))) + ;; this is used internally by dependency analysis + (depend-val (type int) (uninitialized? #t)) + ;; this is filled in by the type phase + (dictionary-args (type (list var)) (uninitialized? #t)) + ;; used for defaulting + (module (type symbol) (default '|Prelude|)) + )) + +(define-struct single-fun-def + (include ast-node) + (slots + ;; this list is always empty for pattern definition + ;; and always non-empty for function definition. + ;; The length of this list is the arity of the function. + ;; All single-fun-defs for a function have the same arity. + (args (type (list pattern))) + ;; <gdrhs>, this contains a list of guard , expression pairs + (rhs-list (type (list guarded-rhs))) + ;; this contains declarations local to the + ;; single fun def. It scopes over the args. The + ;; guarded-rhs may refer to these values. + (where-decls (type (list decl))) + ;; true when declared in infix style. Used for printing + ;; and to check precs in prec parsing. + (infix? (type bool) (bit #t)) + )) + + + +;;; <gdrhs> -> <gd> = <exp> [<gdrhs>] +;;; +;;; <gd> -> | <exp> + +(define-struct guarded-rhs ; a single guarded expression. A special expression + (include ast-node) + (slots + ;; node - omitted-guard - is used when no guard given + (guard (type exp)) + (rhs (type exp)))) + + +;;; Some examples of the above: +;;; (a,b) | z>y = (z,y) +;;; | otherwise = (1,2) +;;; where z = x-2 +;;; +;;; valdef: +;;; lhs = (a,b) +;;; definitions = +;;; [single-fun-def: +;;; args = [] +;;; rhs-list = [guarded-rhs: guard = z>y +;;; rhs = (z,y), +;;; guarded-rhs: guard = otherwise +;;; rhs = (1,2)] +;;; where-decls = [valdef: lhs = z +;;; definitions = +;;; [single-fun-def: +;;; args = [] +;;; rhs-list = [guarded-rhs: +;;; guard = omitted-guard +;;; exp = x-2] +;;; where-decls = []]]] +;;; +;;; fact 0 = 1 +;;; fact (n+1) = (n+1)*fact n +;;; +;;; valdef: +;;; lhs = fact +;;; definitions = +;;; [single-fun-def: +;;; args = [0] +;;; rhs-list = [guarded-rhs: guard = omitted-guard +;;; rhs = 1] +;;; where-decls = [], +;;; single-fun-def: +;;; args = [n+1] +;;; rhs-list = [guarded-rhs: guard = omitted-guard +;;; rhs = (n+1)*fact n] +;;; where-decls = []] + + + + +;;; Definitions for patterns + +;;; This is a simplification; the real syntax is complicated by +;;; rules for precedence and associativity. +;;; +;;; <pat> -> <pat> <conop> <pat> pcon +;;; -> <pat> + <integer> plus-pat +;;; -> - <integer-or-float> *** ??? const-pat? +;;; -> <apat> +;;; -> <con> <apat> .... <apat> pcon +;;; +;;; <apat> -> <var> var-pat +;;; -> <var> @ <apat> as-pat +;;; -> <con> *** ??? var-pat? +;;; -> <literal> const-pat +;;; -> _ wildcard-pat +;;; -> () pcon special case +;;; -> ( <pat> ) (grouping syntax) +;;; -> ( <pat> , ... , <pat> ) pcon special case +;;; -> [ <pat> , ... , <pat> ] list-pat +;;; -> ~ <apat> irr-pat + +(define-struct pattern + (include ast-node)) + +(define-struct apat + (include pattern)) + +(define-struct as-pat ;; var@pat + (include apat) + (slots + (var (type var-ref)) + (pattern (type pattern)))) + +(define-struct irr-pat ;; ~pat + (include apat) + (slots + (pattern (type pattern)))) + +(define-struct var-pat ;; v + (include apat) + (predicate var-pat?) + (slots + (var (type var-ref)))) + +(define-struct wildcard-pat ;; _ + (include apat) + (predicate wildcard-pat?)) + +(define-struct const-pat ;; literal + (include apat) + (predicate const-pat?) + (slots + (value (type const)) + ;; this is the code that actually performs the match. + ;; it's filled in by type phase. + (match-fn (type exp) (uninitialized? #t)))) + +(define-struct plus-pat ;; p+k + (include pattern) + (slots + (pattern (type pattern)) + (k (type integer)) + ;; code to check for match, filled in by type phase + (match-fn (type exp) (uninitialized? #t)) + ;; code to bind result, filled in by type phase + (bind-fn (type exp) (uninitialized? #t)) + )) + +(define-struct pcon ;; con pat1 pat2 ... + (include pattern) ;; pat1 con pat2 + (predicate pcon?) + (slots + (name (type symbol)) + (con (type def)) + (pats (type (list pattern))) + (infix? (type bool) (bit #t)))) + +(define-struct list-pat ;; [p1,p2,...] + (include apat) + (slots + (pats (type (list pattern))))) + +;;; The following structs deal with prec parsing of patterns. + +(define-struct pp-pat-list + (include pattern) + (slots + (pats (type (list pattern))))) + +(define-struct pp-pat-plus + (include pattern) + (predicate pp-pat-plus?)) + +(define-struct pp-pat-negated + (include pattern) + (predicate pp-pat-negated?)) + + + +;;; Structs for annotations + +(define-struct annotation + (include decl) + (predicate annotation?)) + +(define-struct annotation-decl + (include annotation) + (predicate annotation-decl?) + (slots + (names (type (list symbol))) + (annotations (type (list annotation-value))))) + +(define-struct annotation-value + (include annotation) + (predicate annotation-value?) + (slots + (name (type symbol)) + (args (type (list t))))) + +;;; This is a list of annotations placed in where decls lists in the same +;;; manner a signdecls. + +(define-struct annotation-decls + (include annotation) + (predicate annotation-decls?) + (slots + (annotations (type (list annotation))))) diff --git a/backend/README b/backend/README new file mode 100644 index 0000000..f221b1a --- /dev/null +++ b/backend/README @@ -0,0 +1,10 @@ +This directory contains the files for the compiler backend. All of these +phases operate on FLIC code. + +optimize -- performs various tweaks to compact the code and make it faster. + also includes a postpass to fill in some additional structure slots. + +strictness -- attaches strictness information to functions and decides + whether locally-bound variables have a boxed or unboxed representation. + +codegen -- generates Lisp code from the optimized FLIC code. diff --git a/backend/backend.scm b/backend/backend.scm new file mode 100644 index 0000000..b370ea7 --- /dev/null +++ b/backend/backend.scm @@ -0,0 +1,21 @@ +;;; backend.scm -- compilation unit for code generator stuff +;;; +;;; author : Sandra Loosemore +;;; date : 13 May 1992 +;;; + + +(define-compilation-unit backend + (source-filename "$Y2/backend/") + (require flic) + (unit optimize + (source-filename "optimize.scm")) + (unit strictness + (source-filename "strictness.scm")) + (unit box + (source-filename "box.scm")) + (unit codegen + (source-filename "codegen.scm")) + (unit interface-codegen + (source-filename "interface-codegen.scm"))) + diff --git a/backend/box.scm b/backend/box.scm new file mode 100644 index 0000000..c47848a --- /dev/null +++ b/backend/box.scm @@ -0,0 +1,417 @@ +;;; box.scm -- determine which expressions need to be boxed +;;; +;;; author : Sandra Loosemore +;;; date : 03 Apr 1993 +;;; +;;; +;;; This phase determines whether expressions need to be boxed or unboxed. +;;; +;;; In the case of an expression that needs to be boxed, it determines +;;; whether it can be evaluated eagerly and boxed or whether a delay +;;; must be constructed. +;;; +;;; In the case of an expression that needs to be unboxed, it determines +;;; whether it is already known to have been evaluated and can simply +;;; be unboxed instead of checking for a delay that must be forced. +;;; +;;; This phase may mark previously non-strict variables as strict if their +;;; initializers can be evaluated eagerly. However, doing this evaluation +;;; eagerly never causes any other non-strict variables to be forced, +;;; so there is no need to propagate this strictness information backwards +;;; (as happens in the var-strictness-walk pass). + + +;;;====================================================================== +;;; Top-level function +;;;====================================================================== + + +;;; Complexity computation + +(define-integrable delay-complexity 10) +(define-integrable unbox-complexity 1) +(define-integrable box-complexity 2) +(define-integrable sel-complexity 1) +(define-integrable is-constructor-complexity 1) +(define-integrable pack-complexity 2) +(define-integrable con-number-complexity 1) + +(define (add-complexity c1 c2) + (cond ((not c1) + '#f) + ((not c2) + '#f) + (else + ;; *** We might want to establish an arbitrary cutoff here. + ;; *** e.g., if complexity > N then set it to '#f. + (the fixnum (+ (the fixnum c1) (the fixnum c2)))))) + + + +;;; The second argument to the walker is a list of things +;;; that are known to have been forced already. +;;; The third argument is a list of variables that have not yet +;;; been initialized. +;;; Walkers return two values: a new value for already-forced and +;;; the complexity of the expression. + +;;; This helper function sets the unboxed? and cheap? bits for the +;;; code generator, and adjusts the basic complexity to account for +;;; forces, boxes, and delays. +;;; +;;; The basic decision tree for the code generator should be: +;;; if unboxed? +;;; then if strict-result? +;;; then generate x (1) +;;; else if cheap? +;;; then generate (unbox x) (2) +;;; else generate (force x) (3) +;;; else if strict-result? +;;; then if cheap? +;;; then generate (box x) (4) +;;; else generate (delay x) (5) +;;; else if cheap? +;;; then generate x (6) +;;; then generate (delay (force x)) (7) +;;; See function do-codegen in codegen.scm. + + +(define (do-box-analysis object already-forced uninitialized unboxed?) + (setf (flic-exp-unboxed? object) unboxed?) + (multiple-value-bind (result complexity) + (box-analysis object already-forced uninitialized) + (setf complexity + (if unboxed? + ;; If the expression returns a boxed value and we want + ;; an unboxed one, we may need to do a force. + (if (flic-exp-strict-result? object) + (begin ; case (1) + ;; this flic-exp-cheap? bit is used only by + ;; exp-would-be-cheap? below -- not by codegen + (setf (flic-exp-cheap? object) + (if complexity '#t '#f)) + complexity) + (if (already-forced? object already-forced) + (begin ; case (2) + (setf (flic-exp-cheap? object) '#t) + (add-complexity complexity unbox-complexity)) + (begin ; case (3) + (setf (flic-exp-cheap? object) '#f) + '#f))) + ;; We want a boxed value. If the expression already + ;; returns a boxed value, return its complexity directly; + ;; otherwise return the cost of either boxing or delaying it. + (if (flic-exp-strict-result? object) + (if complexity + (begin ; case (4) + (setf (flic-exp-cheap? object) '#t) + (add-complexity complexity box-complexity)) + (begin ; case (5) + (setf (flic-exp-cheap? object) '#f) + delay-complexity)) + (if complexity + (begin + (setf (flic-exp-cheap? object) '#t) ; case (6) + complexity) + (begin ; case (7) + (setf (flic-exp-cheap? object) '#f) + delay-complexity))) + )) + (values + (if unboxed? + (note-already-forced object result) + result) + complexity))) + + + + +;;;====================================================================== +;;; Code walk +;;;====================================================================== + + +(define *local-function-calls* '()) + +(define-flic-walker box-analysis (object already-forced uninitialized)) + +(define-box-analysis flic-lambda (object already-forced uninitialized) + (do-box-analysis (flic-lambda-body object) already-forced uninitialized '#t) + (values already-forced 0)) + +(define-box-analysis flic-let (object already-forced uninitialized) + (let ((bindings (flic-let-bindings object))) + (dynamic-let ((*local-function-calls* (dynamic *local-function-calls*))) + (dolist (var bindings) + ;; Note local functions + (when (and (not (var-toplevel? var)) + (is-type? 'flic-lambda (var-value var)) + (not (var-standard-refs? var))) + (push (cons var '()) (dynamic *local-function-calls*)))) + (multiple-value-bind (already-forced complexity) + (box-analysis-let-aux object already-forced uninitialized) + (dolist (var bindings) + ;; Go back and reexamine local functions to see whether + ;; we can make more arguments strict, based on the values + ;; the function is actually called with. + (let ((stuff (assq var (dynamic *local-function-calls*)))) + (when stuff + (maybe-make-more-arguments-strict var (cdr stuff))))) + (values already-forced complexity))))) + +(define (box-analysis-let-aux object already-forced uninitialized) + (let ((recursive? (flic-let-recursive? object)) + (bindings (flic-let-bindings object)) + (body (flic-let-body object))) + (when recursive? (setf uninitialized (append bindings uninitialized))) + (dolist (var bindings) + (let* ((value (var-value var)) + (strict? (var-strict? var)) + (result (do-box-analysis value already-forced uninitialized + strict?))) + (cond (strict? + ;; Propagate information about things forced. + (setf already-forced result)) + ((and (flic-exp-cheap? value) + (flic-exp-strict-result? value)) + ;; The value expression is cheap unboxed value, so mark + ;; the variable as strict. + (setf (var-strict? var) '#t) + (setf (flic-exp-unboxed? value) '#t)))) + (when recursive? (pop uninitialized))) + ;; *** Could be smarter about computing complexity. + (values + (do-box-analysis body already-forced uninitialized '#t) + '#f))) + +(define (maybe-make-more-arguments-strict var calls) + (setf (var-strictness var) + (maybe-make-more-arguments-strict-aux + (flic-lambda-vars (var-value var)) + calls))) + +(define (maybe-make-more-arguments-strict-aux vars calls) + (if (null? vars) + '() + (let ((var (car vars))) + ;; If the variable is not already strict, check to see + ;; whether it's always called with "cheap" arguments. + (when (and (not (var-strict? var)) + (every-1 (lambda (call) + (exp-would-be-cheap? (car call) var)) + calls)) + (setf (var-strict? var) '#t) + (dolist (call calls) + (setf (flic-exp-unboxed? (car call)) '#t))) + (cons (var-strict? var) + (maybe-make-more-arguments-strict-aux + (cdr vars) + (map (function cdr) calls)))) + )) + + +;;; Look for one special fixed-point case: argument used as counter-type +;;; variable. Otherwise ignore fixed points. + +(define (exp-would-be-cheap? exp var) + (or (and (flic-exp-cheap? exp) + (flic-exp-strict-result? exp)) + (and (is-type? 'flic-ref exp) + (eq? (flic-ref-var exp) var)) + (and (is-type? 'flic-app exp) + (is-type? 'flic-ref (flic-app-fn exp)) + (var-complexity (flic-ref-var (flic-app-fn exp))) + (every-1 (lambda (a) (exp-would-be-cheap? a var)) + (flic-app-args exp))) + )) + + + +(define-box-analysis flic-app (object already-forced uninitialized) + (let ((fn (flic-app-fn object)) + (args (flic-app-args object)) + (saturated? (flic-app-saturated? object))) + (cond ((and saturated? (is-type? 'flic-ref fn)) + (let* ((var (flic-ref-var fn)) + (stuff (assq var (dynamic *local-function-calls*)))) + (when stuff + (push args (cdr stuff))) + (box-analysis-app-aux + (var-strictness var) (var-complexity var) + args already-forced uninitialized))) + ((and saturated? (is-type? 'flic-pack fn)) + (box-analysis-app-aux + (con-slot-strict? (flic-pack-con fn)) pack-complexity + args already-forced uninitialized)) + (else + ;; The function is going to be forced but all the arguments + ;; are non-strict. + (dolist (a args) + (do-box-analysis a already-forced uninitialized '#f)) + (values + (do-box-analysis fn already-forced uninitialized '#t) + '#f)) + ))) + + + +;;; Propagation of already-forced information depends on whether or +;;; not the implementation evaluates function arguments in left-to-right +;;; order. If not, we can still propagate this information upwards. + +(define (box-analysis-app-aux + strictness complexity args already-forced uninitialized) + (let ((result already-forced)) + (dolist (a args) + (let ((strict? (pop strictness))) + (multiple-value-bind (new-result new-complexity) + (do-box-analysis a already-forced uninitialized strict?) + (when strict? + (setf result + (if left-to-right-evaluation + (setf already-forced new-result) + (union-already-forced + new-result already-forced result)))) + (setf complexity (add-complexity complexity new-complexity))))) + (values result complexity))) + + +(define-box-analysis flic-ref (object already-forced uninitialized) + (values + already-forced + (if (memq (flic-ref-var object) uninitialized) + '#f + 0))) + +(define-box-analysis flic-const (object already-forced uninitialized) + (declare (ignore object uninitialized)) + (values already-forced 0)) + +(define-box-analysis flic-pack (object already-forced uninitialized) + (declare (ignore object uninitialized)) + (values already-forced 0)) + + +;;; For case-block and and, already-forced information can be propagated +;;; sequentially in the clauses. But only the first expression is +;;; guaranteed to be evaluated, so only it can propagate the information +;;; outwards. + +(define-box-analysis flic-case-block (object already-forced uninitialized) + (values + (box-analysis-sequence + (flic-case-block-exps object) already-forced uninitialized) + '#f)) + +(define-box-analysis flic-and (object already-forced uninitialized) + (values + (box-analysis-sequence + (flic-and-exps object) already-forced uninitialized) + '#f)) + +(define (box-analysis-sequence exps already-forced uninitialized) + (let ((result + (setf already-forced + (do-box-analysis + (car exps) already-forced uninitialized '#t)))) + (dolist (e (cdr exps)) + (setf already-forced + (do-box-analysis e already-forced uninitialized '#t))) + (values result already-forced))) + + +(define-box-analysis flic-return-from (object already-forced uninitialized) + (values + (do-box-analysis + (flic-return-from-exp object) already-forced uninitialized '#t) + '#f)) + + +;;; For if, the test propagates to both branches and the result. +;;; Look for an important optimization: +;;; in (if (and e1 e2 ...) e-then e-else), +;;; e-then can inherit already-forced information from all of the ei +;;; rather than only from e1. +;;; *** Could be smarter about the complexity, I suppose.... +;;; *** Also could intersect already-forced results from both +;;; *** branches. + +(define-box-analysis flic-if (object already-forced uninitialized) + (if (is-type? 'flic-and (flic-if-test-exp object)) + (box-analysis-if-and-aux object already-forced uninitialized) + (box-analysis-if-other-aux object already-forced uninitialized))) + +(define (box-analysis-if-other-aux object already-forced uninitialized) + (setf already-forced + (do-box-analysis + (flic-if-test-exp object) already-forced uninitialized '#t)) + (do-box-analysis (flic-if-then-exp object) already-forced uninitialized '#t) + (do-box-analysis (flic-if-else-exp object) already-forced uninitialized '#t) + (values already-forced '#f)) + +(define (box-analysis-if-and-aux object already-forced uninitialized) + (let* ((test-exp (flic-if-test-exp object)) + (subexps (flic-and-exps test-exp)) + (then-exp (flic-if-then-exp object)) + (else-exp (flic-if-else-exp object))) + (setf (flic-exp-unboxed? test-exp) '#t) + (multiple-value-bind (result1 resultn) + (box-analysis-sequence subexps already-forced uninitialized) + (do-box-analysis then-exp resultn uninitialized '#t) + (do-box-analysis else-exp result1 uninitialized '#t) + (values result1 '#f)))) + + +(define-box-analysis flic-sel (object already-forced uninitialized) + (multiple-value-bind (result complexity) + (do-box-analysis + (flic-sel-exp object) already-forced uninitialized '#t) + (values result (add-complexity sel-complexity complexity)))) + +(define-box-analysis flic-is-constructor (object already-forced uninitialized) + (multiple-value-bind (result complexity) + (do-box-analysis + (flic-is-constructor-exp object) already-forced uninitialized '#t) + (values result (add-complexity is-constructor-complexity complexity)))) + +(define-box-analysis flic-con-number (object already-forced uninitialized) + (multiple-value-bind (result complexity) + (do-box-analysis + (flic-con-number-exp object) already-forced uninitialized '#t) + (values result (add-complexity con-number-complexity complexity)))) + +(define-box-analysis flic-void (object already-forced uninitialized) + (declare (ignore object uninitialized)) + (values already-forced 0)) + + + + +;;;====================================================================== +;;; Already-forced bookkeeping +;;;====================================================================== + + +;;; For now, we only keep track of variables that have been forced, +;;; and not data structure accesses. + +(define (already-forced? object already-forced) + (and (is-type? 'flic-ref object) + (memq (flic-ref-var object) already-forced))) + +(define (note-already-forced object already-forced) + (if (is-type? 'flic-ref object) + (cons (flic-ref-var object) already-forced) + already-forced)) + +(define (union-already-forced new tail result) + (cond ((eq? new tail) + result) + ((memq (car new) result) + (union-already-forced (cdr new) tail result)) + (else + (union-already-forced (cdr new) tail (cons (car new) result))) + )) + + + diff --git a/backend/codegen.scm b/backend/codegen.scm new file mode 100644 index 0000000..283594f --- /dev/null +++ b/backend/codegen.scm @@ -0,0 +1,600 @@ +;;; codegen.scm -- compile flic code to Lisp +;;; +;;; Author : Sandra Loosemore +;;; Date : 29 Apr 1992 +;;; +;;; to do: check completeness of special cases for constructors +;;; constants still need work +;;; optimized entry points +;;; +;;; The code generated here uses the following helper functions: +;;; (make-curried-fn opt-fn strictness) +;;; make a curried function that calls opt-fn after collecting the +;;; arguments and processing them according to strictness. Both +;;; the arguments are evaluated. +;;; (make-tuple-constructor arity) +;;; return a function that makes an untagged data structure with "arity" +;;; slots. "arity" is a constant. +;;; (make-tuple . args) +;;; uncurried version of the above +;;; (make-tagged-data-constructor n arity) +;;; return a function that makes a data structure with tag "n" and +;;; "arity" slots. +;;; (make-tagged-data n . args) +;;; uncurried version of the above +;;; (tuple-select arity i object) +;;; extract component "i" from untagged "object" +;;; (tagged-data-select arity i object) +;;; extract component "i" from tagged "object" +;;; (constructor-number object) +;;; return the tag from "object" +;;; (delay form) +;;; returns a delay object with unevaluated "form". +;;; (box form) +;;; returns a delay object with evaluated "form". +;;; (force delay) +;;; return the value of the delay object. +;;; (make-haskell-string string) +;;; Converts a Lisp string lazily to a haskell string (using a magic +;;; delay function). Returns an unboxed result. + + + +;;;====================================================================== +;;; Code walker +;;;====================================================================== + + +;;; Here is the main entry point. + +(define (codegen-top big-let) + (do ((bindings (flic-let-bindings big-let) (cdr bindings)) + (result '()) + (decls '())) + ((null? bindings) `(begin ,@(nreverse decls) ,@(nreverse result))) + (let ((var (car bindings))) + (push `(predefine ,(fullname var)) decls) + (push (codegen-definition var (var-value var)) result)))) + + +;;; See box.scm for more information about this... + +(define (do-codegen object) + (let ((x (codegen object)) + (unboxed? (flic-exp-unboxed? object)) + (strict-result? (flic-exp-strict-result? object)) + (cheap? (flic-exp-cheap? object))) + (if unboxed? + (if strict-result? + x + (if cheap? + `(unbox ,x) + `(force ,x))) + (if strict-result? + (if cheap? + `(box ,x) + `(delay ,x)) + (if cheap? + x + `(delay (force ,x))))))) + + +(define (do-codegen-list list) + (map (function do-codegen) list)) + + +(define-flic-walker codegen (object)) + + +;;; For top-level definitions bound to lambda expressions, make both +;;; a standard entry point (with possibly unboxed arguments) and +;;; a standard entry point. + +(define (codegen-definition var exp) + (let ((fullname (fullname var))) + (when (or (memq 'codegen (dynamic *printers*)) + (memq 'codegen-flic (dynamic *printers*))) +; (format '#t "~%Codegen of ~A [~A] " (def-name var) (struct-hash var)) + (format '#t "~%Codegen of ~A " (def-name var)) + (when (not (var-strict? var)) + (format '#t "Nonstrict ")) + (when (not (eq? (var-strictness var) '())) + (format '#t "Strictness: ") + (dolist (s (var-strictness var)) + (format '#t (if s "S " "N ")))) + (when (var-simple? var) + (format '#t " Inline ")) + (format '#t "~%") + (when (memq 'codegen-flic (dynamic *printers*)) + (pprint* exp))) + (let ((lisp-code + (if (not (flic-lambda? exp)) + `(define ,fullname ,(do-codegen exp)) + (let* ((optname (optname var)) + (lambda (codegen-lambda-aux exp)) + (def `(define (,optname ,@(cadr lambda)) + ,@(cddr lambda)))) + (if (var-selector-fn? var) + ;; Standard entry point for selectors is never used. + def + `(begin + ,def + (define ,fullname + ,(maybe-make-box-value + (codegen-curried-fn + `(function ,optname) (var-strictness var)) + (var-strict? var))))))))) + (when (or (memq 'codegen (dynamic *printers*)) + (memq 'codegen-flic (dynamic *printers*))) + (pprint* lisp-code)) + lisp-code))) + +(define (codegen-lambda-list vars) + (map (function fullname) vars)) + +(define (codegen-curried-fn opt-fn strictness) + (if (null? (cdr strictness)) + ;; one-argument special cases + (if (car strictness) + `(make-curried-fn-1-strict ,opt-fn) + `(make-curried-fn-1-nonstrict ,opt-fn)) + ;; general case + `(make-curried-fn ,opt-fn ',strictness))) + + +;;; Curry lambdas. Functions always return an unboxed value. + +(define-codegen flic-lambda (object) + (codegen-curried-fn + (codegen-lambda-aux object) + (map (lambda (x) (var-strict? x)) (flic-lambda-vars object)))) + +(define (codegen-lambda-aux object) + (let* ((vars (flic-lambda-vars object)) + (ignore '()) + (args (codegen-lambda-list vars))) + (dolist (v vars) + (if (eqv? (var-referenced v) 0) + (push (fullname v) ignore))) + `(lambda ,args + ,@(if (not (null? ignore)) + `((declare (ignore ,@ignore))) + '()) + ,(do-codegen (flic-lambda-body object))))) + + +;;; This is only for non-top-level lets. +;;; The boxing of the value of each of the bindings is controlled by its +;;; strict? property. + +(define-codegen flic-let (object) + (let ((bindings (flic-let-bindings object)) + (body (flic-let-body object)) + (recursive? (flic-let-recursive? object))) + (if recursive? + (codegen-letrec bindings body) + (codegen-let* bindings body)))) + + +;;; For efficiency reasons, we want to make all the function bindings +;;; in the function namespace (some implementations do not do tail-recursion +;;; or other optimizations correctly otherwise). This means we have +;;; to sort out the variable bindings from the function bindings here. + +(define (codegen-letrec bindings body) + (let ((let-bindings '()) + (labels-bindings '())) + (dolist (var bindings) + (let ((value (var-value var)) + (fullname (fullname var)) + (strict? (var-strict? var))) + (if (flic-lambda? value) + ;; Some functions may need only the optimized or standard + ;; entry points, but not both. + (let ((optname (optname var)) + (lambda (codegen-lambda-aux value)) + (optimized? (var-optimized-refs? var)) + (standard? (var-standard-refs? var))) + (when standard? + (push (list fullname + (maybe-make-box-value + (codegen-curried-fn + (if optimized? `(function ,optname) lambda) + (var-strictness var)) + strict?)) + let-bindings)) + (when optimized? + (push (cons optname (cdr lambda)) labels-bindings))) + (push (list fullname (do-codegen value)) let-bindings)))) + (setf let-bindings (nreverse let-bindings)) + (setf labels-bindings (nreverse labels-bindings)) + (cond ((null? let-bindings) + `(labels ,labels-bindings ,(do-codegen body))) + ((null? labels-bindings) + `(letrec ,let-bindings ,(do-codegen body))) + (t + `(let ,(map (lambda (b) `(,(car b) '#f)) let-bindings) + (labels ,labels-bindings + ,@(map (lambda (b) `(setf ,@b)) let-bindings) + ,(do-codegen body)))) + ))) + +(define (codegen-let* bindings body) + (if (null? bindings) + (do-codegen body) + (let* ((var (car bindings)) + (value (var-value var)) + (fullname (fullname var)) + (strict? (var-strict? var)) + (body (codegen-let* (cdr bindings) body))) + (if (flic-lambda? value) + ;; Some functions may need only the optimized or standard + ;; entry points, but not both. + (let ((optname (optname var)) + (lambda (codegen-lambda-aux value)) + (optimized? (var-optimized-refs? var)) + (standard? (var-standard-refs? var))) + (when standard? + (setf body + (add-let-binding + (list fullname + (maybe-make-box-value + (codegen-curried-fn + (if optimized? `(function ,optname) lambda) + (var-strictness var)) + strict?)) + body))) + (when optimized? + (setf body `(flet ((,optname ,@(cdr lambda))) ,body))) + body) + (add-let-binding (list fullname (do-codegen value)) body))))) + +(define (add-let-binding binding body) + (if (and (pair? body) (eq? (car body) 'let*)) + `(let* (,binding ,@(cadr body)) ,@(cddr body)) + `(let* (,binding) ,body))) + + +(define-codegen flic-app (object) + (let ((fn (flic-app-fn object)) + (args (flic-app-args object)) + (saturated? (flic-app-saturated? object))) + (cond ((and saturated? (flic-pack? fn)) + ;; Saturated call to constructor + (codegen-constructor-app-aux + (flic-pack-con fn) + (do-codegen-list args))) + ((and saturated? (flic-ref? fn)) + ;; Saturated call to named function + (let* ((var (flic-ref-var fn)) + (optname (optname var)) + (argcode (do-codegen-list args))) + `(,optname ,@argcode))) + (else + ;; Have to make a curried call to standard entry point. + (let ((fncode (do-codegen fn)) + (argcode (do-codegen-list args))) + (if (and (pair? fncode) + (eq? (car fncode) 'force)) + `(funcall-force ,(cadr fncode) ,@argcode) + `(funcall ,fncode ,@argcode)))) + ))) + +(define (codegen-constructor-app-aux con argcode) + (let ((alg (con-alg con))) + (cond ((eq? con (core-symbol ":")) + `(cons ,@argcode)) + ((algdata-implemented-by-lisp? alg) + (apply-maybe-lambda (cadr (con-lisp-fns con)) argcode)) + ((algdata-tuple? alg) + `(make-tuple ,@argcode)) + (else + `(make-tagged-data ,(con-tag con) ,@argcode))))) + + +(define-codegen flic-ref (object) + (fullname (flic-ref-var object))) + + +(define-codegen flic-const (object) + (let ((value (flic-const-value object))) + (cond ((string? value) + `(make-haskell-string ,value)) + ((char? value) + ;; *** I think the parser ought to convert characters to their + ;; *** ASCII codes instead of doing it here. There are problems + ;; *** with valid Haskell characters that can't be represented + ;; *** portably as Lisp characters. + (char->integer value)) + ((number? value) + value) + (else + ;; It must be a ratio. This is a bit of a hack - this depends on + ;; the fact that 2 tuples are represented in the same manner as + ;; rationals. Hacked for strict rationals - jcp + `(make-tuple ,(car value) ,(cadr value))) + ))) + + +;;; Returns a function or constant, so doesn't need to delay result. +;;; See flic-app for handling of saturated constructor calls. + +(define-codegen flic-pack (object) + (let* ((con (flic-pack-con object)) + (arity (con-arity con)) + (alg (con-alg con)) + (tuple? (algdata-tuple? alg)) + (strictness (con-slot-strict? con)) + (index (con-tag con))) + (cond ((eq? con (core-symbol "Nil")) + ''()) + ((eq? con (core-symbol "True")) + ''#t) + ((eq? con (core-symbol "False")) + ''#f) + ((eq? con (core-symbol ":")) + '(function make-cons-constructor)) + ((algdata-implemented-by-lisp? alg) + (let ((fn (cadr (con-lisp-fns con)))) + (if (eqv? (con-arity con) 0) + fn + (codegen-curried-fn + (if (and (pair? fn) (eq? (car fn) 'lambda)) + fn + `(function ,fn)) + strictness)))) + ((algdata-enum? alg) + ;; All constructors have 0 arity; represent them just + ;; by numbers. + index) + (tuple? + ;; Only a single constructor for this type. + (codegen-curried-fn + `(make-tuple-constructor ,arity) + strictness)) + ((eqv? arity 0) + ;; No arguments to this constructor. + `(make-tagged-data ,index)) + (else + ;; General case. + (codegen-curried-fn + `(make-tagged-data-constructor ,index ,arity) + strictness)) + ))) + + + +;;; These expressions translate directly into their Lisp equivalents. + +(define-codegen flic-case-block (object) + `(block ,(flic-case-block-block-name object) + ,@(do-codegen-list (flic-case-block-exps object)))) + +(define-codegen flic-return-from (object) + `(return-from ,(flic-return-from-block-name object) + ,(do-codegen (flic-return-from-exp object)))) + +(define-codegen flic-and (object) + `(and ,@(do-codegen-list (flic-and-exps object)))) + +(define-codegen flic-if (object) + `(if ,(do-codegen (flic-if-test-exp object)) + ,(do-codegen (flic-if-then-exp object)) + ,(do-codegen (flic-if-else-exp object)))) + +(define-codegen flic-sel (object) + (codegen-flic-sel-aux + (flic-sel-con object) + (flic-sel-i object) + (do-codegen (flic-sel-exp object)))) + +(define (codegen-flic-sel-aux con index exp) + (let* ((alg (con-alg con)) + (tuple? (algdata-tuple? alg)) + (arity (con-arity con))) + (cond ((eq? con (core-symbol ":")) + (if (eqv? index 0) + `(car ,exp) + `(cdr ,exp))) + ((algdata-implemented-by-lisp? alg) + (apply-maybe-lambda (list-ref (cddr (con-lisp-fns con)) index) + (list exp))) + (tuple? + `(tuple-select ,arity ,index ,exp)) + (else + `(tagged-data-select ,arity ,index ,exp)) + ))) + +(define-codegen flic-is-constructor (object) + (codegen-flic-is-constructor-aux + (flic-is-constructor-con object) + (do-codegen (flic-is-constructor-exp object)))) + +(define (codegen-flic-is-constructor-aux con exp) + (let ((type (con-alg con))) + (cond ((eq? type (core-symbol "Bool")) + (if (eq? con (core-symbol "True")) + exp + `(not ,exp))) + ((eq? type (core-symbol "List")) + (if (eq? con (core-symbol ":")) + `(pair? ,exp) + `(null? ,exp))) + ((algdata-implemented-by-lisp? type) + (let ((fn (car (con-lisp-fns con)))) + (apply-maybe-lambda fn (list exp)))) + ((algdata-tuple? type) + ;; This should never happen. + ''#t) + ((algdata-enum? type) + `(eqv? (the fixnum ,exp) (the fixnum ,(con-tag con)))) + (else + `(eqv? (the fixnum (constructor-number ,exp)) + (the fixnum ,(con-tag con)))) + ))) + + +(define-codegen flic-con-number (object) + (let ((type (flic-con-number-type object)) + (exp (do-codegen (flic-con-number-exp object)))) + `(the fixnum + ,(cond ((eq? type (core-symbol "Bool")) + `(if ,exp 1 0)) + ((eq? type (core-symbol "List")) + `(if (pair? ,exp) 0 1)) + ((algdata-tuple? type) + ;; This should never happen. + 0) + ((algdata-implemented-by-lisp? type) + (let ((var (gensym))) + `(let ((,var ,exp)) + (cond ,@(map (lambda (con) + `(,(apply-maybe-lambda + (car (con-lisp-fns con)) + (list var)) + ',(con-tag con))) + (algdata-constrs type)) + (else (error "No constructor satisfies ~A.~%" + ',(def-name type))))))) + ((algdata-enum? type) + exp) + (else + `(constructor-number ,exp)) + )) + )) + + + +;;;====================================================================== +;;; Utility functions +;;;====================================================================== + +;;; Here are some helper functions for handing boxing and unboxing +;;; of values. +;;; maybe-make-box-delay is used to box forms that are "expensive" to +;;; compute; maybe-make-box-value is used to box forms like constants +;;; or functions that are "cheap" to compute eagerly. +;;; Maybe-unbox is used to unbox a form that returns a boxed result. + +(define (maybe-make-box-delay form unboxed?) + (if unboxed? + form + `(delay ,form))) + +(define (maybe-make-box-value form unboxed?) + (if unboxed? + form + `(box ,form))) + +(define (maybe-unbox form unboxed?) + (if unboxed? + `(force ,form) + form)) + + +;;; These two var slots are filled in lazily by the code generator, +;;; since most vars generated don't need them. You should always +;;; use these functions instead of accessing the structure slot +;;; directly. + +(define (fullname var) + (or (var-fullname var) + (setf (var-fullname var) + (if (var-toplevel? var) + ;; For toplevel names, use module name glued onto base names. + ;; These are always interned symbols. + (if (def-core? var) + (symbol-append '|*Core:| (def-name var)) + (symbol-append (def-module var) '\: (def-name var))) + ;; Otherwise, make sure we have a gensym. + ;; The uniquification of interned symbols is required + ;; because there may be multiple nested bindings of the + ;; same name, and we want to be able to distinguish between + ;; the different bindings. + (let ((name (def-name var))) + (if (gensym? name) + name + (gensym (symbol->string name)))))) + )) + +(define (optname var) + (or (var-optimized-entry var) + (let ((name (string-append (symbol->string (fullname var)) "/OPT"))) + (setf (var-optimized-entry var) + (if (var-toplevel? var) + (string->symbol name) + (gensym name)))))) + + + +;;;====================================================================== +;;; Exported functions +;;;====================================================================== + +;;; This handles types exported to lisp from Haskell +;;; *** Is this really supposed to create variable bindings as +;;; *** opposed to function bindings??? +;;; *** I assume all of these functions want strict arguments and return +;;; *** strict results, even if the data structures contain boxed values. + +(define (codegen-exported-types mods) + (let ((defs '())) + (dolist (m mods) + (dolist (a (module-alg-defs m)) + (when (algdata-export-to-lisp? a) + (dolist (c (algdata-constrs a)) + (setf defs (nconc (codegen-constr c) defs)))))) + `(begin ,@defs))) + +(define (codegen-constr c) + (let ((lisp-fns (con-lisp-fns c))) + (if c + (let ((res + `(,(codegen-lisp-predicate (car lisp-fns) c) + ,(codegen-lisp-constructor (cadr lisp-fns) c) + ,@(codegen-lisp-accessors + (cddr lisp-fns) (con-slot-strict? c) c 0)))) + (when (memq 'codegen (dynamic *printers*)) + (dolist (d res) + (pprint* d))) + res) + '()))) + +(define (codegen-lisp-predicate name c) + `(define (,name x) + ,(codegen-flic-is-constructor-aux c 'x))) + +(define (codegen-lisp-constructor name c) + (let ((strictness (con-slot-strict? c)) + (args '()) + (exps '())) + (dolist (s strictness) + (let ((arg (gensym))) + (push arg args) + (push (if s arg `(box ,arg)) exps))) + `(define (,name ,@(nreverse args)) + ,(codegen-constructor-app-aux c (nreverse exps))))) + +(define (codegen-lisp-accessors names strictness c i) + (declare (type fixnum i)) + (if (null? names) + '() + (let ((body (codegen-flic-sel-aux c i 'x))) + (when (not (car strictness)) + (setf body `(force ,body))) + (cons `(define (,(car names) x) ,body) + (codegen-lisp-accessors (cdr names) (cdr strictness) c (+ i 1)))) + )) + + + +;;; This is a special hack needed due to brain-dead common lisp problems. +;;; This allows the user to place lambda defined functions in ImportLispType +;;; *** I'm not convinced this is necessary; ((lambda ...) args) +;;; *** is perfectly valid Common Lisp syntax! + +(define (apply-maybe-lambda fn args) + (if (and (pair? fn) + (eq? (car fn) 'lambda)) + `(funcall ,fn ,@args) + `(,fn ,@args))) diff --git a/backend/interface-codegen.scm b/backend/interface-codegen.scm new file mode 100644 index 0000000..50c8630 --- /dev/null +++ b/backend/interface-codegen.scm @@ -0,0 +1,200 @@ + +;;; This generates code for vars defined in an interface. This looks at +;;; annotations and fills in the slots of the var definition. + +(define (haskell-codegen/interface mods) + (codegen/interface (car mods))) + +(define (codegen/interface mod) + (let ((code '())) + (dolist (d (module-decls mod)) + (when (not (signdecl? d)) + (error 'bad-decl)) + (dolist (var (signdecl-vars d)) + (let ((v (var-ref-var var))) + (setf (var-type v) (var-signature v)) + (setf (var-toplevel? v) '#t) + (let ((a (lookup-annotation v '|Complexity|))) + (when (not (eq? a '#f)) + (setf (var-complexity v) + (car (annotation-value-args a))))) + (let ((a (lookup-annotation v '|LispName|))) + (when (not (eq? a '#f)) + (let ((lisp-entry (generate-lisp-entry v a))) + (push lisp-entry code) + (when (memq 'codegen (dynamic *printers*)) + (pprint* lisp-entry)))))))) + `(begin ,@code))) + +(define (generate-lisp-entry v a) + (let ((lisp-name (read-lisp-object (car (annotation-value-args a)))) + (type (maybe-expand-io-type (gtype-type (var-type v))))) + (setf (var-optimized-entry v) lisp-name) + (if (arrow-type? type) + (codegen-lisp-fn v (gather-arg-types type)) + (codegen-lisp-const v type)))) + +(define (codegen-lisp-fn var arg-types) + (let* ((aux-definition '()) + (wrapper? (foreign-fn-needs-wrapper? var arg-types)) + (strictness-annotation (lookup-annotation var '|Strictness|)) + (strictness (determine-strictness strictness-annotation arg-types)) + (temps (gen-temp-names strictness))) + (setf (var-strict? var) '#t) + (setf (var-arity var) (length strictness)) + (setf (var-strictness var) strictness) + (when wrapper? + (mlet (((code name) + (make-wrapper-fn var (var-optimized-entry var) arg-types))) + (setf (var-optimized-entry var) name) + (setf aux-definition (list code)))) + `(begin ,@aux-definition + (define ,(fullname var) + ,(maybe-make-box-value + (codegen-curried-fn + (if wrapper? + `(function ,(var-optimized-entry var)) + `(lambda ,temps + (,(var-optimized-entry var) ,@temps))) + (var-strictness var)) + '#t))))) + +(define (determine-strictness a args) + (if (eq? a '#f) + (map (lambda (x) (declare (ignore x)) '#t) (cdr args)) + (parse-strictness (car (annotation-value-args a))))) + +(define (codegen-lisp-const var type) + (let ((conversion-fn (output-conversion-fn type))) + (setf (var-strict? var) '#f) + (setf (var-arity var) 0) + (setf (var-strictness var) '()) + `(define ,(fullname var) + (delay + ,(if (eq? conversion-fn '#f) + (var-optimized-entry var) + `(,@conversion-fn ,(var-optimized-entry var))))))) + +(define (maybe-expand-io-type ty) + (cond ((and (ntycon? ty) + (eq? (ntycon-tycon ty) (core-symbol "IO"))) + (**ntycon (core-symbol "Arrow") + (list (**ntycon (core-symbol "SystemState") '()) + (**ntycon (core-symbol "IOResult") + (ntycon-args ty))))) + ((arrow-type? ty) + (**ntycon (core-symbol "Arrow") + (list (car (ntycon-args ty)) + (maybe-expand-io-type (cadr (ntycon-args ty)))))) + (else ty))) + +(define (gather-arg-types type) + (if (arrow-type? type) + (let ((a (ntycon-args type))) + (cons (car a) (gather-arg-types (cadr a)))) + (list type))) + +(define (input-conversion-fn ty) + (if (ntycon? ty) + (let ((tycon (ntycon-tycon ty))) + (cond ((eq? tycon (core-symbol "String")) + (lambda (x) `(haskell-string->string ,x))) + ((eq? tycon (core-symbol "List")) ; needs to convert elements + (let ((var (gensym "X")) + (inner-fn (input-conversion-fn (car (ntycon-args ty))))) + (lambda (x) `(haskell-list->list + (lambda (,var) + ,(if (eq? inner-fn '#f) + var + (funcall inner-fn var))) + ,x)))) + ((eq? tycon (core-symbol "Char")) + (lambda (x) `(integer->char ,x))) + (else '#f))) + '#f)) + +(define (output-conversion-fn ty) + (if (ntycon? ty) + (let ((tycon (ntycon-tycon ty))) + (cond ((eq? tycon (core-symbol "String")) + (lambda (x) `(make-haskell-string ,x))) + ((eq? tycon (core-symbol "List")) + (let ((var (gensym "X")) + (inner-fn (output-conversion-fn (car (ntycon-args ty))))) + (lambda (x) `(list->haskell-list + (lambda (,var) + ,(if (eq? inner-fn '#f) + var + (funcall inner-fn var))) + ,x)))) + ((eq? tycon (core-symbol "UnitType")) + (lambda (x) `(insert-unit-value ,x))) + ((eq? tycon (core-symbol "IOResult")) + (lambda (x) + (let ((c1 (output-conversion-fn (car (ntycon-args ty))))) + `(box ,(apply-conversion c1 x))))) + (else '#f))) + '#f)) + +(define (apply-conversion fn x) + (if (eq? fn '#f) + x + (funcall fn x))) + +(define (foreign-fn-needs-wrapper? var args) + (if (lookup-annotation var '|NoConversion|) + '#f + (ffnw-1 args))) + +(define (ffnw-1 args) + (if (null? (cdr args)) + (not (eq? (output-conversion-fn (car args)) '#f)) + (or (not (eq? (input-conversion-fn (car args)) '#f)) + (systemstate? (car args)) + (ffnw-1 (cdr args))))) + +(define (make-wrapper-fn var fn args) + (mlet ((new-fn (symbol-append (fullname var) '|/wrapper|)) + (avars (gen-temp-names (cdr args))) + (ignore-state? (systemstate? (cadr (reverse args)))) + ((arg-conversions res-conversion) + (collect-conversion-fns avars args))) + (values + `(define (,new-fn ,@avars) + ,@(if ignore-state? `((declare (ignore ,(car (last avars))))) + '()) + ,@arg-conversions + ,(apply-conversion res-conversion + `(,fn ,@(if ignore-state? + (butlast avars) + avars)))) + new-fn))) + +(define (collect-conversion-fns avars args) + (if (null? avars) + (values '() (output-conversion-fn (car args))) + (mlet ((fn (input-conversion-fn (car args))) + ((c1 r) (collect-conversion-fns (cdr avars) (cdr args)))) + (values (if (eq? fn '#f) + c1 + `((setf ,(car avars) ,(funcall fn (car avars))) ,@c1)) + r)))) + +(define (arrow-type? x) + (and (ntycon? x) + (eq? (ntycon-tycon x) (core-symbol "Arrow")))) + +(define (systemstate? x) + (and (ntycon? x) + (eq? (ntycon-tycon x) (core-symbol "SystemState")))) + +(define (gen-temp-names l) + (gen-temp-names-1 l '(A B C D E F G H I J K L M N O P))) + +(define (gen-temp-names-1 l1 l2) + (if (null? l1) + '() + (if (null? l2) + (gen-temp-names-1 l1 (list (gensym "T"))) + (cons (car l2) (gen-temp-names-1 (cdr l1) (cdr l2)))))) + diff --git a/backend/optimize.scm b/backend/optimize.scm new file mode 100644 index 0000000..1624e35 --- /dev/null +++ b/backend/optimize.scm @@ -0,0 +1,1986 @@ +;;; optimize.scm -- flic optimizer +;;; +;;; author : Sandra Loosemore +;;; date : 7 May 1992 +;;; +;;; +;;; The optimizer does these kinds of program transformations: +;;; +;;; * remove unreferenced variable bindings. +;;; +;;; * constant folding and various other kinds of compile-time +;;; evaluation. +;;; +;;; * beta reduction (replace references to variables bound to simple +;;; expressions with the expression) +;;; + + +;;; Since some of the optimizations can make additional transformations +;;; possible, we want to make multiple iteration passes. But since each +;;; pass is likely to have diminishing benefits, we don't want to keep +;;; iterating indefinitely. So establish a fairly arbitrary cutoff point. +;;; The value is based on empirical results from compiling the prelude. + +(define *max-optimize-iterations* 5) +(define *optimize-foldr-iteration* 0) ; when to inline foldr +(define *optimize-build-iteration* 0) ; when to inline build +(define *current-optimize-iteration* 0) + + +;;; Flags for enabling various optimizations + +(define *all-optimizers* '(foldr inline constant lisp)) +(define *optimizers* *all-optimizers*) + + +;;; Used to note whether we are doing the various optimizations + +(define-local-syntax (do-optimization? o) + `(memq ,o (dynamic *optimizers*))) + +(define *do-foldr-optimizations* (do-optimization? 'foldr)) +(define *do-inline-optimizations* (do-optimization? 'inline)) +(define *do-constant-optimizations* (do-optimization? 'constant)) + + +;;; If the foldr optimization is enabled, bind the corresponding +;;; variables to these values instead of the defaults. + +(define *foldr-max-optimize-iterations* 15) +(define *foldr-optimize-foldr-iteration* 8) +(define *foldr-optimize-build-iteration* 5) + + +;;; Some random other variables + +(define *structured-constants* '()) +(define *structured-constants-table* '#f) +(define *lambda-depth* 0) +(define *local-bindings* '()) + + +;;; This is for doing some crude profiling. +;;; Comment out the body of the macro to disable profiling. + +;;; Here are current counts from compiling the prelude: +;;; (LET-REMOVE-UNUSED-BINDING . 5835) +;;; (REF-INLINE-SINGLE-REF . 2890) +;;; (REF-INLINE . 2692) +;;; (LET-EMPTY-BINDINGS . 2192) +;;; (APP-LAMBDA-TO-LET . 1537) +;;; (APP-MAKE-SATURATED . 416) +;;; (LET-HOIST-RETURN-FROM . 310) +;;; (CASE-BLOCK-IDENTITY . 273) +;;; (CASE-BLOCK-DEAD-CODE . 234) +;;; (CASE-BLOCK-TO-IF . 212) +;;; (SEL-FOLD-VAR . 211) +;;; (APP-HOIST-LET . 190) +;;; (LET-HOIST-LAMBDA . 181) +;;; (FOLDR-INLINE . 176) +;;; (AND-UNARY . 172) +;;; (LAMBDA-COMPRESS . 168) +;;; (APP-FOLD-SELECTOR . 141) +;;; (BUILD-INLINE-LAMBDA . 134) +;;; (LET-COMPRESS . 134) +;;; (IF-FOLD . 128) +;;; (INTEGER-TO-INT-CONSTANT-FOLD . 124) +;;; (AND-COMPRESS . 94) +;;; (APP-COMPRESS . 93) +;;; (FOLDR-CONS-IDENTITY . 69) +;;; (IF-COMPRESS-TEST . 65) +;;; (IF-HOIST-LAMBDA . 61) +;;; (APP-HOIST-STRUCTURED-CONSTANT . 60) +;;; (FOLDR-PRIM-APPEND-INLINE . 55) +;;; (FOLDR-BUILD-IDENTITY . 40) +;;; (CASE-BLOCK-DISCARD-REDUNDANT-TEST . 37) +;;; (FOLDR-NIL-IDENTITY . 36) +;;; (LET-HOIST-INVARIANT-ARGS . 30) +;;; (FOLDR-HOIST-LET . 28) +;;; (CON-NUMBER-FOLD-TUPLE . 21) +;;; (FOLDR-CONS-NIL-IDENTITY . 15) +;;; (AND-CONTAINS-TRUE . 14) +;;; (IF-IDENTITY-INVERSE . 8) +;;; (IF-HOIST-RETURN-FROM . 7) +;;; (CASE-BLOCK-HOIST-LET . 7) +;;; (INTEGER-TO-INT-IDENTITY . 7) +;;; (APP-PACK-IDENTITY . 2) +;;; (CON-NUMBER-FOLD . 2) +;;; (IF-IDENTITY . 2) +;;; (INT-TO-INTEGER-CONSTANT-FOLD . 2) +;;; (LET-HOIST-STRUCTURED-CONSTANT . 1) + + +(define-local-syntax (record-hack type . args) + (declare (ignore args)) + `',type +; `(record-hack-aux ,type ,@args) + ) + +(define *hacks-done* '()) + +(define (record-hack-aux type . args) + ;; *** debug + ;; (format '#t "~s ~s~%" type args) + (declare (ignore args)) + (let ((stuff (assq type (car (dynamic *hacks-done*))))) + (if stuff + (incf (cdr stuff)) + (push (cons type 1) (car (dynamic *hacks-done*)))))) + +(define (total-hacks) + (let ((totals '())) + (dolist (alist *hacks-done*) + (dolist (entry alist) + (let ((stuff (assq (car entry) totals))) + (if stuff + (setf (cdr stuff) (+ (cdr stuff) (cdr entry))) + (push (cons (car entry) (cdr entry)) totals))))) + totals)) + + +;;; This is the main entry point. + +(define (optimize-top object) + (dynamic-let ((*structured-constants* '()) + (*structured-constants-table* (make-table)) + (*lambda-depth* 0) + (*local-bindings* '()) + (*do-inline-optimizations* + (do-optimization? 'inline)) + (*do-constant-optimizations* + (do-optimization? 'constant)) + (*max-optimize-iterations* + (if (do-optimization? 'foldr) + (dynamic *foldr-max-optimize-iterations*) + (dynamic *max-optimize-iterations*))) + (*optimize-foldr-iteration* + (if (do-optimization? 'foldr) + (dynamic *foldr-optimize-foldr-iteration*) + (dynamic *optimize-foldr-iteration*))) + (*optimize-build-iteration* + (if (do-optimization? 'foldr) + (dynamic *foldr-optimize-build-iteration*) + (dynamic *optimize-build-iteration*)))) + (setf *hacks-done* '()) + (dotimes (i (dynamic *max-optimize-iterations*)) + (dynamic-let ((*current-optimize-iteration* i)) +;; debug (*duplicate-object-table* (make-table))) + (when (memq 'optimize-extra (dynamic *printers*)) + (format '#t "~%Optimize pass ~s:" i) + (pprint object)) + (push '() *hacks-done*) + (setf object (optimize-flic-let-aux object '#t)))) + (setf (flic-let-bindings object) + (nconc (nreverse (dynamic *structured-constants*)) + (flic-let-bindings object)))) + (install-uninterned-globals (flic-let-bindings object)) + (postoptimize object) + object) + + +(define-flic-walker optimize (object)) + +;;; debugging stuff +;;; +;;; (define *duplicate-object-table* (make-table)) +;;; +;;; (define (new-optimize object) +;;; (if (table-entry (dynamic *duplicate-object-table*) object) +;;; (error "Duplicate object ~s detected." object) +;;; (begin +;;; (setf (table-entry (dynamic *duplicate-object-table*) object) '#t) +;;; (old-optimize object)))) +;;; +;;; (lisp:setf (lisp:symbol-function 'old-optimize) +;;; (lisp:symbol-function 'optimize)) +;;; (lisp:setf (lisp:symbol-function 'optimize) +;;; (lisp:symbol-function 'new-optimize)) + +(define (optimize-list objects) + (optimize-list-aux objects) + objects) + +(define (optimize-list-aux objects) + (if (null? objects) + '() + (begin + (setf (car objects) (optimize (car objects))) + (optimize-list-aux (cdr objects))))) + + +;;; Compress nested lambdas. This hack is desirable because saturating +;;; applications within the lambda body effectively adds additional +;;; parameters to the function. + +;;; *** Maybe this should look for hoistable constant lambdas too. + +(define-optimize flic-lambda (object) + (let ((vars (flic-lambda-vars object))) + (dynamic-let ((*lambda-depth* (1+ (dynamic *lambda-depth*))) + (*local-bindings* (cons vars (dynamic *local-bindings*)))) + (dolist (var vars) + (setf (var-referenced var) 0)) + (let ((new-body (optimize (flic-lambda-body object)))) + (setf (flic-lambda-body object) new-body) + (cond ((is-type? 'flic-lambda new-body) + (record-hack 'lambda-compress) + (setf (flic-lambda-vars object) + (nconc (flic-lambda-vars object) + (flic-lambda-vars new-body))) + (setf (flic-lambda-body object) (flic-lambda-body new-body))) + (else + '#f)) + object)))) + + +;;; For let, first mark all variables as unused and check for "simple" +;;; binding values that permit beta reduction. Then walk the subexpressions. +;;; Finally discard any bindings that are still marked as unused. +;;; *** This fails to detect unused recursive variables. + +(define-optimize flic-let (object) + (optimize-flic-let-aux object '#f)) + +(define (optimize-flic-let-aux object toplevel?) + (let ((bindings (flic-let-bindings object)) + (recursive? (flic-let-recursive? object))) + ;; *** This handling of *local-bindings* isn't quite right since + ;; *** it doesn't account for the sequential nature of bindings + ;; *** in a non-recursive let, but it's close enough. We won't + ;; *** get any semantic errors, but it might miss a few optimizations. + (dynamic-let ((*local-bindings* + (if (and recursive? (not toplevel?)) + (cons bindings (dynamic *local-bindings*)) + (dynamic *local-bindings*)))) + (optimize-flic-let-bindings bindings recursive? toplevel?) + (dynamic-let ((*local-bindings* + (if (and (not recursive?) (not toplevel?)) + (cons bindings (dynamic *local-bindings*)) + (dynamic *local-bindings*)))) + (setf (flic-let-body object) (optimize (flic-let-body object)))) + ;; Check for unused bindings and other rewrites. + ;; Only do this for non-toplevel lets. + (if toplevel? + object + (optimize-flic-let-rewrite object bindings recursive?))))) + +(define (optimize-flic-let-bindings bindings recursive? toplevel?) + ;; Initialize + (dolist (var bindings) + (setf (var-referenced var) 0) + (setf (var-fn-referenced var) 0) + (when (is-type? 'flic-lambda (var-value var)) + (dolist (v (flic-lambda-vars (var-value var))) + (setf (var-arg-invariant? v) '#t) + (setf (var-arg-invariant-value v) '#f)))) + ;; Traverse value subforms + (do ((bindings bindings (cdr bindings))) + ((null? bindings) '#f) + (let* ((var (car bindings)) + (val (var-value var))) + (if (and (is-type? 'flic-app val) + (dynamic *do-constant-optimizations*) + (let ((fn (flic-app-fn val)) + (args (flic-app-args val))) + (if recursive? + (structured-constant-app-recursive? + fn args bindings (list var)) + (structured-constant-app? fn args)))) + ;; Variable is bound to a structured constant. If this + ;; isn't already a top-level binding, replace the value + ;; of the constant with a reference to a top-level variable + ;; that is in turn bound to the constant expression. + ;; binding to top-level if this is a new constant. + ;; *** Maybe we should also look for variables bound + ;; *** to lambdas, that can also be hoisted to top level. + (when (not toplevel?) + (multiple-value-bind (con args cvar) + (enter-structured-constant-aux val '#t) + (record-hack 'let-hoist-structured-constant) + (if cvar + (setf (var-value var) (make-flic-ref cvar)) + (add-new-structured-constant var con args)))) + (begin + ;; If this is a function that's a candidate for foldr/build + ;; optimization, stash the value away prior to + ;; inlining the calls. + ;; *** We might try to automagically detect functions + ;; *** that are candidates for these optimizations here, + ;; *** but have to watch out for infinite loops! + (when (and (var-force-inline? var) + (eqv? (the fixnum + (dynamic *current-optimize-iteration*)) + (the fixnum + (dynamic *optimize-build-iteration*))) + (is-type? 'flic-lambda val) + (or (is-foldr-or-build-app? (flic-lambda-body val)))) + (setf (var-inline-value var) (copy-flic-top val))) + ;; Then walk value normally. + (let ((new-val (optimize val))) + (setf (var-value var) new-val) + (setf (var-simple? var) + (or (var-force-inline? var) + (and (not (var-selector-fn? var)) + (can-inline? + new-val + (if recursive? bindings '()) + toplevel?)))))) + )))) + + +(define (is-foldr-or-build-app? exp) + (typecase exp + (flic-app + (let ((fn (flic-app-fn exp))) + (and (is-type? 'flic-ref fn) + (or (eq? (flic-ref-var fn) (core-symbol "foldr")) + (eq? (flic-ref-var fn) (core-symbol "build")))))) + (flic-let + (is-foldr-or-build-app? (flic-let-body exp))) + (flic-ref + (let ((val (var-value (flic-ref-var exp)))) + (and val (is-foldr-or-build-app? val)))) + (else + '#f))) + + +(define (optimize-flic-let-rewrite object bindings recursive?) + ;; Delete unused variables from the list. + (setf bindings + (list-delete-if + (lambda (var) + (cond ((var-toplevel? var) + ;; This was a structured constant hoisted to top-level. + '#t) + ((eqv? (the fixnum (var-referenced var)) (the fixnum 0)) + (record-hack 'let-remove-unused-binding var) + '#t) + ((eqv? (the fixnum (var-referenced var)) (the fixnum 1)) + (setf (var-single-ref var) (dynamic *lambda-depth*)) + '#f) + (else + (setf (var-single-ref var) '#f) + '#f))) + bindings)) + ;; Add extra bindings for reducing functions with invariant + ;; arguments. Hopefully some of the extra bindings will go + ;; away in future passes! + (setf (flic-let-bindings object) + (setf bindings (add-stuff-for-invariants bindings))) + ;; Look for other special cases. + (cond ((null? bindings) + ;; Simplifying the expression by getting rid of the LET may + ;; make it possible to do additional optimizations on the + ;; next pass. + (record-hack 'let-empty-bindings) + (flic-let-body object)) + ((is-type? 'flic-return-from (flic-let-body object)) + ;; Hoist return-from outside of LET. This may permit + ;; further optimizations by an enclosing case-block. + (record-hack 'let-hoist-return-from) + (let* ((body (flic-let-body object)) + (inner-body (flic-return-from-exp body))) + (setf (flic-return-from-exp body) object) + (setf (flic-let-body object) inner-body) + body)) + ((and (not recursive?) + (is-type? 'flic-let (flic-let-body object)) + (not (flic-let-recursive? (flic-let-body object)))) + ;; This is purely to produce more compact code. + (record-hack 'let-compress) + (let ((body (flic-let-body object))) + (setf (flic-let-bindings object) + (nconc bindings (flic-let-bindings body))) + (setf (flic-let-body object) (flic-let-body body)) + object)) + ((is-type? 'flic-lambda (flic-let-body object)) + ;; Hoist lambda outside of LET. This may permit + ;; merging of nested lambdas on a future pass. + (record-hack 'let-hoist-lambda) + (let* ((body (flic-let-body object)) + (inner-body (flic-lambda-body body))) + (setf (flic-lambda-body body) object) + (setf (flic-let-body object) inner-body) + body)) + (else + object)) + ) + +;;; Look for constant-folding and structured constants here. + +(define-optimize flic-app (object) + (optimize-flic-app-aux object)) + +(define (optimize-flic-app-aux object) + (let ((new-fn (optimize (flic-app-fn object))) + (new-args (optimize-list (flic-app-args object)))) + (typecase new-fn + (flic-ref + ;; The function is a variable. + (let* ((var (flic-ref-var new-fn)) + (val (var-value var)) + (n (length new-args)) + (arity (guess-function-arity var))) + (cond ((and arity (< (the fixnum n) (the fixnum arity))) + ;; This is a first-class call that is not fully saturated. + ;; Make it saturated by wrapping a lambda around it. + (setf new-fn + (do-app-make-saturated object new-fn new-args arity n)) + (setf new-args '())) + ((var-selector-fn? var) + ;; This is a saturated call to a selector. We might + ;; be able to inline the call. + (multiple-value-bind (fn args) + (try-to-fold-selector var new-fn new-args) + (setf new-fn fn) + (setf new-args args))) + ((and (not (var-toplevel? var)) + (is-type? 'flic-lambda val)) + ;; This is a saturated call to a local function. + ;; Increment its reference count and note if any of + ;; the arguments are invariant. + (incf (var-fn-referenced var)) + (note-invariant-args new-args (flic-lambda-vars val))) + (else + (let ((magic (magic-optimize-function var))) + (when magic + (multiple-value-bind (fn args) + (funcall magic new-fn new-args) + (setf new-fn fn) + (setf new-args args))))) + ))) + (flic-lambda + ;; Turn application of lambda into a let. + (multiple-value-bind (fn args) + (do-lambda-to-let-aux new-fn new-args) + (setf new-fn fn) + (setf new-args args))) + (flic-pack + (let ((con (flic-pack-con new-fn)) + (temp '#f)) + (when (eqv? (length new-args) (con-arity con)) + (cond ((and (dynamic *do-constant-optimizations*) + (every-1 (function structured-constant?) new-args)) + ;; This is a structured constant that + ;; can be replaced with a top-level binding. + (setf (flic-app-fn object) new-fn) + (setf (flic-app-args object) new-args) + (record-hack 'app-hoist-structured-constant object) + (setf new-fn (enter-structured-constant object '#t)) + (setf new-args '())) + ((and (setf temp (is-selector? con 0 (car new-args))) + (is-selector-list? con 1 temp (cdr new-args))) + ;; This is an expression like (cons (car x) (cdr x)). + ;; Replace it with just plain x to avoid reconsing. + (record-hack 'app-pack-identity new-fn) + (setf new-fn (copy-flic-top temp)) + (setf new-args '())) + )))) + (flic-let + ;; Hoist let to surround entire application. + ;; Simplifying the function being applied may permit further + ;; optimizations on next pass. + ;; (We might try to hoist lets in the argument expressions, too, + ;; but I don't think that would lead to any real simplification + ;; of the code.) + (record-hack 'app-hoist-let) + (setf (flic-app-fn object) (flic-let-body new-fn)) + (setf (flic-app-args object) new-args) + (setf new-args '()) + (setf (flic-let-body new-fn) object) + ) + (flic-app + ;; Try to compress nested applications. + ;; This may make the call saturated and permit further optimizations + ;; on the next pass. + (record-hack 'app-compress) + (setf new-args (nconc (flic-app-args new-fn) new-args)) + (setf new-fn (flic-app-fn new-fn))) + ) + (if (null? new-args) + new-fn + (begin + (setf (flic-app-fn object) new-fn) + (setf (flic-app-args object) new-args) + object)) + )) + +(define (guess-function-arity var) + (or (let ((value (var-value var))) + (and value + (is-type? 'flic-lambda value) + (length (flic-lambda-vars value)))) + (var-arity var))) + +(define (do-app-make-saturated app fn args arity nargs) + (declare (type fixnum arity nargs)) + (record-hack 'app-make-saturated fn args) + (let ((newvars '()) + (newargs '())) + (dotimes (i (- arity nargs)) + (declare (type fixnum i)) + (let ((v (init-flic-var (create-temp-var 'arg) '#f '#f))) + (push v newvars) + (push (make-flic-ref v) newargs))) + (setf (flic-app-fn app) fn) + (setf (flic-app-args app) (nconc args newargs)) + (make-flic-lambda newvars app))) + + + +;;; If the function is a selector applied to a literal dictionary, +;;; inline it. + +(define (try-to-fold-selector var new-fn new-args) + (let ((exp (car new-args))) + (if (or (and (is-type? 'flic-ref exp) + ;; *** should check that var is top-level? + (is-bound-to-constructor-app? (flic-ref-var exp))) + (and (is-type? 'flic-app exp) + (is-constructor-app-prim? exp))) + (begin + (record-hack 'app-fold-selector) + (setf new-fn (copy-flic-top (var-value var))) + (do-lambda-to-let-aux new-fn new-args)) + (values new-fn new-args)))) + + +;;; Various primitive functions have special optimizer functions +;;; associated with them, that do constant folding and certain +;;; other identities. The optimizer function is called with the +;;; function expression and list of argument expressions (at least +;;; as many arguments as the arity of the function) and should return +;;; the two values. + +;;; *** This should really use some kind of hash table, but we'd +;;; *** have to initialize the table dynamically because core-symbols +;;; *** aren't defined when this file is loaded. + +(define (magic-optimize-function var) + (cond ((eq? var (core-symbol "foldr")) + (function optimize-foldr-aux)) + ((eq? var (core-symbol "build")) + (function optimize-build)) + ((eq? var (core-symbol "primIntegerToInt")) + (function optimize-integer-to-int)) + ((eq? var (core-symbol "primIntToInteger")) + (function optimize-int-to-integer)) + ((eq? var (core-symbol "primRationalToFloat")) + (function optimize-rational-to-float)) + ((eq? var (core-symbol "primRationalToDouble")) + (function optimize-rational-to-double)) + ((or (eq? var (core-symbol "primNegInt")) + (eq? var (core-symbol "primNegInteger")) + (eq? var (core-symbol "primNegFloat")) + (eq? var (core-symbol "primNegDouble"))) + (function optimize-neg)) + (else + '#f))) + + +;;; Foldr identities for deforestation + +(define (optimize-foldr fn args) + (multiple-value-bind (fn args) + (optimize-foldr-aux fn args) + (maybe-make-app fn args))) + +(define (optimize-foldr-aux fn args) + (let ((k (car args)) + (z (cadr args)) + (l (caddr args)) + (tail (cdddr args))) + (cond ((and (is-type? 'flic-pack k) + (eq? (flic-pack-con k) (core-symbol ":")) + (is-type? 'flic-pack z) + (eq? (flic-pack-con z) (core-symbol "Nil"))) + ;; foldr (:) [] l ==> l + ;; (We arrange for build to be inlined before foldr + ;; so that this pattern can be detected.) + (record-hack 'foldr-cons-nil-identity) + (values l tail)) + ((and (is-type? 'flic-app l) + (is-type? 'flic-ref (flic-app-fn l)) + (eq? (flic-ref-var (flic-app-fn l)) + (core-symbol "build")) + (null? (cdr (flic-app-args l)))) + ;; foldr k z (build g) ==> g k z + (record-hack 'foldr-build-identity) + (values + (car (flic-app-args l)) + (cons k (cons z tail)))) + ((and (is-type? 'flic-pack l) + (eq? (flic-pack-con l) (core-symbol "Nil"))) + ;; foldr k z [] ==> z + (record-hack 'foldr-nil-identity) + (values z tail)) + ((short-string-constant? l) + ;; If the list argument is a string constant, expand it inline. + ;; Only do this if the string is fairly short, though. + (optimize-foldr-aux + fn + (cons k (cons z (cons (expand-string-constant l) tail))))) + ((and (is-type? 'flic-app l) + (is-type? 'flic-pack (flic-app-fn l)) + (eq? (flic-pack-con (flic-app-fn l)) (core-symbol ":")) + (eqv? (length (flic-app-args l)) 2)) + ;; foldr k z x:xs ==> let c = k in c x (foldr c z xs) + (record-hack 'foldr-cons-identity) + (let ((x (car (flic-app-args l))) + (xs (cadr (flic-app-args l)))) + (values + (if (can-inline? k '() '#f) + (do-foldr-cons-identity k z x xs) + (let ((cvar (init-flic-var (create-temp-var 'c) k '#f))) + (make-flic-let + (list cvar) + (do-foldr-cons-identity (make-flic-ref cvar) z x xs) + '#f))) + tail))) + ((is-type? 'flic-let l) + ;; foldr k z (let bindings in body) ==> + ;; let bindings in foldr k z body + (record-hack 'foldr-hoist-let) + (setf (flic-let-body l) + (optimize-foldr fn (list k z (flic-let-body l)))) + (values l tail)) + ((not (eqv? (the fixnum (dynamic *current-optimize-iteration*)) + (the fixnum (dynamic *optimize-foldr-iteration*)))) + ;; Hope for more optimizations later. + (values fn args)) + ((and (is-type? 'flic-pack k) + (eq? (flic-pack-con k) (core-symbol ":"))) + ;; Inline to special case, highly optimized append primitive. + ;; Could also look for (++ (++ l1 l2) l3) => (++ l1 (++ l2 l3)) + ;; here, but I don't think that happens very often. + (record-hack 'foldr-prim-append-inline) + (values + (make-flic-ref (core-symbol "primAppend")) + (cons l (cons z tail)))) + (else + ;; Default inline. + (record-hack 'foldr-inline k z) + (let ((new-fn + (copy-flic-top (var-value (core-symbol "inlineFoldr"))))) + (if (is-type? 'flic-lambda new-fn) + (do-lambda-to-let-aux new-fn args) + (values new-fn args)))) + ))) + + +;;; Mess with compile-time expansion of short string constants. + +(define-integrable max-short-string-length 3) + +(define (short-string-constant? l) + (and (is-type? 'flic-const l) + (let ((string (flic-const-value l))) + (and (string? string) + (<= (the fixnum (string-length string)) + (the fixnum max-short-string-length)))))) + +(define (expand-string-constant l) + (let* ((string (flic-const-value l)) + (length (string-length string))) + (expand-string-constant-aux string 0 length))) + +(define (expand-string-constant-aux string i length) + (declare (type fixnum i length)) + (if (eqv? i length) + (make-flic-pack (core-symbol "Nil")) + (make-flic-app + (make-flic-pack (core-symbol ":")) + (list (make-flic-const (string-ref string i)) + (expand-string-constant-aux string (+ 1 i) length)) + '#f))) + + +;;; Helper function for the case of expanding foldr applied to cons call. + +(define (do-foldr-cons-identity c z x xs) + (make-flic-app + c + (list x + (optimize-foldr + (make-flic-ref (core-symbol "foldr")) + (list (copy-flic-top c) z xs))) + '#f)) + + + +;;; Short-circuit build inlining for the usual case where the +;;; argument is a lambda. (It would take several optimizer passes +;;; for this simplification to fall out, otherwise.) + +(define (optimize-build fn args) + (let ((arg (car args))) + (cond ((not (eqv? (dynamic *current-optimize-iteration*) + (dynamic *optimize-build-iteration*))) + (values fn args)) + ((is-type? 'flic-lambda arg) + (record-hack 'build-inline-lambda) + (do-lambda-to-let-aux + arg + (cons (make-flic-pack (core-symbol ":")) + (cons (make-flic-pack (core-symbol "Nil")) + (cdr args))))) + (else + (record-hack 'build-inline-other) + (let ((new-fn + (copy-flic-top (var-value (core-symbol "inlineBuild"))))) + (if (is-type? 'flic-lambda new-fn) + (do-lambda-to-let-aux new-fn args) + (values new-fn args)))) + ))) + + +;;; Various simplifications on numeric functions. +;;; *** Obviously, could get much fancier about this. + +(define (optimize-integer-to-int fn args) + (let ((arg (car args))) + (cond ((is-type? 'flic-const arg) + (record-hack 'integer-to-int-constant-fold) + (if (is-type? 'integer (flic-const-value arg)) + (let ((value (flic-const-value arg))) + (when (not (is-type? 'fixnum value)) + ;; Overflow is a user error, not an implementation error. + (phase-error 'int-overflow + "Int overflow in primIntegerToInt: ~s" + value)) + (values arg (cdr args))) + (error "Bad argument ~s to primIntegerToInt." arg))) + ((and (is-type? 'flic-app arg) + (is-type? 'flic-ref (flic-app-fn arg)) + (eq? (flic-ref-var (flic-app-fn arg)) + (core-symbol "primIntToInteger")) + (null? (cdr (flic-app-args arg)))) + (record-hack 'integer-to-int-identity) + (values (car (flic-app-args arg)) (cdr args))) + (else + (values fn args))))) + +(define (optimize-int-to-integer fn args) + (let ((arg (car args))) + (cond ((is-type? 'flic-const arg) + (record-hack 'int-to-integer-constant-fold) + (if (is-type? 'integer (flic-const-value arg)) + (values arg (cdr args)) + (error "Bad argument ~s to primIntToInteger." arg))) + ((and (is-type? 'flic-app arg) + (is-type? 'flic-ref (flic-app-fn arg)) + (eq? (flic-ref-var (flic-app-fn arg)) + (core-symbol "primIntegerToInt")) + (null? (cdr (flic-app-args arg)))) + (record-hack 'int-to-integer-identity) + (values (car (flic-app-args arg)) (cdr args))) + (else + (values fn args))))) + +(predefine (prim.rational-to-float-aux n d)) ; in prims.scm +(predefine (prim.rational-to-double-aux n d)) ; in prims.scm + +(define (optimize-rational-to-float fn args) + (let ((arg (car args))) + (cond ((is-type? 'flic-const arg) + (record-hack 'rational-to-float-constant-fold) + (if (is-type? 'list (flic-const-value arg)) + (let ((value (flic-const-value arg))) + (setf (flic-const-value arg) + (prim.rational-to-float-aux (car value) (cadr value))) + (values arg (cdr args))) + (error "Bad argument ~s to primRationalToFloat." arg))) + (else + (values fn args))))) + +(define (optimize-rational-to-double fn args) + (let ((arg (car args))) + (cond ((is-type? 'flic-const arg) + (record-hack 'rational-to-double-constant-fold) + (if (is-type? 'list (flic-const-value arg)) + (let ((value (flic-const-value arg))) + (setf (flic-const-value arg) + (prim.rational-to-double-aux (car value) (cadr value))) + (values arg (cdr args))) + (error "Bad argument ~s to primRationalToDouble." arg))) + (else + (values fn args))))) + +(define (optimize-neg fn args) + (let ((arg (car args))) + (cond ((is-type? 'flic-const arg) + (record-hack 'neg-constant-fold) + (if (is-type? 'number (flic-const-value arg)) + (begin + (setf (flic-const-value arg) (- (flic-const-value arg))) + (values arg (cdr args))) + (error "Bad argument ~s to ~s." arg fn))) + (else + (values fn args))))) + + + +;;; Convert lambda applications to lets. +;;; If application is not saturated, break it up into two nested +;;; lambdas before doing the transformation. +;;; It's better to do this optimization immediately than hoping +;;; the call will become fully saturated on the next pass. +;;; Maybe we could also look for a flic-let with a flic-lambda as +;;; the body to catch the cases where additional arguments can +;;; be found on a later pass. + +(define (do-lambda-to-let new-fn new-args) + (multiple-value-bind (fn args) + (do-lambda-to-let-aux new-fn new-args) + (maybe-make-app fn args))) + +(define (maybe-make-app fn args) + (if (null? args) + fn + (make-flic-app fn args '#f))) + +(define (do-lambda-to-let-aux new-fn new-args) + (let ((vars (flic-lambda-vars new-fn)) + (body (flic-lambda-body new-fn)) + (matched '())) + (record-hack 'app-lambda-to-let) + (do () + ((or (null? new-args) (null? vars))) + (let ((var (pop vars)) + (arg (pop new-args))) + (setf (var-value var) arg) + (setf (var-simple? var) (can-inline? arg '() '#t)) + (if (eqv? (var-referenced var) 1) + (setf (var-single-ref var) (dynamic *lambda-depth*))) + (push var matched))) + (setf matched (nreverse matched)) + (if (not (null? vars)) + (setf body (make-flic-lambda vars body))) + (setf new-fn (make-flic-let matched body '#f)) + (values new-fn new-args))) + + +;;; For references, check to see if we can beta-reduce. +;;; Don't increment reference count for inlineable vars, but do +;;; traverse the new value expression. + +(define-optimize flic-ref (object) + (optimize-flic-ref-aux object)) + +(define (optimize-flic-ref-aux object) + (let ((var (flic-ref-var object))) + (cond ((var-single-ref var) + ;; (or (eqv? (var-single-ref var) (dynamic *lambda-depth*))) + ;; *** The lambda-depth test is too conservative to handle + ;; *** inlining of stuff necessary for foldr/build optimizations. + ;; Can substitute value no matter how hairy it is. + ;; Note that this is potentially risky; if the single + ;; reference detected on the previous pass appeared as + ;; the value of a variable binding that is being inlined + ;; on the current pass, it might turn into multiple + ;; references again! + ;; We copy the value anyway to avoid problems with shared + ;; structure in the multiple reference case. + (record-hack 'ref-inline-single-ref var) + (optimize (copy-flic-top (var-value var)))) + ((and (var-inline-value var) (dynamic *do-inline-optimizations*)) + ;; Use the previously saved value in preference to the current + ;; value of the variable. + (record-hack 'ref-inline-foldr-hack) + (optimize (copy-flic-top (var-inline-value var)))) + ((and (var-simple? var) + (or (dynamic *do-inline-optimizations*) + (not (var-toplevel? var)))) + ;; Can substitute, but must copy. + (record-hack 'ref-inline var) + (optimize (copy-flic-top (var-value var)))) + ((eq? var (core-symbol "foldr")) + ;; Magic stuff for deforestation + (if (> (the fixnum (dynamic *current-optimize-iteration*)) + (the fixnum (dynamic *optimize-foldr-iteration*))) + (begin + (record-hack 'ref-inline-foldr) + (optimize (make-flic-ref (core-symbol "inlineFoldr")))) + object)) + ((eq? var (core-symbol "build")) + ;; Magic stuff for deforestation + (if (> (the fixnum (dynamic *current-optimize-iteration*)) + (the fixnum (dynamic *optimize-build-iteration*))) + (begin + (record-hack 'ref-inline-build) + (optimize (make-flic-ref (core-symbol "inlineBuild")))) + object)) + ((var-toplevel? var) + object) + (else + (incf (var-referenced var)) + object)))) + + +;;; Don't do anything exciting with constants. + +(define-optimize flic-const (object) + object) + +(define-optimize flic-pack (object) + object) + + + +;;; Various simplifications on and + +(define-optimize flic-and (object) + (maybe-simplify-and + object + (optimize-and-exps (flic-and-exps object) '()))) + +(define (maybe-simplify-and object exps) + (cond ((null? exps) + (record-hack 'and-empty) + (make-flic-pack (core-symbol "True"))) + ((null? (cdr exps)) + (record-hack 'and-unary) + (car exps)) + (else + (setf (flic-and-exps object) exps) + object))) + +(define (optimize-and-exps exps result) + (if (null? exps) + (nreverse result) + (let ((exp (optimize (car exps)))) + (typecase exp + (flic-pack + (cond ((eq? (flic-pack-con exp) (core-symbol "True")) + ;; True appears in subexpressions. + ;; Discard this test only. + (record-hack 'and-contains-true) + (optimize-and-exps (cdr exps) result)) + ((eq? (flic-pack-con exp) (core-symbol "False")) + ;; False appears in subexpressions. + ;; Discard remaining tests as dead code. + ;; Can't replace the whole and expression with false because + ;; of possible strictness side-effects. + (record-hack 'and-contains-false) + (nreverse (cons exp result))) + (else + ;; Should never happen. + (error "Non-boolean con ~s in and expression!" exp)))) + (flic-and + ;; Flatten nested ands. + (record-hack 'and-compress) + (optimize-and-exps + (cdr exps) + (nconc (nreverse (flic-and-exps exp)) result))) + (else + ;; No optimization possible. + (optimize-and-exps (cdr exps) (cons exp result))) + )))) + + +;;; Case-block optimizations. These optimizations are possible because +;;; of the restricted way this construct is used; return-froms are +;;; never nested, etc. + +(define-optimize flic-case-block (object) + (let* ((sym (flic-case-block-block-name object)) + (exps (optimize-case-block-exps + sym (flic-case-block-exps object) '()))) + (optimize-flic-case-block-aux object sym exps))) + +(define (optimize-flic-case-block-aux object sym exps) + (cond ((null? exps) + ;; This should never happen. It means all of the tests were + ;; optimized away, including the failure case! + (error "No exps left in case block ~s!" object)) + ((and (is-type? 'flic-and (car exps)) + (is-return-from-block? + sym + (car (last (flic-and-exps (car exps)))))) + ;; The first clause is a simple and. Hoist it out of the + ;; case-block and rewrite as if/then/else. + (record-hack 'case-block-to-if) + (let ((then-exp (car (last (flic-and-exps (car exps)))))) + (setf (flic-case-block-exps object) (cdr exps)) + (make-flic-if + (maybe-simplify-and + (car exps) + (butlast (flic-and-exps (car exps)))) + (flic-return-from-exp then-exp) + (optimize-flic-case-block-aux object sym (cdr exps))))) + ((is-return-from-block? sym (car exps)) + ;; Do an identity reduction. + (record-hack 'case-block-identity) + (flic-return-from-exp (car exps))) + ((is-type? 'flic-let (car exps)) + ;; The first clause is a let. Since this clause is going + ;; to be executed anyway, hoisting the bindings to surround + ;; the entire case-block should not change their strictness + ;; properties, and it may permit some further optimizations. + (record-hack 'case-block-hoist-let) + (let* ((exp (car exps)) + (body (flic-let-body exp))) + (setf (flic-let-body exp) + (optimize-flic-case-block-aux + object sym (cons body (cdr exps)))) + exp)) + (else + (setf (flic-case-block-exps object) exps) + object) + )) + + +(define (optimize-case-block-exps sym exps result) + (if (null? exps) + (nreverse result) + (let ((exp (optimize (car exps)))) + (cond ((is-return-from-block? sym exp) + ;; Any remaining clauses are dead code and should be removed. + (if (not (null? (cdr exps))) + (record-hack 'case-block-dead-code)) + (nreverse (cons exp result))) + ((is-type? 'flic-and exp) + ;; See if we can remove redundant tests. + (push (maybe-simplify-and + exp + (look-for-redundant-tests (flic-and-exps exp) result)) + result) + (optimize-case-block-exps sym (cdr exps) result)) + (else + ;; No optimization possible. + (optimize-case-block-exps sym (cdr exps) (cons exp result))) + )))) + + +;;; Look for case-block tests that are known to be either true or false +;;; because of tests made in previous clauses. +;;; For now, we only look at is-constructor tests. Such a test is known +;;; to be true if previous clauses have eliminated all other possible +;;; constructors. And such a test is known to be false if a previous +;;; clause has already matched this constructor. + +(define (look-for-redundant-tests exps previous-clauses) + (if (null? exps) + '() + (let ((exp (car exps))) + (cond ((and (is-type? 'flic-is-constructor exp) + (constructor-test-redundant? exp previous-clauses)) + ;; Known to be true. + (record-hack 'case-block-discard-redundant-test) + (cons (make-flic-pack (core-symbol "True")) + (look-for-redundant-tests (cdr exps) previous-clauses))) + + ((and (is-type? 'flic-is-constructor exp) + (constructor-test-duplicated? exp previous-clauses)) + ;; Known to be false. + (record-hack 'case-block-discard-duplicate-test) + (list (make-flic-pack (core-symbol "False")))) + (else + ;; No optimization. + (cons exp + (look-for-redundant-tests (cdr exps) previous-clauses))) + )))) + + +;;; In looking for redundant/duplicated tests, only worry about +;;; is-constructor tests that have an argument that is a variable. +;;; It's too hairy to consider any other cases. + +(define (constructor-test-duplicated? exp previous-clauses) + (let ((con (flic-is-constructor-con exp)) + (arg (flic-is-constructor-exp exp))) + (and (is-type? 'flic-ref arg) + (constructor-test-present? con arg previous-clauses)))) + +(define (constructor-test-redundant? exp previous-clauses) + (let ((con (flic-is-constructor-con exp)) + (arg (flic-is-constructor-exp exp))) + (and (is-type? 'flic-ref arg) + (every-1 (lambda (c) + (or (eq? c con) + (constructor-test-present? c arg previous-clauses))) + (algdata-constrs (con-alg con)))))) + +(define (constructor-test-present? con arg previous-clauses) + (cond ((null? previous-clauses) + '#f) + ((constructor-test-present-1? con arg (car previous-clauses)) + '#t) + (else + (constructor-test-present? con arg (cdr previous-clauses))))) + + +;;; The tricky thing here is that, even if the constructor test is +;;; present in the clause, we have to make sure that the entire clause won't +;;; fail due to the presence of some other test which fails. So look +;;; for a very specific pattern here, namely +;;; (and (is-constructor con arg) (return-from ....)) + +(define (constructor-test-present-1? con arg clause) + (and (is-type? 'flic-and clause) + (let ((exps (flic-and-exps clause))) + (and (is-type? 'flic-is-constructor (car exps)) + (is-type? 'flic-return-from (cadr exps)) + (null? (cddr exps)) + (let* ((inner-exp (car exps)) + (inner-con (flic-is-constructor-con inner-exp)) + (inner-arg (flic-is-constructor-exp inner-exp))) + (and (eq? inner-con con) + (flic-exp-eq? arg inner-arg))))))) + + + +;;; No fancy optimizations for return-from by itself. + +(define-optimize flic-return-from (object) + (setf (flic-return-from-exp object) + (optimize (flic-return-from-exp object))) + object) + + + +;;; Obvious simplification on if + +(define-optimize flic-if (object) + (let ((test-exp (optimize (flic-if-test-exp object))) + (then-exp (optimize (flic-if-then-exp object))) + (else-exp (optimize (flic-if-else-exp object)))) + (cond ((and (is-type? 'flic-pack test-exp) + (eq? (flic-pack-con test-exp) (core-symbol "True"))) + ;; Fold constant test + (record-hack 'if-fold) + then-exp) + ((and (is-type? 'flic-pack test-exp) + (eq? (flic-pack-con test-exp) (core-symbol "False"))) + ;; Fold constant test + (record-hack 'if-fold) + else-exp) + ((and (is-type? 'flic-is-constructor test-exp) + (eq? (flic-is-constructor-con test-exp) (core-symbol "True"))) + ;; Remove redundant is-constructor test. + ;; Doing this as a general is-constructor identity + ;; backfires because it prevents some of the important case-block + ;; optimizations from being recognized, but it works fine here. + (record-hack 'if-compress-test) + (setf (flic-if-test-exp object) (flic-is-constructor-exp test-exp)) + (setf (flic-if-then-exp object) then-exp) + (setf (flic-if-else-exp object) else-exp) + object) + ((and (is-type? 'flic-is-constructor test-exp) + (eq? (flic-is-constructor-con test-exp) (core-symbol "False"))) + ;; Remove redundant is-constructor test, flip branches. + (record-hack 'if-compress-test) + (setf (flic-if-test-exp object) (flic-is-constructor-exp test-exp)) + (setf (flic-if-then-exp object) else-exp) + (setf (flic-if-else-exp object) then-exp) + object) + ((and (is-type? 'flic-return-from then-exp) + (is-type? 'flic-return-from else-exp) + (eq? (flic-return-from-block-name then-exp) + (flic-return-from-block-name else-exp))) + ;; Hoist return-from outside of IF. + ;; This may permit further case-block optimizations. + (record-hack 'if-hoist-return-from) + (let ((return-exp then-exp)) + (setf (flic-if-test-exp object) test-exp) + (setf (flic-if-then-exp object) (flic-return-from-exp then-exp)) + (setf (flic-if-else-exp object) (flic-return-from-exp else-exp)) + (setf (flic-return-from-exp return-exp) object) + return-exp)) + ((and (is-type? 'flic-pack then-exp) + (is-type? 'flic-pack else-exp) + (eq? (flic-pack-con then-exp) (core-symbol "True")) + (eq? (flic-pack-con else-exp) (core-symbol "False"))) + ;; This if does nothing useful at all! + (record-hack 'if-identity) + test-exp) + ((and (is-type? 'flic-pack then-exp) + (is-type? 'flic-pack else-exp) + (eq? (flic-pack-con then-exp) (core-symbol "False")) + (eq? (flic-pack-con else-exp) (core-symbol "True"))) + ;; Inverse of previous case + (record-hack 'if-identity-inverse) + (make-flic-is-constructor (core-symbol "False") test-exp)) + ((or (is-type? 'flic-lambda then-exp) + (is-type? 'flic-lambda else-exp)) + ;; Hoist lambdas to surround entire if. This allows us to + ;; do a better job of saturating them. + (record-hack 'if-hoist-lambda) + (multiple-value-bind (vars then-exp else-exp) + (do-if-hoist-lambda then-exp else-exp) + (setf (flic-if-test-exp object) test-exp) + (setf (flic-if-then-exp object) then-exp) + (setf (flic-if-else-exp object) else-exp) + (make-flic-lambda vars object))) + (else + ;; No optimization possible + (setf (flic-if-test-exp object) test-exp) + (setf (flic-if-then-exp object) then-exp) + (setf (flic-if-else-exp object) else-exp) + object) + ))) + + + +;;; Try to pull as many variables as possible out to surround the entire +;;; let. + +(define (do-if-hoist-lambda then-exp else-exp) + (let ((vars '()) + (then-args '()) + (else-args '())) + (do ((then-vars (if (is-type? 'flic-lambda then-exp) + (flic-lambda-vars then-exp) + '()) + (cdr then-vars)) + (else-vars (if (is-type? 'flic-lambda else-exp) + (flic-lambda-vars else-exp) + '()) + (cdr else-vars))) + ((and (null? then-vars) (null? else-vars)) '#f) + (let ((var (init-flic-var (create-temp-var 'arg) '#f '#f))) + (push var vars) + (push (make-flic-ref var) then-args) + (push (make-flic-ref var) else-args))) + (values + vars + (if (is-type? 'flic-lambda then-exp) + (do-lambda-to-let then-exp then-args) + (make-flic-app then-exp then-args '#f)) + (if (is-type? 'flic-lambda else-exp) + (do-lambda-to-let else-exp else-args) + (make-flic-app else-exp else-args '#f))))) + + + +;;; Look for (sel (pack x)) => x + +(define-optimize flic-sel (object) + (optimize-flic-sel-aux object)) + +(define (optimize-flic-sel-aux object) + (let ((new-exp (optimize (flic-sel-exp object)))) + (setf (flic-sel-exp object) new-exp) + (typecase new-exp + (flic-ref + ;; Check to see whether this is bound to a pack application + (let ((val (is-bound-to-constructor-app? (flic-ref-var new-exp)))) + (if val + ;; Yup, it is. Now extract the appropriate component, + ;; provided it is inlineable. + (let* ((i (flic-sel-i object)) + (args (flic-app-args val)) + (newval (list-ref args i))) + (if (can-inline? newval '() '#t) + (begin + (record-hack 'sel-fold-var) + (optimize (copy-flic-top newval))) + object)) + ;; The variable was bound to something else. + object))) + (flic-app + ;; The obvious optimization. + (if (is-constructor-app-prim? new-exp) + (begin + (record-hack 'sel-fold-app) + (list-ref (flic-app-args new-exp) (flic-sel-i object))) + object)) + (else + object)))) + + + + +;;; Do similar stuff for is-constructor. + +(define-optimize flic-is-constructor (object) + (let ((con (flic-is-constructor-con object)) + (exp (optimize (flic-is-constructor-exp object))) + (exp-con '#f)) + (cond ((algdata-tuple? (con-alg con)) + ;; Tuples have only one constructor, so this is always true + (record-hack 'is-constructor-fold-tuple) + (make-flic-pack (core-symbol "True"))) + ((setf exp-con (is-constructor-app? exp)) + ;; The expression is a constructor application. + (record-hack 'is-constructor-fold) + (make-flic-pack + (if (eq? exp-con con) + (core-symbol "True") + (core-symbol "False")))) + (else + ;; No optimization possible + (setf (flic-is-constructor-exp object) exp) + object) + ))) + + +(define-optimize flic-con-number (object) + (let ((exp (flic-con-number-exp object)) + (type (flic-con-number-type object))) + ;; ***Maybe ast-to-flic should look for this one. + (if (algdata-tuple? type) + (begin + (record-hack 'con-number-fold-tuple) + (make-flic-const 0)) + (let* ((new-exp (optimize exp)) + (con (is-constructor-app? new-exp))) + (if con + (begin + (record-hack 'con-number-fold) + (make-flic-const (con-tag con))) + (begin + (setf (flic-con-number-exp object) new-exp) + object))) + ))) + +(define-optimize flic-void (object) + object) + + +;;;=================================================================== +;;; General helper functions +;;;=================================================================== + + +;;; Lucid's built-in every function seems to do a lot of unnecessary +;;; consing. This one is much faster. + +(define (every-1 fn list) + (cond ((null? list) + '#t) + ((funcall fn (car list)) + (every-1 fn (cdr list))) + (else + '#f))) + + + +;;; Equality predicate on flic expressions + +(define (flic-exp-eq? a1 a2) + (typecase a1 + (flic-const + (and (is-type? 'flic-const a2) + (equal? (flic-const-value a1) (flic-const-value a2)))) + (flic-ref + (and (is-type? 'flic-ref a2) + (eq? (flic-ref-var a1) (flic-ref-var a2)))) + (flic-pack + (and (is-type? 'flic-pack a2) + (eq? (flic-pack-con a1) (flic-pack-con a2)))) + (flic-sel + (and (is-type? 'flic-sel a2) + (eq? (flic-sel-con a1) (flic-sel-con a2)) + (eqv? (flic-sel-i a1) (flic-sel-i a2)) + (flic-exp-eq? (flic-sel-exp a1) (flic-sel-exp a2)))) + (else + '#f))) + + + +;;; Predicates for testing whether an expression matches a pattern. + +(define (is-constructor-app? exp) + (typecase exp + (flic-app + ;; See if we have a saturated call to a constructor. + (is-constructor-app-prim? exp)) + (flic-ref + ;; See if we can determine anything about the value the variable + ;; is bound to. + (let ((value (var-value (flic-ref-var exp)))) + (if value + (is-constructor-app? value) + '#f))) + (flic-let + ;; See if we can determine anything about the body of the let. + (is-constructor-app? (flic-let-body exp))) + (flic-pack + ;; See if this is a nullary constructor. + (let ((con (flic-pack-con exp))) + (if (eqv? (con-arity con) 0) + con + '#f))) + (else + '#f))) + +(define (is-return-from-block? sym exp) + (and (is-type? 'flic-return-from exp) + (eq? (flic-return-from-block-name exp) sym))) + +(define (is-constructor-app-prim? exp) + (let ((fn (flic-app-fn exp)) + (args (flic-app-args exp))) + (if (and (is-type? 'flic-pack fn) + (eqv? (length args) (con-arity (flic-pack-con fn)))) + (flic-pack-con fn) + '#f))) + +(define (is-bound-to-constructor-app? var) + (let ((val (var-value var))) + (if (and val + (is-type? 'flic-app val) + (is-constructor-app-prim? val)) + val + '#f))) + +(define (is-selector? con i exp) + (or (and (is-type? 'flic-ref exp) + (is-selector? con i (var-value (flic-ref-var exp)))) + (and (is-type? 'flic-sel exp) + (eq? (flic-sel-con exp) con) + (eqv? (the fixnum i) (the fixnum (flic-sel-i exp))) + (flic-sel-exp exp)) + )) + +(define (is-selector-list? con i subexp exps) + (declare (type fixnum i)) + (if (null? exps) + subexp + (let ((temp (is-selector? con i (car exps)))) + (and (flic-exp-eq? subexp temp) + (is-selector-list? con (+ 1 i) subexp (cdr exps)))))) + + + +;;;=================================================================== +;;; Inlining criteria +;;;=================================================================== + +;;; Expressions that can be inlined unconditionally are constants, variable +;;; references, and some functions. +;;; I've made some attempt here to arrange the cases in the order they +;;; are likely to occur. + +(define (can-inline? exp recursive-vars toplevel?) + (typecase exp + (flic-sel + ;; Listed first because it happens more frequently than + ;; anything else. + ;; *** Inlining these is an experiment. + ;; *** This transformation interacts with the strictness + ;; *** analyzer; if the variable referenced is not strict, then + ;; *** it is probably not a good thing to do since it adds extra + ;; *** forces. + ;; (let ((subexp (flic-sel-exp exp))) + ;; (and (is-type? 'flic-ref subexp) + ;; (not (memq (flic-ref-var subexp) recursive-vars)))) + '#f) + (flic-lambda + ;; Do not try to inline lambdas if the fancy inline optimization + ;; is disabled. + ;; Watch for problems with infinite loops with recursive variables. + (if (dynamic *do-inline-optimizations*) + (simple-function-body? (flic-lambda-body exp) + (flic-lambda-vars exp) + recursive-vars + toplevel?) + '#f)) + (flic-ref + ;; We get into infinite loops trying to inline recursive variables. + (not (memq (flic-ref-var exp) recursive-vars))) + ((or flic-pack flic-const) + '#t) + (else + '#f))) + + +;;; Determining whether to inline a function is difficult. This is +;;; very conservative to avoid code bloat. What we need to do is +;;; compare the cost (in program size mainly) of the inline call with +;;; an out of line call. For an out of line call, we pay for one function +;;; call and a setup for each arg. When inlining, we pay for function +;;; calls in the body and for args referenced more than once. In terms of +;;; execution time, we win big when a functional parameter is called +;;; since this `firstifies' the program. + +;;; Here's the criteria: +;;; An inline function gets to reference no more that 2 non-parameter +;;; values (including constants and repeated parameter references). +;;; For non-toplevel functions, be slightly more generous since the +;;; fixed overhead of binding the local function would go away. + +(define (simple-function-body? exp lambda-vars recursive-vars toplevel?) + (let ((c (if toplevel? 2 4))) + (>= (the fixnum (simple-function-body-1 exp lambda-vars recursive-vars c)) + 0))) + + +;;; I've made some attempt here to order the cases by how frequently +;;; they appear. + +(define (simple-function-body-1 exp lambda-vars recursive-vars c) + (declare (type fixnum c)) + (if (< c 0) + (values c '()) + (typecase exp + (flic-ref + (let ((var (flic-ref-var exp))) + (cond ((memq var lambda-vars) + (values c (list-remove-1 var lambda-vars))) + ((memq var recursive-vars) + (values -1 '())) + (else + (values (the fixnum (1- c)) lambda-vars))))) + (flic-app + (simple-function-body-1/l + (cons (flic-app-fn exp) (flic-app-args exp)) + lambda-vars recursive-vars c)) + (flic-sel + (simple-function-body-1 + (flic-sel-exp exp) + lambda-vars recursive-vars (the fixnum (1- c)))) + (flic-is-constructor + (simple-function-body-1 + (flic-is-constructor-exp exp) + lambda-vars recursive-vars (the fixnum (1- c)))) + ((or flic-const flic-pack) + (values (the fixnum (1- c)) lambda-vars)) + (else + ;; case & let & lambda not allowed. + (values -1 '()))))) + +(define (list-remove-1 item list) + (cond ((null? list) + '()) + ((eq? item (car list)) + (cdr list)) + (else + (cons (car list) (list-remove-1 item (cdr list)))) + )) + +(define (simple-function-body-1/l exps lambda-vars recursive-vars c) + (declare (type fixnum c)) + (if (or (null? exps) (< c 0)) + (values c lambda-vars) + (multiple-value-bind (c-1 lambda-vars-1) + (simple-function-body-1 (car exps) lambda-vars recursive-vars c) + (simple-function-body-1/l + (cdr exps) lambda-vars-1 recursive-vars c-1)))) + + + +;;;=================================================================== +;;; Constant structured data detection +;;;=================================================================== + + +;;; Look to determine whether an object is a structured constant, +;;; recursively examining its components if it's an app. This is +;;; necessary in order to detect constants with arbitrary circular +;;; reference to the vars in recursive-vars. + +(define (structured-constant-recursive? object recursive-vars stack) + (typecase object + (flic-const + '#t) + (flic-ref + (let ((var (flic-ref-var object))) + (or (memq var stack) + (var-toplevel? var) + (and (memq var recursive-vars) + (structured-constant-recursive? + (var-value var) recursive-vars (cons var stack)))))) + (flic-pack + '#t) + (flic-app + (structured-constant-app-recursive? + (flic-app-fn object) + (flic-app-args object) + recursive-vars + stack)) + (flic-lambda + (lambda-hoistable? object)) + (else + '#f))) + +(define (structured-constant-app-recursive? fn args recursive-vars stack) + (and (is-type? 'flic-pack fn) + (eqv? (length args) (con-arity (flic-pack-con fn))) + (every-1 (lambda (a) + (structured-constant-recursive? a recursive-vars stack)) + args))) + + +;;; Here's a non-recursive (and more efficient) version of the above. +;;; Instead of looking at the whole structure, it only looks one level +;;; deep. This can't detect circular constants, but is useful in +;;; contexts where circularities cannot appear. + +(define (structured-constant? object) + (typecase object + (flic-ref + (var-toplevel? (flic-ref-var object))) + (flic-const + '#t) + (flic-pack + '#t) + (flic-lambda + (lambda-hoistable? object)) + (else + '#f))) + +(define (structured-constant-app? fn args) + (and (is-type? 'flic-pack fn) + (eqv? (length args) (con-arity (flic-pack-con fn))) + (every-1 (function structured-constant?) args))) + + +;;; Determine whether a lambda can be hoisted to top-level. +;;; The main purpose of this code is to mark structured constants +;;; containing simple lambdas to permit later folding of sel expressions +;;; on those constants. Since the latter expression is permissible +;;; only on inlinable functions, stop if we hit an expression that +;;; would make the function not inlinable. + +(define (lambda-hoistable? object) + (and (can-inline? object '() '#t) + (lambda-hoistable-aux + (flic-lambda-body object) + (flic-lambda-vars object)))) + +(define (lambda-hoistable-aux object local-vars) + (typecase object + (flic-ref + (or (var-toplevel? (flic-ref-var object)) + (memq (flic-ref-var object) local-vars))) + ((or flic-const flic-pack) + '#t) + (flic-sel + (lambda-hoistable-aux (flic-sel-exp object) local-vars)) + (flic-is-constructor + (lambda-hoistable-aux (flic-is-constructor-exp object) local-vars)) + (flic-app + (and (lambda-hoistable-aux (flic-app-fn object) local-vars) + (every-1 (lambda (x) (lambda-hoistable-aux x local-vars)) + (flic-app-args object)))) + (else + '#f))) + + +;;; Having determined that something is a structured constant, +;;; enter it (and possibly its subcomponents) in the hash table +;;; and return a var-ref. + +(define (enter-structured-constant value recursive?) + (multiple-value-bind (con args var) + (enter-structured-constant-aux value recursive?) + (when (not var) + (setf var (create-temp-var 'constant)) + (add-new-structured-constant var con args)) + (make-flic-ref var))) + +(define (enter-structured-constant-aux value recursive?) + (let* ((fn (flic-app-fn value)) + (con (flic-pack-con fn)) + (args (if recursive? + (map (function enter-structured-constant-arg) + (flic-app-args value)) + (flic-app-args value)))) + (values con args (lookup-structured-constant con args)))) + +(define (enter-structured-constant-arg a) + (if (is-type? 'flic-app a) + (enter-structured-constant a '#t) + a)) + +(define (lookup-structured-constant con args) + (lookup-structured-constant-aux + (table-entry *structured-constants-table* con) args)) + +(define (lookup-structured-constant-aux alist args) + (cond ((null? alist) + '#f) + ((every (function flic-exp-eq?) (car (car alist)) args) + (cdr (car alist))) + (else + (lookup-structured-constant-aux (cdr alist) args)))) + +(define (add-new-structured-constant var con args) + (push (cons args var) (table-entry *structured-constants-table* con)) + (setf (var-toplevel? var) '#t) + (setf (var-value var) (make-flic-app (make-flic-pack con) args '#t)) + (push var *structured-constants*) + var) + + + +;;;=================================================================== +;;; Invariant argument stuff +;;;=================================================================== + + +;;; When processing a saturated call to a locally defined function, +;;; note whether any of the arguments are always passed the same value. + +(define (note-invariant-args args vars) + (when (and (not (null? args)) (not (null? vars))) + (let* ((arg (car args)) + (var (car vars)) + (val (var-arg-invariant-value var))) + (cond ((not (var-arg-invariant? var)) + ;; This argument already marked as having more than one + ;; value. + ) + ((and (is-type? 'flic-ref arg) + (eq? (flic-ref-var arg) var)) + ;; This is a recursive call with the same argument. + ;; Don't update the arg-invariant-value slot. + ) + ((or (not val) + (flic-exp-eq? arg val)) + ;; Either this is the first call, or a second call with + ;; the same argument. + (setf (var-arg-invariant-value var) arg)) + (else + ;; Different values for this argument are passed in + ;; different places, so we can't mess with it. + (setf (var-arg-invariant? var) '#f))) + (note-invariant-args (cdr args) (cdr vars))))) + + +;;; After processing a let form, check to see if any of the bindings +;;; are for local functions with invariant arguments. +;;; Suppose we have something like +;;; let foo = \ x y z -> <fn-body> +;;; in <let-body> +;;; and y is known to be invariant; then we rewrite this as +;;; let foo1 = \ x z -> let y = <invariant-value> in <fn-body> +;;; foo = \ x1 y1 z1 -> foo1 x1 z1 +;;; in <let-body> +;;; The original foo binding is inlined on subsequent passes and +;;; should go away. Likewise, the binding of y should be inlined also. +;;; *** This is kind of bogus because of the way it depends on the +;;; *** magic force-inline bit. It would be better to do a code walk +;;; *** now on the entire let expression to rewrite all the calls to foo. + +(define (add-stuff-for-invariants bindings) + (if (null? bindings) + '() + (let* ((var (car bindings)) + (val (var-value var))) + (setf (cdr bindings) + (add-stuff-for-invariants (cdr bindings))) + (if (and (is-type? 'flic-lambda val) + ;; Don't mess with single-reference variable bindings, + ;; or things we are going to inline anyway. + (not (var-single-ref var)) + (not (var-simple? var)) + ;; All references must be in saturated calls to do this. + (eqv? (var-referenced var) (var-fn-referenced var)) + ;; There is at least one argument marked invariant. + (some (function var-arg-invariant?) (flic-lambda-vars val)) + ;; Every argument marked invariant must also be hoistable. + (every-1 (function arg-hoistable?) (flic-lambda-vars val))) + (hoist-invariant-args + var + val + bindings) + bindings)))) + +(define (arg-hoistable? var) + (if (var-arg-invariant? var) + (or (not (var-arg-invariant-value var)) + (flic-invariant? (var-arg-invariant-value var) + (dynamic *local-bindings*))) + '#t)) + +(define (hoist-invariant-args var val bindings) + (let ((foo1-var (copy-temp-var (def-name var))) + (foo1-def-vars '()) + (foo1-app-args '()) + (foo1-let-vars '()) + (foo-def-vars '())) + (push foo1-var bindings) + (dolist (v (flic-lambda-vars val)) + (let ((new-v (copy-temp-var (def-name v)))) + (push (init-flic-var new-v '#f '#f) foo-def-vars) + (if (var-arg-invariant? v) + (when (var-arg-invariant-value v) + (push (init-flic-var + v (copy-flic-top (var-arg-invariant-value v)) '#f) + foo1-let-vars)) + (begin + (push v foo1-def-vars) + (push (make-flic-ref new-v) foo1-app-args)) + ))) + (setf foo1-def-vars (nreverse foo1-def-vars)) + (setf foo1-app-args (nreverse foo1-app-args)) + (setf foo1-let-vars (nreverse foo1-let-vars)) + (setf foo-def-vars (nreverse foo-def-vars)) + (record-hack 'let-hoist-invariant-args var foo1-let-vars) + ;; Fix up the value of foo1 + (init-flic-var + foo1-var + (let ((body (make-flic-let foo1-let-vars (flic-lambda-body val) '#f))) + (if (null? foo1-def-vars) + ;; *All* of the arguments were invariant. + body + ;; Otherwise, make a new lambda + (make-flic-lambda foo1-def-vars body))) + '#f) + ;; Fix up the value of foo and arrange for it to be inlined. + (setf (flic-lambda-vars val) foo-def-vars) + (setf (flic-lambda-body val) + (if (null? foo1-app-args) + (make-flic-ref foo1-var) + (make-flic-app (make-flic-ref foo1-var) foo1-app-args '#t))) + (setf (var-simple? var) '#t) + (setf (var-force-inline? var) '#t) + ;; Return modified list of bindings + bindings)) + + + +;;;=================================================================== +;;; Install globals +;;;=================================================================== + + +;;; The optimizer, CFN, etc. can introduce new top-level variables that +;;; are not installed in the symbol table. This causes problems if +;;; those variables are referenced in the .hci file (as in the inline +;;; expansion of some other variables). So we need to fix up the +;;; symbol table before continuing. + +(define (install-uninterned-globals vars) + (dolist (v vars) + (let* ((module (locate-module (def-module v))) + (name (def-name v)) + (table (module-symbol-table module)) + (def (table-entry table name))) + (cond ((not def) + ;; This def was not installed. Rename it if it's a gensym + ;; and install it. + (when (gensym? name) + (setf name (rename-gensym-var v name table))) + (setf (table-entry table name) v)) + ((eq? def v) + ;; Already installed. + '#t) + (else + ;; Ooops! The symbol installed in the symbol table isn't + ;; this one! + (error "Duplicate defs ~s and ~s in symbol table for ~s!" + v def module)) + )))) + + +(define (rename-gensym-var var name table) + (setf name (string->symbol (symbol->string name))) + (if (table-entry table name) + ;; This name already in use; gensym a new one! + (rename-gensym-var var (gensym (symbol->string name)) table) + ;; OK, no problem + (setf (def-name var) name))) + + + +;;;=================================================================== +;;; Postoptimizer +;;;=================================================================== + +;;; This is another quick traversal of the structure to determine +;;; whether references to functions are fully saturated or not. +;;; Also makes sure that reference counts on variables are correct; +;;; this is needed so the code generator can generate ignore declarations +;;; for unused lambda variables. + +(define-flic-walker postoptimize (object)) + +(define-postoptimize flic-lambda (object) + (dolist (var (flic-lambda-vars object)) + (setf (var-referenced var) 0)) + (postoptimize (flic-lambda-body object))) + +(define-postoptimize flic-let (object) + (dolist (var (flic-let-bindings object)) + (setf (var-referenced var) 0) + (let ((val (var-value var))) + (setf (var-arity var) + (if (is-type? 'flic-lambda val) + (length (flic-lambda-vars val)) + 0)))) + (dolist (var (flic-let-bindings object)) + (postoptimize (var-value var))) + (postoptimize (flic-let-body object))) + +(define-postoptimize flic-app (object) + (let ((fn (flic-app-fn object))) + (typecase fn + (flic-ref + (let* ((var (flic-ref-var fn)) + (arity (var-arity var))) + (if (not (var-toplevel? var)) (incf (var-referenced var))) + (when (not (eqv? arity 0)) + (postoptimize-app-aux object var arity (flic-app-args object))))) + (flic-pack + (let* ((con (flic-pack-con fn)) + (arity (con-arity con))) + (postoptimize-app-aux object '#f arity (flic-app-args object)))) + (else + (postoptimize fn))) + (dolist (a (flic-app-args object)) + (postoptimize a)))) + +(define (postoptimize-app-aux object var arity args) + (declare (type fixnum arity)) + (let ((nargs (length args))) + (declare (type fixnum nargs)) + (cond ((< nargs arity) + ;; not enough arguments + (when var (setf (var-standard-refs? var) '#t))) + ((eqv? nargs arity) + ;; exactly the right number of arguments + (when var (setf (var-optimized-refs? var) '#t)) + (setf (flic-app-saturated? object) '#t)) + (else + ;; make the fn a nested flic-app + (multiple-value-bind (arghead argtail) + (split-list args arity) + (setf (flic-app-fn object) + (make-flic-app (flic-app-fn object) arghead '#t)) + (setf (flic-app-args object) argtail) + (when var (setf (var-optimized-refs? var) '#t)) + (dolist (a arghead) + (postoptimize a)))) + ))) + +(define-postoptimize flic-ref (object) + (let ((var (flic-ref-var object))) + (if (not (var-toplevel? var)) (incf (var-referenced var))) + (setf (var-standard-refs? var) '#t))) + +(define-postoptimize flic-const (object) + object) + +(define-postoptimize flic-pack (object) + object) + +(define-postoptimize flic-and (object) + (for-each (function postoptimize) (flic-and-exps object))) + +(define-postoptimize flic-case-block (object) + (for-each (function postoptimize) (flic-case-block-exps object))) + +(define-postoptimize flic-if (object) + (postoptimize (flic-if-test-exp object)) + (postoptimize (flic-if-then-exp object)) + (postoptimize (flic-if-else-exp object))) + +(define-postoptimize flic-return-from (object) + (postoptimize (flic-return-from-exp object))) + +(define-postoptimize flic-sel (object) + (postoptimize (flic-sel-exp object))) + +(define-postoptimize flic-is-constructor (object) + (postoptimize (flic-is-constructor-exp object))) + +(define-postoptimize flic-con-number (object) + (postoptimize (flic-con-number-exp object))) + +(define-postoptimize flic-void (object) + object) diff --git a/backend/strictness.scm b/backend/strictness.scm new file mode 100644 index 0000000..5e03aa6 --- /dev/null +++ b/backend/strictness.scm @@ -0,0 +1,845 @@ +;;; strictness.scm -- strictness analyzer +;;; +;;; author : Sandra Loosemore +;;; date : 28 May 1992 +;;; +;;; The algorithm used here follows Consel, "Fast Strictness Analysis +;;; Via Symbolic Fixpoint Interation". +;;; +;;; The basic idea is to do a traversal of the flic structure, building +;;; a boolean term that represents the strictness of each subexpression. +;;; The boolean terms are composed of ands & ors of the argument variables +;;; to each function. After traversing the body of the function, we can +;;; determine which argument variables are strict by examining the +;;; corresponding term, and then we can update the strictness attribute +;;; of the var that names the function. +;;; +;;; Another traversal needs to be done to attach strictness properties +;;; to locally bound variables. + + +;;; Here's the main entry point. + +(define (strictness-analysis-top big-let) + (fun-strictness-walk big-let) + (var-strictness-walk big-let '() '()) + ;; *** This probably belongs somewhere else? + (do-box-analysis big-let '() '() '#t) + big-let) + + +;;;====================================================================== +;;; Function strictness analyzer code walk +;;;====================================================================== + +;;; This actually involves two code walkers. The first merely traverses +;;; structure and identifies function definitions. The second traverses +;;; the definitions of the functions to compute their strictness. + + +;;; Fun-strictness-walk is the walker to find function definitions. +;;; This is trivial for everything other than flic-let. + +(define-flic-walker fun-strictness-walk (object)) + +(define-fun-strictness-walk flic-lambda (object) + (fun-strictness-walk (flic-lambda-body object))) + +(define-fun-strictness-walk flic-let (object) + (if (flic-let-recursive? object) + (fun-strictness-walk-letrec object) + (fun-strictness-walk-let* object)) + (dolist (v (flic-let-bindings object)) + (fun-strictness-walk (var-value v))) + (fun-strictness-walk (flic-let-body object))) + +(define-fun-strictness-walk flic-app (object) + (fun-strictness-walk (flic-app-fn object)) + (for-each (function fun-strictness-walk) (flic-app-args object))) + +(define-fun-strictness-walk flic-ref (object) + (declare (ignore object)) + '#f) + +(define-fun-strictness-walk flic-pack (object) + (declare (ignore object)) + '#f) + +(define-fun-strictness-walk flic-const (object) + (declare (ignore object)) + '#f) + +(define-fun-strictness-walk flic-case-block (object) + (for-each (function fun-strictness-walk) (flic-case-block-exps object))) + +(define-fun-strictness-walk flic-return-from (object) + (fun-strictness-walk (flic-return-from-exp object))) + +(define-fun-strictness-walk flic-and (object) + (for-each (function fun-strictness-walk) (flic-and-exps object))) + +(define-fun-strictness-walk flic-if (object) + (fun-strictness-walk (flic-if-test-exp object)) + (fun-strictness-walk (flic-if-then-exp object)) + (fun-strictness-walk (flic-if-else-exp object))) + +(define-fun-strictness-walk flic-sel (object) + (fun-strictness-walk (flic-sel-exp object))) + +(define-fun-strictness-walk flic-is-constructor (object) + (fun-strictness-walk (flic-is-constructor-exp object))) + +(define-fun-strictness-walk flic-con-number (object) + (fun-strictness-walk (flic-con-number-exp object))) + +(define-fun-strictness-walk flic-void (object) + (declare (ignore object)) + '#f) + + + +;;; Here is the magic for let bindings of function definitions. +;;; Sequential bindings are easy. For recursive bindings, we must +;;; keep track of mutually recursive functions. +;;; If a function binding has a strictness annotation attached, +;;; do not mess with it further. + +(define (fun-strictness-walk-let* object) + (dolist (var (flic-let-bindings object)) + (let ((val (var-value var))) + (when (is-type? 'flic-lambda val) + (if (var-strictness var) + (mark-argument-strictness + (var-strictness var) (flic-lambda-vars val)) + (compute-function-strictness var val '()))) + ))) + +(define (fun-strictness-walk-letrec object) + (let ((stack '())) + (dolist (var (flic-let-bindings object)) + (let ((val (var-value var))) + (if (and (is-type? 'flic-lambda val) (not (var-strictness var))) + (setf stack (add-recursive-function-1 var (init-var-env) stack))))) + (dolist (var (flic-let-bindings object)) + (let ((val (var-value var))) + (when (is-type? 'flic-lambda val) + (if (var-strictness var) + (mark-argument-strictness + (var-strictness var) (flic-lambda-vars val)) + (compute-function-strictness var val stack))) + )))) + +(define (compute-function-strictness var val stack) + (let* ((vars (flic-lambda-vars val)) + (env (add-var-binding-n vars (map (function list) vars) + (init-var-env))) + (term (compute-strictness-walk (flic-lambda-body val) env stack))) + (when (eq? term '#t) + (signal-infinite-loop-function var) + (setf (flic-lambda-body val) + (make-infinite-loop-error + (format '#f "Function ~s has an infinite loop." var)))) + (setf (var-strictness var) (munge-strictness-terms term vars)))) + + +(define (signal-infinite-loop-function var) + (recoverable-error 'infinite-loop-function + "Function ~s has an infinite loop." + var)) + +(define (make-infinite-loop-error msg) + (make-flic-app + (make-flic-ref (core-symbol "error")) + (list (make-flic-const msg)) + '#t)) + + +;;; compute-strictness-walk is the traversal to compute strictness +;;; terms. +;;; The purpose of the env is to map locally bound variables onto +;;; strictness terms which are expressed as lists of argument variables +;;; to the function being analyzed. +;;; The purpose of the stack is to keep track of recursive function +;;; walks and recognize when we've reached a fixed point. + +(define-flic-walker compute-strictness-walk (object env stack)) + + +;;; Making a function never forces anything. + +(define-compute-strictness-walk flic-lambda (object env stack) + (declare (ignore object env stack)) + '#f) + + +;;; For let, add bindings to environment and get strictness of body. + +(define-compute-strictness-walk flic-let (object env stack) + (let ((bindings (flic-let-bindings object)) + (body (flic-let-body object)) + (recursive? (flic-let-recursive? object))) + (if recursive? + ;; Must add stuff to env and stack before traversing anything. + (begin + (dolist (var bindings) + (setf env (add-var-binding-1 var '#f env))) + (dolist (var bindings) + (let ((val (var-value var))) + (when (is-type? 'flic-lambda val) + (setf stack (add-recursive-function-1 var env stack))))) + (dolist (var bindings) + (let ((val (var-value var))) + (set-var-env var env (compute-strictness-walk val env stack))))) + ;; Otherwise just do things sequentially. + ;; Note that even though there is no possibility of recursion + ;; here, we must add stuff to the stack anyway so that we can + ;; walk calls in the correct env. + (dolist (var bindings) + (let ((val (var-value var))) + (when (is-type? 'flic-lambda val) + (setf stack (add-recursive-function-1 var env stack))) + (setf env + (add-var-binding-1 + var (compute-strictness-walk val env stack) env))))) + (compute-strictness-walk body env stack))) + + +;;; Treat explicit, saturated calls to named functions specially. + +(define-compute-strictness-walk flic-app (object env stack) + (let ((fn (flic-app-fn object)) + (args (flic-app-args object)) + (saturated? (flic-app-saturated? object))) + (cond ((and (is-type? 'flic-ref fn) saturated?) + ;; Special handling for named functions. + (compute-application-strictness + (flic-ref-var fn) + args env stack)) + ((and (is-type? 'flic-pack fn) saturated?) + ;; Similarly for constructor applications, but we always + ;; know which arguments are strict in advance. + (compute-application-strictness-aux + (con-slot-strict? (flic-pack-con fn)) + args env stack)) + (else + ;; Otherwise, we know that the function expression is going to + ;; be forced, but all of its arguments are lazy. So ignore the + ;; arguments in computing the strictness of the whole expression. + (compute-strictness-walk fn env stack))))) + + +(define (compute-application-strictness var args env stack) + (let* ((strictness (var-strictness var)) + (info '#f) + (arg-strictness-list '#f)) + (cond ((eq? var (core-symbol "error")) + ;; This expression will return bottom no matter what. + 'error) + (strictness + ;; We've already completed the walk for this function and + ;; determined which of its arguments are strict. + ;; The strictness expression for the application is the + ;; OR of the strictness of its non-lazy arguments. + (compute-application-strictness-aux strictness args env stack)) + ((get-recursive-function-trace + (setf arg-strictness-list + (map (lambda (a) (compute-strictness-walk a env stack)) + args)) + (setf info (get-recursive-function var stack))) + ;; We're already tracing this call. Return true to + ;; terminate the fixpoint iteration. + '#t) + (else + ;; Otherwise, begin a new trace instance. + ;; Add stuff to the saved var-env to map references to + ;; the argument variables to the strictness terms for + ;; the actual arguments at this call site. + ;; References to closed-over variables within the function + ;; use the strictness values that were stored in the env + ;; at the point of function definition. + (let* ((env (get-recursive-function-env info)) + (lambda (var-value var)) + (body (flic-lambda-body lambda)) + (vars (flic-lambda-vars lambda)) + (result '#f)) + (push-recursive-function-trace arg-strictness-list info) + (setf result + (compute-strictness-walk + body + (add-var-binding-n vars arg-strictness-list env) + stack)) + (pop-recursive-function-trace info) + result)) + ))) + + +(define (compute-application-strictness-aux strictness args env stack) + (make-or-term + (map (lambda (strict? arg) + (if strict? (compute-strictness-walk arg env stack) '#f)) + strictness args))) + + +;;; For a reference, look up the term associated with the variable in env. +;;; If not present in the environment, ignore it; the binding was established +;;; outside the scope of the function being analyzed. + +(define-compute-strictness-walk flic-ref (object env stack) + (declare (ignore stack)) + (get-var-env (flic-ref-var object) env)) + + +;;; References to constants or constructors never fail. + +(define-compute-strictness-walk flic-const (object env stack) + (declare (ignore object env stack)) + '#f) + +(define-compute-strictness-walk flic-pack (object env stack) + (declare (ignore object env stack)) + '#f) + + +;;; The first clause of a case-block is the only one that is always +;;; executed, so it is the only one that affects the strictness of +;;; the overall expression. + +(define-compute-strictness-walk flic-case-block (object env stack) + (compute-strictness-walk (car (flic-case-block-exps object)) env stack)) + + +;;; Return-from fails if its subexpression fails. + +(define-compute-strictness-walk flic-return-from (object env stack) + (compute-strictness-walk (flic-return-from-exp object) env stack)) + + +;;; For and, the first subexpression is the only one that is always +;;; executed, so it is the only one that affects the strictness of +;;; the overall expression. + +(define-compute-strictness-walk flic-and (object env stack) + (compute-strictness-walk (car (flic-and-exps object)) env stack)) + + +;;; The strictness of an IF is the strictness of the test OR'ed +;;; with the AND of the strictness of its branches. + +(define-compute-strictness-walk flic-if (object env stack) + (make-or-term-2 + (compute-strictness-walk (flic-if-test-exp object) env stack) + (make-and-term-2 + (compute-strictness-walk (flic-if-then-exp object) env stack) + (compute-strictness-walk (flic-if-else-exp object) env stack)))) + + +;;; Selecting a component of a data structure causes it to be forced, +;;; so propagate the strictness of the subexpression upwards. + +(define-compute-strictness-walk flic-sel (object env stack) + (compute-strictness-walk (flic-sel-exp object) env stack)) + + +;;; Is-constructor and con-number force their subexpressions. + +(define-compute-strictness-walk flic-is-constructor (object env stack) + (compute-strictness-walk (flic-is-constructor-exp object) env stack)) + +(define-compute-strictness-walk flic-con-number (object env stack) + (compute-strictness-walk (flic-con-number-exp object) env stack)) + +(define-compute-strictness-walk flic-void (object env stack) + (declare (ignore object env stack)) + '#f) + + + +;;;====================================================================== +;;; Utilities for managing the env +;;;====================================================================== + +;;; The env is just an a-list. + +(define (init-var-env) + '()) + +(define (add-var-binding-1 var binding env) + (cons (cons var binding) env)) + +(define (add-var-binding-n vars bindings env) + (if (null? vars) + env + (add-var-binding-n (cdr vars) (cdr bindings) + (cons (cons (car vars) (car bindings)) env)))) + +(define (get-var-env var env) + (let ((stuff (assq var env))) + (if stuff + (cdr stuff) + '#f))) + +(define (set-var-env var env new-value) + (let ((stuff (assq var env))) + (if stuff + (setf (cdr stuff) new-value) + (error "Can't find binding for ~s in environment." var)))) + + + +;;;====================================================================== +;;; Utilities for managing the stack +;;;====================================================================== + +;;; For now, the stack is just an a-list too. +;;; Some sort of hashing scheme could also be used instead of a linear +;;; search, but if the iteration depth for the fixpoint analysis is +;;; small, it's probably not worth the trouble. + +(define (add-recursive-function-1 var env stack) + (cons (list var env '()) stack)) + +(define (get-recursive-function var stack) + (or (assq var stack) + (error "Can't find entry for ~s in stack." var))) + +(define (get-recursive-function-env entry) + (cadr entry)) + +(define (push-recursive-function-trace new-args entry) + (push new-args (caddr entry))) + +(define (pop-recursive-function-trace entry) + (pop (caddr entry))) + +(define (get-recursive-function-trace args entry) + (get-recursive-function-trace-aux args (caddr entry))) + +(define (get-recursive-function-trace-aux args list) + (cond ((null? list) + '#f) + ((every (function term=) args (car list)) + '#t) + (else + (get-recursive-function-trace-aux args (cdr list))))) + + +;;;====================================================================== +;;; Utilities for boolean terms +;;;====================================================================== + + +;;; A term is either #t, #f, the symbol 'error, or a list of variables +;;; (which are implicitly or'ed together). +;;; #t and 'error are treated identically, except that #t indicates +;;; failure because of infinite recursion and 'error indicates failure +;;; due to a call to the error function. +;;; In general, AND terms add nothing to the result, so to reduce +;;; needless computation we generally reduce (and a b) to #f. + +;;; Make an OR term. First look for some obvious special cases as an +;;; efficiency hack, otherwise fall through to more general code. + +(define (make-or-term terms) + (cond ((null? terms) + '#f) + ((null? (cdr terms)) + (car terms)) + ((eq? (car terms) '#t) + '#t) + ((eq? (car terms) 'error) + 'error) + ((eq? (car terms) '#f) + (make-or-term (cdr terms))) + (else + (make-or-term-2 (car terms) (make-or-term (cdr terms)))))) + +(define (make-or-term-2 term1 term2) + (cond ((eq? term2 '#t) + '#t) + ((eq? term2 'error) + 'error) + ((eq? term2 '#f) + term1) + ((eq? term1 '#t) + '#t) + ((eq? term1 'error) + 'error) + ((eq? term1 '#f) + term2) + ;; At this point we know both terms are variable lists. + ((implies? term2 term1) + term2) + ((implies? term1 term2) + term1) + (else + (merge-list-terms term1 term2)))) + + +;;; Merge the two lists, throwing out duplicate variables. + +(define (merge-list-terms list1 list2) + (cond ((null? list1) + list2) + ((null? list2) + list1) + ((eq? (car list1) (car list2)) + (cons (car list1) (merge-list-terms (cdr list1) (cdr list2)))) + ((var< (car list1) (car list2)) + (cons (car list1) (merge-list-terms (cdr list1) list2))) + (else + (cons (car list2) (merge-list-terms list1 (cdr list2)))))) + + +;;; Helper function: does term1 imply term2? +;;; True if every subterm of term2 is also included in term1. + +(define (implies? term1 term2) + (every (lambda (v2) (memq v2 term1)) term2)) + + +;;; Make an AND term. Because we don't want to build up arbitrarily +;;; complex AND expressions, basically just compute an OR list that +;;; represents the intersection of the subterms. + +(define (make-and-term terms) + (cond ((null? terms) + '#f) + ((null? (cdr terms)) + (car terms)) + ((eq? (car terms) '#t) + (make-and-term (cdr terms))) + ((eq? (car terms) 'error) + (make-and-term (cdr terms))) + ((eq? (car terms) '#f) + '#f) + (else + (make-and-term-2 (car terms) (make-and-term (cdr terms)))))) + +(define (make-and-term-2 term1 term2) + (cond ((eq? term2 '#t) + term1) + ((eq? term2 'error) + term1) + ((eq? term2 '#f) + '#f) + ((eq? term1 '#t) + term2) + ((eq? term1 'error) + term2) + ((eq? term1 '#f) + '#f) + ;; At this point we know both terms are variable lists. + ((implies? term2 term1) + term1) + ((implies? term1 term2) + term2) + (else + (let ((result '())) + (dolist (v term1) + (if (memq v term2) + (push v result))) + (if (null? result) + '#f + (nreverse result)))) + )) + + +;;; Subterms of an and/or term are always sorted, so that to compare +;;; two terms we can just compare subterms componentwise. + +(define (term= term1 term2) + (or (eq? term1 term2) + (and (pair? term1) + (pair? term2) + (eq? (car term1) (car term2)) + (term= (cdr term1) (cdr term2))))) + + +;;; Variables within an OR-list are sorted alphabetically by names. + +(define (var< var1 var2) + (string<? (symbol->string (def-name var1)) + (symbol->string (def-name var2)))) + + +;;; Determine which of the vars are present in the term. + +(define (munge-strictness-terms term vars) + (map (lambda (v) + (setf (var-strict? v) + (cond ((var-force-strict? v) + '#t) + ((eq? term '#t) + '#t) + ((eq? term 'error) + '#t) + ((eq? term '#f) + '#f) + ((memq v term) + '#t) + (else + '#f)))) + vars)) + +(define (mark-argument-strictness strictness vars) + (map (lambda (s v) (setf (var-strict? v) s)) strictness vars)) + + + +;;;====================================================================== +;;; Variable strictness propagation code walk +;;;====================================================================== + +;;; Walk the code, marking any vars found in strict contexts as strict. +;;; Locally bound variables are consed onto the varlist. This is +;;; used to determine which variables can be marked as strict when they +;;; appear in strict contexts. +;;; When walking something that does not appear in a strict context +;;; or that is not always evaluated, reinitialize varlist to the empty +;;; list. +;;; The stack is used to keep track of variables that have not been +;;; initialized yet, so that we can detect some kinds of infinite loops. +;;; When walking something that is not always evaluated, reset this to +;;; the empty list. + +(define-flic-walker var-strictness-walk (object varlist stack)) + + + +;;; Since the body of the lambda might not be evaluated, reset +;;; both varlist and stack. + +(define-var-strictness-walk flic-lambda (object varlist stack) + (declare (ignore varlist stack)) + (var-strictness-walk (flic-lambda-body object) '() '())) + + +;;; The basic idea for let is to find the variables that are strict in +;;; the body first, and propagate that information backwards to the +;;; binding initializers. + +(define-var-strictness-walk flic-let (object varlist stack) + (let ((bindings (flic-let-bindings object))) + (var-strictness-walk-let-aux + bindings + (flic-let-body object) + (append bindings varlist) + (append bindings stack) + (flic-let-recursive? object)))) + +(define (var-strictness-walk-let-aux bindings body varlist stack recursive?) + (if (null? bindings) + (var-strictness-walk body varlist stack) + (begin + (var-strictness-walk-let-aux + (cdr bindings) body varlist (cdr stack) recursive?) + (let* ((var (car bindings)) + (val (var-value var))) + (cond ((var-strict? var) + ;; Recursive variables have to be set back to unstrict + ;; because the value form might contain forward references. + ;; The box analyzer will set them to strict again if the + ;; value forms are safe. + (when recursive? (setf (var-strict? var) '#f)) + ;; Detect x = 1 + x circularities here + (var-strictness-walk val varlist stack)) + ((flic-exp-strict-result? val) + ;; The val is going to be wrapped in a delay. + (var-strictness-walk val '() '())) + (else + ;; Watch out for x = x and x = cdr x circularities. + ;; *** I am still a little confused about this. It + ;; *** seems like the stack should be passed through + ;; *** when walking already-boxed values that appear as + ;; *** non-strict function arguments as well, but doing + ;; *** so generates some apparently bogus complaints + ;; *** about infinite loops. So maybe doing it here + ;; *** is incorrect too, and we just haven't run across + ;; *** a test case that triggers it??? + (var-strictness-walk val '() stack)) + ))))) + + +(define (flic-exp-strict-result? val) + (cond ((is-type? 'flic-ref val) + (var-strict? (flic-ref-var val))) + ((is-type? 'flic-sel val) + (list-ref (con-slot-strict? (flic-sel-con val)) (flic-sel-i val))) + (else + '#t))) + +(define-var-strictness-walk flic-app (object varlist stack) + (let ((fn (flic-app-fn object)) + (args (flic-app-args object)) + (saturated? (flic-app-saturated? object))) + (cond ((and saturated? (is-type? 'flic-ref fn)) + ;; Strictness of function should be stored on var + (do-var-strictness-flic-app-aux + (var-strictness (flic-ref-var fn)) + fn args varlist stack)) + ((and saturated? (is-type? 'flic-pack fn)) + ;; Strictness of constructor should be stored on con + (do-var-strictness-flic-app-aux + (con-slot-strict? (flic-pack-con fn)) + fn args varlist stack)) + (else + ;; All arguments are non-strict + (var-strictness-walk fn varlist stack) + (dolist (a args) + (var-strictness-walk a '() '())))))) + +(define (do-var-strictness-flic-app-aux strictness fn args varlist stack) + (when (not strictness) + (error "Can't find strictness for function ~s." fn)) + (dolist (a args) + (if (pop strictness) + (var-strictness-walk a varlist stack) + (var-strictness-walk a '() '())))) + + +(define-var-strictness-walk flic-ref (object varlist stack) + (let ((var (flic-ref-var object))) + (cond ((memq var stack) + ;; Circular variable definition detected. + (signal-infinite-loop-variable var) + (setf (var-value var) + (make-infinite-loop-error + (format '#f "Variable ~s has an infinite loop." var)))) + ((memq var varlist) + (setf (var-strict? var) '#t)) + (else + '#f)))) + +(define (signal-infinite-loop-variable var) + (recoverable-error 'infinite-loop-variable + "Variable ~s has an infinite loop." + var)) + +(define-var-strictness-walk flic-const (object varlist stack) + (declare (ignore object varlist stack)) + '#f) + +(define-var-strictness-walk flic-pack (object varlist stack) + (declare (ignore object varlist stack)) + '#f) + +(define-var-strictness-walk flic-case-block (object varlist stack) + (var-strictness-walk (car (flic-case-block-exps object)) varlist stack) + (dolist (exp (cdr (flic-case-block-exps object))) + (var-strictness-walk exp '() '()))) + +(define-var-strictness-walk flic-return-from (object varlist stack) + (var-strictness-walk (flic-return-from-exp object) varlist stack)) + +(define-var-strictness-walk flic-and (object varlist stack) + (var-strictness-walk (car (flic-and-exps object)) varlist stack) + (dolist (exp (cdr (flic-and-exps object))) + (var-strictness-walk exp '() '()))) + +(define-var-strictness-walk flic-if (object varlist stack) + (var-strictness-walk (flic-if-test-exp object) varlist stack) + (var-strictness-walk (flic-if-then-exp object) '() '()) + (var-strictness-walk (flic-if-else-exp object) '() '())) + +(define-var-strictness-walk flic-sel (object varlist stack) + (var-strictness-walk (flic-sel-exp object) varlist stack)) + +(define-var-strictness-walk flic-is-constructor (object varlist stack) + (var-strictness-walk (flic-is-constructor-exp object) varlist stack)) + +(define-var-strictness-walk flic-con-number (object varlist stack) + (var-strictness-walk (flic-con-number-exp object) varlist stack)) + +(define-var-strictness-walk flic-void (object varlist stack) + (declare (ignore object varlist stack)) + '#f) + + + +;;;====================================================================== +;;; Printer support +;;;====================================================================== + +(define (strictness-analysis-printer big-let) + (print-strictness big-let 0)) + +(define (print-strictness-list list depth) + (dolist (o list) + (print-strictness o depth))) + +(define (print-strictness-indent depth) + (dotimes (i (* 2 depth)) + (declare (ignorable i)) + (write-char #\space))) + +(define (strictness-string bool) + (if bool "#t" "#f")) + +(define-flic-walker print-strictness (object depth)) + +(define-print-strictness flic-lambda (object depth) + (print-strictness-indent depth) + (format '#t "In anonymous function:~%") + (print-strictness (flic-lambda-body object) (1+ depth))) + +(define-print-strictness flic-let (object depth) + (dolist (var (flic-let-bindings object)) + (let ((val (var-value var))) + (if (is-type? 'flic-lambda val) + (begin + (print-strictness-indent depth) + (format '#t "Function ~s has argument strictness ~a.~%" + var + (map (function strictness-string) (var-strictness var))) + (print-strictness (flic-lambda-body val) (1+ depth))) + (begin + (print-strictness-indent depth) + (format '#t "Variable ~s has strictness ~a.~%" + var + (strictness-string (var-strict? var))) + (print-strictness val depth))))) + (print-strictness (flic-let-body object) depth)) + +(define-print-strictness flic-app (object depth) + (print-strictness (flic-app-fn object) depth) + (print-strictness-list (flic-app-args object) depth)) + +(define-print-strictness flic-ref (object depth) + (declare (ignore object depth)) + '#f) + +(define-print-strictness flic-const (object depth) + (declare (ignore object depth)) + '#f) + +(define-print-strictness flic-pack (object depth) + (declare (ignore object depth)) + '#f) + +(define-print-strictness flic-case-block (object depth) + (print-strictness-list (flic-case-block-exps object) depth)) + +(define-print-strictness flic-return-from (object depth) + (print-strictness (flic-return-from-exp object) depth)) + +(define-print-strictness flic-and (object depth) + (print-strictness-list (flic-and-exps object) depth)) + +(define-print-strictness flic-if (object depth) + (print-strictness (flic-if-test-exp object) depth) + (print-strictness (flic-if-then-exp object) depth) + (print-strictness (flic-if-else-exp object) depth)) + +(define-print-strictness flic-sel (object depth) + (print-strictness (flic-sel-exp object) depth)) + +(define-print-strictness flic-is-constructor (object depth) + (print-strictness (flic-is-constructor-exp object) depth)) + +(define-print-strictness flic-con-number (object depth) + (print-strictness (flic-con-number-exp object) depth)) + +(define-print-strictness flic-void (object depth) + (declare (ignore object depth)) + '#f) + diff --git a/bin/cmu-clx-haskell b/bin/cmu-clx-haskell new file mode 100755 index 0000000..dba0998 --- /dev/null +++ b/bin/cmu-clx-haskell @@ -0,0 +1,9 @@ +#!/bin/csh +# +# run cmu clx haskell + +if (`arch -k` == "sun4c") then + $CMUCLBIN -core $HASKELL/bin/sun4c-clx-haskell.core +else + $CMUCLBIN -core $HASKELL/bin/sun4m-clx-haskell.core +endif diff --git a/bin/cmu-haskell b/bin/cmu-haskell new file mode 100755 index 0000000..ff82dfc --- /dev/null +++ b/bin/cmu-haskell @@ -0,0 +1,9 @@ +#!/bin/csh +# +# run cmu haskell + +if (`arch -k` == "sun4c") then + $CMUCLBIN -core $HASKELL/bin/sun4c-haskell.core +else + $CMUCLBIN -core $HASKELL/bin/sun4m-haskell.core +endif diff --git a/bin/magic.scm b/bin/magic.scm new file mode 100644 index 0000000..999e8b0 --- /dev/null +++ b/bin/magic.scm @@ -0,0 +1,10 @@ +;;; magic.scm -- magic support file for dumping compiled code files. +;;; +;;; author : Sandra Loosemore +;;; date : 8 Jul 1992 +;;; +;;; This file is used to dump compiled code files. The macro call below +;;; expands into the code being dumped. See dump-interface.scm for more +;;; details. + +(magic-form-to-compile) diff --git a/cfn/README b/cfn/README new file mode 100644 index 0000000..80a25c1 --- /dev/null +++ b/cfn/README @@ -0,0 +1,35 @@ +Whats what in the cfn. + +Language generated by cfn contains these ast node types: + lambda + let + if + case -- restriction: all patterns must be either literals or + a constructor with var and wildcard args + app + var-ref + con-ref + const + con-number + sel + is-constructor + +Transformations to do: + Convert lists to explicit calls to cons + Simplify patterns + Remove sequences + Remove list comprehensions + Remove sections + Reduce patterns on lhs of decls + Reduce patterns in function args + Convert where decls to let statements + Convert guarded-expressions to if - then - else form + +Done earlier: + signdecls are removed in scoping + exp-signs are removed in typechecker + prec parser removes `negate' & pp-* nodes + + + + diff --git a/cfn/cfn.scm b/cfn/cfn.scm new file mode 100644 index 0000000..bf43be0 --- /dev/null +++ b/cfn/cfn.scm @@ -0,0 +1,21 @@ +;;; cfn.scm -- module definition for CFN phase +;;; +;;; author : Sandra Loosemore +;;; date : 11 Mar 1992 +;;; + + +(define-compilation-unit cfn + (source-filename "$Y2/cfn/") + (require ast haskell-utils) + (unit main + (source-filename "main.scm")) + (unit misc + (source-filename "misc.scm") + (require main)) + (unit pattern + (source-filename "pattern.scm") + (require main))) + + + diff --git a/cfn/main.scm b/cfn/main.scm new file mode 100644 index 0000000..3853b03 --- /dev/null +++ b/cfn/main.scm @@ -0,0 +1,83 @@ +;;; main.scm -- main entry point for CFN pass +;;; +;;; author : Sandra Loosemore +;;; date : 27 Feb 1992 +;;; + + +;;;=================================================================== +;;; Basic support +;;;=================================================================== + + +;;; Define the basic walker and some helper functions. + +(define-walker cfn ast-td-cfn-walker) + +(define (cfn-ast-1 x) + (call-walker cfn x)) + +(define (cfn-ast/list l) + (map (lambda (x) (cfn-ast-1 x)) l)) + + +;;; This is the main entry point. It is called by the driver on +;;; each top-level decl in the module. + +(define (cfn-ast x) + (let ((result (cfn-ast-1 x))) +; (pprint result) ;*** debug + result)) + + + +;;;=================================================================== +;;; Default traversal methods +;;;=================================================================== + + +(define-local-syntax (make-cfn-code slot type) + (let ((stype (sd-type slot)) + (sname (sd-name slot))) + (cond ((and (symbol? stype) + (or (eq? stype 'exp) + (subtype? stype 'exp))) + `(setf (struct-slot ',type ',sname object) + (cfn-ast-1 (struct-slot ',type ',sname object)))) + ((and (pair? stype) + (eq? (car stype) 'list) + (symbol? (cadr stype)) + (or (eq? (cadr stype) 'exp) + (subtype? (cadr stype) 'exp))) + `(setf (struct-slot ',type ',sname object) + (cfn-ast/list (struct-slot ',type ',sname object)))) + ((and (pair? stype) + (eq? (car stype) 'list) + (eq? (cadr stype) 'decl)) + `(setf (struct-slot ',type ',sname object) + (cfn-valdef-list (struct-slot ',type ',sname object)))) + (else +; (format '#t "Cfn: skipping slot ~A in ~A~%" +; (sd-name slot) +; type) + '#f)))) + +(define-modify-walker-methods cfn + (let if + exp-sign + app + var-ref con-ref + integer-const float-const char-const string-const + con-number sel is-constructor + void + case-block return-from and-exp + ) + (object) + make-cfn-code) + + +;;; These have specialized walkers: +;;; lambda, case, valdef, list-comp (pattern.scm) +;;; list-exp, list-comp, section-l, section-r, dict-placeholder, +;;; recursive-placeholder, save-old-exp (misc.scm) + diff --git a/cfn/misc.scm b/cfn/misc.scm new file mode 100644 index 0000000..4bcba64 --- /dev/null +++ b/cfn/misc.scm @@ -0,0 +1,113 @@ +;;; misc.scm -- random other transformations done during CFN processing +;;; +;;; author : Sandra Loosemore +;;; date : 27 Feb 1992 +;;; +;;; This file contains specialized CFN walkers that implement rewrite rules +;;; for list-exp, sequence-xxx, list-comp, section-l, and section-r. + + +;;; Turn list-exps into cons chains. + +(define-walker-method cfn list-exp (object) + (do-cfn-list-exp (list-exp-exps object))) + +(define (do-cfn-list-exp exps) + (if (null? exps) + ;; Make a con-ref for [] + (**con/def (core-symbol "Nil")) + ;; Otherwise make an app of : + (let ((first (cfn-ast-1 (car exps))) + (rest (do-cfn-list-exp (cdr exps)))) + (**app (**con/def (core-symbol ":")) first rest)))) + + +;;; Sections get turned into lambda expressions. + +(define-walker-method cfn section-l (object) + (let ((def (create-temp-var 'section-arg))) + (**lambda/pat + (list (**var-pat/def def)) + (**app (cfn-ast-1 (section-l-op object)) + (**var/def def) + (cfn-ast-1 (section-l-exp object)))))) + +(define-walker-method cfn section-r (object) + (let ((def (create-temp-var 'section-arg))) + (**lambda/pat + (list (**var-pat/def def)) + (**app (cfn-ast-1 (section-r-op object)) + (cfn-ast-1 (section-r-exp object)) + (**var/def def))))) + + + +;;; Do list comprehensions. +;;; rewrite in terms of build and foldr so that we can apply +;;; deforestation techniques later. + +(define-walker-method cfn list-comp (object) + (let ((c (create-temp-var 'c)) + (n (create-temp-var 'n))) + (cfn-ast-1 + (**app (**var/def (core-symbol "build")) + (**lambda/pat + (list (**var-pat/def c) (**var-pat/def n)) + (do-cfn-list-comp + (list-comp-exp object) (list-comp-quals object) c n)))))) + +(define (do-cfn-list-comp exp quals c n) + (if (null? quals) + (**app (**var/def c) exp (**var/def n)) + (let ((qual (car quals))) + (if (is-type? 'qual-generator qual) + (do-cfn-list-comp-generator exp qual (cdr quals) c n) + (do-cfn-list-comp-filter exp qual (cdr quals) c n))))) + +(define (do-cfn-list-comp-filter exp qual quals c n) + (**if (qual-filter-exp qual) + (do-cfn-list-comp exp quals c n) + (**var/def n))) + +(define (do-cfn-list-comp-generator exp qual quals c n) + (let ((gen-pat (qual-generator-pat qual)) + (gen-exp (qual-generator-exp qual)) + (l (create-temp-var 'list)) + (b (create-temp-var 'rest))) + (**app (**var/def (core-symbol "foldr")) + (**lambda/pat + (list (**var-pat/def l) (**var-pat/def b)) + (**case (**var/def l) + (list (**alt/simple + gen-pat + (do-cfn-list-comp exp quals c b)) + (**alt/simple + (**wildcard-pat) + (**var/def b))))) + (**var/def n) + gen-exp))) + +;;; Placeholders just get eliminated + +(define-walker-method cfn dict-placeholder (object) + (if (eq? (dict-placeholder-exp object) '#f) + (error "Type checker screwed a dict placeholder object ~s." object) + (cfn-ast-1 (dict-placeholder-exp object)))) + +(define-walker-method cfn method-placeholder (object) + (if (eq? (method-placeholder-exp object) '#f) + (error "Type checker screwed a method placeholder object ~s." object) + (cfn-ast-1 (method-placeholder-exp object)))) + +(define-walker-method cfn recursive-placeholder (object) + (if (eq? (recursive-placeholder-exp object) '#f) + (error "Type checker screwed a recursive placeholder object ~s." object) + (cfn-ast-1 (recursive-placeholder-exp object)))) + +(define-walker-method cfn cast (object) + (cfn-ast-1 (cast-exp object))) + +;;; Eliminate saved old expressions + +(define-walker-method cfn save-old-exp (object) + (cfn-ast-1 (save-old-exp-new-exp object))) diff --git a/cfn/pattern.scm b/cfn/pattern.scm new file mode 100644 index 0000000..64badbf --- /dev/null +++ b/cfn/pattern.scm @@ -0,0 +1,654 @@ +;;; pattern.scm -- cfn processing of pattern-related AST structures +;;; +;;; author : Sandra Loosemore +;;; date : 27 Feb 1992 +;;; +;;; This file contains specialized CFN walkers for lambda, case, and valdef +;;; structures. + + + +;;;===================================================================== +;;; Top-level walkers +;;;===================================================================== + + +;;; The calls to remember-context are so an appropriate error message +;;; can be produced for pattern-matching failures. + +(define-walker-method cfn lambda (object) + (remember-context object + (do-cfn-lambda (lambda-pats object) (lambda-body object)))) + + +(define-walker-method cfn case (object) + (remember-context object + (do-cfn-case + (case-exp object) + (case-alts object)))) + + + + +;;; Valdefs are always processed as a list. + +(define (cfn-valdef-list list-of-valdefs) + (if (null? list-of-valdefs) + '() + (nconc (cfn-valdef (car list-of-valdefs)) + (cfn-valdef-list (cdr list-of-valdefs))))) + +(define (cfn-valdef object) + (remember-context object + (if (null? (single-fun-def-args (car (valdef-definitions object)))) + ;; This is a pattern binding. + (do-cfn-pattern-def-top object) + ;; This is a function binding. + ;; Branch on single-headed/multi-headed definition. + (list (add-dict-params + object + (if (null? (cdr (valdef-definitions object))) + (do-cfn-function-def-simple object) + (do-cfn-function-def-general object)))) + ))) + + +;;; This adds the dictionary parameters needed by the type system. A valdef +;;; structure has a dictionary-args field which contains the variables to be +;;; bound to dicationary arguments. + +(define (add-dict-params original-valdef generated-valdef) + (let ((vars (valdef-dictionary-args original-valdef))) + (when (not (null? vars)) + (let* ((sfd (car (valdef-definitions generated-valdef))) + (rhs (car (single-fun-def-rhs-list sfd))) + (exp (guarded-rhs-rhs rhs)) + (pats (map (function **var-pat/def) vars))) + (if (is-type? 'lambda exp) + (setf (lambda-pats exp) + (nconc pats (lambda-pats exp))) + (setf (guarded-rhs-rhs rhs) + (**lambda/pat pats exp)))))) + generated-valdef) + + +;;;===================================================================== +;;; Lambda rewriting +;;;===================================================================== + + +;;; For lambda, make all the argument patterns into var pats. +;;; Rewrite the body as a CASE to do any more complicated pattern +;;; matching. +;;; The CFN output for lambda is a modified lambda expression with +;;; all var-pats as arguments. + +(define (do-cfn-lambda pats body) + (let ((new-args '()) + (new-vars '()) + (new-pats '())) + (dolist (p pats) + (typecase p + (wildcard-pat + (push (**var-pat/def (create-temp-var 'arg)) new-args)) + (var-pat + (push p new-args)) + (as-pat + (let ((var (var-ref-var (as-pat-var p)))) + (push (**var-pat/def var) new-args) + (push (**var/def var) new-vars) + (push (as-pat-pattern p) new-pats))) + (else + (let ((var (create-temp-var 'arg))) + (push (**var-pat/def var) new-args) + (push (**var/def var) new-vars) + (push p new-pats))))) + (setf new-args (nreverse new-args)) + (setf new-vars (nreverse new-vars)) + (setf new-pats (nreverse new-pats)) + (**lambda/pat + new-args + (cond ((null? new-vars) + ;; No fancy pattern matching necessary. + (cfn-ast-1 body)) + ((null? (cdr new-vars)) + ;; Exactly one argument to match on. + (do-cfn-case (car new-vars) + (list (**alt/simple (car new-pats) body)))) + (else + ;; Multiple arguments to match on. + (do-cfn-case-tuple + new-vars + (list (**alt/simple (**tuple-pat new-pats) body)))) + )))) + + +;;;===================================================================== +;;; Function definitions +;;;===================================================================== + + +;;; The output of the CFN for function definitions is a simple +;;; valdef which binds a variable to a lambda expression. + + +;;; The simple case: there is only one set of arguments. + +(define (do-cfn-function-def-simple object) + (let* ((pat (valdef-lhs object)) + (sfd (car (valdef-definitions object)))) + (**valdef/pat + pat + (do-cfn-lambda + (single-fun-def-args sfd) + (rewrite-guards-and-where-decls + (single-fun-def-where-decls sfd) + (single-fun-def-rhs-list sfd) + '#f))))) + + +;;; The general case: generate new variables as the formal parameters +;;; to the resulting lambda, then use case to do the pattern matching. + +(define (do-cfn-function-def-general object) + (let ((pat (valdef-lhs object)) + (vars (map (lambda (p) + (declare (ignore p)) + (create-temp-var 'arg)) + (single-fun-def-args (car (valdef-definitions object))))) + (alts (map (lambda (sfd) + (**alt (**tuple-pat (single-fun-def-args sfd)) + (single-fun-def-rhs-list sfd) + (single-fun-def-where-decls sfd))) + (valdef-definitions object)))) + (**valdef/pat + pat + (**lambda/pat + (map (function **var-pat/def) vars) + (if (null? (cdr vars)) + ;; one-argument case + (do-cfn-case (**var/def (car vars)) alts) + ;; multi-argument case + (do-cfn-case-tuple (map (function **var/def) vars) alts)))) + )) + + +;;;===================================================================== +;;; Case +;;;===================================================================== + + +;;; For case, add failure alt, then call helper function to generate +;;; pattern matching tests. +;;; The CFN output for case is a case-block construct. + +(define (do-cfn-case exp alts) + (setf alts + (append alts + (list (**alt/simple (**wildcard-pat) (make-failure-exp))))) + (let ((list-of-pats (map (lambda (a) (list (alt-pat a))) alts))) + (if (is-type? 'var-ref exp) + (match-pattern-list (list exp) list-of-pats alts) + (let ((temp (create-temp-var 'cfn))) + (**let (list (**valdef/def temp (cfn-ast-1 exp))) + (match-pattern-list + (list (**var/def temp)) + list-of-pats + alts))) + ))) + + + +;;; Here's a special case, for when the exp being matched is a tuple +;;; of var-refs and all the alts also have tuple pats. + +(define (do-cfn-case-tuple exps alts) + (setf alts + (append alts + (list + (**alt/simple + (**tuple-pat + (map (lambda (e) (declare (ignore e)) (**wildcard-pat)) + exps)) + (make-failure-exp))))) + (match-pattern-list + exps + (map (lambda (a) (pcon-pats (alt-pat a))) alts) + alts)) + + +(define (match-pattern-list exps list-of-pats alts) + (let ((block-name (gensym "PMATCH"))) + (**case-block + block-name + (map (lambda (a p) (match-pattern exps p a block-name)) + alts + list-of-pats)))) + + +;;; Produce an exp that matches the given alt against the exps. +;;; If the match succeeds, it will return-from the given block-name. + +(define (match-pattern exps pats alt block-name) + (if (null pats) + ;; No more patterns to match. + ;; Return an exp that handles the guards and where-decls. + (cfn-ast-1 + (rewrite-guards-and-where-decls + (alt-where-decls alt) (alt-rhs-list alt) block-name)) + ;; Otherwise dispatch on type of first pattern. + (let ((pat (pop pats)) + (exp (pop exps))) + (funcall + (typecase pat + (wildcard-pat (function match-wildcard-pat)) + (var-pat (function match-var-pat)) + (pcon (function match-pcon)) + (as-pat (function match-as-pat)) + (irr-pat (function match-irr-pat)) + (const-pat (function match-const-pat)) + (plus-pat (function match-plus-pat)) + (list-pat (function match-list-pat)) + (else (error "Unrecognized pattern ~s." pat))) + pat + exp + pats + exps + alt + block-name)))) + + + + +;;; Wildcard patterns add no pattern matching test. +;;; Just recurse on the next pattern to be matched. + +(define (match-wildcard-pat pat exp pats exps alt block-name) + (declare (ignore pat exp)) + (match-pattern exps pats alt block-name)) + + +;;; A variable pattern likewise does not add any test. However, +;;; a binding of the variable to the corresponding exp must be added. + +(define (match-var-pat pat exp pats exps alt block-name) + (push (**valdef/pat pat exp) + (alt-where-decls alt)) + (match-pattern exps pats alt block-name)) + + +;;; Pcons are the hairy case because they may have subpatterns that need +;;; to be matched. +;;; If there are subpats and the exp is not a var-ref, make a let binding. +;;; If the con is a tuple type, there is no need to generate a test +;;; since the test would always succeed anyway. +;;; Do not generate let bindings here for subexpressions; do this lazily +;;; if and when necessary. + +(define (match-pcon pat exp pats exps alt block-name) + (let* ((var? (is-type? 'var-ref exp)) + (var (if var? + (var-ref-var exp) + (create-temp-var 'conexp))) + (con (pcon-con pat)) + (arity (con-arity con)) + (alg (con-alg con)) + (tuple? (algdata-tuple? alg)) + (subpats (pcon-pats pat)) + (subexps '())) + (dotimes (i arity) + (push (**sel con (**var/def var) i) subexps)) + (setf exps (nconc (nreverse subexps) exps)) + (setf pats (append subpats pats)) + (let ((tail (match-pattern exps pats alt block-name))) + (when (not tuple?) + (setf tail + (**and-exp (**is-constructor (**var/def var) con) tail))) + (when (not var?) + (setf tail + (**let (list (**valdef/def var (cfn-ast-1 exp))) tail))) + tail))) + + +;;; For as-pat, add a variable binding. +;;; If the expression being matched is not already a variable reference, +;;; take this opportunity to make the let binding. Otherwise push the +;;; let-binding onto the where-decls. + +(define (match-as-pat pat exp pats exps alt block-name) + (let ((var (var-ref-var (as-pat-var pat))) + (subpat (as-pat-pattern pat))) + (if (is-type? 'var-ref exp) + (begin + (push (**valdef/def var (**var/def (var-ref-var exp))) + (alt-where-decls alt)) + (match-pattern + (cons exp exps) + (cons subpat pats) + alt + block-name)) + (**let (list (**valdef/def var (cfn-ast-1 exp))) + (match-pattern + (cons (**var/def var) exps) + (cons subpat pats) + alt + block-name))))) + + +;;; An irrefutable pattern adds no test to the pattern matching, +;;; but adds a pattern binding to the where-decls. + +(define (match-irr-pat pat exp pats exps alt block-name) + (let ((subpat (irr-pat-pattern pat))) + (push (**valdef/pat subpat exp) (alt-where-decls alt)) + (match-pattern exps pats alt block-name))) + + +;;; A const pat has a little piece of code inserted by the typechecker +;;; to do the test. +;;; For matches against string constants, generate an inline test to match +;;; on each character of the string. + +(define (match-const-pat pat exp pats exps alt block-name) + (let ((const (const-pat-value pat))) + (**and-exp + (if (is-type? 'string-const const) + (let ((string (string-const-value const))) + (if (string=? string "") + (**is-constructor exp (core-symbol "Nil")) + (**app (**var/def (core-symbol "primStringEq")) const exp))) + (cfn-ast-1 (**app (const-pat-match-fn pat) exp))) + (match-pattern exps pats alt block-name)) + )) + + +;;; Plus pats have both a magic test and a piece of code to +;;; make a binding in the where-decls. Make a variable binding +;;; for the exp if it's not already a variable. + +(define (match-plus-pat pat exp pats exps alt block-name) + (let* ((var? (is-type? 'var-ref exp)) + (var (if var? (var-ref-var exp) (create-temp-var 'plusexp)))) + (push (**valdef/pat (plus-pat-pattern pat) + (**app (plus-pat-bind-fn pat) (**var/def var))) + (alt-where-decls alt)) + (let ((tail (match-pattern exps pats alt block-name))) + (setf tail + (**and-exp + (cfn-ast-1 (**app (plus-pat-match-fn pat) (**var/def var))) + tail)) + (if var? + tail + (**let (list (**valdef/def var exp)) tail))))) + + +;;; Rewrite list pats as pcons, then process recursively. + +(define (match-list-pat pat exp pats exps alt block-name) + (let ((newpat (rewrite-list-pat (list-pat-pats pat)))) + (match-pattern + (cons exp exps) + (cons newpat pats) + alt + block-name))) + +(define (rewrite-list-pat subpats) + (if (null? subpats) + (**pcon/def (core-symbol "Nil") '()) + (**pcon/def (core-symbol ":") + (list (car subpats) + (rewrite-list-pat (cdr subpats)))))) + + + + +;;;===================================================================== +;;; Pattern definitions +;;;===================================================================== + + +(define (do-cfn-pattern-def-top object) + (typecase (valdef-lhs object) + (var-pat + ;; If the pattern definition is a simple variable assignment, it + ;; may have dictionary parameters that need to be messed with. + ;; Complicated pattern bindings can't be overloaded in this way. + (list (add-dict-params object (do-cfn-pattern-def-simple object)))) + (irr-pat + ;; Irrefutable patterns are redundant here. + (setf (valdef-lhs object) (irr-pat-pattern (valdef-lhs object))) + (do-cfn-pattern-def-top object)) + (wildcard-pat + ;; Wildcards are no-ops. + '()) + (pcon + ;; Special-case because it's frequent and general case creates + ;; such lousy code + (do-cfn-pattern-def-pcon object)) + (else + (do-cfn-pattern-def-general object)))) + + +;;; Do a "simple" pattern definition, e.g. one that already has a +;;; var-pat on the lhs. + +(define (do-cfn-pattern-def-simple object) + (let* ((pat (valdef-lhs object)) + (sfd (car (valdef-definitions object))) + (exp (rewrite-guards-and-where-decls + (single-fun-def-where-decls sfd) + (single-fun-def-rhs-list sfd) + '#f))) + (**valdef/pat pat (cfn-ast-1 exp)))) + + +;;; Destructure a pcon. +;;; Note that the simplified expansion is only valid if none of +;;; the subpatterns introduce tests. Otherwise we must defer to +;;; the general case. + +(define (do-cfn-pattern-def-pcon object) + (let* ((pat (valdef-lhs object)) + (subpats (pcon-pats pat))) + (if (every (function irrefutable-pat?) subpats) + (let* ((con (pcon-con pat)) + (arity (con-arity con)) + (alg (con-alg con)) + (tuple? (algdata-tuple? alg)) + (temp (create-temp-var 'pbind)) + (result '())) + (dotimes (i arity) + (setf result + (nconc result + (do-cfn-pattern-def-top + (**valdef/pat (pop subpats) + (**sel con (**var/def temp) i)))))) + (if (null? result) + '() + (let* ((sfd (car (valdef-definitions object))) + (exp (cfn-ast-1 + (rewrite-guards-and-where-decls + (single-fun-def-where-decls sfd) + (single-fun-def-rhs-list sfd) + '#f)))) + (when (not tuple?) + (let ((temp1 (create-temp-var 'cfn))) + (setf exp + (**let (list (**valdef/def temp1 exp)) + (**if (**is-constructor (**var/def temp1) con) + (**var/def temp1) + (make-failure-exp)))))) + (cons (**valdef/def temp exp) result)))) + (do-cfn-pattern-def-general object)))) + + + +;;; Turn a complicated pattern definition into a list of simple ones. +;;; The idea is to use case to match the pattern and build a tuple of +;;; all the values which are being destructured into the pattern +;;; variables. + +(define (do-cfn-pattern-def-general object) + (multiple-value-bind (new-pat vars new-vars) + (copy-pattern-variables (valdef-lhs object)) + (if (not (null? vars)) + (let* ((sfd (car (valdef-definitions object))) + (exp (rewrite-guards-and-where-decls + (single-fun-def-where-decls sfd) + (single-fun-def-rhs-list sfd) + '#f)) + (arity (length vars))) + (if (eqv? arity 1) + (list (**valdef/def + (var-ref-var (car vars)) + (do-cfn-case + exp + (list (**alt/simple new-pat (car new-vars)))))) + (let ((temp (create-temp-var 'pbind)) + (bindings '())) + (dotimes (i arity) + (push (**valdef/def (var-ref-var (pop vars)) + (**tuple-sel arity i (**var/def temp))) + bindings)) + (cons (**valdef/def + temp + (do-cfn-case + exp + (list (**alt/simple new-pat (**tuple/l new-vars))))) + bindings)))) + '()))) + + + +;;; Helper function for above. +;;; All the variables in the pattern must be replaced with temporary +;;; variables. + +(define (copy-pattern-variables pat) + (typecase pat + (wildcard-pat + (values pat '() '())) + (var-pat + (let ((new (create-temp-var (var-ref-name (var-pat-var pat))))) + (values (**var-pat/def new) + (list (var-pat-var pat)) + (list (**var/def new))))) + (pcon + (multiple-value-bind (new-pats vars new-vars) + (copy-pattern-variables-list (pcon-pats pat)) + (values (**pcon/def (pcon-con pat) new-pats) + vars + new-vars))) + (as-pat + (let ((new (create-temp-var (var-ref-name (as-pat-var pat))))) + (multiple-value-bind (new-pat vars new-vars) + (copy-pattern-variables (as-pat-pattern pat)) + (values + (make as-pat + (var (**var/def new)) + (pattern new-pat)) + (cons (as-pat-var pat) vars) + (cons (**var/def new) new-vars))))) + (irr-pat + (multiple-value-bind (new-pat vars new-vars) + (copy-pattern-variables (irr-pat-pattern pat)) + (values + (make irr-pat (pattern new-pat)) + vars + new-vars))) + (const-pat + (values pat '() '())) + (plus-pat + (multiple-value-bind (new-pat vars new-vars) + (copy-pattern-variables (plus-pat-pattern pat)) + (values + (make plus-pat + (pattern new-pat) + (k (plus-pat-k pat)) + (match-fn (plus-pat-match-fn pat)) + (bind-fn (plus-pat-bind-fn pat))) + vars + new-vars))) + (list-pat + (multiple-value-bind (new-pats vars new-vars) + (copy-pattern-variables-list (list-pat-pats pat)) + (values (make list-pat (pats new-pats)) + vars + new-vars))) + (else + (error "Unrecognized pattern ~s." pat)))) + +(define (copy-pattern-variables-list pats) + (let ((new-pats '()) + (vars '()) + (new-vars '())) + (dolist (p pats) + (multiple-value-bind (p v n) (copy-pattern-variables p) + (push p new-pats) + (setf vars (nconc vars v)) + (setf new-vars (nconc new-vars n)))) + (values (nreverse new-pats) + vars + new-vars))) + + + +;;;===================================================================== +;;; Helper functions for processing guards and where-decls +;;;===================================================================== + +;;; Process guards and where-decls into a single expression. +;;; If block-name is non-nil, wrap the exp with a return-from. +;;; If block-name is nil, add a failure exp if necessary. +;;; Note that this does NOT do the CFN traversal on the result or +;;; any part of it. + +(define (rewrite-guards-and-where-decls where-decls rhs-list block-name) + (if (null? where-decls) + (rewrite-guards rhs-list block-name) + (**let where-decls + (rewrite-guards rhs-list block-name)))) + +(define (rewrite-guards rhs-list block-name) + (if (null? rhs-list) + (if block-name + (**con/def (core-symbol "False")) + (make-failure-exp)) + (let* ((rhs (car rhs-list)) + (guard (guarded-rhs-guard rhs)) + (exp (guarded-rhs-rhs rhs))) + (when block-name + (setf exp (**return-from block-name exp))) + (cond ((is-type? 'omitted-guard (guarded-rhs-guard (car rhs-list))) + exp) + ((and block-name (null? (cdr rhs-list))) + (**and-exp guard exp)) + (else + (**if guard + exp + (rewrite-guards (cdr rhs-list) block-name))) + )))) + + +(define (make-failure-exp) + (let ((c (dynamic *context*))) + (**abort + (if (not c) + "Pattern match failed." + (let* ((stuff (ast-node-line-number c)) + (line (source-pointer-line stuff)) + (file (source-pointer-file stuff))) + (if (and (is-type? 'valdef c) + (is-type? 'var-pat (valdef-lhs c))) + (format + '#f + "Pattern match failed in function ~a at line ~s in file ~a." + (valdef-lhs c) line file) + (format + '#f + "Pattern match failed at line ~s in file ~a." + line file))))))) + + + + diff --git a/cl-support/PORTING b/cl-support/PORTING new file mode 100644 index 0000000..2114be5 --- /dev/null +++ b/cl-support/PORTING @@ -0,0 +1,105 @@ +Here are the steps involved in porting to a new Common Lisp implementation. + +(0) Find the executable you want to use. If possible, use an image + that doesn't have stuff like CLX, CLOS, a snazzy editor, and the + like loaded, since we don't use any of that stuff. + + Put an environment variable in the haskell-development script to point + to the lisp you want to run. + +(1) You must add appropriate conditionalizations to cl-init.lisp and + cl-definitions.lisp in this directory. Look for places where there + are #+ things for the other dialects. + + As a matter of style, try to make an explicit case for each Lisp + instead of using #- to test for it *not* being a particular dialect. + This will prevent confusion on future ports. + + You may also need/want to add conditionals to the primitive + implementation files in the runtime directory. + + Do not add #+/#- conditionalizations to any other random .scm + files, since we want to keep this implementation-dependent stuff + centralized. + +(2) Make subdirectories to hold compiled files in each of the source + directories. The name of the subdirectory must match the constant + lisp-implementation-name in cl-definitions.lisp. + +(3) Try compiling the Haskell system (by loading cl-init.lisp) and + fix any compilation warnings that happen. (Hopefully there won't + be any.) + + You probably want to build a system initially with the default + compiler settings and verbose compiler diagnostics. This will make + any problems that show up later easier to debug. Also, it is + helpful to capture all the messages in a dribble file to make it + easier to verify that everything went OK. + +(4) Try compiling the prelude using (compile/prelude *prelude-unit*). + You need to create a subdirectory in the progs/prelude directory + to hold the output files, and define $PRELUDEBIN to point at + this directory (see the haskell-setup script). + + The important thing at this point is that the prelude makes it all + the way through the codegen phase and produces Lisp code. Don't worry + too much now if the Lisp compiler has trouble digesting the output. + + Once you get to this stage, it's time to start messing with + compiler optimize proclamations. We generally use (speed 3) and + (safety 0). Also, you should figure out how to suppress any + compiler messages (e.g., set *compile-print* and *compile-verbose* + to false). We usually leave *compile-verbose* on during compilation + of the Haskell compiler, but turn it off later so that people don't + get messages from the Lisp compiler when running Haskell programs. + +(5) Make a subdirectory in the com directory and make the following set + of scripts there: + + clean -- remove all binary files. Also change the main com/clean + script to invoke this. + compile -- recompile everything with the right compiler flags (see + step 5). + build-prelude -- run the prelude through the haskell compiler. + This should save the old compiled prelude files as old-prelude.* + case something goes wrong. + savesys -- load the compiled prelude and save a core file. + This should also be careful not to overwrite an existing file. + + Look at the scripts that have already been written for other Lisps + for hints. + + At some point you also need to put a README file in this directory. + + +(6) Now it's time to get serious about getting the prelude to compile. + Use the clean, compile, and build-prelude scripts you just wrote. + + Some compilers have a hard time dealing with the large pieces of + Lisp code produced for the prelude. You will probably need to do + something to make the heap bigger. (And, make sure the machine + you are using to do the build on has plenty of swap space.) You + may also need to tweak the chunk-size parameters to force the + output to be split up into smaller pieces. + + It's OK to leave the prelude interface file as a source file, or + to compile it with low speed optimizations. On the other hand, + the prelude code file ought to be processed with as many speed + optimizations as possible. + +(7) Build a new executable using the "savesys" script and take it for + a test drive. + +(8) You must also hack the emacs interface file, emacs-tools/haskell.el, + to recognize when it's gotten into the debugger or break loop. + To test your new executable with the emacs stuff, you must + define the environment variable HASKELLPROG to point at it, or + set the emacs variable haskell-program-name. + +(9) If you want to use the Haskell->CLX interface, you'll have to + mess with equivalents of the build-xlib and savesys-xlib scripts. + There is some system-dependent code in xlibclx.scm to set up an + error handler -- make sure you have conditionalized this appropriately + for your Lisp system. + + diff --git a/cl-support/README b/cl-support/README new file mode 100644 index 0000000..5553e4a --- /dev/null +++ b/cl-support/README @@ -0,0 +1,3 @@ +This directory contains Common-Lisp-syntax files to set up a more +Scheme-like environment. Load cl-init.lisp and it will suck in all +the rest. diff --git a/cl-support/cl-definitions.lisp b/cl-support/cl-definitions.lisp new file mode 100644 index 0000000..8727679 --- /dev/null +++ b/cl-support/cl-definitions.lisp @@ -0,0 +1,1351 @@ +;;; cl-definitions.lisp -- mumble compatibility package for Common Lisp +;;; +;;; author : Sandra Loosemore +;;; date : 11 Oct 1991 +;;; +;;; You must load cl-setup and cl-support before trying to compile this +;;; file. + +(in-package "MUMBLE-IMPLEMENTATION") + + +;;;===================================================================== +;;; Syntax +;;;===================================================================== + +(define-mumble-import quote) +(define-mumble-import function) + +;;; Lambda lists have to have dot syntax converted to &rest. + +(define-mumble-macro mumble::lambda (lambda-list &rest body) + `(function (lambda ,(mung-lambda-list lambda-list) ,@body))) + +(defun mung-lambda-list (lambda-list) + (cond ((consp lambda-list) + (let ((last (last lambda-list))) + (if (null (cdr last)) + lambda-list + `(,@(ldiff lambda-list last) ,(car last) &rest ,(cdr last))))) + ((null lambda-list) + '()) + (t + `(&rest ,lambda-list)))) + + +;;; We only funcall and apply things that are real functions. + + +;;; Gag. Lucid needs to see the procedure declaration to avoid putting +;;; a coerce-to-procedure check in, but there's a compiler bug that causes +;;; it to barf if the function is a lambda form. + +#+lucid +(define-mumble-macro mumble::funcall (fn . args) + (if (and (consp fn) (eq (car fn) 'mumble::lambda)) + `(funcall ,fn ,@args) + `(funcall (the system::procedure ,fn) ,@args))) + +#+(or cmu allegro akcl lispworks mcl) +(define-mumble-macro mumble::funcall (fn . args) + `(funcall (the function ,fn) ,@args)) + +#+wcl +(define-mumble-macro mumble::funcall (fn . args) + `(funcall (the lisp:procedure ,fn) ,@args)) + +#-(or lucid cmu allegro akcl mcl lispworks wcl) +(missing-mumble-definition mumble::funcall) + + +;;; Could make this declare its fn argument too + +(define-mumble-import apply) + +(define-mumble-synonym mumble::map mapcar) +(define-mumble-synonym mumble::for-each mapc) +(define-mumble-import some) +(define-mumble-import every) +(define-mumble-import notany) +(define-mumble-import notevery) +(define-mumble-synonym mumble::procedure? functionp) + + +(define-mumble-import if) +(define-mumble-import when) +(define-mumble-import unless) + + +;;; COND and CASE differ from Common Lisp because of using "else" instead +;;; of "t" as the fall-through case. + +(define-mumble-import mumble::else) + +(define-mumble-macro mumble::cond (&rest cases) + (let ((last (car (last cases)))) + (if (eq (car last) 'mumble::else) + `(cond ,@(butlast cases) (t ,@(cdr last))) + `(cond ,@cases)))) + +(define-mumble-macro mumble::case (data &rest cases) + (let ((last (car (last cases)))) + (if (eq (car last) 'mumble::else) + `(case ,data ,@(butlast cases) (t ,@(cdr last))) + `(case ,data ,@cases)))) + + +(define-mumble-import and) +(define-mumble-import or) +(define-mumble-import not) + +(define-mumble-macro mumble::set! (variable value) + `(setq ,variable ,value)) +(define-mumble-import setf) + + +;;; AKCL's SETF brokenly tries to macroexpand the place +;;; form before looking for a define-setf-method. Redefine the +;;; internal function to do the right thing. + +#+akcl +(defun system::setf-expand-1 (place newvalue env) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method place env) + (declare (ignore access-form)) + `(let* ,(mapcar #'list + (append vars stores) + (append vals (list newvalue))) + ,store-form))) + + +;;; Allegro has renamed this stuff as per ANSI CL. + +#+allegro +(eval-when (eval compile load) + (setf (macro-function 'define-setf-method) + (macro-function 'define-setf-expander)) + (setf (symbol-function 'get-setf-method) + (symbol-function 'get-setf-expansion)) + ) + +(define-mumble-import let) +(define-mumble-import let*) + +(define-mumble-macro mumble::letrec (bindings &rest body) + `(let ,(mapcar #'car bindings) + ,@(mapcar #'(lambda (b) (cons 'setq b)) bindings) + (locally ,@body))) + +(define-mumble-import flet) +(define-mumble-import labels) + +(define-mumble-macro mumble::dynamic-let (bindings &rest body) + `(let ,bindings + (declare (special ,@(mapcar #'car bindings))) + ,@body)) + +(define-mumble-macro mumble::dynamic (name) + `(locally (declare (special ,name)) ,name)) + +(define-setf-method mumble::dynamic (name) + (let ((store (gensym))) + (values nil + nil + (list store) + `(locally (declare (special ,name)) (setf ,name ,store)) + `(locally (declare (special ,name)) ,name)))) + + +(define-mumble-macro mumble::begin (&rest body) + `(progn ,@body)) + +(define-mumble-import block) +(define-mumble-import return-from) + +(define-mumble-import do) +(define-mumble-import dolist) +(define-mumble-import dotimes) + +(define-mumble-import values) +(define-mumble-import multiple-value-bind) + +(define-mumble-macro mumble::let/cc (variable &rest body) + (let ((tagvar (gensym))) + `(let* ((,tagvar (gensym)) + (,variable (let/cc-aux ,tagvar))) + (catch ,tagvar (locally ,@body))))) + +(defun let/cc-aux (tag) + #'(lambda (&rest values) + (throw tag (values-list values)))) + + +(define-mumble-import unwind-protect) + +(define-mumble-import declare) +(define-mumble-import ignore) + + +;;; IGNORABLE is part of ANSI CL but not implemented by Lucid yet. +;;; IGNORE in Lucid seems to behave like what ANSI CL says IGNORABLE +;;; should do, but there doesn't seem to be any way to rename it. + +#+(or lucid akcl lispworks wcl) +(progn + (proclaim '(declaration mumble::ignorable)) + (define-mumble-import mumble::ignorable)) + +#+(or cmu mcl allegro) +(define-mumble-import cl:ignorable) + +#-(or lucid cmu allegro akcl mcl lispworks wcl) +(missing-mumble-definition mumble::ignorable) + + +(define-mumble-import type) + + + +;;;===================================================================== +;;; Definitions +;;;===================================================================== + + +;;; *** This shouldn't really do a DEFPARAMETER, since that proclaims +;;; *** the variable SPECIAL and makes any LETs of the variable do +;;; *** special binding rather than lexical binding. But if you just +;;; *** SETF the variable, you'll get a compiler warning about an +;;; *** undeclared free variable on every reference!!! Argggh. + +(define-mumble-macro mumble::define (pattern &rest value) + (if (consp pattern) + `(defun ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@value) + `(defparameter ,pattern ,(car value)))) + +(define-mumble-macro mumble::define-integrable (pattern &rest value) + (if (consp pattern) + `(progn + (eval-when (eval compile load) + (proclaim '(inline ,(car pattern)))) + (defun ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@value)) + `(defconstant ,pattern ,(car value)))) + + +(define-mumble-macro mumble::define-syntax (pattern . body) + `(defmacro ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@body)) + +(define-mumble-macro mumble::define-local-syntax (pattern . body) + `(eval-when (eval compile) + (defmacro ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@body))) + + +(define-mumble-macro mumble::define-setf (getter setter) + `(define-setf-method ,getter (&rest subforms) + (define-setf-aux ',setter ',getter subforms))) + +(defun define-setf-aux (setter getter subforms) + (let ((temps nil) + (tempvals nil) + (args nil) + (store (gensym))) + (dolist (x subforms) + (if (constantp x) + (push x args) + (let ((temp (gensym))) + (push temp temps) + (push x tempvals) + (push temp args)))) + (setq temps (nreverse temps)) + (setq tempvals (nreverse tempvals)) + (setq args (nreverse args)) + (values temps + tempvals + (list store) + `(,setter ,store ,@args) + `(,getter ,@args)))) + + +;;; Declaring variables special will make the compiler not proclaim +;;; about references to them. +;;; A proclamation works to disable undefined function warnings in +;;; most Lisps. Harlequin seems to offer no way to shut up these warnings. +;;; In allegro, we have to work around a bug in the compiler's handling +;;; of PROCLAIM. + +(define-mumble-macro mumble::predefine (pattern) + `(eval-when (eval compile) + #+allegro (let ((excl::*compiler-environment* nil)) + (do-predefine ',pattern)) + #-allegro (do-predefine ',pattern) + )) + +(eval-when (eval compile load) + (defun do-predefine (pattern) + (if (consp pattern) + (proclaim `(ftype (function ,(mung-decl-lambda-list (cdr pattern)) t) + ,(car pattern))) + (proclaim `(special ,pattern)))) + (defun mung-decl-lambda-list (lambda-list) + (cond ((consp lambda-list) + (cons 't (mung-decl-lambda-list (cdr lambda-list)))) + ((null lambda-list) + '()) + (t + '(&rest t)))) + ) + + +;;; CMUCL doesn't complain about function redefinitions, but Lucid does. + +#+(or cmu akcl mcl lispworks wcl) +(define-mumble-macro mumble::redefine (pattern . value) + `(mumble::define ,pattern ,@value)) + +#+lucid +(define-mumble-macro mumble::redefine (pattern . value) + `(let ((lcl:*redefinition-action* nil)) + (mumble::define ,pattern ,@value))) + +#+allegro +(define-mumble-macro mumble::redefine (pattern . value) + `(let ((excl:*redefinition-warnings* nil)) + (mumble::define ,pattern ,@value))) + +#-(or cmu lucid allegro akcl mcl lispworks wcl) +(missing-mumble-definition mumble::redefine) + + +#+(or cmu akcl mcl lispworks wcl) +(define-mumble-macro mumble::redefine-syntax (pattern . body) + `(mumble::define-syntax ,pattern ,@body)) + +#+lucid +(define-mumble-macro mumble::redefine-syntax (pattern . body) + `(eval-when (eval compile load) + (let ((lcl:*redefinition-action* nil)) + (mumble::define-syntax ,pattern ,@body)))) + +#+allegro +(define-mumble-macro mumble::redefine-syntax (pattern . body) + `(eval-when (eval compile load) + (let ((excl:*redefinition-warnings* nil)) + (mumble::define-syntax ,pattern ,@body)))) + +#-(or cmu lucid allegro akcl mcl lispworks wcl) +(missing-mumble-definition mumble::redefine-syntax) + + + +;;;===================================================================== +;;; Equivalence +;;;===================================================================== + +(define-mumble-function-inline mumble::eq? (x y) + (eq x y)) +(define-mumble-function-inline mumble::eqv? (x y) + (eql x y)) + +(define-mumble-function mumble::equal? (x1 x2) + (cond ((eql x1 x2) + t) + ((consp x1) + (and (consp x2) + (mumble::equal? (car x1) (car x2)) + (mumble::equal? (cdr x1) (cdr x2)))) + ((simple-string-p x1) + (and (simple-string-p x2) + (string= x1 x2))) + ((simple-vector-p x1) + (and (simple-vector-p x2) + (eql (length (the simple-vector x1)) + (length (the simple-vector x2))) + (every #'mumble::equal? + (the simple-vector x1) + (the simple-vector x2)))) + (t nil))) + + +;;;===================================================================== +;;; Lists +;;;===================================================================== + +(define-mumble-function-inline mumble::pair? (x) + (consp x)) + +(define-mumble-import cons) + + +;;; Can't import this directly because of type problems. + +(define-mumble-synonym mumble::list list) + +(define-mumble-function-inline mumble::make-list (length &optional (init nil)) + (the list + (make-list length :initial-element init))) + +(define-mumble-import car) +(define-mumble-import cdr) +(define-mumble-import caar) +(define-mumble-import cadr) +(define-mumble-import cadr) +(define-mumble-import cddr) +(define-mumble-import caaar) +(define-mumble-import caadr) +(define-mumble-import caadr) +(define-mumble-import caddr) +(define-mumble-import cdaar) +(define-mumble-import cdadr) +(define-mumble-import cdadr) +(define-mumble-import cdddr) +(define-mumble-import caaaar) +(define-mumble-import caaadr) +(define-mumble-import caaadr) +(define-mumble-import caaddr) +(define-mumble-import cadaar) +(define-mumble-import cadadr) +(define-mumble-import cadadr) +(define-mumble-import cadddr) +(define-mumble-import cdaaar) +(define-mumble-import cdaadr) +(define-mumble-import cdaadr) +(define-mumble-import cdaddr) +(define-mumble-import cddaar) +(define-mumble-import cddadr) +(define-mumble-import cddadr) +(define-mumble-import cddddr) + +(define-mumble-function-inline mumble::null? (x) + (null x)) + +(define-mumble-function mumble::list? (x) + (cond ((null x) t) + ((consp x) (mumble::list? (cdr x))) + (t nil))) + +(define-mumble-function-inline mumble::length (x) + (the fixnum (length (the list x)))) + +(define-mumble-import append) +(define-mumble-import nconc) + +(define-mumble-function-inline mumble::reverse (x) + (the list (reverse (the list x)))) +(define-mumble-function-inline mumble::nreverse (x) + (the list (nreverse (the list x)))) + +(define-mumble-function-inline mumble::list-tail (list n) + (nthcdr n list)) +(define-mumble-function-inline mumble::list-ref (list n) + (nth n list)) + +(define-mumble-import last) +(define-mumble-import butlast) + +(define-setf-method mumble::list-ref (list n) + (get-setf-method `(nth ,n ,list))) + +(define-mumble-function-inline mumble::memq (object list) + (member object list :test #'eq)) +(define-mumble-function-inline mumble::memv (object list) + (member object list)) +(define-mumble-function-inline mumble::member (object list) + (member object list :test #'mumble::equal?)) + +;;; *** The Lucid compiler is not doing anything inline for assq so +;;; *** I'm rewriting this -- jcp +(define-mumble-function mumble::assq (object list) + (if (null list) + nil + (if (eq object (caar list)) + (car list) + (mumble::assq object (cdr list))))) + +(define-mumble-function-inline mumble::assv (object list) + (assoc object list)) +(define-mumble-function-inline mumble::assoc (object list) + (assoc object list :test #'mumble::equal?)) + +(define-mumble-import push) +(define-mumble-import pop) + +(define-mumble-synonym mumble::list-copy copy-list) + + +;;;===================================================================== +;;; Symbols +;;;===================================================================== + +(define-mumble-function-inline mumble::symbol? (x) + (symbolp x)) +(define-mumble-synonym mumble::symbol->string symbol-name) + +(define-mumble-function-inline mumble::string->symbol (x) + (intern x)) + + +;;; We want a gensym that follows the new ANSI CL gensym-name-stickiness +;;; decision. + +#+(or lucid akcl wcl) +(define-mumble-function mumble::gensym (&optional (prefix "G")) + (gensym prefix)) + +#+(or cmu allegro mcl lispworks) +(define-mumble-import gensym) + +#-(or lucid akcl wcl cmu allegro mcl lispworks) +(missing-mumble-definition mumble::gensym) + +(define-mumble-function mumble::gensym? (x) + (and (symbolp x) + (not (symbol-package x)))) + +(defun symbol-append (&rest symbols) + (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) +(define-mumble-import symbol-append) + + +;;;===================================================================== +;;; Characters +;;;===================================================================== + +(define-mumble-function-inline mumble::char? (x) + (characterp x)) + +(define-mumble-synonym mumble::char=? char=) +(define-mumble-synonym mumble::char<? char<) +(define-mumble-synonym mumble::char>? char>) +(define-mumble-synonym mumble::char>=? char>=) +(define-mumble-synonym mumble::char<=? char<=) + +(define-mumble-synonym mumble::char-ci=? char-equal) +(define-mumble-synonym mumble::char-ci<? char-lessp) +(define-mumble-synonym mumble::char-ci>? char-greaterp) +(define-mumble-synonym mumble::char-ci>=? char-not-lessp) +(define-mumble-synonym mumble::char-ci<=? char-not-greaterp) + +(define-mumble-synonym mumble::char-alphabetic? alpha-char-p) +(define-mumble-synonym mumble::char-numeric? digit-char-p) + +(define-mumble-function mumble::char-whitespace? (c) + (member c '(#\space #\tab #\newline #\linefeed #\page #\return))) + +(define-mumble-synonym mumble::char-upper-case? upper-case-p) +(define-mumble-synonym mumble::char-lower-case? lower-case-p) + +(define-mumble-synonym mumble::char->integer char-code) +(define-mumble-synonym mumble::integer->char code-char) + +(define-mumble-import char-upcase) +(define-mumble-import char-downcase) +(define-mumble-import char-name) + +(define-mumble-synonym mumble::char->digit digit-char-p) + + +;;;===================================================================== +;;; Strings +;;;===================================================================== + +(define-mumble-function-inline mumble::string? (x) + (simple-string-p x)) + +(define-mumble-function-inline mumble::make-string + (length &optional (init nil init-p)) + (the simple-string + (if init-p + (make-string length :initial-element init) + (make-string length)))) + +(define-mumble-function-inline mumble::string (char &rest more-chars) + (the simple-string (coerce (cons char more-chars) 'string))) + +(define-mumble-function-inline mumble::string-length (string) + (the fixnum (length (the simple-string string)))) + +(define-mumble-function-inline mumble::string-ref (x n) + (the character (schar (the simple-string x) (the fixnum n)))) + +(define-setf-method mumble::string-ref (string n) + (get-setf-method `(schar ,string ,n))) + +(define-mumble-synonym mumble::string=? string=) +(define-mumble-synonym mumble::string<? string<) +(define-mumble-synonym mumble::string>? string>) +(define-mumble-synonym mumble::string<=? string<=) +(define-mumble-synonym mumble::string>=? string>=) + +(define-mumble-synonym mumble::string-ci=? string-equal) +(define-mumble-synonym mumble::string-ci<? string-lessp) +(define-mumble-synonym mumble::string-ci>? string-greaterp) +(define-mumble-synonym mumble::string-ci<=? string-not-greaterp) +(define-mumble-synonym mumble::string-ci>=? string-not-lessp) + +(define-mumble-function-inline mumble::substring (string start end) + (the simple-string (subseq (the simple-string string) start end))) + +(define-mumble-function-inline mumble::string-append + (string &rest more-strings) + (declare (type simple-string string)) + (the simple-string (apply #'concatenate 'string string more-strings))) + +(define-mumble-function-inline mumble::string->list (string) + (the list (coerce (the simple-string string) 'list))) + +(define-mumble-function-inline mumble::list->string (list) + (the simple-string (coerce (the list list) 'string))) + +(define-mumble-function-inline mumble::string-copy (string) + (the simple-string (copy-seq (the simple-string string)))) + +(define-mumble-import string-upcase) +(define-mumble-import string-downcase) + + +;;;===================================================================== +;;; Vectors +;;;===================================================================== + +(define-mumble-function-inline mumble::vector? (x) + (simple-vector-p x)) + +(define-mumble-function-inline mumble::make-vector + (length &optional (init nil init-p)) + (declare (type fixnum length)) + (the simple-vector + (if init-p + (make-array length :initial-element init) + (make-array length)))) + + +;;; Can't import directly because types are incompatible. + +(define-mumble-synonym mumble::vector vector) + +(define-mumble-function-inline mumble::vector-length (vector) + (the fixnum (length (the simple-vector vector)))) + +(define-mumble-function-inline mumble::vector-ref (x n) + (svref (the simple-vector x) (the fixnum n))) + +(define-setf-method mumble::vector-ref (vector n) + (get-setf-method `(svref ,vector ,n))) + +(define-mumble-function-inline mumble::vector->list (vector) + (the list (coerce (the simple-vector vector) 'list))) + +(define-mumble-function-inline mumble::list->vector (list) + (the simple-vector (coerce (the list list) 'simple-vector))) + +(define-mumble-function-inline mumble::vector-copy (vector) + (the simple-vector (copy-seq (the simple-vector vector)))) + + +;;;===================================================================== +;;; Numbers +;;;===================================================================== + +(define-mumble-synonym mumble::number? numberp) +(define-mumble-synonym mumble::integer? integerp) +(define-mumble-synonym mumble::rational? rationalp) +(define-mumble-synonym mumble::float? floatp) + +(define-mumble-function-inline mumble::fixnum? (x) + (typep x 'fixnum)) + +(define-mumble-synonym mumble::exact->inexact float) + +(define-mumble-import =) +(define-mumble-import <) +(define-mumble-import >) +(define-mumble-import <=) +(define-mumble-import >=) + +(define-mumble-synonym mumble::zero? zerop) +(define-mumble-function-inline mumble::positive? (x) + (> x 0)) +(define-mumble-function-inline mumble::negative? (x) + (< x 0)) + +(define-mumble-import min) +(define-mumble-import max) + +(define-mumble-import +) +(define-mumble-import *) +(define-mumble-import -) +(define-mumble-import /) + +(define-mumble-synonym mumble::quotient floor) +(define-mumble-synonym mumble::remainder rem) +(define-mumble-synonym mumble::modulo mod) + +(define-mumble-function-inline mumble::floor (x) + (if (floatp x) (ffloor x) (floor (the rational x)))) +(define-mumble-function-inline mumble::ceiling (x) + (if (floatp x) (fceiling x) (ceiling (the rational x)))) +(define-mumble-function-inline mumble::truncate (x) + (if (floatp x) (ftruncate x) (truncate (the rational x)))) +(define-mumble-function-inline mumble::round (x) + (if (floatp x) (fround x) (round (the rational x)))) + +(define-mumble-synonym mumble::floor->exact floor) +(define-mumble-synonym mumble::ceiling->exact ceiling) +(define-mumble-synonym mumble::truncate->exact truncate) +(define-mumble-synonym mumble::round->exact round) + +(define-mumble-import 1+) +(define-mumble-import 1-) +(define-mumble-import incf) +(define-mumble-import decf) + +(define-mumble-function mumble::number->string (number &optional (radix 10)) + (let ((*print-base* radix)) + (prin1-to-string number))) + +(define-mumble-function mumble::string->number (string &optional (radix 10)) + (let ((*read-base* radix)) + (read-from-string string))) + +(define-mumble-import expt) + + + +;;;===================================================================== +;;; Tables +;;;===================================================================== + +(define-mumble-synonym mumble::table? hash-table-p) + +(define-mumble-function-inline mumble::make-table () + (make-hash-table :test #'eq)) + +(define-mumble-function-inline mumble::table-entry (table key) + (gethash key table)) + +(define-setf-method mumble::table-entry (table key) + (get-setf-method `(gethash ,key ,table))) + +(define-mumble-synonym mumble::table-for-each maphash) + +(define-mumble-function mumble::copy-table (old-table) + (let ((new-table (make-hash-table :test #'eq + :size (1+ (hash-table-count old-table))))) + (maphash #'(lambda (key val) (setf (gethash key new-table) val)) + old-table) + new-table)) + + +;;;===================================================================== +;;; I/O +;;;===================================================================== + +(define-mumble-function-inline mumble::call-with-input-file (string proc) + (with-open-file (stream (expand-filename string) :direction :input) + (funcall (the function proc) stream))) + +(define-mumble-function-inline mumble::call-with-output-file (string proc) + (with-open-file (stream (expand-filename string) + :direction :output :if-exists :new-version) + (funcall (the function proc) stream))) + +(define-mumble-function-inline mumble::call-with-input-string (string proc) + (with-input-from-string (stream string) + (funcall (the function proc) stream))) + +(define-mumble-function-inline mumble::call-with-output-string (proc) + (with-output-to-string (stream) + (funcall (the function proc) stream))) + +(define-mumble-synonym mumble::input-port? input-stream-p) +(define-mumble-synonym mumble::output-port? output-stream-p) + +(define-mumble-function-inline mumble::current-input-port () + *standard-input*) +(define-mumble-function-inline mumble::current-output-port () + *standard-output*) + +(define-mumble-function-inline mumble::open-input-file (string) + (open (expand-filename string) :direction :input)) + +(define-mumble-function-inline mumble::open-output-file (string) + (open (expand-filename string) :direction :output :if-exists :new-version)) + + +(define-mumble-synonym mumble::close-input-port close) +(define-mumble-synonym mumble::close-output-port close) + +(defvar *eof-object* (make-symbol "EOF")) + +(define-mumble-function-inline mumble::read + (&optional (port *standard-input*)) + (read port nil *eof-object*)) + +(define-mumble-function-inline mumble::read-char + (&optional (port *standard-input*)) + (read-char port nil *eof-object*)) + +(define-mumble-function-inline mumble::peek-char + (&optional (port *standard-input*)) + (peek-char nil port nil *eof-object*)) + +(define-mumble-function-inline mumble::read-line + (&optional (port *standard-input*)) + (read-line port nil *eof-object*)) + +(define-mumble-function-inline mumble::eof-object? (x) + (eq x *eof-object*)) + + +;;;===================================================================== +;;; Printer +;;;===================================================================== + +(define-mumble-function mumble::internal-write (object port) + (write object :stream port)) +(define-mumble-function-inline mumble::internal-output-width (port) + (declare (ignore port)) + nil) +(define-mumble-function-inline mumble::internal-output-position (port) + (declare (ignore port)) + nil) +(define-mumble-synonym mumble::internal-write-char write-char) +(define-mumble-function-inline mumble::internal-write-string + (string port start end) + (write-string string port :start start :end end)) +(define-mumble-synonym mumble::internal-newline terpri) +(define-mumble-synonym mumble::internal-fresh-line fresh-line) +(define-mumble-synonym mumble::internal-finish-output finish-output) +(define-mumble-synonym mumble::internal-force-output force-output) +(define-mumble-synonym mumble::internal-clear-output clear-output) + +(define-mumble-function mumble::internal-write-to-string (object) + (write-to-string object)) + + +(define-mumble-function-inline mumble::internal-warning (string) + (warn "~a" string)) + +(define-mumble-function-inline mumble::internal-error (string) + (error "~a" string)) + + +;;; Printer stuff used directly by the pretty printer + +(define-mumble-import *print-escape*) +(define-mumble-import *print-circle*) +(define-mumble-import *print-pretty*) +(define-mumble-import *print-level*) +(define-mumble-import *print-length*) +(define-mumble-import *print-base*) +(define-mumble-import *print-radix*) + + +;;; These functions and variables are all defined with the XP stuff. But, +;;; let's export all the symbols from the mumble package. + +(define-mumble-import mumble::write) +(define-mumble-import mumble::print) +(define-mumble-import mumble::prin1) +(define-mumble-import mumble::princ) +(define-mumble-import mumble::pprint) +(define-mumble-import mumble::prin1-to-string) +(define-mumble-import mumble::princ-to-string) +(define-mumble-import mumble::write-char) +(define-mumble-import mumble::write-string) +(define-mumble-import mumble::write-line) +(define-mumble-import mumble::terpri) +(define-mumble-import mumble::fresh-line) +(define-mumble-import mumble::finish-output) +(define-mumble-import mumble::force-output) +(define-mumble-import mumble::clear-output) +(define-mumble-import mumble::display) +(define-mumble-import mumble::newline) +(define-mumble-import mumble::*print-shared*) +(define-mumble-import mumble::*print-dispatch*) +(define-mumble-import mumble::*print-right-margin*) +(define-mumble-import mumble::*print-miser-width*) +(define-mumble-import mumble::*print-lines*) +(define-mumble-import mumble::*default-right-margin*) +(define-mumble-import mumble::*last-abbreviated-printing*) +(define-mumble-import mumble::*print-structure*) +(define-mumble-import mumble::*print-structure-slots*) +(define-mumble-import mumble::standard-print-dispatch) +(define-mumble-import mumble::pprint-newline) +(define-mumble-import mumble::pprint-logical-block) +(define-mumble-import mumble::pprint-pop) +(define-mumble-import mumble::pprint-exit-if-list-exhausted) +(define-mumble-import mumble::pprint-indent) +(define-mumble-import mumble::pprint-tab) +(define-mumble-import mumble::pprint-fill) +(define-mumble-import mumble::pprint-linear) +(define-mumble-import mumble::pprint-tabular) +(define-mumble-import mumble::format) +(define-mumble-import mumble::warning) +(define-mumble-import mumble::error) + + +;;; These are keywords for pprint-newline. + +(define-mumble-import mumble::linear) +(define-mumble-import mumble::fill) +(define-mumble-import mumble::miser) +(define-mumble-import mumble::mandatory) + +;;; These are keywords for pprint-indent + +;; (define-mumble-import mumble::block) ; already imported as special form +(define-mumble-import mumble::current) + +;;; These are keywords for pprint-tab + +(define-mumble-import mumble::line) +(define-mumble-import mumble::section) +(define-mumble-import mumble::line-relative) +(define-mumble-import mumble::section-relative) + + +;;;===================================================================== +;;; System Interface +;;;===================================================================== + +(define-mumble-import macroexpand-1) +(define-mumble-import macroexpand) + + +;;; WITH-COMPILATION-UNIT is an ANSI CL feature that isn't yet +;;; supported by all Lisps. + +#+lucid +(define-mumble-macro mumble::with-compilation-unit (options &body body) + (declare (ignore options)) + `(lcl:with-deferred-warnings ,@body)) + +#+(or cmu mcl allegro lispworks) +(define-mumble-import with-compilation-unit) + +#+(or akcl wcl) +(define-mumble-macro mumble::with-compilation-unit (options &body body) + (declare (ignore options)) + `(progn ,@body)) + +#-(or lucid allegro cmu akcl mcl lispworks wcl) +(missing-mumble-definition mumble::with-compilation-unit) + + +(define-mumble-function mumble::eval (form &optional compile-p) + (if compile-p + (mumble::with-compilation-unit () + (eval-compiling-functions form)) + (eval form))) + + +;;; Simply doing (funcall (compile nil `(lambda () ,form))) would work +;;; except that top-level-ness actions would be lost (causing extraneous +;;; warning messages about global variables whose references are compiled +;;; before a previous predefine is executed, etc). So make an attempt +;;; to process nested top-level forms in order. This doesn't look for +;;; all of the common-lispy things that might show up in macro expansions, +;;; but it's close enough. + +(defun eval-compiling-functions (form) + (if (atom form) + (eval form) + (let ((fn (car form))) + (cond ((or (eq fn 'mumble::begin) + (eq fn 'progn)) + (do ((forms (cdr form) (cdr forms))) + ((null (cdr forms)) (eval-compiling-functions (car forms))) + (eval-compiling-functions (car forms)))) + ((eq fn 'mumble::define) + (if (consp (cadr form)) + (compile-define form) + (compile-other form))) + ((eq fn 'mumble::define-integrable) + (if (consp (cadr form)) + (progn + (proclaim `(inline ,(car (cadr form)))) + (compile-define form)) + (compile-other form))) + ((eq fn 'mumble::predefine) + (do-predefine (cadr form))) + ((macro-function fn) + (eval-compiling-functions (macroexpand-1 form))) + (t + (compile-other form)))))) + +(defun compile-define (form) + (let ((name (car (cadr form))) + (args (mung-lambda-list (cdr (cadr form)))) + (body (cddr form))) + (compile name `(lambda ,args ,@body)) + name)) + +(defun compile-other (form) + (funcall (compile nil `(lambda () ,form)))) + + +;;; Load and compile-file aren't directly imported from the host +;;; Common Lisp because we want to do our own defaulting of file +;;; name extensions. + +(define-mumble-function mumble::load (filename) + (setq filename (expand-filename filename)) + (if (string= (mumble::filename-type filename) "") + (let ((source-file (build-source-filename filename)) + (binary-file (build-binary-filename filename))) + (if (and (probe-file binary-file) + (> (file-write-date binary-file) + (file-write-date source-file))) + (load binary-file) + (load source-file))) + (load filename))) + + +;;; This is used to control OPTIMIZE declarations in a somewhat more +;;; portable way -- different implementations may need slightly different +;;; combinations. +;;; 0 = do as little as possible when compiling code +;;; 1 = use "default" compiler settings +;;; 2 = omit safety checks and do "easy" speed optimizations. +;;; 3 = do as much as possible; type inference, inlining, etc. May be slow. +;;; #f = don't mess with optimize settings. + +(defvar *code-quality* nil) +(define-mumble-import *code-quality*) + +(defun code-quality-hack (q) + (cond ((eql q 0) + (proclaim '(optimize (speed 1) (safety 3) (compilation-speed 3) + #+cmu (ext:debug 1) + #+(or mcl allegro lispworks) (debug 1) + ))) + ((eql q 1) + (proclaim '(optimize (speed 1) (safety 1) (compilation-speed 3) + #+cmu (ext:debug 1) + #+(or mcl allegro lispworks) (debug 1) + ))) + ((eql q 2) + (proclaim '(optimize (speed 3) (safety 0) (compilation-speed 3) + #+cmu (ext:debug 0) + #+(or mcl allegro lispworks) (debug 0) + ))) + ((eql q 3) + (proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0) + #+cmu (ext:debug 0) + #+(or mcl allegro lispworks) (debug 0) + ))) + (t + (warn "Bogus *code-quality* setting ~s." q)))) + + +;;; If we don't do this, code generated with high code-quality settings +;;; can't be interrupted with ^C. + +#+allegro +(setf compiler:generate-interrupt-checks-switch + #'(lambda (safety space speed debug) + (declare (ignore safety space speed debug)) + t)) + + +;;; Note that we expect the binary filename (if supplied) to be +;;; relative to the current directory, not to the source filename. +;;; Lucid and AKCL (and maybe other implementations) merge the :output-file +;;; pathname with the source filename, but the merge by expand-filename +;;; should prevent it from doing anything. + +(define-mumble-function mumble::compile-file (filename &optional binary) + (if *code-quality* (code-quality-hack *code-quality*)) + (setq filename (expand-filename filename)) + (if (string= (mumble::filename-type filename) "") + (setq filename (build-source-filename filename))) + (if binary + (compile-file filename :output-file (expand-filename binary)) + (compile-file filename))) + + +;;; See cl-init.lisp for initialization of *lisp-binary-file-type*. + +(defconstant source-file-type ".scm") +(defconstant binary-file-type *lisp-binary-file-type*) +(define-mumble-import source-file-type) +(define-mumble-import binary-file-type) + + +(defun build-source-filename (filename) + (mumble::assemble-filename filename filename source-file-type)) + +(defun build-binary-filename (filename) + (mumble::assemble-filename filename filename binary-file-type)) + +(proclaim '(ftype (function (simple-string) simple-string) + mumble::filename-place + mumble::filename-name + mumble::filename-type + expand-filename)) + +(proclaim '(ftype (function (simple-string simple-string simple-string) + simple-string) + mumble::assemble-filename)) + +(define-mumble-function mumble::assemble-filename (place name type) + (concatenate 'string + (mumble::filename-place place) + (mumble::filename-name name) + (mumble::filename-type type))) + +(define-mumble-function mumble::filename-place (filename) + (declare (simple-string filename)) + (let ((slash (position #\/ filename :from-end t))) + (if slash + (subseq filename 0 (1+ slash)) + ""))) + +(define-mumble-function mumble::filename-name (filename) + (declare (simple-string filename)) + (let* ((slash (position #\/ filename :from-end t)) + (beg (if slash (1+ slash) 0)) + (dot (position #\. filename :start beg))) + (if (or slash dot) + (subseq filename beg (or dot (length filename))) + filename))) + +(define-mumble-function mumble::filename-type (filename) + (declare (simple-string filename)) + (let* ((slash (position #\/ filename :from-end t)) + (beg (if slash (1+ slash) 0)) + (dot (position #\. filename :start beg))) + (if dot + (subseq filename dot (length filename)) + ""))) + + +;;; This function is called by all functions that pass filenames down +;;; to the operating system. It does environment variable substitution +;;; and merging with *default-pathname-defaults* (set by the cd function). +;;; Since this function translates mumble's notion of pathnames into +;;; a lower-level representation, this function should never need to +;;; be called outside of this file. + +(defun expand-filename (filename) + (declare (simple-string filename)) + (namestring + (merge-pathnames + (fix-filename-syntax + (if (eql (schar filename 0) #\$) + (let* ((end (length filename)) + (slash (or (position #\/ filename) end)) + (new (mumble::getenv (subseq filename 1 slash)))) + (if new + (concatenate 'string new (subseq filename slash end)) + filename)) + filename) + )))) + + +;;; On non-unix machines, may need to change the mumble unix-like filename +;;; syntax to whatever the normal syntax used by the implementation is. + +#+mcl +(defun fix-filename-syntax (filename) + (substitute #\: #\/ filename)) + +#-mcl +(defun fix-filename-syntax (filename) + filename) + + +;;; AKCL's compile-file merges the output pathname against the input +;;; pathname. If the output pathname doesn't have an explicit directory +;;; but the input pathname does, the wrong thing will happen. This +;;; hack is so that expand-filename will always put a directory +;;; specification on both pathnames. +;;; Lucid CL does similar merging, but *default-pathname-defaults* +;;; already defaults to the truename of the current directory. + +#+akcl +(setf *default-pathname-defaults* (truename "./")) + + +;;; WCL's *default-pathname-defaults* is OK except that it has a +;;; type of .lisp, which is inappropriate. + +#+wcl +(setf *default-pathname-defaults* + (make-pathname :directory + (pathname-directory *default-pathname-defaults*))) + +#+(or mcl lispworks) +(setf *default-pathname-defaults* + (truename *default-pathname-defaults*)) + + +(define-mumble-function mumble::file-exists? (filename) + (probe-file (expand-filename filename))) + +(define-mumble-function mumble::file-write-date (filename) + (file-write-date (expand-filename filename))) + +(define-mumble-synonym mumble::current-date get-universal-time) + +(define-mumble-function mumble::get-run-time () + (/ (get-internal-run-time) (float internal-time-units-per-second))) + + +;;; Get environment variables + +#+lucid +(progn + (mumble::predefine (mumble::getenv string)) + (define-mumble-synonym mumble::getenv lcl:environment-variable)) + +#+cmu +(define-mumble-function mumble::getenv (string) + (let ((symbol (intern string (find-package "KEYWORD")))) + (cdr (assoc symbol extensions:*environment-list*)))) + +#+(or akcl allegro lispworks) +(define-mumble-function mumble::getenv (string) + (system::getenv string)) + +#+wcl +(define-mumble-function mumble::getenv (string) + (lisp:getenv string)) + + +;;; Hmmm. The Mac doesn't have environment variables, so we'll have to +;;; roll our own. + +#+mcl +(progn + (defvar *environment-alist* '()) + (define-mumble-function mumble::getenv (string) + (cdr (assoc string *environment-alist* :test #'string=))) + ) + + +#-(or lucid allegro cmu akcl mcl lispworks wcl) +(missing-mumble-definition mumble::getenv) + + +;;; Change working directory. +;;; This stores a directory pathname in *default-pathname-defaults*. +;;; See also expand-filename. + +(define-mumble-function mumble::cd (filename) + (if (not (eql (schar filename (1- (length filename))) #\/)) + (setq filename (concatenate 'string filename "/"))) + (setq *default-pathname-defaults* (pathname (expand-filename filename)))) + + +;;; Leave Lisp + +#+lucid +(define-mumble-synonym mumble::exit lcl:quit) + +#+allegro +(define-mumble-synonym mumble::exit excl:exit) + +#+cmu +(define-mumble-synonym mumble::exit extensions:quit) + +#+akcl +(define-mumble-synonym mumble::exit lisp:bye) + +#+mcl +(define-mumble-synonym mumble::exit ccl:quit) + +#+lispworks +(define-mumble-synonym mumble::exit lw:bye) + +#+wcl +(define-mumble-synonym mumble::exit lisp:quit) + + +#-(or lucid allegro cmu akcl mcl lispworks wcl) +(missing-mumble-definition mumble::exit) + + + +;;;===================================================================== +;;; Reader support +;;;===================================================================== + + +;;; Make the default readtable recognize #f and #t. +;;; CMUCL's loader rebinds *readtable* when loading file, so can't +;;; setq it here; hack the default readtable instead. + +#+(or cmu mcl allegro lispworks) +(defparameter *mumble-readtable* *readtable*) + +#+(or lucid akcl wcl) +(progn + (defparameter *mumble-readtable* (copy-readtable nil)) + (setq *readtable* *mumble-readtable*) + ) + +#-(or lucid allegro cmu akcl mcl lispworks wcl) +(missing-mumble-definition *mumble-readtable*) + + +;;; Lucid's debugger uses the standard readtable rather than *readtable* +;;; unless you do this magic trick. + +#+lucid +(sys:add-debugger-binding '*readtable* *mumble-readtable*) + + + +(set-dispatch-macro-character #\# #\f + #'(lambda (stream subchar arg) + (declare (ignore stream subchar arg)) + nil)) + +(set-dispatch-macro-character #\# #\t + #'(lambda (stream subchar arg) + (declare (ignore stream subchar arg)) + t)) + + + +;;;===================================================================== +;;; Random stuff +;;;===================================================================== + +(defconstant mumble::lisp-implementation-name *lisp-implementation-name*) +(define-mumble-import mumble::lisp-implementation-name) + +(define-mumble-function mumble::identify-system () + (format nil "~a version ~a on ~a" + (or (lisp-implementation-type) + "Generic Common Lisp") + (or (lisp-implementation-version) + "Generic") + (or (machine-type) + "Generic Machine"))) + +(defconstant mumble::left-to-right-evaluation t) +(define-mumble-import mumble::left-to-right-evaluation) + + +#+excl +(define-mumble-function mumble::gc-messages (onoff) + (setf (sys:gsgc-switch :print) onoff)) +#+cmu +(define-mumble-function mumble::gc-messages (onoff) + (setf extensions:*gc-verbose* onoff)) +#+(or lispworks akcl wcl mcl) +(define-mumble-function mumble::gc-messages (onoff) + onoff) ; can't figure out if they have a hook or not +#+lucid +(define-mumble-function mumble::gc-messages (onoff) + (setf lcl:*gc-silence* (not onoff)) + onoff) + + +#-(or lucid cmu allegro akcl mcl lispworks wcl) +(missing-mumble-definition mumble::gc-messages) + + +(define-mumble-import identity) diff --git a/cl-support/cl-init.lisp b/cl-support/cl-init.lisp new file mode 100644 index 0000000..4d78cde --- /dev/null +++ b/cl-support/cl-init.lisp @@ -0,0 +1,170 @@ +;;; cl-init.lisp -- initialize Common Lisp, loading cl-specific files. +;;; +;;; author : Sandra Loosemore +;;; date : 23 Oct 1991 +;;; +;;; All of the files loaded here are assumed to be regular Common Lisp +;;; files. + +(in-package "MUMBLE-IMPLEMENTATION") + + +;;; Turn off bogus warnings and messages!!! + +;;; Lucid complains if files don't start with IN-PACKAGE. +#+lucid +(setq lcl:*warn-if-no-in-package* '()) + + +;;; CMU CL prints too many compiler progress messages. +#+cmu +(progn + (setq *compile-print* '()) + (setq *load-verbose* t) + ) + + +;;; AKCL complains if any package operations appear at top-level +;;; after any other code. +;;; Also prints useless notes about when it does tail recursion elimination. +#+akcl +(progn + (setq compiler:*suppress-compiler-notes* t) + (setq compiler:*compile-verbose* t) + (setq *load-verbose* t) + (setq compiler::*compile-ordinaries* t) + (si:putprop 'make-package nil 'compiler::package-operation) + (si:putprop 'shadow nil 'compiler::package-operation) + (si:putprop 'shadowing-import nil 'compiler::package-operation) + (si:putprop 'export nil 'compiler::package-operation) + (si:putprop 'unexport nil 'compiler::package-operation) + (si:putprop 'use-package nil 'compiler::package-operation) + (si:putprop 'unuse-package nil 'compiler::package-operation) + (si:putprop 'import nil 'compiler::package-operation) + (si:putprop 'provide nil 'compiler::package-operation) + (si:putprop 'require nil 'compiler::package-operation) + ) + + +;;; Allegro also issues too many messages. +;;; ***We really ought to rename the defstructs that give the package +;;; locked errors.... + +#+allegro +(progn + (setf *compile-print* nil) + (setf compiler:*cltl1-compile-file-toplevel-compatibility-p* nil) + (setq excl:*enable-package-locked-errors* nil) + (setf excl:*load-source-file-info* nil) + (setf excl:*record-source-file-info* nil) + (setf excl:*load-xref-info* nil) + (setf excl:*record-source-file-info* nil) + ) + + +;;; Harlequin Lispworks prints too many messages too. + +#+lispworks +(progn + (setf *compile-print* nil) + (setf *load-print* nil) + (lw:toggle-source-debugging nil) + ) + + +;;; Load up definitions + +(defvar *lisp-source-file-type* ".lisp") +(defvar *lisp-binary-file-type* + #+lucid + (namestring (make-pathname :type (car lcl:*load-binary-pathname-types*))) + #+allegro + (concatenate 'string "." excl:*fasl-default-type*) + #+cmu + (concatenate 'string "." (c:backend-fasl-file-type c:*backend*)) + #+akcl + ".o" + #+mcl + ".fasl" + #+lispworks + ".wfasl" + #+wcl + ".o" + #-(or lucid allegro cmu akcl mcl lispworks wcl) + (error "Don't know how to initialize *LISP-BINARY-FILE-TYPE*.") + ) + +(defvar *lisp-implementation-name* + #+lucid "lucid" + #+(and allegro next) "allegro-next" + #+(and allegro (not next)) "allegro" + #+cmu "cmu" + #+akcl "akcl" + #+mcl "mcl" + #+lispworks "lispworks" + #+wcl "wcl" + #-(or lucid allegro cmu akcl mcl lispworks wcl) + (error "Don't know how to initialize *LISP-IMPLEMENTATION-NAME*.") + ) + + + + +;;; Note that this assumes that the current directory is $Y2. +;;; Environment variables in pathnames may not be supported by the +;;; host Lisp. + +#-mcl (progn + (defvar *support-directory* "cl-support/") + (defvar *support-binary-directory* + (concatenate 'string + *support-directory* + *lisp-implementation-name* + "/"))) + +(defun load-compiled-cl-file (filename) + (let ((source-file (concatenate 'string + *support-directory* + filename + *lisp-source-file-type*)) + (binary-file (concatenate 'string + *support-binary-directory* + filename + *lisp-binary-file-type*))) + (if (or (not (probe-file binary-file)) + (< (file-write-date binary-file) (file-write-date source-file))) + (compile-file source-file :output-file (merge-pathnames binary-file))) + (load binary-file))) + + +;;; Do NOT change the load order of these files. + +(load-compiled-cl-file "cl-setup") +(load-compiled-cl-file "cl-support") +(load-compiled-cl-file "cl-definitions") +(load-compiled-cl-file "cl-types") +(load-compiled-cl-file "cl-structs") + + +;;; It would be nice if at this point we could switch *package* +;;; over to the right package. But because *package* is rebound while +;;; this file is being loaded, it will get set back to whatever it was +;;; anyway. Bummer. Well, let's at least make the package that we want +;;; to use. + +(make-package "MUMBLE-USER" :use '("MUMBLE")) + + +;;; Compile and load the rest of the system. (The Lucid compiler is fast +;;; enough to make it practical to compile things all the time.) + +(eval-when (eval compile load) + (setf *package* (find-package "MUMBLE-USER"))) + +(load "$Y2/support/system") +(compile-haskell) + + +;;; All done + +(write-line "Remember to do (in-package \"MUMBLE-USER\")!") diff --git a/cl-support/cl-setup.lisp b/cl-support/cl-setup.lisp new file mode 100644 index 0000000..361963c --- /dev/null +++ b/cl-support/cl-setup.lisp @@ -0,0 +1,30 @@ +;;; cl-setup.lisp -- set up mumble environment in Common Lisp +;;; +;;; author : Sandra Loosemore +;;; date : 10 Oct 1991 +;;; +;;; This file must be loaded before either compiling or loading +;;; the cl-definitions file. + + +;;; The mumble package exports only those symbols that have definitions +;;; in mumble. Many of these symbols shadow built-in CL definitions. +;;; Programs that use mumble should use the mumble package in place of +;;; (rather than in addition to) the CL package. + +(unless (find-package "MUMBLE") + (make-package "MUMBLE" :use nil)) + + +;;; The actual implementation of the mumble compatibility library happens +;;; in the MUMBLE-IMPLEMENTATION package. We'll explicitly package-qualify +;;; all symbols from the MUMBLE package that it references, and rely +;;; on the definitional macros to arrange to export them from the MUMBLE +;;; package. + +(unless (find-package "MUMBLE-IMPLEMENTATION") + (make-package "MUMBLE-IMPLEMENTATION" :use '("LISP"))) + + + + diff --git a/cl-support/cl-structs.lisp b/cl-support/cl-structs.lisp new file mode 100644 index 0000000..0d57693 --- /dev/null +++ b/cl-support/cl-structs.lisp @@ -0,0 +1,699 @@ +;;; cl-structs.lisp -- extended structure definitions +;;; +;;; author : Sandra Loosemore +;;; date : 19 Aug 1992 +;;; + + +;;;==================================================================== +;;; Basic structure types +;;;==================================================================== + + +;;; Use this hash table for mapping names -> type descriptors + +(defvar *struct-lookup-table* (make-hash-table :test #'eq)) + +(defmacro lookup-type (name) + `(gethash ,name *struct-lookup-table*)) + + +;;; Do NOT add or remove slots from these DEFSTRUCTS without also +;;; changing the bootstrap code below!!! +;;; Do NOT try to give these structs complicated defaulting behavior!!! + +;;; All of our objects are subtypes of STRUCT. + + +(mumble::predefine (mumble::write object . maybe-stream)) + +(defun print-struct-object (object stream depth) + (declare (ignore depth)) + (mumble::write object stream) +; (format stream "#<Struct ~a>" (td-name (struct-type-descriptor object))) + ) + + +;;; Note that non-exported slots are prefixed with % to prevent +;;; accidental slot name collisions. + +(defstruct (struct + (:print-function print-struct-object) + (:predicate struct?) + (:constructor nil) ; never instantiated directly + (:copier nil)) + (type-descriptor nil :type t) + (%bits 0 :type fixnum) + ) + + +(defstruct (type-descriptor + (:include struct + (type-descriptor (lookup-type 'type-descriptor))) + (:conc-name td-) + (:constructor create-type-descriptor ()) + (:predicate nil) + (:copier nil)) + (name nil :type symbol) + (slots nil :type list) ; all slots, including inherited + (parent-type nil :type t) + (printer nil :type t) + (%local-slots nil :type list) ; "real" structure slots + (%bits-used 0 :type fixnum) + (%constructor nil :type symbol) + ) + +(defstruct (slot-descriptor + (:include struct + (type-descriptor (lookup-type 'slot-descriptor))) + (:conc-name sd-) + (:constructor create-slot-descriptor ()) + (:predicate nil) + (:copier nil)) + (name nil :type symbol) + (type nil :type t) + (default nil :type t) + (getter nil :type symbol) + (%bit nil :type (mumble::maybe fixnum)) + (%read-only? nil :type mumble::bool) + (%required? nil :type mumble::bool) + (%uninitialized? nil :type mumble::bool)) + + +;;; Helper function for bootstrapping. + +(defun create-slot-simple (prefix name type default + &optional read-only? required? uninitialized?) + (let ((sd (create-slot-descriptor))) + (setf (sd-name sd) name) + (setf (sd-type sd) type) + (setf (sd-default sd) default) + (setf (sd-getter sd) (symbol-append prefix name)) + (setf (sd-%read-only? sd) read-only?) + (setf (sd-%required? sd) required?) + (setf (sd-%uninitialized? sd) uninitialized?) + sd)) + + +;;; Initialize descriptors for the predefined struct types. + +(let ((struct-td (setf (lookup-type 'struct) + (create-type-descriptor))) + (type-td (setf (lookup-type 'type-descriptor) + (create-type-descriptor))) + (slot-td (setf (lookup-type 'slot-descriptor) + (create-type-descriptor)))) + ;; struct + (setf (td-type-descriptor struct-td) type-td) + (setf (td-name struct-td) 'struct) + (setf (td-%bits-used struct-td) 0) + ;; type-descriptor + (setf (td-type-descriptor type-td) type-td) + (setf (td-name type-td) 'type-descriptor) + (setf (td-%local-slots type-td) + (list (create-slot-simple 'td- 'name 'symbol nil) + (create-slot-simple 'td- 'slots 'list nil) + (create-slot-simple 'td- 'parent-type 't nil) + (create-slot-simple 'td- 'printer 't nil) + (create-slot-simple 'td- '%local-slots 'list nil) + (create-slot-simple 'td- '%bits-used 'fixnum 0) + (create-slot-simple 'td- '%constructor 'symbol nil) + )) + (setf (td-slots type-td) (td-%local-slots type-td)) + (setf (td-%bits-used type-td) 0) + (setf (td-%constructor type-td) 'create-type-descriptor) + (setf (td-parent-type type-td) struct-td) + ;; slot-descriptor + (setf (td-type-descriptor slot-td) type-td) + (setf (td-name slot-td) 'slot-descriptor) + (setf (td-%local-slots slot-td) + (list (create-slot-simple 'sd- 'name 'symbol nil) + (create-slot-simple 'sd- 'type 't nil) + (create-slot-simple 'sd- 'default 't nil) + (create-slot-simple 'sd- 'getter 'symbol nil) + (create-slot-simple 'sd- '%bit '(mumble::maybe fixnum) nil) + (create-slot-simple 'sd- '%read-only? 'mumble::bool nil) + (create-slot-simple 'sd- '%required? 'mumble::bool nil) + (create-slot-simple 'sd- '%uninitialized? 'mumble::bool nil) + )) + (setf (td-slots slot-td) (td-%local-slots slot-td)) + (setf (td-%bits-used slot-td) 0) + (setf (td-%constructor slot-td) 'create-slot-descriptor) + (setf (td-parent-type type-td) struct-td) + ) + + + +;;;===================================================================== +;;; Support for bit slots +;;;===================================================================== + +(eval-when (eval compile load) + (defconstant max-bits (integer-length most-positive-fixnum))) + +(defvar *bit-slot-getters* (make-array max-bits)) +(defvar *bit-slot-setters* (make-array max-bits)) + +(defmacro bit-slot-getter (i) `(svref *bit-slot-getters* ,i)) +(defmacro bit-slot-setter (i) `(svref *bit-slot-setters* ,i)) + +(defmacro define-bit-accessors () + (let ((results nil)) + (dotimes (i max-bits) + (let ((getter (intern (format nil "GET-BIT-~a" i))) + (setter (intern (format nil "SET-BIT-~a" i))) + (mask (ash 1 i))) + (push + `(progn + (mumble::define-integrable (,getter x) + (not (eql (the fixnum + (logand (the fixnum (struct-%bits x)) + (the fixnum ,mask))) + 0))) + (mumble::define-integrable (,setter v x) + (setf (struct-%bits x) + (if v + (the fixnum + (logior (the fixnum (struct-%bits x)) + (the fixnum ,mask))) + (the fixnum + (logandc2 (the fixnum (struct-%bits x)) + (the fixnum ,mask))))) + v) + (setf (bit-slot-getter ,i) ',getter) + (setf (bit-slot-setter ,i) ',setter)) + results))) + `(progn ,@results))) + +(define-bit-accessors) + + + + +;;;===================================================================== +;;; Random helper functions +;;;===================================================================== + +(defun quoted? (x) + (and (consp x) (eq (car x) 'quote))) + +(defun quoted-value (x) + (cadr x)) + +(defun unknown-type-error (type) + (error "Struct type ~s has not been defined." type)) + +(defun unknown-slot-error (type slot) + (error "Struct type ~s has no slot named ~s." type slot)) + +(defun lookup-type-descriptor (type) + (or (lookup-type type) + (unknown-type-error type))) + +(defun lookup-slot-descriptor (type slot) + (let ((td (lookup-type-descriptor type))) + (or (find slot (td-slots td) :key #'sd-name) + (unknown-slot-error type slot)))) + +(defun slot-getter-name (type slot) + (sd-getter (lookup-slot-descriptor type slot))) + +(defun sd-getter-function (sd) + (symbol-function (sd-getter sd))) + + + +;;;===================================================================== +;;; Struct-slot macro +;;;===================================================================== + +;;; Note that this can be SETF'ed only if type and slot are quoted. + +(defmacro struct-slot (type slot object) + (if (and (quoted? type) (quoted? slot)) + (struct-slot-compiletime (quoted-value type) (quoted-value slot) object) + (progn + (warn "Type and/or slot argument to STRUCT-SLOT not constant.") + `(struct-slot-runtime ,type ,slot ,object)))) + +(defun struct-slot-compiletime (type slot object) + (let ((sd (lookup-slot-descriptor type slot))) + `(the ,(sd-type sd) (,(sd-getter sd) (the ,type ,object))))) + +(defun struct-slot-runtime (type slot object) + (let ((sd (lookup-slot-descriptor type slot))) + ;; *** Could insert explicit type checks here. + (funcall (sd-getter-function sd) object))) + + +;;;===================================================================== +;;; Make macro and support +;;;===================================================================== + +(defmacro make (type . inits) + (make-aux type inits)) + +;;; Turn the call to MAKE into a call to the boa constructor. +;;; The arguments to the BOA constructor are those slots that have +;;; the required? flag set to true. If initializers for other slots +;;; are provided, turn these into SETFs. Bit attributes are always +;;; handled via SETF. + +(defun make-aux (type inits) + (let* ((td (lookup-type-descriptor type)) + (boa (td-%constructor td)) + (slots (td-slots td)) + (tempvar (gensym)) + (setfs '()) + (bits-inits '()) + (slot-inits '())) + (check-slot-inits type inits) + (dolist (s slots) + (let* ((name (sd-name s)) + (supplied? (mumble::assq name inits)) + (required? (sd-%required? s)) + (uninitialized? (sd-%uninitialized? s)) + (init (if supplied? + (progn + ;; *** Maybe want to suppress this warning. + ;;(when (not required?) + ;; (override-slot-init-warning type name)) + (cadr supplied?)) + (progn + ;; *** Maybe want to suppress this warning. + (when (and required? (not uninitialized?)) + (missing-slot-init-warning type name)) + (sd-default s))))) + (cond ((sd-%bit s) + (cond ((or (eq init 'nil) (equal init '(quote nil))) + ;; do nothing, bit already defaults to 0 + ) + ((and uninitialized? (not supplied?) required?) + ;; no default or init supplied, leave uninitialized + ) + ((constantp init) + ;; it must be a non-false constant, set bit to 1 + (push (ash 1 (sd-%bit s)) bits-inits)) + (t + ;; have to do runtime test + (push `(the fixnum (if ,init ,(ash 1 (sd-%bit s)) 0)) + bits-inits)))) + ((and required? (not uninitialized?)) + ;; The constructor takes the value as a positional argument. + (push init slot-inits)) + (supplied? + ;; Make a setf. + ;; No point in putting the same value in twice. + (unless (and (constantp init) (equal init (sd-default s))) + (push `(setf (,(sd-getter s) ,tempvar) ,init) setfs))) + (t nil)))) + (unless (null bits-inits) + (push `(setf (struct-%bits ,tempvar) + ,(cond ((null (cdr bits-inits)) + (car bits-inits)) + ((every #'constantp bits-inits) + (apply #'logior bits-inits)) + (t + `(the fixnum (logior ,@(nreverse bits-inits)))))) + setfs)) + (if (null setfs) + `(,boa ,@(nreverse slot-inits)) + `(let ((,tempvar (,boa ,@(nreverse slot-inits)))) + ,@(nreverse setfs) + ,tempvar)))) + +(defun override-slot-init-warning (type name) + (warn "Overriding default for slot ~s in MAKE ~s." + name type)) + +(defun missing-slot-init-warning (type name) + (warn "No initializer or default for slot ~s in MAKE ~s." + name type)) + +(defun check-slot-inits (type inits) + (dolist (i inits) + (lookup-slot-descriptor type (car i)))) + + + +;;;==================================================================== +;;; Update-slots macro +;;;==================================================================== + +;;; Note that type is a literal here. +;;; *** Could be smarter about merging setters for bit slots. + +(defmacro update-slots (type exp . inits) + (let ((temp (gensym))) + `(let ((,temp ,exp)) + ,@(mapcar #'(lambda (i) + `(setf (struct-slot ',type ',(car i) ,temp) ,(cadr i))) + inits)))) + + + +;;;==================================================================== +;;; With-slots macro +;;;==================================================================== + +;;; Note that type is a literal here. +;;; ***Could be smarter about merging accesses for bit slots. + +(defmacro mumble::with-slots (type slots exp . body) + (let ((temp (gensym))) + `(let* ((,temp ,exp) + ,@(mapcar #'(lambda (s) + `(,s (struct-slot ',type ',s ,temp))) + slots)) + ,@body))) + + +;;;==================================================================== +;;; Define-struct macro +;;;==================================================================== + + +;;; The rather strange division here is so that the call to MAKE +;;; works right. +;;; All INSTALL-STRUCT-TYPE does is fill in and install the type +;;; descriptor object. + +(defmacro define-struct (name . fields) + (multiple-value-bind (include type-template slots prefix predicate) + (parse-struct-fields name fields) + `(progn + (eval-when (eval compile load) + (install-struct-type + ',name + ',include + ',prefix + (make ,type-template) + ',slots)) + (define-struct-aux ,name ,include ,prefix ,predicate)))) + + +;;; This is the macro that actually creates the DEFSTRUCT expansion. + +(defmacro define-struct-aux (name include prefix predicate) + (let* ((td (lookup-type name)) + (slots (td-slots td)) + (local-slots (td-%local-slots td)) + (bit-slots (remove-if-not #'sd-%bit slots))) + `(progn + ;; Make the struct definition. + ;; *** could put the type descriptor for the default in a + ;; *** global variable; it might speed up reference. + (defstruct (,name + (:include ,include + (type-descriptor (lookup-type ',name))) + (:conc-name ,prefix) + ;; Disable the default keyword constructor. + ;; If you do this in AKCL, it will complain about + ;; the BOA constructor. Bogus!!! + ;; If you do this in WCL, it will just quietly ignore + ;; the BOA. + #-(or akcl wcl) (:constructor nil) + (:constructor ,(td-%constructor td) ,(make-boa-args slots)) + (:predicate ,predicate) + (:copier nil)) + ,@(mapcar + #'(lambda (s) + `(,(sd-name s) ,(sd-default s) + ;; CMU common lisp initializes &aux boa constructor + ;; slots to NIL instead of leaving them uninitialized, + ;; and then complains if this doesn't match the declared + ;; slot type. I think this is a bug, not a feature, but + ;; here's a workaround for it. + :type + #+cmu ,(if (sd-%uninitialized? s) + `(or ,(sd-type s) null) + (sd-type s)) + #-cmu ,(sd-type s) + ;; Can make slots read-only only if a setf-er is not + ;; required by MAKE. + :read-only ,(and (sd-%read-only? s) (sd-%required? s)))) + local-slots)) + ;; Make accessor functions for bit slots. + ,@(mapcar + #'(lambda (s) + (let ((place (symbol-append prefix (sd-name s))) + (getter (bit-slot-getter (sd-%bit s))) + (setter (bit-slot-setter (sd-%bit s)))) + `(progn + (mumble::define-integrable (,place x) (,getter x)) + ,@(unless (sd-%read-only? s) + `((mumble::define-setf ,place ,setter)))) + )) + bit-slots) + ',name) + )) + + + +;;; Determine which arguments to make explicit to the boa constructor. +;;; Basically, expect an explicit initializer for any slot that does not +;;; have a default supplied. +;;; Supplying slot names as &aux parameters to a boa constructor is +;;; supposed to suppress initialization. + +(defun make-boa-args (slots) + (let ((required-args '()) + (uninitialized-args '())) + (dolist (s slots) + (when (and (sd-%required? s) (not (sd-%bit s))) + (if (sd-%uninitialized? s) + (push (sd-name s) uninitialized-args) + (push (sd-name s) required-args)))) + ;; Gag. AKCL does the wrong thing with &AUX arguments; defstruct sticks + ;; another &AUX at the end of the lambda list. Looks like it will do + ;; the right thing if you just omit the uninitialized arguments from + ;; the boa arglist entirely. + #+akcl (nreverse required-args) + #-akcl + (if (null uninitialized-args) + (nreverse required-args) + `(,@(nreverse required-args) &aux ,@(nreverse uninitialized-args))) + )) + + +;;; Install the type descriptor, filling in all the slots. + +(defun install-struct-type (name include prefix td slots) + (let* ((parent-type (lookup-type-descriptor include)) + (bits-used (td-%bits-used parent-type)) + (local-slots '()) + (all-slots '())) + (dolist (s slots) + (multiple-value-bind + (slot-name type default bit read-only? required? uninitialized?) + (parse-slot-fields name s) + (let ((sd (create-slot-simple + prefix slot-name type default + read-only? required? uninitialized?))) + (push sd all-slots) + (cond (bit + (if (eql bits-used max-bits) + (error "Too many bit slots in DEFINE-STRUCT ~s." name)) + (setf (sd-%bit sd) bits-used) + (incf bits-used)) + (t + (push sd local-slots)))))) + (setf local-slots (nreverse local-slots)) + (setf (td-name td) name) + (setf (td-slots td) (append (td-slots parent-type) (nreverse all-slots))) + (setf (td-%local-slots td) local-slots) + (setf (td-%bits-used td) bits-used) + (setf (td-%constructor td) (symbol-append '%create- name)) + (setf (td-parent-type td) parent-type) + (setf (lookup-type name) td))) + + +;;; Struct field parsing. + +(defun parse-struct-fields (name fields) + (when (not (symbolp name)) + (error "Structure name ~s is not a symbol." name)) + (let ((include nil) + (type-template nil) + (slots nil) + (prefix nil) + (predicate nil)) + (dolist (f fields) + (cond ((not (consp f)) + (unknown-field-error f name)) + ((eq (car f) 'include) + (if include + (duplicate-field-error 'include name) + (setf include (cadr f)))) + ((eq (car f) 'type-template) + (if type-template + (duplicate-field-error 'type-template name) + (setf type-template (cadr f)))) + ((eq (car f) 'slots) + (if slots + (duplicate-field-error 'slots name) + (setf slots (cdr f)))) + ((eq (car f) 'prefix) + (if prefix + (duplicate-field-error 'prefix name) + (setf prefix (cadr f)))) + ((eq (car f) 'predicate) + (if predicate + (duplicate-field-error 'predicate name) + (setf predicate (cadr f)))) + (t + (unknown-field-error f name)))) + (values + (or include 'struct) + (or type-template + (and include + (td-name (td-type-descriptor (lookup-type-descriptor include)))) + 'type-descriptor) + (or slots '()) + (or prefix (symbol-append name '-)) + predicate))) + +(defun unknown-field-error (f name) + (error "Unknown field ~s in DEFINE-STRUCT ~s." f name)) + +(defun duplicate-field-error (f name) + (error "Field ~s appears more than once in DEFINE-STRUCT ~s." f name)) + + + +;;; Parsing for slot specifications. + +(defun parse-slot-fields (struct-name slot) + (let ((name nil) + (type t) + (default '*default-slot-default*) + (bit nil) + (read-only? nil) + (required? t) + (uninitialized? nil)) + (if (or (not (consp slot)) + (not (symbolp (setf name (car slot))))) + (invalid-slot-error slot struct-name)) + (dolist (junk (cdr slot)) + (cond ((eq (car junk) 'type) + (setf type (cadr junk))) + ((eq (car junk) 'default) + (setf default (cadr junk)) + (setf required? nil)) + ((eq (car junk) 'bit) + (setf bit (cadr junk))) + ((eq (car junk) 'read-only?) + (setf read-only? (cadr junk))) + ((eq (car junk) 'uninitialized?) + (setf uninitialized? (cadr junk))) + (t + (invalid-slot-error slot struct-name)))) + (values + name + type + default + bit + read-only? + required? + uninitialized? + ))) + +;;; Some implementations of DEFSTRUCT complain if the default value +;;; for a slot doesn't match the declared type of that slot, even if +;;; the default is never used. +;;; Using this variable as the default init form for such slots should +;;; suppress such warnings. + +(defvar *default-slot-default* nil) + +(defun invalid-slot-error (slot struct-name) + (error "Invalid slot syntax ~s in DEFINE-STRUCT ~s." slot struct-name)) + + + +;;;===================================================================== +;;; Printer hooks +;;;===================================================================== + +;;; Here is the macro for associating a printer with a structure type. + +(defmacro define-struct-printer (type function) + `(define-struct-printer-aux ',type (function ,function))) + +(defun define-struct-printer-aux (type function) + (let ((td (lookup-type-descriptor type))) + (setf (td-printer td) function) + type)) + + +;;;===================================================================== +;;; Imports +;;;===================================================================== + + +;;; Generic stuff + +(define-mumble-import struct) +(define-mumble-import struct?) +(define-mumble-import struct-type-descriptor) + + +;;; Predefined types, slots, and accessors +;;; Note: not all slots are exported. + +(define-mumble-import type-descriptor) +(define-mumble-import name) +(define-mumble-import slots) +(define-mumble-import parent-type) +(define-mumble-import printer) +(define-mumble-import td-name) +(define-mumble-import td-slots) +(define-mumble-import td-parent-type) +(define-mumble-import td-printer) + +(define-mumble-import slot-descriptor) +(define-mumble-import name) +(define-mumble-import type) +(define-mumble-import default) +(define-mumble-import getter) +(define-mumble-import sd-name) +(define-mumble-import sd-type) +(define-mumble-import sd-default) +(define-mumble-import sd-getter) + + +;;; Utility functions + +(define-mumble-import lookup-type-descriptor) +(define-mumble-import lookup-slot-descriptor) +(define-mumble-import sd-getter-function) + + +;;; Macros + +(define-mumble-import make) +(define-mumble-import struct-slot) +(define-mumble-import define-struct) +(define-mumble-import mumble::with-slots) +(define-mumble-import update-slots) +(define-mumble-import define-struct-printer) + + +;;; Field names for define-struct + +(define-mumble-import include) +(define-mumble-import type-template) +(define-mumble-import slots) +(define-mumble-import prefix) +(define-mumble-import predicate) + + +;;; Field names for slot options + +(define-mumble-import type) +(define-mumble-import default) +(define-mumble-import bit) +(define-mumble-import read-only?) +(define-mumble-import uninitialized?) + + diff --git a/cl-support/cl-support.lisp b/cl-support/cl-support.lisp new file mode 100644 index 0000000..4f82ce2 --- /dev/null +++ b/cl-support/cl-support.lisp @@ -0,0 +1,86 @@ +;;; cl-support.lisp -- compile-time support for building mumble +;;; +;;; author : Sandra Loosemore +;;; date : 10 Oct 1991 +;;; +;;; This file must be loaded before compiling the cl-definitions file. +;;; However, it is not needed when loading the compiled file. + +(in-package "MUMBLE-IMPLEMENTATION") + + +;;; Use this macro for defining an exported mumble function. + +(defmacro define-mumble-function (name &rest stuff) + `(progn + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) + (defun ,name ,@stuff))) + + +;;; This is similar, but also does some stuff to try to inline the +;;; function definition. + +(defmacro define-mumble-function-inline (name &rest stuff) + `(progn + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) +#+lcl + (lcl:defsubst ,name ,@stuff) +#-lcl + (progn + (proclaim '(inline ,name)) + (defun ,name ,@stuff)) + ',name)) + + +;;; Use this macro for defining an exported mumble macro. + +(defmacro define-mumble-macro (name &rest stuff) + `(progn + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) + (defmacro ,name ,@stuff))) + + +;;; Use this macro for importing a random symbol into the MUMBLE +;;; package. This is useful for things that can share directly with +;;; built-in Common Lisp definitions. + +(defmacro define-mumble-import (name) + `(progn + (eval-when (eval compile load) (import (list ',name) "MUMBLE")) + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) + ',name)) + + +;;; Use this macro for defining a function in the MUMBLE package that +;;; is a synonym for some Common Lisp function. Try to do some stuff +;;; to make the function compile inline. + +(defmacro define-mumble-synonym (name cl-name) + `(progn + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) + (setf (symbol-function ',name) (symbol-function ',cl-name)) +#+lcl + (lcl:def-compiler-macro ,name (&rest args) + (cons ',cl-name args)) + ',name)) + + + +;;; Use this macro to define a type synonym. + +(defmacro define-mumble-type (name &rest stuff) + `(progn + (eval-when (eval compile load) (export (list ',name) "MUMBLE")) + (deftype ,name ,@stuff))) + + +;;; This macro is used to signal a compile-time error in situations +;;; where an implementation-specific definition is missing. + +(defmacro missing-mumble-definition (name) + (error "No definition has been provided for ~s." name)) + + + + + diff --git a/cl-support/cl-types.lisp b/cl-support/cl-types.lisp new file mode 100644 index 0000000..6fb625e --- /dev/null +++ b/cl-support/cl-types.lisp @@ -0,0 +1,90 @@ +;;; cl-types.lisp -- type-related stuff +;;; +;;; author : Sandra Loosemore +;;; date : 5 Oct 1992 +;;; + + +;;; Export CL symbols for type names + +(define-mumble-import t) + +#+lucid +(define-mumble-type mumble::procedure () 'system::procedure) +#+(or cmu akcl allegro mcl lispworks) +(define-mumble-type mumble::procedure () 'function) +#+wcl +(define-mumble-type mumble::procedure () 'lisp:procedure) +#-(or lucid cmu akcl allegro mcl lispworks wcl) +(missing-mumble-definition procedure) + +(define-mumble-type mumble::pair () 'cons) + +(define-mumble-import null) + +(define-mumble-type mumble::list (&optional element-type) + ;; *** Common Lisp provides no way to make use of the element type + ;; *** without using SATISFIES. + (declare (ignore element-type)) + 'list) + +(define-mumble-import symbol) + +(define-mumble-type mumble::char () 'character) +(define-mumble-type mumble::string () 'simple-string) +(define-mumble-type mumble::vector () 'simple-vector) + +(define-mumble-import number) +(define-mumble-import integer) +(define-mumble-import rational) +(define-mumble-import float) +(define-mumble-import fixnum) + +(define-mumble-type mumble::int () 'fixnum) + +(define-mumble-type mumble::table (&optional key-type value-type) + ;; *** Common Lisp provides no way to make use of the element type + ;; *** without using SATISFIES. + (declare (ignore key-type value-type)) + 'hash-table) + + +;;; Extensions + +(define-mumble-type mumble::enum (&rest values) + `(member ,@values)) + +(define-mumble-type mumble::tuple (&rest element-types) + ;; *** Common Lisp provides no way to make use of the element type + ;; *** without using SATISFIES. + (let ((n (length element-types))) + (cond ((< n 2) + (error "Too few arguments to TUPLE type specifier.")) + ((eql n 2) + 'cons) + (t + 'simple-vector)))) + +(define-mumble-type mumble::bool () 't) + +(define-mumble-type mumble::alist (&optional key-type value-type) + `(mumble::list (tuple ,key-type ,value-type))) + +(define-mumble-type mumble::maybe (type) + `(or ,type null)) + + + +;;; Functions, etc. + +(define-mumble-import the) +(define-mumble-synonym mumble::subtype? subtypep) + +(define-mumble-function-inline mumble::is-type? (type object) + (typep object type)) + +(define-mumble-macro mumble::typecase (data &rest cases) + (let ((last (car (last cases)))) + (if (eq (car last) 'mumble::else) + `(typecase ,data ,@(butlast cases) (t ,@(cdr last))) + `(typecase ,data ,@cases)))) diff --git a/cl-support/wcl-patches.lisp b/cl-support/wcl-patches.lisp new file mode 100644 index 0000000..3e9395c --- /dev/null +++ b/cl-support/wcl-patches.lisp @@ -0,0 +1,68 @@ +(in-package "LISP") + + +;;; The default version of this function has a bug with relative +;;; pathnames. + +(defun pathname->string (p) + (let ((dirlist (pathname-directory p))) + (format nil "~A~{~A/~}~A~A~A" + (case (car dirlist) + (:absolute "/") + (:relative "./") + (:up "../") + (t "")) + (cdr dirlist) + (nil->empty-string (pathname-name p)) + (if (null (pathname-type p)) "" ".") + (nil->empty-string (pathname-type p))))) + + +;;; The default version of this function defaults the C file to the +;;; wrong directory -- LOAD can't find it. + +(defun my-comf (file &key + (output-file (merge-pathnames ".o" file)) + (c-file (merge-pathnames ".c" output-file)) + (verbose *compile-verbose*) + (print *compile-print*) + (config *config*) + (pic? *pic?*) + only-to-c?) + (old-comf file + :output-file output-file + :c-file c-file + :verbose verbose + :print print + :config config + :pic? pic? + :only-to-c? only-to-c?)) + +(when (not (fboundp 'old-comf)) + (setf (symbol-function 'old-comf) #'comf) + (setf (symbol-function 'comf) #'my-comf)) + + +;;; WCL's evaluator tries to macroexpand everything before executing +;;; anything. Unfortunately, this does the wrong thing with +;;; top-level PROGN's -- it tries to expand macros in subforms before +;;; executing earlier subforms that set up stuff required to do the +;;; the expansion properly. + +(defun eval-1 (form venv fenv tenv benv) + (let ((new-form (macroexpand form *eval-macro-env*))) + (if (and (consp new-form) + (eq (car new-form) 'progn)) + (do ((forms (cdr new-form) (cdr forms))) + ((null (cdr forms)) (eval-1 (car forms) venv fenv tenv benv)) + (eval-1 (car forms) venv fenv tenv benv)) + (let ((expansion (expand new-form))) + (when (and (listp expansion) + (eq (car expansion) 'define-function)) + (setf (get (second (second expansion)) + :function-definition) + form)) + (eval/5 expansion venv fenv tenv benv)) + ))) + + diff --git a/com/README b/com/README new file mode 100644 index 0000000..806c62a --- /dev/null +++ b/com/README @@ -0,0 +1,4 @@ +This directory contains various useful command scripts. Scripts +that are specific to a particular host Lisp are found in the appropriate +subdirectories. Scripts for building release distribution are in the +distrib subdirectory. diff --git a/com/akcl/README b/com/akcl/README new file mode 100644 index 0000000..1e997d5 --- /dev/null +++ b/com/akcl/README @@ -0,0 +1,39 @@ +This directory contains command scripts used for building Yale Haskell +from the source distribution under AKCL. We have been using +AKCL version 1.615 on a Sparc, but we don't expect that there would +be difficulties in building with AKCL on other platforms. + +Developers need to source haskell-development instead of haskell-setup +in the .cshrc file. + +To rebuild the system: + +* You need to define environment variables Y2 and AKCL to point to the + appropriate pathnames. See the haskell-development script for details. + +* Make sure that the environment variable PRELUDEBIN (in the + haskell-setup script) points to $PRELUDE/akcl. + +* Execute the "compile" script. This will recompile all of the Lisp + source files that make up the Yale Haskell system. Compiled files are + put in the "akcl" subdirectory of each source directory. + +* Execute the "build-prelude" script to compile the standard prelude. + Note that this process tends to use up a huge amount of memory! + +* Execute the "savesys" script to build a new executable. + +* The new executable is initially called "bin/new-akcl-haskell". Try + it out. If it works, you should rename it to "bin/akcl-haskell". + Make sure that HASKELLPROG (in the haskell-setup script) is correct. + +A word of warning: we have noticed that AKCL is slower by a factor of +three or four than the other Common Lisps we've ported Yale Haskell +to. We don't really support AKCL and we encourage you to buy one of +the commercial Lisp products instead. + +We do not support our Haskell-to-CLX interface under AKCL, either. + + + + diff --git a/com/akcl/build-prelude b/com/akcl/build-prelude new file mode 100755 index 0000000..8f61827 --- /dev/null +++ b/com/akcl/build-prelude @@ -0,0 +1,35 @@ +#!/bin/csh +# +# build-prelude -- recompile the prelude, saving the old one as old-prelude.* +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/akcl +rm $PRELUDEBIN/old* +if (-e $PRELUDEBIN/Prelude.o) then + foreach i ($PRELUDEBIN/Prelude*.{o,scm}) + mv $i $PRELUDEBIN/old-$i:t + end + endif +$AKCL <<EOF +;; Need a big heap to compile the prelude. +;(setf ext:*bytes-consed-between-gcs* 10000000) +;; If you want to recompile +;; everything from scratch, execute the "clean" script first, or +;; else use the "compile" script to do this. +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(load "cl-support/cl-init.lisp") +;; Use the same compiler settings for processing the prelude. +(in-package :mumble-user) +(setf *printers* '(phase-time dump-stat)) +(setf *optimizers* *all-optimizers*) +;; The compiler barfs while compiling the interface file for the prelude, +;; so set the flag for writing it as a source file. +;; Also have it break up the prelude code file into many small pieces +;; to avoid overwhelming the C compiler. +(setf *code-chunk-size* 100) +(setf *compile-interface* '#f) +(compile/compile *prelude-unit-filename*) +(lisp:bye) +EOF diff --git a/com/akcl/clean b/com/akcl/clean new file mode 100755 index 0000000..aba58af --- /dev/null +++ b/com/akcl/clean @@ -0,0 +1,4 @@ +#!/bin/csh +# +# delete AKCL binaries +'rm' $Y2/*/akcl/*.o diff --git a/com/akcl/compile b/com/akcl/compile new file mode 100755 index 0000000..3ed28f5 --- /dev/null +++ b/com/akcl/compile @@ -0,0 +1,11 @@ +#!/bin/csh +# +# compile -- compile the Yale Haskell system from scratch. +# +# +cd $Y2 +$AKCL <<EOF +;; Default optimize settings for AKCL are (speed 3) (safety 0) +(load "support/cl-support/cl-init.lisp") +(bye) +EOF diff --git a/com/akcl/savesys b/com/akcl/savesys new file mode 100755 index 0000000..c01db2b --- /dev/null +++ b/com/akcl/savesys @@ -0,0 +1,46 @@ +#!/bin/csh +# +# savesys -- build a saved executable in bin/new-cmu-haskell.core +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/akcl +if !(-e $PRELUDEBIN/Prelude.o) then + echo "Build the prelude first, stupid..." + exit + endif +$AKCL <<EOF +;;; Load the Haskell system. +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(load "cl-support/cl-init.lisp") +;;; Set various internal switches to appropriate values for running +;;; Haskell code. +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(setf *load-verbose* nil) +(setf compiler:*compile-verbose* nil) +(in-package :mumble-user) +(setf *printers* '(compiling loading)) +(setf *optimizers* '()) +(setf *compile-interface* '#f) +(setf *code-chunk-size* 100) +;;; Load the prelude. +(compile/load *prelude-unit-filename*) +;;; Set up the saved system. +;;; AKCL doesn't have the new CL condition system, so define the +;;; restart function using catch and throw. +(define (haskell-toplevel) + (setf lisp:*package* (lisp:find-package :mumble-user)) + (setf lisp:*default-pathname-defaults* (lisp:truename "./")) + (load-init-files) + (do () ('#f) + (lisp:catch 'restart-haskell + (heval)))) +(define (restart-haskell) + (lisp:throw 'restart-haskell '#f)) +;;; Have to do garbage collection and set-up of top-level function +;;; by hand before calling save. +;;; AKCL exits automatically after calling save. +(lisp:gbc 3) +(setf system::*top-level-hook* (function haskell-toplevel)) +(lisp:save "bin/new-akcl-haskell") +EOF diff --git a/com/allegro/README b/com/allegro/README new file mode 100644 index 0000000..b9dc676 --- /dev/null +++ b/com/allegro/README @@ -0,0 +1,40 @@ +This directory contains command scripts used for building Yale Haskell +from the source distribution under Franz Allegro Common Lisp. We've +been using version 4.1 on both NeXT and Sparc platforms -- don't +expect our code to work without modifications under earlier versions. + +Be sure you load the Allegro patches -- the scripts do this +automatically. If you're trying to build on some other kind of +platform, you'll have to get the equivalent patches from Franz Inc. +Our code won't work without these bug fixes. + +Developers need to source haskell-development instead of haskell-setup +in the .cshrc file. + +To rebuild the system: + +* You need to define environment variables Y2 and ALLEGRO to point to the + appropriate pathnames. See the haskell-development script for details. + +* Make sure that the environment variable PRELUDEBIN (in the + haskell-setup script) points to $PRELUDE/allegro (or $PRELUDE/allegro-next, + as appropriate). + +* Execute the "compile" script. This will recompile all of the Lisp + source files that make up the Yale Haskell system. Compiled files are + put in the "allegro" or "allegro-next" subdirectory of each source directory. + +* Execute the "build-prelude" script to compile the standard prelude. + Note that this process tends to use up a huge amount of memory! + +* Execute the "savesys" script to build a new executable. + +* The new executable is initially called "bin/new-allegro-haskell". Try + it out. If it works, you should rename it to "bin/allegro-haskell". + Make sure that HASKELLPROG (in the haskell-setup script) is correct. + +* If you want to build an executable with the X support, you'll also + need to run the "build-xlib" and "savesys-xlib" scripts. You may + need to edit these scripts to change the pathname of the file + containing the CLX library (or suppress the load entirely if you + are using a Lisp executable with CLX pre-loaded.). diff --git a/com/allegro/build-prelude b/com/allegro/build-prelude new file mode 100755 index 0000000..44fb422 --- /dev/null +++ b/com/allegro/build-prelude @@ -0,0 +1,32 @@ +#!/bin/csh +# +# build-prelude -- recompile the prelude, saving the old one as old-prelude.* +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/$ALLEGRODIR +if (-e $PRELUDEBIN/Prelude.fasl) then + rm $PRELUDEBIN/old* + foreach i ($PRELUDEBIN/Prelude*.{fasl,scm}) + mv $i $PRELUDEBIN/old-$i:t + end + endif +$ALLEGRO <<EOF +;; Need a big heap to compile the prelude. +;;(lcl:change-memory-management :expand 512 :growth-limit 2048) +#+next (progn (load "com/allegro/next-patches/patch0149.fasl") + (load "com/allegro/next-patches/patch0151.fasl")) +#+sparc (load "com/allegro/sparc-patches/patch0151.fasl") +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(load "cl-support/cl-init") +(in-package :mumble-user) +(setf *printers* '(phase-time dump-stat)) +(setf *optimizers* *all-optimizers*) +;; Set appropriate compiler settings for processing the prelude. +;; Don't try to compile the interface. +(setf *code-chunk-size* 300) +(setf *compile-interface* '#f) +(compile/compile *prelude-unit-filename*) +(excl:exit) +EOF diff --git a/com/allegro/build-xlib b/com/allegro/build-xlib new file mode 100755 index 0000000..a805308 --- /dev/null +++ b/com/allegro/build-xlib @@ -0,0 +1,14 @@ +#!/bin/csh +# +# build-xlib -- recompile the xlib stuff +# +# note that allegro's loader will look in its lib directory automagically +# for the clx library +cd $Y2 +setenv LIBRARYBIN $Y2/progs/lib/X11/$ALLEGRODIR +rm $LIBRARYBIN/xlib*.sbin +bin/allegro-haskell <<EOF +:(lisp:load "clx") +:(setf *code-quality* 3) +:compile \$HASKELL_LIBRARY/X11/xlib +EOF diff --git a/com/allegro/clean b/com/allegro/clean new file mode 100755 index 0000000..dadab0f --- /dev/null +++ b/com/allegro/clean @@ -0,0 +1,5 @@ +#!/bin/csh +# +# delete Allegro CL binaries +'rm' $Y2/*/$ALLEGRODIR/*.fasl + diff --git a/com/allegro/compile b/com/allegro/compile new file mode 100755 index 0000000..6aadee8 --- /dev/null +++ b/com/allegro/compile @@ -0,0 +1,15 @@ +#!/bin/csh +# +# compile -- compile the Yale Haskell system from scratch. +# +# +cd $Y2 +$ALLEGRO <<EOF +#+next (progn (load "com/allegro/next-patches/patch0149.fasl") + (load "com/allegro/next-patches/patch0151.fasl")) +#+sparc (load "com/allegro/sparc-patches/patch0151.fasl") +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(load "cl-support/cl-init") +(excl:exit) +EOF diff --git a/com/allegro/next-patches/patch0149.fasl b/com/allegro/next-patches/patch0149.fasl Binary files differnew file mode 100644 index 0000000..da10254 --- /dev/null +++ b/com/allegro/next-patches/patch0149.fasl diff --git a/com/allegro/next-patches/patch0151.fasl b/com/allegro/next-patches/patch0151.fasl Binary files differnew file mode 100644 index 0000000..c954667 --- /dev/null +++ b/com/allegro/next-patches/patch0151.fasl diff --git a/com/allegro/savesys b/com/allegro/savesys new file mode 100755 index 0000000..3d3abd8 --- /dev/null +++ b/com/allegro/savesys @@ -0,0 +1,54 @@ +#!/bin/csh +# +# savesys -- build a saved executable in bin/new-allegro-haskell +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/$ALLEGRODIR +if !(-e $PRELUDEBIN/Prelude.fasl) then + echo "Build the prelude first, stupid..." + exit + endif +$ALLEGRO <<EOF +;;; Load the Haskell system. +#+next (progn (load "com/allegro/next-patches/patch0149.fasl") + (load "com/allegro/next-patches/patch0151.fasl")) +#+sparc (load "com/allegro/sparc-patches/patch0151.fasl") +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(load "cl-support/cl-init") +;;; Set various internal switches to appropriate values for running +;;; Haskell code. +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(setf *compile-verbose* nil) +(setf *load-verbose* nil) +(setf excl:*load-source-file-info* nil) +(setf excl:*record-source-file-info* nil) +(setf excl:*load-xref-info* nil) +(setf excl:*record-source-file-info* nil) +(in-package :mumble-user) +(setf *printers* '(compiling loading)) +(setf *optimizers* '()) +(setf *compile-interface* '#f) +;;; Load the prelude. +(compile/load *prelude-unit-filename*) +;;; Set up the saved system. +(define *saved-readtable* (lisp:copy-readtable lisp:*readtable*)) +(define (haskell-toplevel) + ;; Saved system always starts up in USER package. + (setf lisp:*package* (lisp:find-package :mumble-user)) + ;; Saved system seems to forget about our readtable hacks. + (setf lisp:*readtable* *saved-readtable*) + ;; Set printer variables w/implementation-defined initial values + ;; to known values + (setf *print-pretty* '#f) + (load-init-files) + (do () ('#f) + (cl:with-simple-restart (restart-haskell "Restart Haskell.") + (heval)))) +(define (restart-haskell) + (cl:invoke-restart 'restart-haskell)) +(excl:dumplisp + :name #+next "bin/new-allegro-next-haskell" #-next "bin/new-allegro-haskell" + :restart-function 'haskell-toplevel) +(excl:exit) +EOF diff --git a/com/allegro/savesys-xlib b/com/allegro/savesys-xlib new file mode 100755 index 0000000..c8443a3 --- /dev/null +++ b/com/allegro/savesys-xlib @@ -0,0 +1,65 @@ +#!/bin/csh +# +# savesys -- build a saved executable in bin/new-allegro-haskell +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/$ALLEGRODIR +if !(-e $PRELUDEBIN/Prelude.fasl) then + echo "Build the prelude first, stupid..." + exit + endif +setenv LIBRARYBIN $Y2/progs/lib/X11/$ALLEGRODIR +if !(-e $LIBRARYBIN/xlib.fasl) then + echo "Build the xlib stuff first, silly..." + exit + endif +$ALLEGRO <<EOF +;;; Load the Haskell system. +#+next (progn (load "com/allegro/next-patches/patch0149.fasl") + (load "com/allegro/next-patches/patch0151.fasl")) +#+sparc (load "com/allegro/sparc-patches/patch0151.fasl") +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(load "cl-support/cl-init") +;;; Set various internal switches to appropriate values for running +;;; Haskell code. +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(setf *compile-verbose* nil) +(setf *load-verbose* nil) +(setf excl:*load-source-file-info* nil) +(setf excl:*record-source-file-info* nil) +(setf excl:*load-xref-info* nil) +(setf excl:*record-source-file-info* nil) +(in-package :mumble-user) +(setf *printers* '(compiling loading)) +(setf *optimizers* '()) +(setf *compile-interface* '#f) +;;; Load the prelude. +(compile/load *prelude-unit-filename*) +;;; Load the X support. +(lisp:load "clx") +(compile/load "\$HASKELL_LIBRARY/X11/xlib") +(setf *haskell-compiler-update* + (string-append *haskell-compiler-update* "-X11")) +;;; Set up the saved system. +(define *saved-readtable* (lisp:copy-readtable lisp:*readtable*)) +(define (haskell-toplevel) + ;; Saved system always starts up in USER package. + (setf lisp:*package* (lisp:find-package :mumble-user)) + ;; Saved system seems to forget about our readtable hacks. + (setf lisp:*readtable* *saved-readtable*) + ;; Set printer variables w/implementation-defined initial values + ;; to known values + (setf *print-pretty* '#f) + (load-init-files) + (do () ('#f) + (cl:with-simple-restart (restart-haskell "Restart Haskell.") + (heval)))) +(define (restart-haskell) + (cl:invoke-restart 'restart-haskell)) +(excl:dumplisp + :name #+next "bin/new-allegro-next-clx-haskell" + #-next "bin/new-allegro-clx-haskell" + :restart-function 'haskell-toplevel) +(excl:exit) +EOF diff --git a/com/allegro/sparc-patches/patch0151.fasl b/com/allegro/sparc-patches/patch0151.fasl Binary files differnew file mode 100644 index 0000000..cfbc48f --- /dev/null +++ b/com/allegro/sparc-patches/patch0151.fasl diff --git a/com/clean b/com/clean new file mode 100755 index 0000000..91918e2 --- /dev/null +++ b/com/clean @@ -0,0 +1,14 @@ +#!/bin/csh +# +# clean -- delete binaries +# + +$Y2/com/lucid/clean +$Y2/com/cmu/clean +$Y2/com/allegro/clean +$Y2/com/lispworks/clean +$Y2/com/akcl/clean + +# T stuff +'rm' $Y2/*/t/*.{si,sd,sn,so} +'rm' $Y2/support/t-support/*.{si,sd,sn,so} diff --git a/com/cmu/README b/com/cmu/README new file mode 100644 index 0000000..3653d60 --- /dev/null +++ b/com/cmu/README @@ -0,0 +1,45 @@ +This directory contains command scripts used for building Yale Haskell +from the source distribution under CMU Common Lisp on the sparc. + +We have been using version 16f of CMU Common Lisp to build Haskell. +You can ftp this from lisp-rt1.slisp.cs.cmu.edu (128.2.217.9). +There is a known problem with this version of CMU CL: core files built +under SunOS 4.1.2 won't work under 4.1.3, and vice versa. There are +also apparently compatibility problems with 4.1.3 between sun4c and +sun4m architectures. Anyway, we have built under 4.1.2 on a sun4c +and 4.1.3 on a sun4m. + +Developers need to source haskell-development instead of haskell-setup +in the .cshrc file. + +To rebuild the system: + +* You need to define environment variables Y2, CMUCL, and CMUCLLIB to + point to the appropriate pathnames. See the haskell-development + script for details. + +* Make sure that the environment variable PRELUDEBIN (in the + haskell-setup script) points to $PRELUDE/cmu. + +* Execute the "compile" script. This will recompile all of the Lisp + source files that make up the Yale Haskell system. Compiled files + are put in the "cmu" subdirectory of each source directory. + +* Execute the "build-prelude" script to compile the standard prelude. + Note that this process tends to use up a huge amount of memory! + +* Execute the "savesys" script to save a core file. + +* The new core file is initially called "bin/new-cmu-haskell.core". + Use the -core command line argument to cmucl to test it. If it + works, you should rename it to "bin/sun4c-haskell.core" (or + "bin/sun4m-haskell.core") and use the "bin/cmu-haskell" script + to execute it. Make sure HASKELLPROG (in the haskell-setup script) + is correct. Depending on where you have cmucl this script may need + editing. + +* If you want to build an executable with the X support, you'll also + need to run the "build-xlib" and "savesys-xlib" scripts. You + need to edit these scripts to change the pathname of the file + containing the CLX library (or suppress the load entirely if you + are using a Lisp executable with CLX pre-loaded.). diff --git a/com/cmu/build-prelude b/com/cmu/build-prelude new file mode 100755 index 0000000..68d2621 --- /dev/null +++ b/com/cmu/build-prelude @@ -0,0 +1,32 @@ +#!/bin/csh +# +# build-prelude -- recompile the prelude, saving the old one as old-prelude.* +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/cmu +if (-e $PRELUDEBIN/Prelude.sparcf) then + rm $PRELUDEBIN/old* + foreach i ($PRELUDEBIN/Prelude*.{scm,sparcf}) + mv $i $PRELUDEBIN/old-$i:t + end + endif +$CMUCL <<EOF +;; Need a big heap to compile the prelude. +(setf ext:*bytes-consed-between-gcs* 10000000) +;; If you want to recompile +;; everything from scratch, execute the "clean" script first, or +;; else use the "compile" script to do this. +(proclaim '(optimize (speed 3) (safety 0) (debug 0) (ext:inhibit-warnings 3))) +(load "cl-support/cl-init") +;; Use the same compiler settings for processing the prelude. +(in-package :mumble-user) +(setf *printers* '(phase-time dump-stat)) +(setf *optimizers* *all-optimizers*) +;; The compiler barfs while compiling the interface file for the prelude, +;; so set the flag for writing it as a source file. +(setf *code-chunk-size* 300) +(setf *compile-interface* '#f) +(compile/compile *prelude-unit-filename*) +(ext:quit) +EOF diff --git a/com/cmu/build-xlib b/com/cmu/build-xlib new file mode 100755 index 0000000..df6eb05 --- /dev/null +++ b/com/cmu/build-xlib @@ -0,0 +1,15 @@ +#!/bin/csh +# +# build-xlib -- recompile the xlib stuff +# +# +cd $Y2 +setenv CLXFILE /net/nebula/homes/systems/hcompile/cmu/lib/subsystems/clx-library.sparcf +setenv LIBRARYBIN $Y2/progs/lib/bin/cmu +rm $LIBRARYBIN/xlib*.sparcf +bin/cmu-haskell <<EOF +:(setf ext:*bytes-consed-between-gcs* 8000000) +:(load "\$CLXFILE") +:(setf *code-quality* 3) +:compile \$HASKELL_LIBRARY/X11/xlib +EOF diff --git a/com/cmu/clean b/com/cmu/clean new file mode 100755 index 0000000..370ed36 --- /dev/null +++ b/com/cmu/clean @@ -0,0 +1,4 @@ +#!/bin/csh +# +# delete CMU CL binaries +'rm' $Y2/*/cmu/*.sparcf diff --git a/com/cmu/compile b/com/cmu/compile new file mode 100755 index 0000000..e4126ea --- /dev/null +++ b/com/cmu/compile @@ -0,0 +1,12 @@ +#!/bin/csh +# +# compile -- compile the Yale Haskell system from scratch. +# +# +cd $Y2 +$CMUCL <<EOF +(setf ext:*bytes-consed-between-gcs* 4000000) +(proclaim '(optimize (speed 3) (safety 0) (debug 0) (ext:inhibit-warnings 3))) +(load "cl-support/cl-init") +(quit) +EOF diff --git a/com/cmu/savesys b/com/cmu/savesys new file mode 100755 index 0000000..b3b0672 --- /dev/null +++ b/com/cmu/savesys @@ -0,0 +1,46 @@ +#!/bin/csh +# +# savesys -- build a saved executable in bin/new-cmu-haskell.core +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/cmu +if !(-e $PRELUDEBIN/Prelude.sparcf) then + echo "Build the prelude first, stupid..." + exit + endif +$CMUCL <<EOF +;;; Load the Haskell system. +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(load "cl-support/cl-init") +;;; Set various internal switches to appropriate values for running +;;; Haskell code. +(setf ext:*bytes-consed-between-gcs* 4000000) +(proclaim '(optimize (speed 3) (safety 0) (debug 0) (ext:inhibit-warnings 3))) +(setf *load-verbose* nil) +(setf *compile-verbose* nil) +(in-package :mumble-user) +(gc-messages '#f) +(setf *printers* '(compiling loading)) +(setf *optimizers* '()) +(setf *compile-interface* '#f) +;;; Load the prelude. +(compile/load *prelude-unit-filename*) +;;; Set up the saved system. +(define (haskell-toplevel) + (load-init-files) + (do () ('#f) + (lisp:with-simple-restart (restart-haskell "Restart Haskell.") + (heval)))) +(define (restart-haskell) + (lisp:invoke-restart 'restart-haskell)) +(ext:save-lisp "bin/new-cmu-haskell.core" + :purify '#t + :root-structures '() + :init-function 'haskell-toplevel + :load-init-file '#f + :site-init '#f + :print-herald '#f + ) +(ext:quit) +EOF diff --git a/com/cmu/savesys-xlib b/com/cmu/savesys-xlib new file mode 100755 index 0000000..763e680 --- /dev/null +++ b/com/cmu/savesys-xlib @@ -0,0 +1,57 @@ +#!/bin/csh +# +# savesys-xlib -- build a saved executable in bin/new-cmu-clx-haskell.core +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/cmu +if !(-e $PRELUDEBIN/Prelude.sparcf) then + echo "Build the prelude first, stupid..." + exit + endif +setenv CLXFILE /net/nebula/homes/systems/hcompile/cmu/lib/subsystems/clx-library.sparcf +setenv LIBRARYBIN $Y2/progs/lib/bin/cmu +if !(-e $LIBRARYBIN/xlib.sparcf) then + echo "Build the xlib stuff first, silly..." + exit + endif +$CMUCL <<EOF +;;; Load the Haskell system. +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(load "cl-support/cl-init") +;;; Set various internal switches to appropriate values for running +;;; Haskell code. +(setf ext:*bytes-consed-between-gcs* 4000000) +(proclaim '(optimize (speed 3) (safety 0) (debug 0) (ext:inhibit-warnings 3))) +(setf *load-verbose* nil) +(setf *compile-verbose* nil) +(in-package :mumble-user) +(gc-messages '#f) +(setf *printers* '(compiling loading)) +(setf *optimizers* '()) +(setf *compile-interface* '#f) +;;; Load the prelude. +(compile/load *prelude-unit-filename*) +;;; Load the X support. +(load "\$CLXFILE") +(compile/load "\$HASKELL_LIBRARY/X11/xlib") +(setf *haskell-compiler-update* + (string-append *haskell-compiler-update* "-X11")) +;;; Set up the saved system. +(define (haskell-toplevel) + (load-init-files) + (do () ('#f) + (lisp:with-simple-restart (restart-haskell "Restart Haskell.") + (heval)))) +(define (restart-haskell) + (lisp:invoke-restart 'restart-haskell)) +(ext:save-lisp "bin/new-cmu-clx-haskell.core" + :purify '#t + :root-structures '() + :init-function 'haskell-toplevel + :load-init-file '#f + :site-init '#f + :print-herald '#f + ) +(ext:quit) +EOF diff --git a/com/lispworks/README b/com/lispworks/README new file mode 100644 index 0000000..bf7aab2 --- /dev/null +++ b/com/lispworks/README @@ -0,0 +1,43 @@ +This directory contains command scripts used for building Yale Haskell +from the source distribution under Lispworks from Harlequin. We have +been using version 3.1.1 on a Sparc. + +Developers need to source haskell-development instead of haskell-setup +in the .cshrc file. + +Important: Make sure you load the stuff in the patches directory +before trying to build the system (the command files do this for you). +If you're building on some platform other than a sparc, you'll have to +get equivalent patches from Harlequin before proceeding. + +To rebuild the system: + +* You need to define environment variables Y2 and LISPWORKS to point to the + appropriate pathnames. See the haskell-development script for details. + +* Make sure that the environment variable PRELUDEBIN (in the + haskell-setup script) points to $PRELUDE/lispworks. + +* Execute the "compile" script. This will recompile all of the Lisp + source files that make up the Yale Haskell system. Compiled files are + put in the "lispworks" subdirectory of each source directory. + +* Execute the "build-prelude" script to compile the standard prelude. + Note that this process tends to use up a huge amount of memory! + +* Execute the "savesys" script to build a new executable. + +* The new executable is initially called "bin/new-lispworks-haskell". Try + it out. If it works, you should rename it to "bin/lispworks-haskell". + Make sure that HASKELLPROG (in the haskell-setup script) is correct. + +* If you want to build an executable with the X support, you'll also + need to run the "build-xlib" and "savesys-xlib" scripts. You may + need to edit these scripts to load the CLX library explicitly if + you are using a Lisp executable that doesn't have CLX pre-loaded. + +When you compile things with the Lispworks compiler, you'll see a +bunch of messages complaining about forward references to things that +haven't yet been defined. We haven't been able to figure out how to +suppress these messages, so unless something else goes wrong you should +just ignore them. diff --git a/com/lispworks/build-prelude b/com/lispworks/build-prelude new file mode 100755 index 0000000..cde5619 --- /dev/null +++ b/com/lispworks/build-prelude @@ -0,0 +1,35 @@ +#!/bin/csh +# +# build-prelude -- recompile the prelude, saving the old one as old-prelude.* +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/lispworks +if (-e $PRELUDEBIN/Prelude.wfasl) then + rm $PRELUDEBIN/old* + foreach i ($PRELUDEBIN/Prelude*.{wfasl,scm}) + mv $i $PRELUDEBIN/old-$i:t + end + endif +$LISPWORKS <<EOF +(load "com/lispworks/patches/safe-fo-closure.wfasl") +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +;; Need a bigger than normal stack for compiling the prelude. +(setf system::*stack-overflow-behaviour* :warn) +;; Need a big heap to compile the prelude. +;(lcl:change-memory-management :expand 512 :growth-limit 2048) +;; If you want to recompile +;; everything from scratch, execute the "clean" script first, or +;; else use the "compile" script to do this. +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(load "cl-support/cl-init") +(in-package :mumble-user) +(setf *printers* '(phase-time dump-stat)) +(setf *optimizers* *all-optimizers*) +;; Set appropriate compiler settings for processing the prelude. +;; Don't try to compile the interface files. +(setf *code-chunk-size* 300) +(setf *compile-interface* '#f) +(compile/compile *prelude-unit-filename*) +(lw:bye) +EOF diff --git a/com/lispworks/build-xlib b/com/lispworks/build-xlib new file mode 100755 index 0000000..612820e --- /dev/null +++ b/com/lispworks/build-xlib @@ -0,0 +1,12 @@ +#!/bin/csh +# +# build-xlib -- recompile the xlib stuff +# +# note that lispworks comes with clx pre-loaded! +cd $Y2 +setenv LIBRARYBIN $Y2/progs/lib/X11/lispworks +rm $LIBRARYBIN/xlib*.wfasl +bin/lispworks-haskell <<EOF +:(setf *code-quality* 3) +:compile \$HASKELL_LIBRARY/X11/xlib +EOF diff --git a/com/lispworks/clean b/com/lispworks/clean new file mode 100755 index 0000000..7eb1459 --- /dev/null +++ b/com/lispworks/clean @@ -0,0 +1,5 @@ +#!/bin/csh +# +# delete lispworks binaries +'rm' $Y2/*/lispworks/*.{wfasl} + diff --git a/com/lispworks/compile b/com/lispworks/compile new file mode 100755 index 0000000..de0b459 --- /dev/null +++ b/com/lispworks/compile @@ -0,0 +1,13 @@ +#!/bin/csh +# +# compile -- compile the Yale Haskell system from scratch. +# +# +cd $Y2 +$LISPWORKS <<EOF +(load "com/lispworks/patches/safe-fo-closure.wfasl") +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(load "cl-support/cl-init") +(lw:bye) +EOF diff --git a/com/lispworks/patches/safe-fo-closure.wfasl b/com/lispworks/patches/safe-fo-closure.wfasl Binary files differnew file mode 100644 index 0000000..71c9a5f --- /dev/null +++ b/com/lispworks/patches/safe-fo-closure.wfasl diff --git a/com/lispworks/savesys b/com/lispworks/savesys new file mode 100755 index 0000000..f97b6f6 --- /dev/null +++ b/com/lispworks/savesys @@ -0,0 +1,43 @@ +#!/bin/csh +# +# savesys -- build a saved executable in bin/new-lispworks-haskell +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/lispworks +if !(-e $PRELUDEBIN/Prelude.wfasl) then + echo "Build the prelude first, stupid..." + exit + endif +$LISPWORKS <<EOF +;;; Load the Haskell system. +(load "com/lispworks/patches/safe-fo-closure.wfasl") +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(load "cl-support/cl-init") +;;; Set various internal switches to appropriate values for running +;;; Haskell code. +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(setf *load-verbose* nil) +(setf *compile-verbose* nil) +(in-package :mumble-user) +(setf *printers* '(compiling loading)) +(setf *optimizers* '()) +(setf *compile-interface* '#f) +;;; Load the prelude +(compile/load *prelude-unit-filename*) +;;; Set up the saved system. +(define (haskell-toplevel) + ;; Need to reset pathname defaults + (setf lisp:*default-pathname-defaults* (lisp:truename "")) + (load-init-files) + (do () ('#f) + (lisp:with-simple-restart (restart-haskell "Restart Haskell.") + (heval)))) +(define (restart-haskell) + (lisp:invoke-restart 'restart-haskell)) +(lw:save-image "bin/new-lispworks-haskell" + :gc '#t + :normal-gc '#f ; don't reset gc parameters + :restart-function 'haskell-toplevel) +(lw:bye) +EOF diff --git a/com/lispworks/savesys-xlib b/com/lispworks/savesys-xlib new file mode 100755 index 0000000..d1e81a0 --- /dev/null +++ b/com/lispworks/savesys-xlib @@ -0,0 +1,52 @@ +#!/bin/csh +# +# savesys -- build a saved executable in bin/new-lispworks-haskell +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/lispworks +if !(-e $PRELUDEBIN/Prelude.wfasl) then + echo "Build the prelude first, stupid..." + exit + endif +setenv LIBRARYBIN $Y2/progs/lib/X11/lispworks +if !(-e $LIBRARYBIN/xlib.wfasl) then + echo "Build the xlib stuff first, silly..." + exit + endif +$LISPWORKS <<EOF +;;; Load the Haskell system. +(load "com/lispworks/patches/safe-fo-closure.wfasl") +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(load "cl-support/cl-init") +;;; Set various internal switches to appropriate values for running +;;; Haskell code. +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(setf *load-verbose* nil) +(setf *compile-verbose* nil) +(in-package :mumble-user) +(setf *printers* '(compiling loading)) +(setf *optimizers* '()) +(setf *compile-interface* '#f) +;;; Load the prelude. +(compile/load *prelude-unit-filename*) +;;; Load the X support. +(compile/load "\$HASKELL_LIBRARY/X11/xlib") +(setf *haskell-compiler-update* + (string-append *haskell-compiler-update* "-X11")) +;;; Set up the saved system. +(define (haskell-toplevel) + ;; Need to reset pathname defaults + (setf lisp:*default-pathname-defaults* (lisp:truename "")) + (load-init-files) + (do () ('#f) + (lisp:with-simple-restart (restart-haskell "Restart Haskell.") + (heval)))) +(define (restart-haskell) + (lisp:invoke-restart 'restart-haskell)) +(lw:save-image "bin/new-lispworks-clx-haskell" + :gc '#t + :normal-gc '#f ; don't reset gc parameters + :restart-function 'haskell-toplevel) +(lw:bye) +EOF diff --git a/com/locked b/com/locked new file mode 100755 index 0000000..f98fd19 --- /dev/null +++ b/com/locked @@ -0,0 +1,14 @@ +#!/bin/csh +# +# +# identify locked source files +# + +cd $Y2 +foreach i (*/*.scm */*.lisp) + if (-e $i:h/RCS/$i:t,v) then + foreach j (`rlog -R -L $i:h/RCS/$i:t,v`) + ls -l $i + end + endif +end diff --git a/com/lookfor b/com/lookfor new file mode 100755 index 0000000..4b07f33 --- /dev/null +++ b/com/lookfor @@ -0,0 +1,9 @@ +#!/bin/csh +# +# +# look for the argument in source files. +# useful for finding all references of a function, etc. +# + +cd $Y2 +fgrep -i $1 */*.scm diff --git a/com/lucid/README b/com/lucid/README new file mode 100644 index 0000000..508ed40 --- /dev/null +++ b/com/lucid/README @@ -0,0 +1,39 @@ +This directory contains command scripts used for building Yale Haskell +from the source distribution under Lucid Common Lisp. We have been using +Lucid version 4.0.0 on a Sparc, but we don't expect that there would +be difficulties in building with Lucid on other platforms. + +Developers need to source haskell-development instead of haskell-setup +in the .cshrc file. + +To rebuild the system: + +* You need to define environment variables Y2 and LUCID to point to the + appropriate pathnames. See the haskell-development script for details. + +* Make sure that the environment variable PRELUDEBIN (in the + haskell-setup script) points to $PRELUDE/lucid. + +* Execute the "compile" script. This will recompile all of the Lisp + source files that make up the Yale Haskell system. Compiled files are + put in the "lucid" subdirectory of each source directory. + +* Execute the "build-prelude" script to compile the standard prelude. + Note that this process tends to use up a huge amount of memory! + +* Execute the "savesys" script to build a new executable. + +* The new executable is initially called "bin/new-lucid-haskell". Try + it out. If it works, you should rename it to "bin/lucid-haskell". + Make sure that HASKELLPROG (in the haskell-setup script) is correct. + +* If you want to build an executable with the X support, you'll also + need to run the "build-xlib" and "savesys-xlib" scripts. You + need to edit these scripts to change the pathname of the file + containing the CLX library (or suppress the load entirely if you + are using a Lisp executable with CLX pre-loaded.). + +Important note for Emacs users: We've been told that Lucid provides +some patches to GNU Emacs that cause the Haskell Emacs mode not to work. +(Apparently these patches redefine some of the interprocess communication +functions in an incompatible way.) Use a standard Emacs. diff --git a/com/lucid/build-prelude b/com/lucid/build-prelude new file mode 100755 index 0000000..aee2274 --- /dev/null +++ b/com/lucid/build-prelude @@ -0,0 +1,36 @@ +#!/bin/csh +# +# build-prelude -- recompile the prelude, saving the old one as old-prelude.* +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/lucid +if (-e $PRELUDEBIN/Prelude.sbin) then + rm $PRELUDEBIN/old* + foreach i ($PRELUDEBIN/Prelude*.{sbin,scm}) + mv $i $PRELUDEBIN/old-$i:t + end + endif +$LUCID <<EOF +;; Need a big heap to compile the prelude. +(lcl:change-memory-management :expand 512 :growth-limit 2048) +;; This will make sure any files that need to get compiled will be +;; compiled with Lucid's production compiler. If you want to recompile +;; everything from scratch, execute the "clean" script first, or +;; else use the "compile" script to do this. +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(load "cl-support/cl-init") +(in-package :mumble-user) +(setf *printers* '(phase-time dump-stat)) +(setf *optimizers* *all-optimizers*) +;; Set appropriate compiler settings for processing the prelude. +;; Use production compiler on prelude code and split it up into pieces. +;; Use fast development compiler on interface. +(setf *code-chunk-size* 200) +(setf *compile-interface* '#t) +(setf *interface-code-quality* 2) +(setf *interface-chunk-size* '#f) +(compile/compile *prelude-unit-filename*) +(lcl:quit) +EOF diff --git a/com/lucid/build-xlib b/com/lucid/build-xlib new file mode 100755 index 0000000..960bd13 --- /dev/null +++ b/com/lucid/build-xlib @@ -0,0 +1,15 @@ +#!/bin/csh +# +# build-xlib -- recompile the xlib stuff +# +# +cd $Y2 +setenv CLXFILE /cs/licensed/sclisp-4.0/windows-x.sbin +setenv LIBRARYBIN $Y2/progs/lib/bin/lucid +rm $LIBRARYBIN/xlib*.sbin +bin/haskell <<EOF +:(lcl:change-memory-management :expand 512) +:(load "\$CLXFILE") +:(setf *code-quality* 3) +:compile \$HASKELL_LIBRARY/X11/xlib +EOF diff --git a/com/lucid/clean b/com/lucid/clean new file mode 100755 index 0000000..4c72d9b --- /dev/null +++ b/com/lucid/clean @@ -0,0 +1,5 @@ +#!/bin/csh +# +# delete lucid binaries +'rm' $Y2/*/lucid/*.{sbin,rbin} + diff --git a/com/lucid/compile b/com/lucid/compile new file mode 100755 index 0000000..115156a --- /dev/null +++ b/com/lucid/compile @@ -0,0 +1,13 @@ +#!/bin/csh +# +# compile -- compile the Yale Haskell system from scratch. +# +# +cd $Y2 +$LUCID <<EOF +;; To get Lucid's development mode compiler, remove (compilation-speed 0) +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(load "cl-support/cl-init") +(quit) +EOF diff --git a/com/lucid/savesys b/com/lucid/savesys new file mode 100755 index 0000000..786f44e --- /dev/null +++ b/com/lucid/savesys @@ -0,0 +1,44 @@ +#!/bin/csh +# +# savesys -- build a saved executable in bin/new-lucid-haskell +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/lucid +if !(-e $PRELUDEBIN/Prelude.sbin) then + echo "Build the prelude first, stupid..." + exit + endif +$LUCID <<EOF +;;; Load the Haskell system. +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(setf lcl:*record-source-files* nil) +(load "cl-support/cl-init") +;;; Set various internal switches to appropriate values for running +;;; Haskell code. +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(lcl:compiler-options :file-messages nil) +(setf lcl:*redefinition-action* nil) +(setf *load-verbose* nil) +(in-package :mumble-user) +(setf *printers* '(compiling loading)) +(setf *optimizers* '()) +(setf *compile-interface* '#t) +(setf *interface-code-quality* 1) +(setf *code-chunk-size* 200) +;;; Load the prelude. +(compile/load *prelude-unit-filename*) +;;; Set up the saved system. +(define (haskell-toplevel) + (load-init-files) + (do () ('#f) + (lcl:with-simple-restart (restart-haskell "Restart Haskell.") + (heval)))) +(define (restart-haskell) + (lcl:invoke-restart 'restart-haskell)) +(lcl:gc) +(lcl:disksave "bin/new-lucid-haskell" + :reserved-free-segments 64 :dynamic-free-segments 25 + :restart-function 'haskell-toplevel :full-gc '#t) +(lcl:quit) +EOF diff --git a/com/lucid/savesys-xlib b/com/lucid/savesys-xlib new file mode 100755 index 0000000..0d5a959 --- /dev/null +++ b/com/lucid/savesys-xlib @@ -0,0 +1,55 @@ +#!/bin/csh +# +# savesys-xlib -- build a saved executable in bin/new-lucid-clx-haskell +# +# +cd $Y2 +setenv PRELUDEBIN $Y2/progs/prelude/lucid +if !(-e $PRELUDEBIN/Prelude.sbin) then + echo "Build the prelude first, stupid..." + exit + endif +setenv CLXFILE /cs/licensed/sclisp-4.0/windows-x.sbin +setenv LIBRARYBIN $Y2/progs/lib/bin/lucid +if !(-e $LIBRARYBIN/xlib.sbin) then + echo "Build the xlib stuff first, silly..." + exit + endif +$LUCID <<EOF +;;; Load the Haskell system. +(make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")) +(setf lcl:*record-source-files* nil) +(load "cl-support/cl-init") +;;; Set various internal switches to appropriate values for running +;;; Haskell code. +(proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0))) +(lcl:compiler-options :file-messages nil) +(setf lcl:*redefinition-action* nil) +(setf *load-verbose* nil) +(in-package :mumble-user) +(setf *printers* '(compiling loading)) +(setf *optimizers* '()) +(setf *compile-interface* '#t) +(setf *interface-code-quality* 1) +(setf *code-chunk-size* 200) +;;; Load the prelude. +(compile/load *prelude-unit-filename*) +;;; Load the X support. +(load "\$CLXFILE") +(compile/load "\$HASKELL_LIBRARY/X11/xlib") +(setf *haskell-compiler-update* + (string-append *haskell-compiler-update* "-X11")) +;;; Set up the saved system. +(define (haskell-toplevel) + (load-init-files) + (do () ('#f) + (lcl:with-simple-restart (restart-haskell "Restart Haskell.") + (heval)))) +(define (restart-haskell) + (lcl:invoke-restart 'restart-haskell)) +(lcl:gc) +(lcl:disksave "bin/new-lucid-clx-haskell" + :reserved-free-segments 64 :dynamic-free-segments 25 + :restart-function 'haskell-toplevel :full-gc '#t) +(lcl:quit) +EOF diff --git a/com/unchecked b/com/unchecked new file mode 100755 index 0000000..b80d166 --- /dev/null +++ b/com/unchecked @@ -0,0 +1,10 @@ +#!/bin/csh +# +# +# identify unchecked-in source files +# + +cd $Y2 +foreach i (*/*.scm) + if !(-e $i:h/RCS/$i:t,v) ls -l $i +end diff --git a/command-interface-help b/command-interface-help new file mode 100644 index 0000000..d015a1e --- /dev/null +++ b/command-interface-help @@ -0,0 +1,33 @@ +Commands used by the Y2.0 command interface: + +Commands to dispose of the current extension: +:eval Evaluate dialogues in the current extension +:save Save the current extension +:kill Forget about the current extension +:list Print the current extension + +Commands to load & run files (compilation units) +:load file Load a file into the system +:compile file Compile a file to native code and save the binary +:run file Load a file and run `main' + +Commands to control the current module: +:clear Remove all saved definitions in the current module +:module name Set the current module +:Main Switch to an empty module named Main + +Other commands: +:cd directory Set the current directory +:p? Describe available printers +:p= p1 p2 ... Set the printers +:p+ p1 p2 ... Enable selected printers +:p- p1 p2 ... Disable selected printers +:o? Describe available optimizers +:o= o1 o2 ... Set the optimizers +:o+ o1 o2 ... Enable selected optimizers +:o- o1 o2 ... Disable selected optimizers +:(fn ...) Evaluate a Lisp expression + +Abbreviations within the current extension: +=exp Creates a dialogue to print the expression under :e +@exp Creates a definition which will run the dialogue under :e diff --git a/command-interface/README b/command-interface/README new file mode 100644 index 0000000..f4991af --- /dev/null +++ b/command-interface/README @@ -0,0 +1,2 @@ +This directory contains code to implement the command interface and +incremental compiler. See the doc directory for details. diff --git a/command-interface/command-interface.scm b/command-interface/command-interface.scm new file mode 100644 index 0000000..1eebde3 --- /dev/null +++ b/command-interface/command-interface.scm @@ -0,0 +1,11 @@ +;;; csys.scm -- compilation unit definition for the compilation system + +(define-compilation-unit command-interface + (source-filename "$Y2/command-interface/") + (require global) + (unit command + (source-filename "command.scm")) + (unit command-utils + (source-filename "command-utils.scm")) + (unit incremental-compiler + (source-filename "incremental-compiler.scm"))) diff --git a/command-interface/command-utils.scm b/command-interface/command-utils.scm new file mode 100644 index 0000000..d46663f --- /dev/null +++ b/command-interface/command-utils.scm @@ -0,0 +1,208 @@ +;;; command-interface/command-utils.scm + +;;; These are utilities used by the command interface. + +;;; These send output to the user + +;;; This is used in emacs mode + +(define (say/em . args) + (say1 args)) + +;;; This is for both ordinary text to emacs and output to the command interface + +(define (say . args) + (say1 args)) + +(define (say1 args) + (apply (function format) (cons (current-output-port) args))) + +;;; This is for non-emacs output + +(define (say/ne . args) + (when (not *emacs-mode*) + (say1 args))) + + +;;; These random utilities should be elsewhere + +;;; This determines whether the current module is loaded & available. +;;; If the module is Main, an empty Main module is created. + +(define (cm-available?) + (cond ((table-entry *modules* *current-mod*) + '#t) + ((eq? *current-mod* '|Main|) + (make-empty-main) + '#t) + (else + '#f))) + +;;; This creates a empty module named Main to use as a scratch pad. + +(define (make-empty-main) + (compile/load "$PRELUDE/Prelude") + (setf *unit* '|Main|) + (setf *current-mod* '|Main|) + (let ((mods (parse-from-string + "module Main where {import Prelude}" + (function parse-module-list) + "foo"))) + ;;; This should generate no code at all so the returned code is ignored. + (modules->lisp-code mods) + (setf (table-entry *modules* *current-mod*) (car mods)) + (clear-extended-modules))) + +(define (eval-fragment eval?) + (cond ((not (cm-available?)) + (say "~&Module ~A is not loaded.~%" *current-mod*) + 'error) + ((memq *fragment-status* '(Compiled Saved)) + (when eval? + (eval-module *extension-module*)) + 'ok) + ((eq? *fragment-status* 'Error) + (say/ne "~&Errors exist in current fragment.~%") + 'error) + ((string=? *current-string* "") + (say/ne "~&Current extension is empty.~%") + 'error) + (else + (let ((res (compile-fragment + *current-mod* *current-string* + *extension-file-name*))) + (cond ((eq? res 'error) + (setf *fragment-status* 'Error) + (notify-error)) + (else + (setf *extension-module* res) + (setf *fragment-status* 'Compiled) + (when eval? + (eval-module *extension-module*)))))))) + +(define (set-current-file file) + (cond ((null? file) + '()) + ((null? (cdr file)) + (setf *remembered-file* (car file))) + (else + (say "~&Invalid file spec ~s.~%" file) + (funcall *abort-command*)))) + +(define (select-current-mod mods) + (when (pair? mods) + (when (not (memq *current-mod* mods)) + (setf *current-mod* (car mods)) + (say/ne "~&Now in module ~A.~%" *current-mod*)))) + +;;; Emacs mode stuff + +;;; *** bogus alert!!! This coercion may fail to produce a +;;; *** real character in some Lisps. + +(define *emacs-notify-char* (integer->char 1)) + +(define (notify-ready) + (when *emacs-mode* + (say/em "~Ar" *emacs-notify-char*) + (force-output (current-output-port)))) + +(define (notify-input-request) + (when *emacs-mode* + (say/em "~Ai" *emacs-notify-char*) + (force-output (current-output-port)))) + +(define (notify-error) + (when *emacs-mode* + (say/em "~Ae" *emacs-notify-char*) + (force-output (current-output-port)))) + +(define (notify-printers printers) + (notify-settings "p" printers)) + +(define (notify-optimizers optimizers) + (notify-settings "o" optimizers)) + +(define (notify-settings flag values) + (when *emacs-mode* + (say/em "~A~A(" *emacs-notify-char* flag) + (dolist (p values) + (say/em " ~A" (string-downcase (symbol->string p)))) + (say/em ")~%") + (force-output (current-output-port)))) + +(define (notify-status-line str) + (when *emacs-mode* + (say/em "~As~A~%" *emacs-notify-char* str) + (force-output (current-output-port)))) + +;;; These are used to drive the real compiler. + +(define *compile/compile-cflags* + (make cflags + (load-code? '#t) + (compile-code? '#t) + (write-code? '#t) + (write-interface? '#t))) + + +(define (compile/compile file) + (haskell-compile file *compile/compile-cflags*)) + + +(define *compile/load-cflags* + (make cflags + (load-code? '#t) + (compile-code? '#f) + (write-code? '#f) + (write-interface? '#f))) + +(define (compile/load file) + (haskell-compile file *compile/load-cflags*)) + + +;;; Printer setting support + +(define (set-printers args mode) + (set-switches *printers* (strings->syms args) + mode *all-printers* "printers")) + +(define (set-optimizers args mode) + (set-switches *optimizers* (strings->syms args) + mode *all-optimizers* "optimizers")) + +(define (set-switches current new mode all name) + (dolist (s new) + (when (and (not (eq? s 'all)) (not (memq s all))) + (signal-invalid-value s name all))) + (let ((res (cond ((eq? mode '+) + (set-union current new)) + ((eq? mode '-) + (set-difference current new)) + ((eq? mode '=) + (if (equal? new '(all)) + all + new))))) + res)) + +(define (signal-invalid-value s name all) + (recoverable-error 'invalid-value + "~A is not one of the valid ~A. Possible values are: ~%~A" + s name all)) + +(define (print-file file) + (call-with-input-file file (function write-all-chars))) + +(define (write-all-chars port) + (let ((line (read-line port))) + (if (eof-object? line) + 'ok + (begin + (write-line line) + (write-all-chars port))))) + +(define (strings->syms l) + (map (lambda (x) + (string->symbol (string-upcase x))) + l)) + diff --git a/command-interface/command.scm b/command-interface/command.scm new file mode 100644 index 0000000..3b98991 --- /dev/null +++ b/command-interface/command.scm @@ -0,0 +1,308 @@ + +;;; Globals used by the command interpreter + +(define *current-string* "") +(define *current-mod* '|Main|) +(define *current-command* '()) +(define *remembered-file* "Foo") +(define *fragment-status* '()) +(define *temp-counter* 0) +(define *last-compiled* "") +(define *abort-command* '()) +(define *command-dispatch* '()) +(define *extension-module* '()) +(define *extension-file-name* "interactive") + +(define (prompt mod) + (format '#f "~A> " mod)) + +(define-local-syntax (define-command name&args helpstr . body) + (let* ((str (car name&args)) + (args (cdr name&args)) + (fname (string->symbol (string-append "CMD-" str)))) + `(begin + (define (,fname arguments) + (verify-command-args ',args arguments ',helpstr) + (apply (lambda ,args ,@body) arguments)) + (setf *command-dispatch* + (nconc *command-dispatch* + (list (cons ',str (function ,fname))))) + ',fname))) + +(define (heval) + (initialize-haskell-system) + (setf *current-string* "") + (setf *fragment-status* 'Building) + (say "~&Yale Haskell ~A~A ~A~%Type :? for help.~%" + *haskell-compiler-version* *haskell-compiler-update* (identify-system)) + (read-commands)) + + +;;; This loop reads commands until a quit + +(define (read-commands) + (do ((cmd-status (read-command) (read-command))) + ((eq? cmd-status 'quit-command-loop) (exit)))) + +;;; This processes a single line of input. + +(define (read-command) + (let/cc abort-command + (setf *abort-command* (lambda () (funcall abort-command 'error))) + (setf *abort-compilation* *abort-command*) + (setf *phase* 'command-interface) + (setf *in-error-handler?* '#f) + (ready-for-input-line) + (let ((ch (peek-char))) + (cond ((eof-object? ch) + 'quit-command-loop) + ((char=? ch '#\:) + (read-char) + (execute-command)) + ((and (char=? ch '#\newline) + (not (eq? *fragment-status* 'Building))) + (read-char) + 'Ignored) + (else + (when (not (eq? *fragment-status* 'Building)) + (setf *fragment-status* 'Building) + (setf *current-string* "")) + (cond ((eqv? ch '#\=) + (read-char) + (append-to-current-string (expand-print-abbr (read-line)))) + ((eqv? ch '#\@) + (read-char) + (append-to-current-string (expand-exec-abbr (read-line)))) + (else + (append-to-current-string (read-line)))) + 'OK) + )))) + +(define (append-to-current-string string) + (setf *current-string* + (string-append *current-string* + string + (string #\newline)))) + + +(define (expand-print-abbr string) + (incf *temp-counter*) + (format '#f "temp_~a = print temp1_~a where temp1_~a = ~a" + *temp-counter* *temp-counter* *temp-counter* string)) + +(define (expand-exec-abbr string) + (incf *temp-counter*) + (format '#f "temp_~a :: Dialogue~%temp_~a = ~a" + *temp-counter* *temp-counter* string)) + + +(define (ready-for-input-line) + (when (not *emacs-mode*) + (fresh-line (current-output-port)) + (write-string (prompt *current-mod*) (current-output-port)) + (force-output (current-output-port))) + (notify-ready)) + +(define (execute-command) + (if (char=? (peek-char) '#\() ;this is the escape to the lisp evaluator + (let ((form (read))) + (eval form) + 'OK) + (let* ((string (read-line)) + (length (string-length string)) + (cmd+args (parse-command-args string 0 0 length))) + (cond ((null? cmd+args) + (say "~&Eh?~%") + 'OK) + (else + (let ((fn (assoc/test (function string-starts?) + (car cmd+args) + *command-dispatch*))) + (cond ((eq? fn '#f) + (say "~&~A: unknown command. Use :? for help.~%" + (car cmd+args)) + 'OK) + (else + (funcall (cdr fn) (cdr cmd+args)))))))))) + + +;;; This parses the command into a list of substrings. +;;; Args are separated by spaces. + +(define (parse-command-args string start next end) + (declare (type fixnum start next end) + (type string string)) + (cond ((eqv? next end) + (if (eqv? start next) + '() + (list (substring string start next)))) + ((char=? (string-ref string next) '#\space) + (let ((next-next (+ next 1))) + (if (eqv? start next) + (parse-command-args string next-next next-next end) + (cons (substring string start next) + (parse-command-args string next-next next-next end))))) + (else + (parse-command-args string start (+ next 1) end)))) + +(define (verify-command-args template args help) + (cond ((and (null? template) (null? args)) + '#t) + ((symbol? template) + '#t) + ((or (null? template) (null? args)) + (say "~&Command error.~%~A~%" help) + (funcall *abort-command*)) + (else + (verify-command-args (car template) (car args) help) + (verify-command-args (cdr template) (cdr args) help)))) + +(define-command ("?") + ":? Print the help file." + (print-file "$HASKELL/command-interface-help")) + +(define-command ("eval") + ":eval Evaluate current extension." + (eval-fragment '#t) + 'OK) + +(define-command ("save") + ":save Save current extension" + (eval-fragment '#f) + (cond ((eq? *fragment-status* 'Error) + (say/ne "~&Cannot save: errors encountered.~%")) + ((eq? *fragment-status* 'Compiled) + (extend-module *current-mod* *extension-module*) + (setf *fragment-status* 'Saved))) + 'OK) + +(define-command ("quit") + ":quit Quit the Haskell evaluator." + 'quit-command-loop) + +(define-command ("module" mod) + ":module module-name Select module for incremental evaluation." + (setf *current-mod* (string->symbol mod)) + (when (not (cm-available?)) + (say/ne "~&Warning: module ~A is not currently loaded.~%" *current-mod*)) + 'OK) + +(define-command ("run" . file) + ":run <file> Compile, load, and run a file." + (set-current-file file) + (clear-extended-modules) + (let ((mods (compile/load *remembered-file*))) + (when (pair? mods) + (dolist (m mods) + (eval-module (table-entry *modules* m))))) + 'OK) + +(define-command ("compile" . file) + ":compile <file> Compile and load a file." + (set-current-file file) + (clear-extended-modules) + (select-current-mod (compile/compile *remembered-file*)) + 'OK) + +(define-command ("load" . file) + ":load <file> Load a file." + (set-current-file file) + (clear-extended-modules) + (select-current-mod (compile/load *remembered-file*)) + 'OK) + +(define-command ("Main") + ":Main Switch to an empty Main module." + (make-empty-main) + 'OK) + +(define-command ("clear") + ":clear Clear saved definitions from current module." + (remove-extended-modules *current-mod*) + (setf *current-string* "") + (setf *fragment-status* 'Building)) + +(define-command ("list") + ":list List current extension." + (say "~&Current Haskell extension:~%~a" *current-string*) + (cond ((eq? *fragment-status* 'Error) + (say "Extension contains errors.~%")) + ((eq? *fragment-status* 'Compiled) + (say "Extension is compiled and ready.~%"))) + 'OK) + +(define-command ("kill") + ":kill Clear the current fragment." + (when (eq? *fragment-status* 'Building) + (setf *current-string* "")) + 'OK) + +(define-command ("p?") + ":p? Show available printers." + (if *emacs-mode* + (notify-printers (dynamic *printers*)) + (begin + (print-file "$HASKELL/emacs-tools/printer-help.txt") + (say "~&Active printers: ~A~%" (dynamic *printers*))) + )) + +(define-command ("p=" . passes) + ":p= pass1 pass2 ... Set printers." + (setf *printers* (set-printers passes '=)) + (say/ne "~&Setting printers: ~A~%" *printers*)) + +(define-command ("p+" . passes) + ":p+ pass1 pass2 ... Add printers." + (setf *printers* (set-printers passes '+)) + (say/ne "~&Setting printers: ~A~%" *printers*)) + +(define-command ("p-" . passes) + ":p- pass1 pass2 ... Turn off printers." + (setf *printers* (set-printers passes '-)) + (say/ne "~&Setting printers: ~A~%" *printers*)) + + + +(define-command ("o?") + ":o? Show available optimizers." + (if *emacs-mode* + (notify-optimizers (dynamic *optimizers*)) + (begin + (print-file "$HASKELL/emacs-tools/optimizer-help.txt") + (say "~&Active optimizers: ~A~%" (dynamic *optimizers*))) + )) + +(define-command ("o=" . optimizers) + ":o= optimizer1 optimizer2 ... Set optimizers." + (setf *optimizers* (set-optimizers optimizers '=)) + (say/ne "~&Setting optimizers: ~A~%" *optimizers*)) + +(define-command ("o+" . optimizers) + ":o+ optimizer1 optimizer2 ... Add optimizers." + (setf *optimizers* (set-optimizers optimizers '+)) + (say/ne "~&Setting optimizers: ~A~%" *optimizers*)) + +(define-command ("o-" . optimizers) + ":o- optimizer1 optimizer2 ... Turn off optimizers." + (setf *optimizers* (set-optimizers optimizers '-)) + (say/ne "~&Setting optimizers: ~A~%" *optimizers*)) + + +(define-command ("cd" d) + ":cd directory Change the current directory." + (cd d) + 'OK) + +(define-command ("Emacs" mode) + ":Emacs on/off Turn on or off emacs mode." + (cond ((string=? mode "on") + (setf *emacs-mode* '#t)) + ((string=? mode "off") + (setf *emacs-mode* '#f)) + (else + (say "~&Use on or off.~%")))) + +(define-command ("file" name) + ":file name" + (setf *extension-file-name* name) + 'OK) diff --git a/command-interface/incremental-compiler.scm b/command-interface/incremental-compiler.scm new file mode 100644 index 0000000..207b79d --- /dev/null +++ b/command-interface/incremental-compiler.scm @@ -0,0 +1,168 @@ +;;; ================================================================== + +;;; This deals with incremental compilation as used by the command interface. +;;; The basic theory is to create new modules which import the entire +;;; symbol table of an existing module. + + +;;; This adds a new module to the extension environment. This env is an alist +;;; of module names & extended modules. + +(define *extension-env* '()) + +(define (extend-module mod-name new-ast) + (push (tuple mod-name new-ast) *extension-env*)) + +;;; This cleans out extensions for a module. + +(define (remove-extended-modules mod-name) + (setf *extension-env* (rem-ext1 *extension-env* mod-name))) + +(define (rem-ext1 env name) + (cond ((null? env) + '()) + ((eq? (tuple-2-1 (car env)) name) + (rem-ext1 (cdr env) name)) + (else + (cons (car env) (rem-ext1 (cdr env) name))))) + +(define (clear-extended-modules) + (setf *extension-env* '())) + +;;; This retrieves the current extension to a module (if any). + +(define (updated-module name) + (let ((name+mod (assq name *extension-env*))) + (if (not (eq? name+mod '#f)) + (tuple-2-2 name+mod) + (let ((mod-in-table (table-entry *modules* name))) + (cond ((eq? mod-in-table '#f) + (signal-module-not-ready name)) + ((eq? (module-type mod-in-table) 'interface) + (signal-cant-eval-interface name)) + (else mod-in-table)))))) + +(define (signal-module-not-ready name) + (fatal-error 'module-not-ready + "Module ~A is not loaded and ready." + name)) + +(define (signal-cant-eval-interface name) + (fatal-error 'no-evaluation-in-interface + "Module ~A is an interface: evaluation not allowed." + name)) + +(define (compile-fragment module str filename) + (let ((mod-ast (updated-module module))) + (dynamic-let + ((*printers* (if (memq 'extension *printers*) *printers* '())) + (*abort-phase* '#f)) + (mlet (((t-code new-ast) (compile-fragment1 module mod-ast str filename))) + (cond ((eq? t-code 'error) + 'error) + (else + (eval t-code) + new-ast)))))) + +(define (compile-fragment1 mod-name mod-ast str filename) + (let/cc x + (dynamic-let ((*abort-compilation* (lambda () (funcall x 'error '())))) + (let* ((mods (parse-from-string + (format '#f "module ~A where~%~A~%" mod-name str) + (function parse-module-list) + filename)) + (new-mod (car mods))) + (when (not (null? (cdr mods))) + (signal-module-decl-in-extension)) + (when (not (null? (module-imports new-mod))) + (signal-import-decl-in-extension)) + (fragment-initialize new-mod mod-ast) + (values (modules->lisp-code mods) new-mod))))) + +(define (signal-module-decl-in-extension) + (fatal-error 'module-decl-in-extension + "Module declarations are not allowed in extensions.")) + +(define (signal-import-decl-in-extension) + (fatal-error 'import-decl-in-extension + "Import declarations are not allowed in extensions.")) + + +;;; Copy stuff into the fragment module structure from its parent module. +;;; The inverted symbol table is not necessary since the module contains +;;; no imports. + +(define (fragment-initialize new old) + (setf (module-name new) (gensym)) + (setf (module-type new) 'extension) + (setf (module-unit new) (module-unit old)) + (setf (module-uses-standard-prelude? new) + (module-uses-standard-prelude? old)) + (setf (module-inherited-env new) old) + (setf (module-fixity-table new) + (copy-table (module-fixity-table old))) + (setf (module-default new) (module-default old))) + +;;; This code deals with the actual evaluation of Haskell code. + +;;; This decides whether a variable has type `Dialogue'. + +(define (io-type? var) + (let ((type (var-type var))) + (when (not (gtype? type)) + (error "~s is not a Gtype." type)) + (and (null? (gtype-context type)) + (is-dialogue? (gtype-type type))))) + +(define (is-dialogue? type) + (let ((type (expand-ntype-synonym type))) + (and (ntycon? type) + (eq? (ntycon-tycon type) (core-symbol "Arrow")) + (let* ((args (ntycon-args type)) + (a1 (expand-ntype-synonym (car args))) + (a2 (expand-ntype-synonym (cadr args)))) + (and + (ntycon? a1) + (eq? (ntycon-tycon a1) (core-symbol "SystemState")) + (ntycon? a2) + (eq? (ntycon-tycon a2) (core-symbol "IOResult"))))))) + +(define (is-list-of? type con) + (and (ntycon? type) + (eq? (ntycon-tycon type) (core-symbol "List")) + (let ((arg (expand-ntype-synonym (car (ntycon-args type))))) + (and (ntycon? arg) (eq? (ntycon-tycon arg) con))))) + +(define (apply-exec var) + (initialize-io-system) + (mlet (((_ sec) + (time-execution + (lambda () + (let/cc x + (setf *runtime-abort* (lambda () (funcall x 'error))) + (let ((fn (eval (fullname var)))) + (unless (var-strict? var) + (setf fn (force fn))) + (funcall fn (box 'state)))))))) + (say "~%") + (when (memq 'time *printers*) + (say "Execution time: ~A seconds~%" sec))) + 'done) + +(define (eval-module mod) + (dolist (v (module-vars mod)) + (when (io-type? v) + (when (not (string-starts? "temp_" (symbol->string (def-name v)))) + (say/ne "~&Evaluating ~A.~%" v)) + (apply-exec v)))) + +(define (run-program name) + (compile/load name) + (let ((main-mod (table-entry *modules* '|Main|))) + (if main-mod + (let ((main-var (table-entry (module-symbol-table main-mod) '|main|))) + (if main-var + (apply-exec main-var) + (error "Variable main missing"))) + (error "module Main missing")))) + diff --git a/csys/README b/csys/README new file mode 100644 index 0000000..6f9c183 --- /dev/null +++ b/csys/README @@ -0,0 +1,3 @@ +This directory contains everything relating to the compilation system, +including stuff for parsing unit files, incremental recompilation, and +reading and writing code and interface files. diff --git a/csys/cache-structs.scm b/csys/cache-structs.scm new file mode 100644 index 0000000..ba38840 --- /dev/null +++ b/csys/cache-structs.scm @@ -0,0 +1,48 @@ +;;; these structures deal with the compilation system and the unit cache. + +;;; An entry in the unit cache: + +(define-struct ucache + (slots + (ufile (type string)) ; the name of the file containing the unit definition + (cifile (type string)) ; the filename of the (compiled) interface file + (sifile (type string)) ; the filename of the (uncompiled) interface file + (cfile (type string)) ; the filename of the (compiled) output file + (sfile (type string)) ; the filename of the (uncompiled) output file + (udate (type integer)) ; the write date of ufile + (idate (type integer)) ; the time stamp of the binary interface file + (stable? (type bool)) ; the stable flag + (load-prelude? (type bool)) ; true if unit uses standard prelude + ;; status is initially available (in cache). It is set to loading when + ;; requested and loaded once all imported units are loaded. + (status (type (enum loaded loading available))) + (ifile-loaded (type bool)) ; true when interface is loaded (modules) + (code-loaded (type bool)) ; true when the associated code is in memory + (source-files (type (list string))) ; source files in the unit + (imported-units (type (list string))) ; the filenames of imported unit files + (lisp-files (type (list (tuple string string)))) ; source/binary pairs + (modules (type (list module))) + (printers-set? (type bool)) + (printers (type (list symbol))) + (optimizers-set? (type bool)) + (optimizers (type (list symbol))) + (chunk-size (type (maybe int))) + )) + + +;;; This is used to hold various flags used by the compilation system, +;;; instead of passing them all as individual arguments. + +(define-struct cflags + (slots + ;; Whether to load code for unit into core + (load-code? (type bool) (default '#t)) + ;; Whether to create an output code file. + (write-code? (type bool) (default '#t)) + ;; Affects whether write-code? creates a source or compiled file, + ;; and whether load-code? uses the interpreter or compiler. + ;; Ignored if load-code? and write-code? are both false. + (compile-code? (type bool) (default '#t)) + ;; Whether to create an output interface file. + (write-interface? (type bool) (default '#t)) + )) diff --git a/csys/compiler-driver.scm b/csys/compiler-driver.scm new file mode 100644 index 0000000..5ce5a71 --- /dev/null +++ b/csys/compiler-driver.scm @@ -0,0 +1,640 @@ +;;; compiler-driver.scm -- compilation unit management +;;; +;;; author : John & Sandra +;;; +;;; + + +;;; Flags for controlling various low-level behaviors of the compiler. +;;; You might want to tweak these in the system-building scripts for +;;; different Lisps, but users don't normally need to mess with them. + +(define *compile-interface* '#f) +(define *interface-code-quality* 2) +(define *interface-chunk-size* '#f) +(define *default-code-quality* 2) +(define *optimized-code-quality* 3) +(define *code-chunk-size* 300) + + + +;;;===================================================================== +;;; Main entry point +;;;===================================================================== + +;;; This is the top level driver for the compiler. It takes a file name +;;; and output controls. It returns '#f if compilation fails. + +(define *codefile-cache* '()) + +(define (haskell-compile filename cflags) + (initialize-haskell-system) + (let/cc abort-compile + (dynamic-let ((*abort-compilation* + (lambda () (funcall abort-compile '#f)))) + (initialize-compilation) + (let ((unit (find-cunit-name filename))) + (let ((res (load-compilation-unit unit cflags))) + (map (lambda (x) (module-name x)) (ucache-modules res))))))) + +;;; this is the initialization code that occurs at the start of compilation. + +(define (initialize-compilation) + (initialize-module-table) + (for-each-unit + (lambda (u) + (setf (ucache-status u) 'available)))) + + + +;;;===================================================================== +;;; Filename utilities +;;;===================================================================== + +;;; File extensions + +(define *source-file-extensions* '(".hs" ".lhs")) +(define *unit-file-extension* ".hu") +(define *interface-file-extension* ".hi") +(define *lisp-file-extensions* '(".lisp" ".scm")) + +(define (source-extension? x) + (mem-string x *source-file-extensions*)) + +(define (unit-extension? x) + (string=? x *unit-file-extension*)) + +(define (interface-extension? x) + (string=? x *interface-file-extension*)) + +(define (lisp-extension? x) + (mem-string x *lisp-file-extensions*)) + + +;;; Build file names. + +(define (make-cifilename filename) + (let ((place (filename-place filename)) + (name (string-append (filename-name filename) "-hci"))) + (assemble-filename place name binary-file-type))) + +(define (make-sifilename filename) + (let ((place (filename-place filename)) + (name (string-append (filename-name filename) "-hci"))) + (assemble-filename place name source-file-type))) + +(define (make-cfilename filename) + (add-extension filename binary-file-type)) + +(define (make-sfilename filename) + (add-extension filename source-file-type)) + + +;;; This take a file name (extension ignored) & searches for a unit file. + +(define (locate-existing-cunit name) + (locate-extension name (list *unit-file-extension*))) + +;;; This take a file name (extension ignored) & searches for a source file. + +(define (locate-existing-source-file name) + (locate-extension name *source-file-extensions*)) + +(define (locate-extension name extensions) + (if (null? extensions) + '#f + (let ((name-1 (add-extension name (car extensions)))) + (if (file-exists? name-1) + name-1 + (locate-extension name (cdr extensions)))))) + + +;;; This delivers the name of a compilation unit. The extension of the name +;;; is ignored & a test for the presence of a compilation unit with +;;; the same name is done. If none is found, signal an error. + +(define (find-cunit-name name) + (or (locate-existing-cunit name) + (locate-existing-source-file name) + (signal-file-not-found name))) + + + +;;;===================================================================== +;;; Compilation unit file parsing +;;;===================================================================== + +;;; This parses a unit file. The file simply contains a list of file names. +;;; The files are sorted into two catagories: other compilation units and +;;; source files in the current unit. When a file has no extension, the system +;;; checks for a unit file first and then a source file. + +(define (parse-compilation-unit filename) + (let ((unit-type (filename-type filename))) + (if (or (source-extension? unit-type) (interface-extension? unit-type)) + (create-ucache filename filename (list filename) '() '() '#f '#t + '#f '() '#f '() '#f) + (parse-compilation-unit-aux + filename + (call-with-input-file filename (function gather-file-names)))))) + +(define (create-ucache filename output-filename + source-files imports lisp-files + stable? load-prelude? + printers-set? printers optimizers-set? optimizers + chunk-size) + (let* ((cifilename + (make-cifilename output-filename)) + (sifilename + (make-sifilename output-filename)) + (all-imports + (if load-prelude? + (cons *prelude-unit-filename* imports) + imports)) + (cache-entry + (make ucache + (ufile filename) + (sifile sifilename) + (cifile cifilename) + (sfile (make-sfilename output-filename)) + (cfile (make-cfilename output-filename)) + (udate (current-date)) + (idate (get-latest-ifiledate cifilename sifilename)) + (stable? stable?) + (load-prelude? load-prelude?) + (status 'loading) + (ifile-loaded '#f) + (code-loaded '#f) + (source-files source-files) + (imported-units all-imports) + (lisp-files lisp-files) + (modules '()) + (printers-set? printers-set?) + (printers printers) + (optimizers-set? optimizers-set?) + (optimizers optimizers) + (chunk-size chunk-size)))) + (install-compilation-unit filename cache-entry) + cache-entry)) + +(define (get-latest-ifiledate cifilename sifilename) + (max (or (and (file-exists? cifilename) + (file-write-date cifilename)) + 0) + (or (and (file-exists? sifilename) + (file-write-date sifilename)) + 0))) + + +;;; This returns a list of strings. Blank lines and lines starting in - +;;; are ignored. + +(define (gather-file-names port) + (let ((char (peek-char port))) + (cond ((eof-object? char) + '()) + ((or (char=? char '#\newline) (char=? char '#\-)) + (read-line port) + (gather-file-names port)) + (else + (let ((line (read-line port))) + (cons line (gather-file-names port))))))) + + +;;; Actually parse contents of the unit file. + +;;; These are in the command-interface stuff. +(predefine (set-printers args mode)) +(predefine (set-optimizers args mode)) +(predefine (parse-command-args string start next end)) + +(define (parse-compilation-unit-aux filename strings) + (let ((input-defaults filename) + (output-defaults filename) + (import-defaults filename) + (stable? '#f) + (load-prelude? '#t) + (filenames '()) + (imports '()) + (sources '()) + (lisp-files '()) + (printers '()) + (printers-set? '#f) + (optimizers '()) + (optimizers-set? '#f) + (chunk-size '#f) + (temp '#f)) + ;;; First look for magic flags. + (dolist (s strings) + (cond ((setf temp (string-match-prefix ":input" s)) + (setf input-defaults (merge-file-defaults temp filename))) + ((setf temp (string-match-prefix ":output" s)) + (setf output-defaults (merge-file-defaults temp filename))) + ((setf temp (string-match-prefix ":import" s)) + (setf import-defaults (merge-file-defaults temp filename))) + ((string=? ":stable" s) + (setf stable? '#t)) + ((string=? ":prelude" s) + (setf load-prelude? '#f)) + ((setf temp (string-match-prefix ":p=" s)) + (setf printers-set? '#t) + (setf printers + (set-printers + (parse-command-args temp 0 0 (string-length temp)) + '=))) + ((setf temp (string-match-prefix ":o=" s)) + (setf optimizers-set? '#t) + (setf optimizers + (set-optimizers + (parse-command-args temp 0 0 (string-length temp)) + '=))) + ((setf temp (string-match-prefix ":chunk-size" s)) + (setf chunk-size (string->number temp))) + (else + (push s filenames)))) + ;;; Next sort filenames into imports and source files. + (dolist (s filenames) + (let ((type (filename-type s)) + (fname '#f)) + (cond ((string=? type "") ; punt for now on this issue + (signal-extension-needed s)) +; ((cond ((setf fname +; (locate-existing-cunit +; (merge-file-defaults s import-defaults))) +; (push fname imports)) +; ((setf fname +; (locate-existing-source-file +; (merge-file-defaults s input-defaults))) +; (push fname sources)) +; (else +; (signal-unit-not-found s)))) + ((unit-extension? type) + (setf fname (merge-file-defaults s import-defaults)) + (if (file-exists? fname) + (push fname imports) + (signal-unit-not-found fname))) + ((or (source-extension? type) (interface-extension? type)) + (setf fname (merge-file-defaults s input-defaults)) + (if (file-exists? fname) + (push fname sources) + (signal-unit-not-found fname))) + ((lisp-extension? type) + (setf fname (merge-file-defaults s input-defaults)) + (if (file-exists? fname) + (push (cons fname + (add-extension + (merge-file-defaults s output-defaults) + binary-file-type)) + lisp-files) + (signal-unit-not-found fname))) + (else + (signal-unknown-file-type s))))) + ;; Finally create the unit object. + (create-ucache filename output-defaults + sources imports lisp-files + stable? load-prelude? + printers-set? printers optimizers-set? optimizers + chunk-size))) + + +;;; Helper functions for the above. + +(define (string-match-prefix prefix s) + (let ((prefix-length (string-length prefix)) + (s-length (string-length s))) + (if (>= s-length prefix-length) + (string-match-prefix-aux prefix s prefix-length s-length 0) + '#f))) + +(define (string-match-prefix-aux prefix s prefix-length s-length i) + (cond ((eqv? i prefix-length) + (string-match-prefix-aux-aux s s-length i)) + ((not (char=? (string-ref s i) (string-ref prefix i))) + '#f) + (else + (string-match-prefix-aux prefix s prefix-length s-length (1+ i))))) + +(define (string-match-prefix-aux-aux s s-length i) + (cond ((eqv? i s-length) + "") + ((let ((ch (string-ref s i))) + (or (char=? ch '#\space) (char=? ch #\tab))) + (string-match-prefix-aux-aux s s-length (1+ i))) + (else + (substring s i s-length)))) + +(define (merge-file-defaults filename defaults) + (let ((place (filename-place filename)) + (name (filename-name filename)) + (type (filename-type filename))) + (assemble-filename + (if (string=? place "") defaults place) + (if (string=? name "") defaults name) + (if (string=? type "") defaults type)))) + + +;;;===================================================================== +;;; Guts +;;;===================================================================== + + +;;; This is the main entry to the compilation system. This causes a +;;; unit to be compiled and/or loaded. + +(define (load-compilation-unit filename cflags) + (let ((cunit (lookup-compilation-unit filename))) + (cond ((eq? cunit '#f) + ;; Unit not found in cache. + (load-compilation-unit-aux + (parse-compilation-unit filename) cflags)) + ((eq? (ucache-status cunit) 'loaded) + ;; Already loaded earlier in this compile. + cunit) + ((eq? (ucache-status cunit) 'loading) + (signal-circular-unit filename)) + (else + (load-compilation-unit-aux cunit cflags)) + ))) + + +(define (load-compilation-unit-aux c cflags) + (setf (ucache-status c) 'loading) + (load-imported-units c cflags) + (if (unit-valid? c cflags) + (load-compiled-unit c (cflags-load-code? cflags)) + (locally-compile c cflags)) + (setf (ucache-status c) 'loaded) + ;; Hack, hack. When loading the prelude, make sure magic symbol + ;; table stuff is initialized. + (when (string=? (ucache-ufile c) *prelude-unit-filename*) + (init-prelude-globals)) + c) + +(define (load-compiled-unit c load-code?) + (when (and load-code? (not (ucache-code-loaded c))) + (when (memq 'loading *printers*) + (format '#t "~&Loading unit ~s.~%" (ucache-ufile c)) + (force-output)) + (load-lisp-files (ucache-lisp-files c)) + (load-more-recent-file (ucache-cfile c) (ucache-sfile c)) + (setf (ucache-code-loaded c) '#t)) + (when (not (ucache-ifile-loaded c)) + (read-binary-interface c)) + (dolist (m (ucache-modules c)) + (add-module-to-symbol-table m)) + (link-instances (ucache-modules c))) + + +;;; These globals save the Prelude symbol table to avoid copying it +;;; into all modules which use the Prelude. + +;;; Danger! This assumes that every local symbol in the Prelude is +;;; exported. + +(define *prelude-initialized* '#f) + +(define (init-prelude-globals) + (when (not *prelude-initialized*) + (let ((pmod (locate-module '|Prelude|))) + (setf *prelude-symbol-table* (module-symbol-table pmod)) + (setf *prelude-fixity-table* (module-fixity-table pmod)) + (when (eq? (module-inverted-symbol-table pmod) '#f) + (let ((table (make-table))) + (table-for-each (lambda (name def) + (setf (table-entry table def) name)) + *prelude-symbol-table*) + (setf (module-inverted-symbol-table pmod) table))) + (setf *prelude-inverted-symbol-table* + (module-inverted-symbol-table pmod))) + (setf *prelude-initialized* '#t))) + + +;;; This recursively loads all units imported by a given unit. + +(define (load-imported-units c cflags) + (dolist (filename (ucache-imported-units c)) + (load-compilation-unit filename cflags))) + + + +;;; Load or compile lisp files. + +(define (load-lisp-files lisp-files) + (dolist (f lisp-files) + (load-more-recent-file (cdr f) (car f)))) + +(define (compile-lisp-files lisp-files) + (dolist (f lisp-files) + (let ((source (car f)) + (binary (cdr f))) + (when (not (lisp-binary-current source binary)) + (compile-file source binary)) + (load binary)))) + + + +;;; This determines whether a unit is valid. + +(define (unit-valid? c cflags) + (and (or (ucache-stable? c) + ;; If the unit is not stable, make sure its source files + ;; haven't changed. + (and (all-imports-current (ucache-imported-units c) + (ucache-idate c)) + (all-sources-current (ucache-source-files c) + (ucache-idate c)) + (all-lisp-sources-current (ucache-lisp-files c) + (ucache-idate c)))) + (or (ucache-ifile-loaded c) + ;; If the interface hasn't been loaded already, make sure + ;; that the interface file exists. + (file-exists? (ucache-cifile c)) + (file-exists? (ucache-sifile c))) + (or (not (cflags-load-code? cflags)) + ;; If we're going to load code, make sure that the code file + ;; exists. + (ucache-code-loaded c) + (file-exists? (ucache-cfile c)) + (file-exists? (ucache-sfile c))) + (or (not (cflags-write-code? cflags)) + ;; If we need to produce a code file, make sure this has + ;; already been done. + ;; Don't write files for stable units which have already + ;; been loaded, regardless of whether or not the file exists. + (and (ucache-stable? c) (ucache-code-loaded c)) + (file-exists? (ucache-cfile c)) + (and (not (cflags-compile-code? cflags)) + (file-exists? (ucache-sfile c)))) + (or (not (cflags-compile-code? cflags)) + ;; If we need to compile the lisp files, make sure this has + ;; already been done. + ;; Don't do this for stable units which have already + ;; been loaded. + (and (ucache-stable? c) (ucache-code-loaded c)) + (all-lisp-binaries-current (ucache-lisp-files c))) + (or (not (cflags-write-interface? cflags)) + ;; If we need to produce an interface file, make sure this has + ;; already been done. + ;; Don't write files for stable units which have already + ;; been loaded, regardless of whether or not the file exists. + (and (ucache-stable? c) (ucache-ifile-loaded c)) + (file-exists? (ucache-cifile c)) + (and (not *compile-interface*) + (file-exists? (ucache-sifile c)))) + )) + +(define (all-sources-current sources unit-write-date) + (every (lambda (s) + (let ((d (file-write-date s))) + (and d (> unit-write-date d)))) + sources)) + +(define (all-imports-current imports unit-write-date) + (every (lambda (s) (> unit-write-date + (ucache-idate (lookup-compilation-unit s)))) + imports)) + +(define (all-lisp-sources-current lisp-files unit-write-date) + (every (lambda (s) + (let ((d (file-write-date (car s)))) + (and d (> unit-write-date d)))) + lisp-files)) + +(define (all-lisp-binaries-current lisp-files) + (every (lambda (s) + (lisp-binary-current (car s) (cdr s))) + lisp-files)) + +(define (lisp-binary-current source binary) + (and (file-exists? binary) + (let ((sd (file-write-date source)) + (bd (file-write-date binary))) + (and sd bd (> bd sd))))) + + +;;; This does the actual job of compilation. + +(define (locally-compile c cflags) + (dynamic-let ((*printers* + (if (ucache-printers-set? c) + (ucache-printers c) + (dynamic *printers*))) + (*optimizers* + (if (ucache-optimizers-set? c) + (ucache-optimizers c) + (dynamic *optimizers*)))) + (when (memq 'compiling *printers*) + (format '#t "~&Compiling unit ~s.~%Optimizers: ~A~%" + (ucache-ufile c) + *optimizers*) + (force-output)) + (if (cflags-compile-code? cflags) + (compile-lisp-files (ucache-lisp-files c)) + (load-lisp-files (ucache-lisp-files c))) + (multiple-value-bind (mods code) + (compile-haskell-files (ucache-source-files c)) + ;; General bookkeeping to update module interface in cache. + (setf (ucache-modules c) mods) + (setf (ucache-idate c) (current-date)) + (setf (ucache-ifile-loaded c) '#t) + ;; Write interface file if necessary. + (when (cflags-write-interface? cflags) + (let ((phase-start-time (get-run-time)) + (icode (create-dump-code c mods (ucache-load-prelude? c)))) + (if (dynamic *compile-interface*) + (write-compiled-code-file + (ucache-cifile c) + icode + (dynamic *interface-code-quality*) + (dynamic *interface-chunk-size*)) + (write-interpreted-code-file (ucache-sifile c) icode '#f)) + (when (memq 'phase-time *printers*) + (let* ((current-time (get-run-time)) + (elapsed-time (- current-time phase-start-time))) + (format '#t "Interface complete: ~A seconds~%" elapsed-time) + (force-output))))) + ;; Write code file if necessary. + (when (cflags-write-code? cflags) + (if (cflags-compile-code? cflags) + (write-compiled-code-file + (ucache-cfile c) + code + (if (memq 'lisp (dynamic *optimizers*)) + (dynamic *optimized-code-quality*) + (dynamic *default-code-quality*)) + (or (ucache-chunk-size c) (dynamic *code-chunk-size*))) + (write-interpreted-code-file (ucache-sfile c) code '#t))) + ;; Load or evaluate code if necessary. + ;; If we just wrote a compiled code file, load that; otherwise + ;; do eval or in-core compilation. + (when (cflags-load-code? cflags) + (if (and (cflags-write-code? cflags) + (cflags-compile-code? cflags)) + (load (ucache-cfile c)) + (eval code (cflags-compile-code? cflags))) + (setf (ucache-code-loaded c) '#t)) + ))) + + + +;;;===================================================================== +;;; Cache manager +;;;===================================================================== + +;;; This is the cache manager for compilation units. We use an alist at +;;; the moment. + +(define *unit-cache* '()) + +(define (reset-unit-cache) + (setf *unit-cache* '())) + + +;;; This checks to make sure that the compilation unit it finds +;;; in the cache has not been made out-of-date by updates to the unit file. + +(define (lookup-compilation-unit name) + (let ((r (ass-string name *unit-cache*))) + (if r + (let ((c (cdr r))) + (if (or (ucache-stable? c) + (> (ucache-udate c) + (or (file-write-date (ucache-ufile c)) 0))) + c + '#f)) + '#f))) + +(define (install-compilation-unit name c) + (let ((r (ass-string name *unit-cache*))) + (if (eq? r '#f) + (push (cons name c) *unit-cache*) + (setf (cdr r) c)))) + +(define (for-each-unit proc) + (dolist (c *unit-cache*) + (funcall proc (cdr c)))) + + +;;;===================================================================== +;;; Error utilities +;;;===================================================================== + +(define (signal-circular-unit filename) + (fatal-error 'circular-unit + "The compilation unit ~a has a circular dependency." + filename)) + +(define (signal-unit-not-found filename) + (fatal-error 'unit-not-found + "The compilation unit file ~a was not found." + filename)) + +(define (signal-extension-needed filename) + (fatal-error 'extension-needed + "You must provide an extension on the filename ~a in the .hu file." + filename)) + + + + + diff --git a/csys/csys.scm b/csys/csys.scm new file mode 100644 index 0000000..a4683b6 --- /dev/null +++ b/csys/csys.scm @@ -0,0 +1,25 @@ +;;; csys.scm -- compilation unit definition for the compilation system + +(define-compilation-unit csys + (source-filename "$Y2/csys/") + (require global runtime flic) + (unit cache-structs + (source-filename "cache-structs.scm")) + (unit compiler-driver + (require cache-structs) + (source-filename "compiler-driver.scm")) + (unit dump-params + (require cache-structs) + (source-filename "dump-params.scm")) + (unit dump-macros + (require dump-params) + (source-filename "dump-macros.scm")) + (unit dump-interface + (require dump-macros) + (source-filename "dump-interface.scm")) + (unit dump-flic + (require dump-macros) + (source-filename "dump-flic.scm")) + (unit dump-cse + (require dump-macros) + (source-filename "dump-cse.scm"))) diff --git a/csys/dump-cse.scm b/csys/dump-cse.scm new file mode 100644 index 0000000..38ec020 --- /dev/null +++ b/csys/dump-cse.scm @@ -0,0 +1,182 @@ +;;; This file handles common subexpressions in the interface file. +;;; Common subexpressions are detected in two places: gtypes and strictness +;;; properties. + +;;; Compressing strictness signatures + +;;; A strictness is represented by a list of booleans. We do two things to +;;; compress strictnesses: all lists less than *pre-defined-strictness-size* +;;; are pre-computed in a vector and the first *pre-defined-strictness-vars* +;;; vector elements are cached in global vars. The strictness will dump as +;;; as either a global or as a vector reference into the vector. + +(define (initialize-strictness-table) + (setf (dynamic *pre-defined-strictness-table*) + (make-vector (expt 2 (1+ (dynamic *pre-defined-strictness-size*))))) + (setf (vector-ref *pre-defined-strictness-table* 1) '()) + (do ((i 1 (1+ i)) + (j 1 (* j 2)) + (k 2 (* k 2))) + ((> i *pre-defined-strictness-size*)) + (do ((l 0 (1+ l))) + ((>= l j)) + (setf (vector-ref *pre-defined-strictness-table* (+ k l)) + (cons '#f (vector-ref *pre-defined-strictness-table* (+ j l)))) + (setf (vector-ref *pre-defined-strictness-table* (+ k j l)) + (cons '#t (vector-ref *pre-defined-strictness-table* (+ j l)))))) + (set-strictness-vars)) + +(define (strictness-table-ref x) + (vector-ref (dynamic *pre-defined-strictness-table*) x)) + +(define (dump-strictness s) + (if (null? s) + ''() + (dump-strictness-1 s s 0 0))) + +(define (dump-strictness-1 s s1 n size) + (if (null? s1) + (if (> size *pre-defined-strictness-size*) + (dump-big-strictness (- size *pre-defined-strictness-size*) s) + (let ((k (+ n (expt 2 size)))) + (if (< k *pre-defined-strictness-vars*) + `(dynamic ,(vector-ref *pre-defined-strictness-names* k)) + `(strictness-table-ref ,k)))) + (dump-strictness-1 s (cdr s1) (+ (* 2 n) (if (car s1) 1 0)) (1+ size)))) + +(define (dump-big-strictness k s) + (if (= k 0) + (dump-strictness s) + `(cons ',(car s) + ,(dump-big-strictness (1- k) (cdr s))))) + +;;; This routine handles saving type signatures (gtypes). +;;; common subexpressions are detected in two places: the type body +;;; and the the contexts. + +(define (init-predefined-gtyvars) + (setf *saved-gtyvars* (make-vector *num-saved-gtyvars*)) + (dotimes (i *num-saved-gtyvars*) + (setf (vector-ref *saved-gtyvars* i) (**gtyvar i))) + (setup-gtyvar-vars)) + +(define (init-cse-structs) + (initialize-strictness-table) + (init-predefined-gtyvars)) + +(define (save-cse-value v) + (setf (vector-ref (dynamic *saved-cse-values*) (dynamic *cse-value-num*)) v) + (incf (dynamic *cse-value-num*))) + +(define (cse-init-code) + (let* ((n (length *cse-objects*)) + (init-code '())) + (do ((i (1- n) (1- i)) + (init *cse-objects* (cdr init))) + ((null? init)) + (push `(save-cse-value ,(car init)) init-code)) + `((setf *saved-cse-values* (make-vector ,n)) + (setf *cse-value-num* 0) + ,@init-code))) + +(define (remember-dumped-object init-code) + (push init-code *cse-objects*) + (incf *cse-object-num*) + *cse-object-num*) + +(define (cse-value-ref x) + (vector-ref (dynamic *saved-cse-values*) x)) + +(define (cse-ref-code n) + (cond ((eqv? n 0) + ''()) + ((<= n *num-saved-gtyvars*) + `(dynamic ,(vector-ref *saved-gtyvar-varnames* (1- n)))) + (else + `(cse-value-ref ,(- n *num-saved-gtyvars* 1))))) + +(define (dump-gtyvar g) + (let ((n (gtyvar-varnum g))) + (if (< n *num-saved-gtyvars*) + (1+ n) + (remember-dumped-object `(**gtyvar ,n))))) + +(define (dump-context-list contexts) + (if (null? contexts) + 0 + (let* ((rest (dump-context-list (cdr contexts))) + (classes (dump-class-list (car contexts))) + (t1 (assq/insert-l classes *gtype-class-index*)) + (res (assq/insert rest (cdr t1)))) + (if (eq? (cdr res) '#f) + (let ((z (remember-dumped-object + `(cons ,(cse-ref-code classes) ,(cse-ref-code rest))))) + (setf (cdr res) z) + z) + (cdr res))))) + +(define (dump-class-list classes) + (if (null? classes) + 0 + (let* ((rest (dump-class-list (cdr classes))) + (class (dump-class/n (car classes))) + (t1 (assq/insert-l class *context-class-index*)) + (res (assq/insert rest (cdr t1)))) + (if (eq? (cdr res) '#f) + (let ((z (remember-dumped-object + `(cons ,class ,(cse-ref-code rest))))) + (setf (cdr res) z) + z) + (cdr res))))) + +(define (dump-gtype-1 g) + (cond ((gtyvar? g) + (dump-gtyvar g)) + ((ntyvar? g) + (dump-gtype-1 (prune g))) + (else + (dump-gtycon g)))) + +(define (dump-gtycon g) + (let* ((ty (ntycon-tycon g)) + (tycon (if (algdata? ty) (dump-algdata/n ty) (dump-synonym/n ty))) + (l (dump-gtype-list (ntycon-args g))) + (t1 (assq/insert-l tycon *gtype-tycon-index*)) + (res (assq/insert l (cdr t1)))) + (if (eq? (cdr res) '#f) + (let ((z (remember-dumped-object + `(**ntycon ,tycon ,(cse-ref-code l))))) + (setf (cdr res) z) + z) + (cdr res)))) + +(define (dump-gtype-list l) + (if (null? l) + 0 + (let* ((g (dump-gtype-1 (car l))) + (rest (dump-gtype-list (cdr l))) + (t1 (assq/insert-l g *gtype-list-index*)) + (res (assq/insert rest (cdr t1)))) + (if (eq? (cdr res) '#f) + (let ((z (remember-dumped-object + `(cons ,(cse-ref-code g) + ,(cse-ref-code rest))))) + (setf (cdr res) z) + z) + (cdr res))))) + +(define (dump-gtype/cse g) + (cse-ref-code + (let* ((context (dump-context-list (gtype-context g))) + (type (dump-gtype-1 (gtype-type g))) + (t1 (assq/insert-l type *gtype-index*)) + (res (assq/insert context (cdr t1)))) + (if (eq? (cdr res) '#f) + (let ((z (remember-dumped-object + `(**gtype ,(cse-ref-code context) + ,(cse-ref-code type))))) + (setf (cdr res) z) + z) + (cdr res))))) + + diff --git a/csys/dump-flic.scm b/csys/dump-flic.scm new file mode 100644 index 0000000..0fc654d --- /dev/null +++ b/csys/dump-flic.scm @@ -0,0 +1,130 @@ +;;; dump-flic.scm -- general dump functions for flic structures +;;; +;;; author : Sandra Loosemore +;;; date : 24 Feb 1993 +;;; +;;; +;;; This stuff is used to write inline expansions to the interface file. +;;; + + +(define-flic-walker dump-flic (object var-renamings)) + +(define (dump-flic-list objects var-renamings) + (let ((result '())) + (dolist (o objects) + (push (dump-flic o var-renamings) result)) + `(list ,@(nreverse result)))) + +(define (dump-flic-top object) + (dump-flic object '())) + + +(define (make-temp-bindings-for-dump oldvars var-renamings) + (let ((vars '()) + (bindings '())) + (dolist (v oldvars) + (let ((var (def-name v)) + (temp (gensym))) + (push temp vars) + (push `(,temp (create-temp-var ',var)) bindings) + (push (cons v temp) var-renamings))) + (setf bindings (nreverse bindings)) + (setf vars (nreverse vars)) + (values vars bindings var-renamings))) + +(define-dump-flic flic-lambda (object var-renamings) + (multiple-value-bind (vars bindings var-renamings) + (make-temp-bindings-for-dump (flic-lambda-vars object) var-renamings) + `(let ,bindings + (make-flic-lambda + (list ,@vars) + ,(dump-flic (flic-lambda-body object) var-renamings))) + )) + +(define-dump-flic flic-let (object var-renamings) + (multiple-value-bind (vars bindings var-renamings) + (make-temp-bindings-for-dump (flic-let-bindings object) var-renamings) + `(let ,bindings + ,@(map (lambda (temp v) + `(setf (var-value ,temp) + ,(dump-flic (var-value v) var-renamings))) + vars + (flic-let-bindings object)) + (make-flic-let + (list ,@vars) + ,(dump-flic (flic-let-body object) var-renamings) + ',(flic-let-recursive? object))) + )) + +(define-dump-flic flic-app (object var-renamings) + `(make-flic-app + ,(dump-flic (flic-app-fn object) var-renamings) + ,(dump-flic-list (flic-app-args object) var-renamings) + ',(flic-app-saturated? object))) + +(define-dump-flic flic-ref (object var-renamings) + (let* ((var (flic-ref-var object)) + (entry (assq var var-renamings))) + (if entry + `(make-flic-ref ,(cdr entry)) + `(make-flic-ref ,(dump-object var))))) + +(define-dump-flic flic-const (object var-renamings) + (declare (ignore var-renamings)) + `(make-flic-const ',(flic-const-value object))) + +(define-dump-flic flic-pack (object var-renamings) + (declare (ignore var-renamings)) + `(make-flic-pack ,(dump-object (flic-pack-con object)))) + +(define-dump-flic flic-case-block (object var-renamings) + `(make-flic-case-block + ',(flic-case-block-block-name object) + ,(dump-flic-list (flic-case-block-exps object) var-renamings))) + +(define-dump-flic flic-return-from (object var-renamings) + `(make-flic-return-from + ',(flic-return-from-block-name object) + ,(dump-flic (flic-return-from-exp object) var-renamings))) + +(define-dump-flic flic-and (object var-renamings) + `(make-flic-and + ,(dump-flic-list (flic-and-exps object) var-renamings))) + +(define-dump-flic flic-if (object var-renamings) + `(make-flic-if + ,(dump-flic (flic-if-test-exp object) var-renamings) + ,(dump-flic (flic-if-then-exp object) var-renamings) + ,(dump-flic (flic-if-else-exp object) var-renamings))) + +(define-dump-flic flic-sel (object var-renamings) + `(make-flic-sel + ,(dump-object (flic-sel-con object)) + ,(flic-sel-i object) + ,(dump-flic (flic-sel-exp object) var-renamings))) + +(define-dump-flic flic-is-constructor (object var-renamings) + `(make-flic-is-constructor + ,(dump-object (flic-is-constructor-con object)) + ,(dump-flic (flic-is-constructor-exp object) var-renamings))) + +(define-dump-flic flic-con-number (object var-renamings) + `(make-flic-con-number + ,(dump-object (flic-con-number-type object)) + ,(dump-flic (flic-con-number-exp object) var-renamings))) + +(define-dump-flic flic-void (object var-renamings) + (declare (ignore object var-renamings)) + `(make-flic-void)) + + + + + + + + + + + diff --git a/csys/dump-interface.scm b/csys/dump-interface.scm new file mode 100644 index 0000000..37b3bbd --- /dev/null +++ b/csys/dump-interface.scm @@ -0,0 +1,800 @@ +;;; dump-interface.scm -- interface file writer/loader +;;; +;;; author : John & Sandra +;;; date : 8 Jul 1992 +;;; +;;; This writes binary interface files. A binary interface file is just +;;; a lisp (mumble) source file which directly builds the ast structure +;;; created by a compilation. These files could be stored in either +;;; source or binary (compiled lisp) form. + +;;; An interface may reference entities defined in other interfaces. +;;; To ensure consistancy between when an interface is written and +;;; when it is read back in, a stamp is assigned to all interface files +;;; which serves as a unique id. The stamps of all imported units are +;;; saved and examined at load time. + + + +;;;================================================================== +;;; Interface to compilation system +;;;================================================================== + + +;;; For compiled code, don't actually write out all the source code. +;;; Use a magic macro to memoize the form to be compiled. + +(define *form-to-compile* '#f) +(define *magic-file-to-compile* "$HASKELL/bin/magic.scm") + + +;;; The output from compiling the prelude can completely overwhelm +;;; the Lisp compiler. If this variable is a number, it specifies +;;; a "reasonable" number of top-level forms which can be compiled +;;; and write-compiled-code-file will try to break up the input +;;; code automagically. + +(define *magic-chunk-size* '#f) + + +;;; This is called to write both the code file and the interface file. + +(define (write-compiled-code-file filename code code-quality chunk-size) + (let ((phase-start-time (get-run-time)) + (forms (flatten-forms code))) + (dynamic-let ((*magic-chunk-size* + (or chunk-size (dynamic *magic-chunk-size*))) + (*code-quality* + (or code-quality (dynamic *code-quality*)))) + (if (or (not (dynamic *magic-chunk-size*)) + (<= (the fixnum (length forms)) + (the fixnum (dynamic *magic-chunk-size*)))) + (write-compiled-code-file-aux filename `(begin ,@forms)) + (with-compilation-unit () + (write-compiled-code-file-aux + filename + `(begin + ,@(map (lambda (f) `(load ,f)) + (write-compiled-code-file-split filename forms))) + )))) + (when (memq 'phase-time *printers*) + (let* ((current-time (get-run-time)) + (elapsed-time (- current-time phase-start-time))) + (format '#t "Lisp compilation complete: ~A seconds~%" elapsed-time))) + )) + +(define (write-compiled-code-file-split filename forms) + (let ((place (filename-place filename)) + (name (filename-name filename)) + (type (filename-type filename)) + (result '())) + (do ((i 0 (1+ i))) + ((null? forms)) + (multiple-value-bind (head tail) + (split-list forms (dynamic *magic-chunk-size*)) + (let ((fname + (assemble-filename + place (format '#f "~a-part~a" name i) type))) + (push fname result) + (write-compiled-code-file-aux fname `(begin ,@head)) + (setf forms tail)))) + (nreverse result))) + +(define (flatten-forms code) + (if (and (pair? code) (eq? (car code) 'begin)) + (nreverse (flatten-forms-aux (cdr code) '())) + (list code))) + +(define (flatten-forms-aux forms result) + (dolist (f forms) + (if (and (pair? f) (eq? (car f) 'begin)) + (setf result (flatten-forms-aux (cdr f) result)) + (push f result))) + result) + + +(define (write-compiled-code-file-aux filename code) + (dynamic-let ((*form-to-compile* code)) + (compile-file (dynamic *magic-file-to-compile*) filename))) + +(define-syntax (magic-form-to-compile) + (dynamic *form-to-compile*)) + + +;;; Writing source code is good for debugging purposes, but slow. +;;; The *print-circle* and *print-shared* flags have to be set because +;;; the code printed out may contain gensyms, and this will ensure +;;; that the code can be read in again. + +(define (write-interpreted-code-file filename code hairy?) + (dynamic-let ((*print-circle* '#t) + (*print-shared* '#t)) + (call-with-output-file + filename + (lambda (port) + (if hairy? + (pprint-flatten code port) + (print-flatten code port)))))) + + +;;; This attempts to read a compiled interface for a unit. This is +;;; done whenever the unit file is newer than the source file. If +;;; imported units have changed, the load will fail and recompilation +;;; will be attempted. +;;; The caller is responsible for making sure that the interface file exists +;;; and for making sure that the interface file is up-to-date with +;;; respect to imported modules and that all the imported modules are +;;; known. + +;;; These variables are assigned by the code in the dump file. + +(define *modules-loaded* '()) +(define *modules-imported* '()) +(define *defs-referenced* '()) +(define *saved-cse-values* '()) +(define *writer-version* '()) + +(define (read-binary-interface unit) + (dynamic-let ((*modules-loaded* '()) + (*modules-imported* '()) + (*defs-referenced* '()) + (*saved-cse-values* '()) + (*writer-version* '())) + (let ((file-date + (load-more-recent-file (ucache-cifile unit) (ucache-sifile unit)))) + (cond ((string=? *writer-version* *haskell-compiler-version*) + (setf (ucache-idate unit) file-date) + (setf (ucache-modules unit) (vector->list *modules-loaded*)) + (setf (ucache-ifile-loaded unit) '#t) + '#t) + (else + (signal-incompatible-interface-file (ucache-cifile unit)) + '#f))))) + +(define (signal-incompatible-interface-file filename) + (fatal-error 'incompatible-interface-file + "File ~A~%~ + was written by a different version of the Haskell system.~%~ + You must remove it and recompile." + filename)) + + +(define (load-more-recent-file cfile sfile) + (cond ((file-exists? cfile) + (if (or (not (file-exists? sfile)) + (> (file-write-date cfile) + (file-write-date sfile))) + (load-compiled-interface-file cfile) + (load-interpreted-interface-file sfile))) + ((file-exists? sfile) + (load-interpreted-interface-file sfile)) + (else + (signal-file-not-found cfile)))) + +(define (load-interpreted-interface-file file) + (load file) + (file-write-date file)) + +(define (load-compiled-interface-file file) + (load file) + (file-write-date file)) + + +;;;================================================================== +;;; Dump code generator +;;;================================================================== + +;;; Globals + +(define *dump-defs* '()) +(define *dump-slot-init-code* '()) +(define *dump-def-counter* 0) +(define *dump-def-code-table* (make-table)) +(define *cse-objects* '()) +(define *cse-value-num* 0) +(define *cse-object-num* '()) +(define *gtype-class-index* '()) +(define *context-class-index* '()) +(define *gtype-tycon-index* '()) +(define *gtype-list-index* '()) +(define *gtype-index* '()) +(define *number-vars-dumped* 0) + + +(define-syntax (def-dump-code def) + `(table-entry *dump-def-code-table* ,def)) + +;;; This saves slot initialization code. + +(define (add-dump-init code) + (push code *dump-slot-init-code*)) + + +;;; Here is the top-level call. + +(define (create-dump-code unit modules load-prelude?) + (dynamic-let ((*unit* (module-unit (car modules))) + (*dump-defs* '()) + (*dump-slot-init-code* '()) + (*dump-def-counter* 0) + (*dump-def-code-table* (make-table)) + (*cse-objects* '()) + (*cse-object-num* *num-saved-gtyvars*) + (*gtype-class-index* '()) + (*context-class-index* '()) + (*gtype-tycon-index* '()) + (*gtype-list-index* '()) + (*gtype-index* '()) + (*number-vars-dumped* 0) + (*number-types-dumped* 0) + (*number-classes-dumped* 0)) + (let ((res (create-dump-code-aux unit modules load-prelude?))) + (when (memq 'dumper (dynamic *printers*)) + (pprint* res)) + (when (memq 'dump-stat (dynamic *printers*)) + (format '#t + "~&Dumped ~A definitions, ~A type objects, and ~A classes.~%" + *number-vars-dumped* *number-types-dumped* + *number-classes-dumped*) + (format '#t "Used ~A definitions and ~A type cells.~%" + *dump-def-counter* (length *cse-objects*))) + res))) + +;;; This assumes all modules are in the same compilation unit and that +;;; *unit* is set to that unit. +;;; imod-code establishes local bindings for all the imported modules. +;;; dmod-code establishes local bindings for all the modules defined in +;;; this compilation unit. + +(define (create-dump-code-aux unit modules load-prelude?) + (let* ((imod-counter 0) + (imod-alist '()) + (explicit-imports (collect-all-imported-modules unit)) + (all-imports (if load-prelude? + (append (collect-prelude-modules) explicit-imports) + explicit-imports)) + (imod-code (map (lambda (m) + (push (cons (module-name m) imod-counter) + imod-alist) + (incf imod-counter) + `(locate-module ',(module-name m))) + all-imports)) + (dmod-counter 0) + (dmod-alist '()) + (dmod-code (map (lambda (m) + (push (cons (module-name m) dmod-counter) + dmod-alist) + (incf dmod-counter) + `(make module + (unit ',(module-unit m)) + (name ',(module-name m)) + (type ',(module-type m)))) + modules))) + ;; This actually does most of the work. It dumps the module asts by + ;; placing inits for each slot into *dump-slot-init-code*. A list of + ;; definitions referenced is maintained in *dump-defs*. + (dolist (m modules) + (dump-module m (cdr (assq (module-name m) dmod-alist)))) + ;; This creates the final code + `(begin + (setf *writer-version* ',*haskell-compiler-version*) + (setf *modules-imported* (vector ,@imod-code)) + (setf *modules-loaded* (vector ,@dmod-code)) + ;; This sets the elements individually instead of using the vector + ;; function, because the vector may be longer than + ;; call-arguments-limit. + (setf *defs-referenced* + (make-vector ,(dynamic *dump-def-counter*))) + ,@(map (lambda (d) + `(setf ,(def-dump-code d) + ,(make-def-init-code d imod-alist dmod-alist))) + *dump-defs*) + ,@(cse-init-code) + ,@(dynamic *dump-slot-init-code*) + ) + )) + + +;;; Runtime support + +(define-syntax (lookup-imported-mod i) + `(vector-ref *modules-imported* ,i)) + +(define-syntax (lookup-defined-mod i) + `(vector-ref *modules-loaded* ,i)) + +(define (set-export-from-def-vector table key index) + (setf (table-entry table key) + (list (cons key (vector-ref *defs-referenced* index))))) + +(define (set-export-from-def table key def) + (setf (table-entry table key) + (list (cons key def)))) + +(define (set-symtab-from-def-vector table key index) + (setf (table-entry table key) + (vector-ref *defs-referenced* index))) + +(define (init-variable-slots var exported? toplevel? type simple? strict?) + (setf (def-exported? var) exported?) + (setf (var-toplevel? var) toplevel?) + (setf (var-type var) type) + (setf (var-simple? var) simple?) + (setf (var-strict? var) strict?) + var) + +(define (init-function-slots var exported? toplevel? type simple? strict? + arity strictness opt-entry) + (setf (def-exported? var) exported?) + (setf (var-toplevel? var) toplevel?) + (setf (var-type var) type) + (setf (var-simple? var) simple?) + (setf (var-strict? var) strict?) + (setf (var-arity var) arity) + (setf (var-strictness var) strictness) + (setf (var-optimized-entry var) opt-entry) + var) + +(define (init-method-var-slots var class default method-signature) + (setf (method-var-class var) class) + (setf (method-var-default var) default) + (setf (method-var-method-signature var) method-signature) + var) + +(define (init-constructor-slots + con arity types signature tag alg fixity infix?) + (setf (con-arity con) arity) + (setf (con-types con) types) + (setf (con-signature con) signature) + (setf (con-tag con) tag) + (setf (con-alg con) alg) + (setf (con-fixity con) fixity) + (setf (con-infix? con) infix?) + (dotimes (i arity) + (push '#f (con-slot-strict? con))) + con) + +(define (make-new-instance algdata tyvars class context gcontext dictionary m) + (make instance + (algdata algdata) + (tyvars tyvars) + (class class) + (context context) + (gcontext gcontext) + (dictionary dictionary) + (methods m) + (ok? '#t))) + + +;;; This computes the transitive closure of all modules available to +;;; a unit. + +(define (collect-all-imported-modules unit) + (collect-all-modules-1 (ucache-imported-units unit) '() '())) + +(define (collect-all-modules-1 units mods-so-far units-seen) + (cond ((null? units) + mods-so-far) + ((mem-string (car units) units-seen) + (collect-all-modules-1 (cdr units) mods-so-far units-seen)) + (else + (let ((u (lookup-compilation-unit (car units)))) + (collect-all-modules-1 + (append (ucache-imported-units u) (cdr units)) + (append (ucache-modules u) mods-so-far) + (cons (ucache-ufile u) units-seen)))) + )) + +(define (collect-prelude-modules) + (let ((prelude-unit (lookup-compilation-unit *prelude-unit-filename*))) + (append (ucache-modules prelude-unit) + (collect-all-imported-modules prelude-unit)))) + +(define (def->core-name-string def) + (if (con? def) + (remove-con-prefix (symbol->string (def-name def))) + (symbol->string (def-name def)))) + +;;; This code returns the load time definition for an object. When the +;;; object is a core symbol or in a different unit, previously +;;; created definitions are returned. Otherwise, a new definition is +;;; created. + +(define (make-def-init-code d imod-alist dmod-alist) + (declare (ignore dmod-alist)) + (cond ((def-core? d) + `(core-symbol ,(def->core-name-string d))) + ((eq? (def-unit d) *unit*) + `(create-definition/inner + ',(def-module d) + ',(def-name d) + ',(cond ((method-var? d) 'method-var) + ((var? d) 'var) + ((con? d) 'con) + ((synonym? d) 'synonym) + ((algdata? d) 'algdata) + ((class? d) 'class)))) + ((is-tuple-constructor? d) + `(tuple-constructor ,(tuple-constructor-arity d))) + ((is-tuple-tycon? d) + `(tuple-tycon ,(tuple-constructor-arity (car (algdata-constrs d))))) + (else + (let ((m (assq (def-module d) imod-alist))) + ;; This is a bogus error message. The problem is that nothing + ;; so far ensures units are closed under import/export: some + ;; modules may be referenced that are accidentally in the symbol + ;; table. The unif file for the current module needs to be + ;; updated when this happens. + (when (eq? m '#f) + (fatal-error 'symbol-not-in-unit + "Reference to symbol ~A in module ~A: not in compilation unit.~%" + (def-name d) (def-module d))) + `(table-entry + (module-symbol-table + (lookup-imported-mod ,(tuple-2-2 m))) + ',(def-name d)))) + )) + + +;;; Once a module has been compiled, most of its slots are useless. +;;; All we really need to save are the identifying information, +;;; symbol table, and export table. +;;; Instances also need to be dumped here instead of with class objects; +;;; this is because links can go across compilation unit boundaries. +;;; They are fixed up when pulling units out of the cache. +;;; The identifying info is stored when the module variable is bound. + + +(define (dump-module module index) + (let ((mod-exp `(lookup-defined-mod ,index)) + (save-all-symbols (or (eq? (module-type module) 'standard) + (eq? (module-name module) '|Prelude|)))) + ;; Dump symbol table entries only for defs for which this is + ;; the "home" module. (In other words, ignore imported defs.) + ;; The purpose of this is to allow references from other + ;; interface files to be resolved; see make-def-init-code. + ;; Jcp: we need to save the complete symbol table for incremental + ;; compilation to work. + (let ((code '())) + (table-for-each + (lambda (key val) + (when (or save-all-symbols + (eq? (def-module val) (module-name module))) + (let ((def (dump-object val))) + (push + (if (and (pair? def) + (eq? (car def) 'vector-ref) + (eq? (cadr def) '*defs-referenced*)) + `(set-symtab-from-def-vector table ',key ,(caddr def)) + `(setf (table-entry table ',key) ,def)) + code)))) + (module-symbol-table module)) + (add-dump-init `(setf (module-symbol-table ,mod-exp) + (let ((table (make-table))) ,@code table)))) + ;; dump the fixity table - needed by the incremental compiler + (when save-all-symbols + (let ((code '())) + (table-for-each + (lambda (key val) + (push `(setf (table-entry table ',key) + (make-fixity ',(fixity-associativity val) + ',(fixity-precedence val))) + code)) + (module-fixity-table module)) + (add-dump-init `(setf (module-fixity-table ,mod-exp) + (let ((table (make-table))) ,@code table))))) + ;; Dump all export table entries. This is used by the import/export + ;; phase to resolve references. + (let ((code '())) + (table-for-each + (lambda (key val) + ;; val is an a-list of (sym . def) pairs. + ;; Look for shortcut to reduce size of generated code. + (push + (if (and (null? (cdr val)) + (eq? (car (car val)) key)) + (let ((def (dump-object (cdr (car val))))) + (if (and (pair? def) + (eq? (car def) 'vector-ref) + (eq? (cadr def) '*defs-referenced*)) + `(set-export-from-def-vector table ',key ,(caddr def)) + `(set-export-from-def table ',key ,def))) + `(setf (table-entry table ',key) ,(dump-object val))) + code)) + (module-export-table module)) + (add-dump-init `(setf (module-export-table ,mod-exp) + (let ((table (make-table))) ,@code table)))) + ;; Dump the instances. + (add-dump-init `(setf (module-instance-defs ,mod-exp) + ,(dump-object (module-instance-defs module)))) + (add-dump-init `(setf (module-default ,mod-exp) + ,(dump-object (module-default module)))) + (add-dump-init `(setf (module-uses-standard-prelude? ,mod-exp) + ,(dump-object + (module-uses-standard-prelude? module)))) + )) + +(define (make-fixity a p) + (make fixity (associativity a) (precedence p))) + + +;;;================================================================== +;;; Dump structure traversal +;;;================================================================== + +;;; This is the general object dumper. It recognizes the basic Lisp +;;; objects and dumps them. Given an object, this generates lisp code +;;; to recreate the object at load time. + +(define (dump-object x) + (cond ((struct? x) + (dump x)) + ((or (symbol? x) (null? x)) + ;; Symbols and lists must be quoted. + `',x) + ((or (number? x) + (eq? x '#t) + (eq? x '#f) + (string? x) ; This makes dumped strings immutable. + (char? x)) + ;; These objects are self-evaluating. + x) + ((list? x) + ;; True lists + `(list ,@(map (function dump-object) x))) + ((pair? x) + `(cons ,(dump-object (car x)) + ,(dump-object (cdr x)))) + ((vector? x) + `(vector ,@(map (function dump-object) (vector->list x)))) + ((table? x) + `(list->table ,@(dump-object (table->list x)))) + (else + (error "Don't know how to dump ~A." x)))) + + +;;; *** Should install the walker in the type descriptor. + +(define-walker dump) + +(define (dump x) + (call-walker dump x)) + + + +;;;================================================================== +;;; Dumpers for defs +;;;================================================================== + + +;;; All walkers for def structures should call this macro. The body +;;; is invoked only if the def belongs to the current compilation unit +;;; and hasn't already been traversed. Within the body, the +;;; variable "v" is bound to a form that will evaluate to the +;;; corresponding def structure at run time. This is also +;;; the return value from the macro. + +(define-local-syntax (with-new-def (v d stat-var) . body) + (let ((temp (gensym)) + (expvar (gensym))) + `(let ((,temp ,d) + (,expvar '#f)) + (if (not (def-dump-code ,temp)) + (begin + (cond ((not (def-core? ,temp)) + (setf ,expvar + (list 'vector-ref + '*defs-referenced* + (dynamic *dump-def-counter*))) + (incf (dynamic *dump-def-counter*)) + (push ,temp *dump-defs*)) + (else + (setf ,expvar + (make-core-symbol-name + (def->core-name-string ,temp))))) + (setf (def-dump-code ,temp) ,expvar) + (when (eq? (def-unit ,temp) *unit*) + (incf (dynamic ,stat-var)) + (let ((,v ,expvar)) + ,@body)) + ,expvar) + (def-dump-code ,temp))))) + + +;;; This macro is used to save the value of a structure slot in the +;;; initforms of the dump. + +(define-local-syntax (dump-def-slots obj-var type dexp slots) + `(add-dump-init + (list 'update-slots ',type ,dexp + ,@(map (lambda (s) + `(list ',s + (dump-object (struct-slot ',type ',s ,obj-var)))) + slots))) + ) + + + +(define-walker-method dump var (var) + (dump-var/n var)) + +(define (dump-var/n var) + (with-new-def (dexp var *number-vars-dumped*) + (do-dump-var dexp var '#f))) + +(define (do-dump-var dexp var method-var?) + (let ((code '()) + (exported? (def-exported? var)) + (toplevel? (var-toplevel? var)) + (type (var-type var)) + (simple? (var-simple? var)) + (strict? (var-strict? var)) + (arity (var-arity var)) + (strictness (var-strictness var)) + (opt-entry (var-optimized-entry var)) + (complexity (var-complexity var)) + (fixity (var-fixity var)) + (value (var-value var)) + (inline-value (var-inline-value var)) + (sel? (var-selector-fn? var))) + ;; Some slots are useless for vars that don't name functions. + (if (eqv? arity 0) + (push `(init-variable-slots var + ',exported? + ',toplevel? + ,(dump-object type) + ',simple? + ',strict?) + code) + (push `(init-function-slots var + ',exported? + ',toplevel? + ,(dump-object type) + ',simple? + ',strict? + ',arity + ,(dump-strictness strictness) + ',opt-entry) + code)) + ;; These slots rarely need to be tweaked from the default. + (when sel? + (push `(setf (var-selector-fn? var) '#t) code)) + (when complexity + (push `(setf (var-complexity var) ,complexity) code)) + (when fixity + (push `(setf (var-fixity var) ,(dump-object fixity)) code)) + ;; Save values of simple variables to permit inlining. + ;; Save values of structured constants to permit folding of flic-sel + ;; operations -- this is necessary to optimize dictionary lookups. + (when (or simple? sel? + (and value + (is-type? 'flic-app value) + (structured-constant-app? + (flic-app-fn value) (flic-app-args value)))) + (push `(setf (var-value var) ,(dump-flic-top value)) code)) + (when inline-value + (push `(setf (var-inline-value var) ,(dump-flic-top inline-value)) code)) + ;; Save extra stuff for method vars + (when method-var? + (push `(init-method-var-slots var + ,(dump-object (method-var-class var)) + ,(dump-object (method-var-default var)) + ,(dump-object (method-var-method-signature var))) + code)) + ;; Push the whole mess onto the init code. + (add-dump-init `(let ((var ,dexp)) ,@(nreverse code))))) + + +(define-walker-method dump method-var (var) + (dump-method-var/n var)) + +(define (dump-method-var/n var) + (with-new-def (dexp var *number-vars-dumped*) + (do-dump-var dexp var '#t))) + +(define-walker-method dump con (con) + (dump-con/n con)) + +(define (dump-con/n con) + (with-new-def (dexp con *number-types-dumped*) + (add-dump-init + `(let ((con (init-constructor-slots + ,dexp + ,(con-arity con) + ,(dump-object (con-types con)) + ,(dump-object (con-signature con)) + ,(con-tag con) + ,(dump-object (con-alg con)) + ,(dump-object (con-fixity con)) + ',(con-infix? con)))) + ,@(if (memq '#t (con-slot-strict? con)) + `((setf (con-slot-strict? con) ',(con-slot-strict? con))) + '()) + ,@(if (eq? (con-lisp-fns con) '()) + '() + `((setf (con-lisp-fns con) ',(con-lisp-fns con)))) + con)))) + +;;; *** Could define similar init functions for other defs instead +;;; *** of setting slots inline, but I'm lazy and they don't show up +;;; *** nearly as often as the others. + +(define-walker-method dump algdata (alg) + (dump-algdata/n alg)) + +(define (dump-algdata/n alg) + (with-new-def (dexp alg *number-types-dumped*) + (dump-def-slots alg algdata dexp + (arity n-constr constrs context tyvars signature + enum? tuple? real-tuple? implemented-by-lisp?)))) + +(define-walker-method dump synonym (syn) + (dump-synonym/n syn)) + +(define (dump-synonym/n syn) + (with-new-def (dexp syn *number-types-dumped*) + (dump-def-slots syn synonym dexp (arity args body)))) + +(define-walker-method dump class (class) + (dump-class/n class)) + +(define (dump-class/n class) + (with-new-def (dexp class *number-classes-dumped*) + (dump-def-slots class class dexp + (super super* tyvar method-vars selectors kind + n-methods dict-size)))) + + +;;;================================================================== +;;; Dumpers for non-def AST structs +;;;================================================================== + +;;; This section contains dumpers to handle type-related structs that +;;; are referenced by the various def guys. + + +(define-walker-method dump instance (o) + (if (not (instance-ok? o)) + (error "Attempt to dump instance that's not ok!")) + `(make-new-instance + ,(dump-object (instance-algdata o)) + ,(dump-object (instance-tyvars o)) + ,(dump-object (instance-class o)) + ,(dump-object (instance-context o)) + ,(dump-object (instance-gcontext o)) + ,(dump-object (instance-dictionary o)) + ,(dump-object (instance-methods o)))) + + + +(define-walker-method dump gtype (o) + (dump-gtype/cse o)) + +(define-walker-method dump fixity (o) + `(**fixity ',(fixity-associativity o) ',(fixity-precedence o))) + +(define-walker-method dump tyvar (o) + `(**tyvar ',(tyvar-name o))) + +(define-walker-method dump class-ref (o) + `(**class/def ,(dump-object (class-ref-class o)))) + +(define-walker-method dump context (o) + `(**context ,(dump-object (context-class o)) + ,(dump-object (context-tyvar o)))) + +(define-walker-method dump tycon (o) + `(**tycon/def ,(dump-object (tycon-def o)) + ,(dump-object (tycon-args o)))) + +(define-walker-method dump default-decl (o) + `(make default-decl (types ,(dump-object (default-decl-types o))))) + +(define-walker-method dump signature (o) + `(make signature (context ,(dump-object (signature-context o))) + (type ,(dump-object (signature-type o))))) + +;;; All ntyvars should be instantiated at this point + +; (define-walker-method dump ntyvar (o) +; (dump-object (prune o))) diff --git a/csys/dump-macros.scm b/csys/dump-macros.scm new file mode 100644 index 0000000..404adf8 --- /dev/null +++ b/csys/dump-macros.scm @@ -0,0 +1,37 @@ +(define-syntax (set-strictness-vars) + (let ((res '())) + (dotimes (i *pre-defined-strictness-vars*) + (push `(setf (dynamic ,(vector-ref *pre-defined-strictness-names* i)) + (vector-ref *pre-defined-strictness-table* ',i)) + res)) + `(begin ,@res))) + +(define-syntax (setup-gtyvar-vars) + (let ((res '())) + (dotimes (i *num-saved-gtyvars*) + (push `(setf (dynamic ,(vector-ref *saved-gtyvar-varnames* i)) + (vector-ref *saved-gtyvars* ',i)) + res)) + `(begin ,@res))) + +(define-syntax (assq/insert x table) + `(let ((res (assq ,x ,table))) + (if (eqv? res '#f) + (begin + (let ((new-pair (cons ,x '#f))) + (push new-pair ,table) + new-pair)) + res))) + +(define-syntax (assq/insert-l x table) + `(let ((res (assq ,x ,table))) + (if (eqv? res '#f) + (begin + (let ((new-pair (cons ,x '()))) + (push new-pair ,table) + new-pair)) + res))) + + + + diff --git a/csys/dump-params.scm b/csys/dump-params.scm new file mode 100644 index 0000000..cabbfd0 --- /dev/null +++ b/csys/dump-params.scm @@ -0,0 +1,18 @@ +(define *num-saved-gtyvars* 19) +(define *pre-defined-strictness-size* 7) ; length of max strictness list +(define *pre-defined-strictness-table* '()) +(define *pre-defined-strictness-vars* 32) ; number of global vars +(define *pre-defined-strictness-names* + (make-vector *pre-defined-strictness-vars*)) + +(dotimes (i *pre-defined-strictness-vars*) + (setf (vector-ref *pre-defined-strictness-names* i) + (string->symbol (format '#f "SAVED-STRICTNESS-~A" i)))) + +(define *saved-gtyvars* '()) +(define *saved-gtyvar-varnames* (make-vector *num-saved-gtyvars*)) +(dotimes (i *num-saved-gtyvars*) + (setf (vector-ref *saved-gtyvar-varnames* i) + (string->symbol (format '#f "SAVED-GTYVAR-NAME~A" i)))) + + diff --git a/csys/magic.scm b/csys/magic.scm new file mode 100644 index 0000000..999e8b0 --- /dev/null +++ b/csys/magic.scm @@ -0,0 +1,10 @@ +;;; magic.scm -- magic support file for dumping compiled code files. +;;; +;;; author : Sandra Loosemore +;;; date : 8 Jul 1992 +;;; +;;; This file is used to dump compiled code files. The macro call below +;;; expands into the code being dumped. See dump-interface.scm for more +;;; details. + +(magic-form-to-compile) diff --git a/depend/README b/depend/README new file mode 100644 index 0000000..0e73262 --- /dev/null +++ b/depend/README @@ -0,0 +1,3 @@ +This directory contains the dependency analysis phase. Its function +is to sort out local variable bindings into sequential and recursive +groups. diff --git a/depend/depend.scm b/depend/depend.scm new file mode 100644 index 0000000..0f42ca9 --- /dev/null +++ b/depend/depend.scm @@ -0,0 +1,13 @@ +;;; depend.scm -- module definition for dependency analysis +;;; +;;; author : John +;;; date : 24 Mar 1992 +;;; + + +(define-compilation-unit depend + (source-filename "$Y2/depend/") + (require ast haskell-utils) + (unit dependency-analysis + (source-filename "dependency-analysis.scm"))) +
\ No newline at end of file diff --git a/depend/dependency-analysis.scm b/depend/dependency-analysis.scm new file mode 100644 index 0000000..c8d259a --- /dev/null +++ b/depend/dependency-analysis.scm @@ -0,0 +1,151 @@ +;;; depend/depend.scm Author: John + +;;; This performs dependency analysis. All module definitions are gathered +;;; into a single nested let/let*. + +(define-walker depend ast-td-depend-walker) + +;;; This extracts the declarations out of the top level of the modules and +;;; creates a single let defining all values from the modules. + +(define (do-dependency-analysis modules) + (let ((all-decls '())) + (dolist (mod modules) + (setf all-decls (append (module-decls mod) all-decls))) + (analyze-dependency-top + (**let all-decls (make void))))) + + +(define *depend-fn-table* (make-table)) + +(define-syntax (var-depend-fn var) + `(table-entry *depend-fn-table* ,var)) + +(define (analyze-dependency-top x) + (dynamic-let ((*depend-fn-table* (make-table))) + (analyze-dependency x))) + + +;;; This is the entry point to dependency analysis for an expression or decl + +(define (analyze-dependency x) + (call-walker depend x)) + +(define (analyze-dependency/list l) + (dolist (x l) + (analyze-dependency x))) + +;;; This makes default walkers for dependency analysis. Expressions are +;;; walked into; declaration lists must be sorted. + +(define-local-syntax (make-depend-code slot type) + (let ((stype (sd-type slot)) + (sname (sd-name slot)) + (depend-exp-types '(exp alt qual single-fun-def guarded-rhs))) + (cond ((and (symbol? stype) + (memq stype depend-exp-types)) + `(analyze-dependency (struct-slot ',type ',sname object))) + ((and (pair? stype) + (eq? (car stype) 'list) + (symbol? (cadr stype)) + (memq (cadr stype) depend-exp-types) + `(analyze-dependency/list + (struct-slot ',type ',sname object)))) + ((equal? stype '(list decl)) + `(setf (struct-slot ',type ',sname object) + (restructure-decl-list (struct-slot ',type ',sname object)))) + (else +; (format '#t "Depend: skipping slot ~A in ~A~%" +; (sd-name slot) +; type) + '#f)))) + +(define-modify-walker-methods depend + (lambda let if case alt exp-sign app con-ref + integer-const float-const char-const string-const + list-exp sequence sequence-then sequence-to sequence-then-to + list-comp section-l section-r qual-generator qual-filter omitted-guard + con-number sel is-constructor cast void + single-fun-def guarded-rhs + case-block return-from and-exp + ) + (object) + make-depend-code) + +;;; This sorts a list of decls. Recursive groups are placed in +;;; special structures: recursive-decl-group + +(define (restructure-decl-list decls) + (let ((stack '()) + (now 0) + (sorted-decls '()) + (edge-fn '())) + (letrec ((visit (lambda (k) + (let ((minval 0) + (recursive? '#f) + (old-edge-fn edge-fn)) + (incf now) +; (format '#t "Visiting ~A: id = ~A~%" (valdef-lhs k) now) + (setf (valdef-depend-val k) now) + (setf minval now) + (push k stack) + (setf edge-fn + (lambda (tv) +; (format '#t "Edge ~A -> ~A~%" (valdef-lhs k) +; (valdef-lhs tv)) + (let ((val (valdef-depend-val tv))) + (cond ((eq? tv k) + (setf recursive? '#t)) + ((eqv? val 0) + (setf minval (min minval + (funcall visit tv)))) + (else + (setf minval (min minval val)))) +; (format '#t "Min for ~A is ~A~%" +; (valdef-lhs k) minval) + ))) + (analyze-dependency/list (valdef-definitions k)) + (setf edge-fn old-edge-fn) + (when (eqv? minval (valdef-depend-val k)) + (let ((defs '())) + (do ((quit? '#f)) (quit?) + (push (car stack) defs) + (setf (valdef-depend-val (car stack)) 100000) + (setf quit? (eq? (car stack) k)) + (setf stack (cdr stack))) +; (format '#t "Popping stack: ~A~%" +; (map (lambda (x) (valdef-lhs x)) defs)) + (if (and (null? (cdr defs)) + (not recursive?)) + (push k sorted-decls) + (push (make recursive-decl-group (decls defs)) + sorted-decls)))) + minval)))) + ;; for now assume all decl lists have only valdefs + (dolist (d decls) + (let ((decl d)) ; to force new binding for each closure + (setf (valdef-depend-val decl) 0) + (dolist (var (collect-pattern-vars (valdef-lhs decl))) + (setf (var-depend-fn (var-ref-var var)) + (lambda () (funcall edge-fn decl)))))) + (dolist (decl decls) + (when (eqv? (valdef-depend-val decl) 0) + (funcall visit decl))) + (dolist (decl decls) + (dolist (var (collect-pattern-vars (valdef-lhs decl))) + (setf (var-depend-fn (var-ref-var var)) '#f))) + (nreverse sorted-decls)))) + +;;; This is the only non-default walker needed. When a reference to a +;;; variable is encountered, the sort algorithm above is notified. + +(define-walker-method depend var-ref (object) + (let ((fn (var-depend-fn (var-ref-var object)))) + (when (not (eq? fn '#f)) + (funcall fn)))) + +(define-walker-method depend overloaded-var-ref (object) + (let ((fn (var-depend-fn (overloaded-var-ref-var object)))) + (when (not (eq? fn '#f)) + (funcall fn)))) + diff --git a/derived/README b/derived/README new file mode 100644 index 0000000..9b461ac --- /dev/null +++ b/derived/README @@ -0,0 +1,2 @@ +This directory contains code to generate AST structure for derived +instances. diff --git a/derived/ast-builders.scm b/derived/ast-builders.scm new file mode 100644 index 0000000..3a16ee6 --- /dev/null +++ b/derived/ast-builders.scm @@ -0,0 +1,273 @@ +;;; These functions build non-trivial ast structure. + +;;; Prelude functions: booleans + +(define (**== e1 e2) + (**app (**var/def (core-symbol "==")) e1 e2)) + +(define (**<= e1 e2) + (**app (**var/def (core-symbol "<=")) e1 e2)) + +(define (**< e1 e2) + (**app (**var/def (core-symbol "<")) e1 e2)) + +(define (**> e1 e2) + (**app (**var/def (core-symbol ">")) e1 e2)) + +(define (**and e1 e2) + (**app (**var/def (core-symbol "&&")) e1 e2)) + +(define (**or e1 e2) + (**app (**var/def (core-symbol "||")) e1 e2)) + +(define (**true) (**con/def (core-symbol "True"))) + +(define (**false) (**con/def (core-symbol "False"))) + +;; Tuples + +(define (**tuple2 x y) + (**app (**con/def (tuple-constructor 2)) x y)) + +(define (**tupleN exps) + (**app/l (**con/def (tuple-constructor (length exps))) exps)) + +;; Arithmetic + +(define (**+ x y) + (**app (**var/def (core-symbol "+")) x y)) + +(define (**+/Int x y) + (**app (**var/def (core-symbol "primPlusInt")) x y)) + +(define (**- x y) + (**app (**var/def (core-symbol "-")) x y)) + +(define (**1+ x) + (**+ x (**int 1))) + +;; Lists + +(define (**cons x y) + (**app (**con/def (core-symbol ":")) x y)) + +(define (**null) + (**con/def (core-symbol "Nil"))) + +(define (**list . args) + (**list/l args)) + +(define (**list/l args) + (if (null? args) + (**null) + (**cons (car args) + (**list/l (cdr args))))) + +(define (**list/pattern pats) + (if (null? pats) + (**pcon/def (core-symbol "Nil") '()) + (**pcon/def (core-symbol ":") + (list (car pats) (**list/pattern (cdr pats)))))) + +(define (**append . lists) + (**append/l lists)) + +(define (**append/l lists) + (if (null? (cdr lists)) + (car lists) + (**app (**var/def (core-symbol "++")) + (car lists) + (**append/l (cdr lists))))) + +(define (**take n l) + (**app (**var/def (core-symbol "take")) n l)) + +(define (**drop n l) + (**app (**var/def (core-symbol "drop")) n l)) + +;; Functionals + +(define (**dot fn . args) + (**dot/l fn args)) + +(define (**dot/l fn args) + (if (null? args) + fn + (**app (**var/def (core-symbol ".")) fn (**dot/l (car args) (cdr args))))) + +;; Printing + +(define (**showChar x) + (**app (**var/def (core-symbol "showChar")) x)) + +(define (**space) + (**showChar (**char #\ ))) + +(define (**comma) + (**showChar (**char #\,))) + +(define (**showsPrec x y) + (**app (**var/def (core-symbol "showsPrec")) x y)) + +(define (**shows x) + (**app (**var/def (core-symbol "shows")) x)) + +(define (**showString x) + (**app (**var/def (core-symbol "showString")) x)) + +(define (**showParen x y) + (**app (**var/def (core-symbol "showParen")) x y)) + +;; Reading + +(define (**readsPrec x y) + (**app (**var/def (core-symbol "readsPrec")) x y)) + +(define (**lex x) + (**app (**var/def (core-symbol "lex")) x)) + +(define (**readParen bool fn r) + (**app (**var/def (core-symbol "readParen")) bool fn r)) + +(define (**reads s) + (**app (**var/def (core-symbol "reads")) s)) + +;;; Binary + +(define (**showBinInt i b) + (**app (**var/def (core-symbol "primShowBinInt")) i b)) + +(define (**readBinSmallInt max b) + (**app (**var/def (core-symbol "primReadBinSmallInt")) max b)) + +(define (**showBin x b) + (**app (**var/def (core-symbol "showBin")) x b)) + +(define (**readBin b) + (**app (**var/def (core-symbol "readBin")) b)) + +;;; Some higher level code generators + +;;; foldr (expanded inline) + +(define (**foldr build-fn terms init) + (if (null? terms) + init + (funcall build-fn (car terms) (**foldr build-fn (cdr terms) init)))) + +;;; Unlike foldr, this uses two sets of args to avoid tupling + +(define (**foldr2 build-fn terms1 terms2 init-fn) + (if (null? (cdr terms1)) + (funcall init-fn (car terms1) (car terms2)) + (funcall build-fn (car terms1) (car terms2) + (**foldr2 build-fn (cdr terms1) (cdr terms2) init-fn)))) + +;;; Enum + +(define (**enumFrom x) + (**app (**var/def (core-symbol "enumFrom")) x)) + +(define (**enumFromThen from then) + (**app (**var/def (core-symbol "enumFromThen")) from then)) + +(define (**enumFromTo from to) + (**app (**var/def (core-symbol "enumFromTo")) from to)) + +(define (**enumFromThenTo from then to) + (**app (**var/def (core-symbol "enumFromThenTo")) from then to)) + +;;; Cast overrides the type system + +(define (**cast x) + (make cast (exp x))) + +;;; Case. This also generates the alts. All variants of case generate +;;; an arm for each constructor in a datatype. This arm can be selected +;;; by pattern matching a value of the type, with all fields bound to vars, +;;; or with numbered or named selections. + +;;; The fn always generates the arms given the constructor. In the /con case, +;;; the fn also gets the variable list of values bound in the fields. + +(define (**case/con alg exp fn) + (**case exp + (map (lambda (con) + (let* ((arity (con-arity con)) + (vars (temp-vars "x" arity))) + (**alt/simple (**pat (cons con vars)) + (funcall fn con vars)))) + (algdata-constrs alg)))) + +;;; Selectors are integers (used for Bin) + +(define (**case/int alg exp fn) + (**case exp + (map (lambda (con) + (**alt/simple + (**pat (con-tag con)) + (funcall fn con))) + (algdata-constrs alg)))) + +;;; Selectors are strings (Text) + +(define (**case/strings alg exp fn) + (**case exp + (map (lambda (con) + (**alt/simple + (**pat (remove-con-prefix (symbol->string (def-name con)))) + (funcall fn con))) + (algdata-constrs alg)))) + +;;; Definitions containing multi-body + +(define (**multi-define fname alg nullary-fn single-fn + combine-fn else-val) + (**define/multiple fname + (append + (map (lambda (con) (**define/2 con nullary-fn single-fn combine-fn)) + (algdata-constrs alg)) + (if (not (eq? else-val '#f)) + `(((_ _) ,(funcall else-val))) + '())))) + +(define (**define/2 con nullary-fn single-fn combine-fn) + (let* ((arity (con-arity con)) + (vars1 (temp-vars "l" arity)) + (vars2 (temp-vars "r" arity))) + `(((,con ,@vars1) (,con ,@vars2)) + ,(if (eqv? arity 0) + (funcall nullary-fn) + (**foldr2 combine-fn (suspend-vars vars1) (suspend-vars vars2) + single-fn))))) + +(define (**define/multiple fn args) + (make valdef + (lhs (**pat fn)) + (definitions + (map (lambda (arg) + (make single-fun-def + (args (map (function **pat) (car arg))) + (rhs-list (list (make guarded-rhs + (guard (**omitted-guard)) + (rhs (cadr arg))))) + (where-decls '()) + (infix? '#f))) + args)))) + +(define (suspend-vars vars) (map (lambda (v) (lambda () (**var v))) vars)) + +(define (temp-vars root arity) + (temp-vars1 root 1 arity)) + +(define (temp-vars1 root i arity) + (if (> i arity) + '() + (cons (string->symbol (string-append root (number->string i))) + (temp-vars1 root (1+ i) arity)))) + +(define (tuple-con algdata) + (car (algdata-constrs algdata))) + +(define (con-string x) + (remove-con-prefix (symbol->string (def-name x)))) diff --git a/derived/derived-instances.scm b/derived/derived-instances.scm new file mode 100644 index 0000000..2c65084 --- /dev/null +++ b/derived/derived-instances.scm @@ -0,0 +1,255 @@ + +;;; Basic DI structure: +;;; a. Create the set of instances +;;; b. Expand the context of each potential instance. +;;; c. Once b. reaches a fixpoint, fill in the ast for the generated instances + +(define *di-context-changed* '#f) + +(define (add-derived-instances modules) + (let ((insts '())) + (walk-modules modules + (lambda () (setf insts (append (find-derivable-instances) insts)))) + (compute-di-fixpoint insts) + (dolist (inst insts) + (when (instance-ok? inst) + (create-instance-fns inst) + (push inst (module-instance-defs + (table-entry *modules* + (def-module (instance-algdata inst))))))))) + +(define (compute-di-fixpoint insts) + (setf *di-context-changed* '#f) + (dolist (inst insts) + (propagate-di-context inst)) + (when *di-context-changed* (compute-di-fixpoint insts))) + +;;; Create instance decls for all derived instances in a module. Filter +;;; out underivable instances (Ix & Enum only) + +(define (find-derivable-instances) + (let ((algs (module-alg-defs *module*)) + (insts '())) + (dolist (alg algs) + (dolist (class (algdata-deriving alg)) + (cond ((memq class (list (core-symbol "Eq") + (core-symbol "Ord") + (core-symbol "Text") + (core-symbol "Binary"))) + (setf insts (add-derivable-instance insts alg class '#f))) + ((eq? class *printer-class*) + (setf insts (add-derivable-instance + insts alg (core-symbol "Text") '#t))) + ((eq? class (core-symbol "Ix")) + (if (or (algdata-enum? alg) + (algdata-tuple? alg)) + (setf insts (add-derivable-instance insts alg class '#f)) + (signal-cant-derive-ix alg))) + ((eq? class (core-symbol "Enum")) + (if (algdata-enum? alg) + (setf insts (add-derivable-instance insts alg class '#f)) + (signal-cant-derive-enum alg))) + (else + (signal-not-derivable class))))) + insts)) + + +(define (signal-cant-derive-ix alg) + (phase-error 'cant-derive-IX + "An Ix instance for ~A cannot be derived. It is not an enumeration~%~ + or single-constructor datatype." + alg)) + +(define (signal-cant-derive-enum alg) + (phase-error 'cant-derive-Enum + "An Enum instance for ~A cannot be derived. It is not an enumeration." + alg)) + +(define (signal-not-derivable class) + (recoverable-error 'not-derivable + "Class ~A is not one of the classes that permits derived instances." + class)) + + +;; This adds a provisional instance template. Of course, there may already +;;; be an instance (error!) + +(define (add-derivable-instance insts alg cls sp) + (let ((existing-inst (lookup-instance alg cls))) + (cond ((eq? existing-inst '#f) + (let ((inst (new-instance cls alg (algdata-tyvars alg)))) + (setf (instance-context inst) (algdata-context alg)) + (setf (instance-decls inst) '()) + (setf (instance-ok? inst) '#t) + (setf (instance-suppress-readers? inst) sp) + (cons inst insts))) + (else + (signal-instance-exists alg cls) + insts)))) + +(define (signal-instance-exists alg cls) + (recoverable-error 'instance-exists + "An instance for type ~A in class ~A already exists;~%~ + the deriving clause is being ignored." + alg cls)) + +;;; This updates all instance contexts for an algdata. Each derivable +;;; instance generates a recursive context for every field. If a +;;; component cannot satisfy the desired context, the ok? field is set to +;;; #f to mark the instance as bogus. + +(define (propagate-di-context inst) + (when (instance-ok? inst) + (propagate-constructor-contexts inst + (algdata-constrs (instance-algdata inst))))) + +;;; These two functions propagate the context to ever field of every +;;; constructor + +(define (propagate-constructor-contexts inst constrs) + (or (null? constrs) + (and (propagate-contexts inst (instance-class inst) + (con-types (car constrs))) + (propagate-constructor-contexts inst (cdr constrs))))) + +(define (propagate-contexts inst class types) + (or (null? types) + (and (propagate-type-context inst class (car types)) + (propagate-contexts inst class (cdr types))))) + +;;; This propagates a context out to a given type. The type can only contain +;;; the tyvars which are args to the algdata. + +(define (propagate-type-context inst class type) + (cond ((tyvar? type) + (cond ((single-ast-context-implies? + (instance-context inst) class (tyvar-name type)) + '#t) + (else + (setf *di-context-changed* '#t) + (setf (instance-context inst) + (augment-context (instance-context inst) class + (tyvar-name type))) + '#t))) + ((synonym? (tycon-def type)) + (propagate-type-context inst class (expand-synonym type))) + (else + (let* ((algdata (tycon-def type)) ; must be a algdata + (args (tycon-args type)) + (new-inst (lookup-instance algdata class))) + (cond ((or (eq? new-inst '#f) + (not (instance-ok? new-inst))) + (signal-cannot-derive-instance + (instance-class inst) (instance-algdata inst)) + (setf (instance-ok? inst) '#f) + (setf *di-context-changed* '#t) + '#f) + (else + (propagate-instance-contexts inst + (instance-context new-inst) + (instance-tyvars new-inst) + args))))))) + + +(define (single-ast-context-implies? ast-context class tyvar) + (cond ((null? ast-context) + '#f) + ((eq? tyvar (context-tyvar (car ast-context))) + (let ((class1 (class-ref-class (context-class (car ast-context))))) + (or (eq? class1 class) + (memq class (class-super* class1)) + (single-ast-context-implies? (cdr ast-context) class tyvar)))) + (else + (single-ast-context-implies? (cdr ast-context) class tyvar)))) + +;;; *** This message makes no sense to me. What is the problem that +;;; *** makes it impossible to derive the instance? + +(define (signal-cannot-derive-instance class alg) + (phase-error 'cannot-derive-instance + "Instance ~A(~A) cannot be derived." + class alg)) + + +;;; This propagates contexts into structure components. The context +;;; changes due to the context associated with the various instance +;;; decls encountered. + +;;; Here's the plan for expanding Cls(Alg t1 t2 .. tn) using +;;; instance (Cls1(vx),Cls2(vy),...) => Cls(Alg(v1 v2 .. vn)) +;;; for each Clsx in the instance context, propagate Clsx to the +;;; ti corresponding to vx, where vx must be in the set vi. + +(define (propagate-instance-contexts inst contexts tyvars args) + (or (null? contexts) + (and (propagate-type-context inst + (class-ref-class (context-class (car contexts))) + (find-corresponding-tyvar + (context-tyvar (car contexts)) tyvars args)) + (propagate-instance-contexts inst (cdr contexts) tyvars args)))) + +;;; Given the t(i) and the v(i), return the t corresponding to a v. + +(define (find-corresponding-tyvar tyvar tyvars args) + (if (eq? tyvar (car tyvars)) + (car args) + (find-corresponding-tyvar tyvar (cdr tyvars) (cdr args)))) + +;;; 1 level type synonym expansion + +(define (expand-synonym type) + (let* ((synonym (tycon-def type)) + (args (synonym-args synonym)) + (body (synonym-body synonym))) + (let ((alist (map (lambda (tyvar arg) (tuple tyvar arg)) + args (tycon-args type)))) + (copy-synonym-body body alist)))) + +(define (copy-synonym-body type alist) + (if (tyvar? type) + (tuple-2-2 (assq (tyvar-name type) alist)) + (make tycon (def (tycon-def type)) + (name (tycon-name type)) + (args (map (lambda (ty) + (copy-synonym-body ty alist)) + (tycon-args type)))))) + +;;; This fills in the body decls for an instance function. + +(define (create-instance-fns inst) + (let ((class (instance-class inst)) + (alg (instance-algdata inst))) + (cond ((eq? class (core-symbol "Eq")) + (add-instance inst (eq-fns alg))) + ((eq? class (core-symbol "Ord")) + (add-instance inst (ord-fns alg))) + ((eq? class (core-symbol "Ix")) + (add-instance inst (ix-fns alg))) + ((eq? class (core-symbol "Enum")) + (add-instance inst (enum-fns alg))) + ((eq? class (core-symbol "Text")) + (add-instance inst (text-fns alg (instance-suppress-readers? inst)))) + ((eq? class (core-symbol "Binary")) + (add-instance inst (binary-fns alg)))))) + +(define (add-instance inst decls) + (setf (instance-decls inst) decls)) + +;;; Add class(var) to a context, removing any contexts made redundant by +;;; the new addition. Example: adding Ord a to (Eq a, Eq b) would yield +;;; (Ord a,Eq b). + +(define (augment-context contexts cl var) + (cons (**context (**class/def cl) var) + (remove-implied-contexts cl var contexts))) + +(define (remove-implied-contexts class1 tyvar1 contexts) + (if (null? contexts) + '#f + (with-slots context (class tyvar) (car contexts) + (let ((rest (remove-implied-contexts class1 tyvar1 (cdr contexts))) + (class2 (class-ref-class class))) + (if (and (eq? tyvar1 tyvar) + (memq class2 (class-super* class1))) + rest + (cons (car contexts) rest)))))) diff --git a/derived/derived.scm b/derived/derived.scm new file mode 100644 index 0000000..975dab6 --- /dev/null +++ b/derived/derived.scm @@ -0,0 +1,21 @@ +;;; -- compilation unit definition for derived instances +;;; +;;; author : John +;;; + +(define-compilation-unit derived + (source-filename "$Y2/derived/") + (require global) + (unit derived-instances + (source-filename "derived-instances.scm")) + (unit ast-builders + (source-filename "ast-builders")) + (unit eq-ord + (source-filename "eq-ord")) + (unit ix-enum + (source-filename "ix-enum")) + (unit text-binary + (source-filename "text-binary")) + ) + + diff --git a/derived/eq-ord.scm b/derived/eq-ord.scm new file mode 100644 index 0000000..b005b58 --- /dev/null +++ b/derived/eq-ord.scm @@ -0,0 +1,69 @@ +;;; ---------------------------------------------------------------- +;;; Eq +;;; ---------------------------------------------------------------- + +(define (Eq-fns algdata) + (list + (cond ((algdata-enum? algdata) + (**define '== '(|x| |y|) + (**== (**con-number (**var '|x|) algdata) + (**con-number (**var '|y|) algdata)))) + (else + (**multi-define '== algdata + ;; For nullary constructors + (function **true) + ;; For unary constructors + (lambda (v1 v2) + (**== (funcall v1) (funcall v2))) + ;; For n-ary constructors + (lambda (v1 v2 bool) + (**and (**== (funcall v1) (funcall v2)) bool)) + ;; The else clause in case the constructors do + ;; not match. + (if (algdata-tuple? algdata) + '#f + (function **false))))))) + +;;; ---------------------------------------------------------------- +;;; Ord +;;; ---------------------------------------------------------------- + +(define (Ord-fns algdata) + (list (ord-fn1 algdata '< (function **<)) + (ord-fn1 algdata '<= (function **<=)))) + +(define (Ord-fn1 algdata fn prim) + (cond ((algdata-enum? algdata) + (**define fn '(|x| |y|) + (funcall prim (**con-number (**var '|x|) algdata) + (**con-number (**var '|y|) algdata)))) + ((algdata-tuple? algdata) + (**multi-define fn algdata + (function **false) + (lambda (x y) (funcall prim (funcall x) (funcall y))) + (function combine-eq-<) + '#f)) + (else + (**define fn '(|x| |y|) + (**let + (list + (**multi-define '|inner| algdata + (if (eq? fn '<) (function **false) + (function **true)) + (lambda (x y) + (funcall prim (funcall x) (funcall y))) + (function combine-eq-<) + '#f) + (**define '|cx| '() (**con-number (**var '|x|) algdata)) + (**define '|cy| '() (**con-number (**var '|y|) algdata))) + (**or (**< (**var '|cx|) (**var '|cy|)) + (**and (**== (**var `|cx|) (**var '|cy|)) + (**app (**var '|inner|) + (**var '|x|) + (**var '|y|))))))))) + +(define (combine-eq-< v1 v2 rest) + (**or (**< (funcall v1) (funcall v2)) + (**and (**== (funcall v1) (funcall v2)) + rest))) + diff --git a/derived/ix-enum.scm b/derived/ix-enum.scm new file mode 100644 index 0000000..fb9a282 --- /dev/null +++ b/derived/ix-enum.scm @@ -0,0 +1,116 @@ +;;; ---------------------------------------------------------------- +;;; Ix +;;; ---------------------------------------------------------------- + +(define (ix-fns algdata) + (if (algdata-enum? algdata) + (ix-fns/enum algdata) + (ix-fns/tuple algdata))) + +(define (ix-fns/enum algdata) + (list + (**define '|range| '((tuple |l| |u|)) + (**let + (list + (**define '|cl| '() (**con-number (**var '|l|) algdata)) + (**define '|cu| '() (**con-number (**var '|u|) algdata))) + (**if (**< (**var '|cu|) (**var '|cl|)) + (**null) + (**take (**+ (**- (**var '|cu|) (**var '|cl|)) (**int 1)) + (**drop (**var '|cl|) + (**list/l + (map (function **con/def) + (algdata-constrs algdata)))))))) + (**define '|index| '((tuple |l| |u|) |x|) + (**- (**con-number (**var '|x|) algdata) + (**con-number (**var '|l|) algdata))) + (**define '|inRange| '((tuple |l| |u|) |x|) + (**and (**<= (**con-number (**var '|l|) algdata) + (**con-number (**var '|x|) algdata)) + (**<= (**con-number (**var '|x|) algdata) + (**con-number (**var '|u|) algdata)))))) + +(define (ix-fns/tuple algdata) + (let* ((con (tuple-con algdata)) + (arity (con-arity con)) + (llist (temp-vars "l" arity)) + (ulist (temp-vars "u" arity)) + (ilist (temp-vars "i" arity))) + (list + (**define '|range| `((tuple (,con ,@llist) (,con ,@ulist))) + (**listcomp (**app/l (**con/def con) (map (function **var) ilist)) + (map (lambda (iv lv uv) + (**gen iv + (**app (**var '|range|) + (**tuple2 (**var lv) + (**var uv))))) + ilist llist ulist))) + (**define '|index| `((tuple (,con ,@llist) (,con ,@ulist)) + (,con ,@ilist)) + (index-body (reverse ilist) (reverse llist) (reverse ulist))) + (**define '|inRange| `((tuple (,con ,@llist) (,con ,@ulist)) + (,con ,@ilist)) + (inrange-body ilist llist ulist))))) + +(define (index-body is ls us) + (let ((i1 (**app (**var '|index|) + (**tuple2 (**var (car ls)) (**var (car us))) + (**var (car is))))) + (if (null? (cdr is)) + i1 + (**app (**var '|+|) + i1 (**app (**var '|*|) + (**1+ (**app (**var '|index|) + (**tuple2 (**var (car ls)) + (**var (car us))) + (**var (car us)))) + (index-body (cdr is) (cdr ls) (cdr us))))))) + +(define (inrange-body is ls us) + (let ((i1 (**app (**var '|inRange|) + (**tuple2 (**var (car ls)) (**var (car us))) + (**var (car is))))) + (if (null? (cdr is)) + i1 + (**app (**var/def (core-symbol "&&")) + i1 + (inrange-body (cdr is) (cdr ls) (cdr us)))))) + +;;; ---------------------------------------------------------------- +;;; Enum +;;; ---------------------------------------------------------------- + +; Enum uses the Int methods since Enums are represented as Ints. + +(define (enum-fns algdata) + (list + (**define '|enumFrom| '(|x|) + (**let + (list + (**define '|from'| '(|x'|) + (**if (**> (**var '|x'|) + (**con-number (**con/def (last-con algdata)) algdata)) + (**null) + (**cons (**var '|x'|) + (**app (**var '|from'|) (**1+ (**var '|x'|))))))) + (**cast (**app (**var '|from'|) + (**con-number (**var '|x|) algdata))))) + (**define '|enumFromThen| '(|x| |y|) + (**let + (list + (**define '|step| '() + (**- (**con-number (**var '|y|) algdata) + (**con-number (**var '|x|) algdata))) + (**define '|from'| '(|x'|) + (**if (**or (**> (**var '|x'|) + (**con-number (**con/def (last-con algdata)) algdata)) + (**< (**var '|x'|) (**int 0))) + (**null) + (**cons (**var '|x'|) + (**app (**var '|from'|) + (**+ (**var '|x'|) (**var '|step|))))))) + (**cast (**app (**var '|from'|) (**con-number (**var '|x|) algdata))))))) + +(define (last-con algdata) + (car (reverse (algdata-constrs algdata)))) + diff --git a/derived/text-binary.scm b/derived/text-binary.scm new file mode 100644 index 0000000..1779d1a --- /dev/null +++ b/derived/text-binary.scm @@ -0,0 +1,228 @@ +;;; ---------------------------------------------------------------- +;;; Text +;;; ---------------------------------------------------------------- + +(define (text-fns algdata suppress-reader?) + (let ((print+read + (cond ((algdata-enum? algdata) + (text-enum-fns algdata)) + (else + (text-general-fns algdata))))) + (when suppress-reader? + (setf print+read (list (car print+read)))) + print+read)) + +(define (text-enum-fns algdata) + (list + (**define '|showsPrec| '(|d| |x|) + (**case/con algdata (**var '|x|) + (lambda (con vars) + (declare (ignore vars)) + (**showString (**string (con-string con)))))) + (**define '|readsPrec| '(|d| |str|) + (**listcomp + (**var '|s|) + (list + (**gen '(tuple |tok| |rest|) (**lex (**var '|str|))) + (**gen '|s| + (**case (**var '|tok|) + `(,@(map (lambda (con) + (**alt/simple + (**pat (con-string con)) + (**list (**tuple2 (**con/def con) + (**var '|rest|))))) + (algdata-constrs algdata)) + ,(**alt/simple (**pat '_) (**null)))))))))) + +;;; This has been hacked to split up the read function for large +;;; data types to avoid choking the lisp compiler. + +(define (text-general-fns algdata) + (let ((split-fn-def? (> (algdata-n-constr algdata) 6))) ;; pretty arbitrary! + (list + (**define '|showsPrec| '(|d| |x|) + (**case/con algdata (**var '|x|) + (lambda (con vars) + (if (con-infix? con) + (show-infix con vars) + (show-prefix con vars))))) + (**define '|readsPrec| '(|d| |str|) + (**append/l + (map (lambda (con) + (cond ((con-infix? con) + (read-infix con)) + (else + (read-prefix con split-fn-def?)))) + (algdata-constrs algdata))))))) + +(define (show-infix con vars) + (multiple-value-bind (p lp rp) (get-con-fixity con) + (**showParen + (**< (**Int p) (**var '|d|)) + (**dot (**showsPrec (**int lp) (**var (car vars))) + (**showString + (**string (string-append " " (con-string con) " "))) + (**showsPrec (**int rp) (**var (cadr vars))))))) + +(define (show-prefix con vars) + (**showParen + (**<= (**int 10) (**var '|d|)) + (**dot/l (**showString (**string (con-string con))) + (show-fields vars)))) + +(define (show-fields vars) + (if (null? vars) + '() + `(,(**space) ,(**showsPrec (**int 10) (**var (car vars))) + ,@(show-fields (cdr vars))))) + +(define (read-infix con) + (multiple-value-bind (p lp rp) (get-con-fixity con) + (**let + (list + (**define '|readVal| '(|r|) + (**listcomp + (**tuple2 (**app (**con/def con) (**var '|u|) (**var '|v|)) + (**var '|s2|)) + (list + (**gen '(tuple |u| |s0|) + (**readsPrec (**int lp) (**var '|r|))) + (**gen `(tuple ,(con-string con) |s1|) + (**lex (**var '|s0|))) + (**gen '(tuple |v| |s2|) + (**readsprec (**int rp) (**var '|s1|))))))) + (**readParen (**< (**int p) (**var '|d|)) + (**var '|readVal|) (**var '|str|))))) + +(define (read-prefix con split?) + (let ((res (read-prefix-1 con))) + (if (not split?) + res + (dynamic-let ((*module-name* (def-module con))) + (dynamic-let ((*module* (table-entry *modules* *module-name*))) + (let* ((alg (con-alg con)) + (fn (make-new-var + (string-append (symbol->string (def-name alg)) + "/read-" + (remove-con-prefix + (symbol->string (def-name con)))))) + (new-code (**app (**var/def fn) (**var '|str|) (**var '|d|))) + (def (**define fn '(|str| |d|) res))) + (setf (module-decls *module*) (cons def (module-decls *module*))) + new-code)))))) + +(define (read-prefix-1 con) + (let* ((arity (con-arity con)) + (vars (temp-vars "x" arity)) + (svars (cons '|rest| (temp-vars "s" arity)))) + (**let + (list + (**define '|readVal| '(|r|) + (**listcomp + (**tuple2 (**app/l (**con/def con) (map (function **var) vars)) + (**var (car (reverse svars)))) + (cons + (**gen `(tuple ,(con-string con) |rest|) + (**lex (**var '|r|))) + (read-fields vars svars (cdr svars)))))) + (**readParen (**< (**int 9) (**var '|d|)) + (**var '|readVal|) (**var '|str|))))) + +(define (read-fields vars s0 s1) + (if (null? vars) + '() + (cons + (**gen `(tuple ,(car vars) ,(car s1)) + (**readsprec (**int 10) (**var (car s0)))) + (read-fields (cdr vars) (cdr s0) (cdr s1))))) + + +;;; ---------------------------------------------------------------- +;;; Binary +;;; ---------------------------------------------------------------- + +(define (binary-fns algdata) + (let ((res + (cond ((algdata-enum? algdata) + (binary-enum-fns algdata)) + ((algdata-tuple? algdata) + (binary-tuple-fns algdata)) + (else + (binary-general-fns algdata))))) +; (dolist (x res) +; (fresh-line) +; (pprint x)) + res)) + + +(define (binary-enum-fns algdata) + (list + (**define '|showBin| '(|x| |b|) + (**showBinInt (**con-number (**var '|x|) algdata) (**var '|b|))) + (**define '|readBin| '(|b|) + (**let + (list + (**define '(tuple |n| |b1|) '() + (**readBinSmallInt + (**var '|b|) + (**int (1- (algdata-n-constr algdata)))))) + (**tuple2 + (**case/int algdata (**var '|n|) + (lambda (con) + (**con/def con))) + (**var '|b1|)))))) + +(define (binary-tuple-fns algdata) + (let* ((con (tuple-con algdata)) + (arity (con-arity con)) + (vars (temp-vars "v" arity))) + (list + (**define '|showBin| `((,con ,@vars) |b|) + (show-binary-body vars '|b|)) + (**define '|readBin| '(|b|) + (read-binary-body con))))) + +(define (show-binary-body vars b) + (**foldr (lambda (new-term prev-terms) + (**showBin new-term prev-terms)) + (map (function **var) vars) + (**var b))) + +(define (read-binary-body con) + (let* ((arity (con-arity con)) + (vars (temp-vars "v" arity)) + (bvars (cons '|b| (temp-vars "b" arity)))) + (**let + (map (lambda (v b nb) + (**define `(tuple ,v ,nb) '() + (**readBin (**var b)))) + vars bvars (cdr bvars)) + (**tuple2 + (**app/l (**con/def con) + (map (function **var) vars)) + (**var (car (reverse bvars))))))) + +(define (binary-general-fns algdata) + (list + (**define '|showBin| '(|x| |b|) + (**showBinInt + (**con-number (**var '|x|) algdata) + (**case/con algdata (**var '|x|) + (lambda (con vars) + (declare (ignore con)) + (show-binary-body vars '|b|))))) + (**define '|readBin| '(|bin|) + (**let + (list + (**define '(tuple |i| |b|) '() + (**readBinSmallInt (**var '|bin|) + (**int (1- (algdata-n-constr algdata)))))) + (**case/int algdata (**var '|i|) (function read-binary-body)))))) + +(define (get-con-fixity con) + (let ((fixity (con-fixity con))) + (if (not (eq? fixity '#f)) + (let ((p (fixity-precedence fixity)) + (a (fixity-associativity fixity))) + (values p (if (eq? a 'L) p (1+ p)) (if (eq? a 'R) p (1+ p)))) + (values 9 10 9)))) diff --git a/doc/announcement b/doc/announcement new file mode 100644 index 0000000..8c9e8f1 --- /dev/null +++ b/doc/announcement @@ -0,0 +1,64 @@ + + Announcing the release of Yale Haskell 2.0.5 + +We are releasing the latest version of the Yale Haskell system, +Y2.0.5, in source form. This fixes a number of minor problems in the +2.0.5a release (for Sparc only) and should be relatively bug free. + +Yale Haskell can be built from sources using CMU Common Lisp, Lucid +Common Lisp, Allegro Common Lisp, or Harlequin LispWorks. The system +may also build on akcl but the performance is very poor. + +Compiled versions of the system are available for Sparc systems running +SunOS 4.1.2 and Sparc 10's (sun4m) running 4.1.3. Anyone building a system +using CMU lisp on a different platform should let us know and we will +add more executables to the ftp area. Look at the README for further +information. + +This release features an X window interface. Using CLX, the full +functionality of X windows has been made available at the Haskell +level. There is also a Haskell <-> Lisp interface similar to the C +interface in the Glasgow system. + + +Our system is available for anonymous ftp from the Yale Haskell ftp site: + + Site Host name Raw IP address + Yale nebula.cs.yale.edu 128.36.13.1 + +All files are in the directory pub/haskell/yale. + +haskell-source-205.tar.gz -- The full sources +haskell-205-<machine+OS>.tar.gz +Compiling from scratch will take an hour or two, depending on system +resources. The file $HASKELL/com/<your-lisp>/README will contain +complete building instructions. + +To obtain Yale Haskell via ftp: + + - Move to the directory where you intend to place Yale Haskell + - Ftp to nebula and login anonymously + - cd to pub/haskell/yale + - Get the tar file: get haskell-source-205.tar.gz (a .Z file is available + for those without gzip). + - Unzip the file: (your zip utility may have a different name) + gzip -d *.gz + - Untar the file: tar xf *.tar + - Consult the documentation for further instructions. Either print + out the reference manual in doc/manual/haskell.dvi or look at + install.verb in the same directory. + +Send any comments or questions to haskell-request@cs.yale.edu + + +New features in this release include: + + * Much better optimization + * Monadic I/O + * A general Haskell to Lisp interface + * An X window interface + * Strictness annotations and strict data constructors + * Lots of bugs fixed + * Improvements to the tutorial and Emacs interface + * Ported to all major Lisp systems + diff --git a/doc/comparison b/doc/comparison new file mode 100644 index 0000000..43c6073 --- /dev/null +++ b/doc/comparison @@ -0,0 +1,291 @@ + + Different Versions of Yale Haskell Compared + ------------------------------------------- + + +There are currently three different platforms running Yale Haskell. +Yale Haskell runs on Lucid Common Lisp, CMU Common Lisp, and AKCL. This +document describes the differences between these systems. + +Differences in performance between the different versions of Yale +Haskell reflect the underlying Lisp systems. The better the Lisp +system, the better the Haskell system built on it. However, getting +optimal performance from our Haskell system on top of a Common Lisp +system requires careful attention to the underlying compiler. Small +changes in the optimization settings or the addition of crucial +declarations can make significant differences in performance. We have +been doing most of our work using the Lucid system and have tuned it +more than the others. These comparisons are greatly influenced by the +amount of time we have spent tuning the system: the CMU version has +been tuned only a little and the AKCL version hardly at all. + + + Methodology + +The following timings are only approximate. They were obtained using +the timing functions provided by the Common Lisp system. All timings +were done on an unloaded Sparc 1. No attempt was made to account for +garbage collection, differences in heap size, or similar factors. We +don't intend these benchmark results to be taken as an exhaustive +comparison of the different Lisp implementations involved. + + + Portability + +We have had no trouble moving our system to different hardware +platforms under the same Lisp system. Since the release is in source +form, we expect that users will be able to build on any hardware +platform supported by one the Lisps we have ported to. Probably the +only real constraint on portability is the requirement for a large +virtual memory space. + +From the comp.lang.lisp FAQ: + + Lucid Common Lisp runs on a variety of platforms, including PCs (AIX), + Apollo, HP, Sun-3, Sparc, IBM RT, IBM RS/6000, Decstation 3100, + Silicon Graphics, and Vax. + + CMU Common Lisp is free, and runs on Sparcs (Mach and SunOs), + DecStation 3100 (Mach), IBM RT (Mach) and requires 16mb RAM, 25mb disk. + + Kyoto Common Lisp (KCL) is free, but requires a license. Conforms to CLtL1. + It is available by anonymous ftp from rascal.ics.utexas.edu [128.83.138.20], + cli.com [192.31.85.1], or [133.11.11.11] (a machine in Japan) + in the directory /pub. AKCL is in the file akcl-xxx.tar.Z (take the + highest value of xxx). To obtain KCL, one must first sign and mail a + copy of the license agreement to: Special Interest Group in LISP, + c/o Taiichi Yuasa, Department of Computer Science, Toyohashi + University of Technology, Toyohashi 441, JAPAN. Runs on Sparc, + IBM RT, RS/6000, DecStation 3100, hp300, hp800, Macintosh II (under AUX), + mp386, IBM PS2, Silicon Graphics 4d, Sun3, Sun4, Sequent Symmetry, + IBM 370, NeXT and Vax. A port to DOS is in beta test as + math.utexas.edu:pub/beta2.zip. + +We have not yet completed ports of Yale Haskell to any other Lisp +implementations, although we are likely to do so in the future. + + + System Size + +The overall size of the Haskell system depends on the size of the +underlying Lisp system and how much unnecessary Lisp overhead has been +removed for the system. We have removed large Lisp packages (like +CLOS or CLX), but have not attempted to do any tree shaking. The size +of the saved images (including the Lisp system, the Haskell compiler, +and the compiled prelude) is + +Image Size: + +Lucid 10 meg +CMU 18 meg +AKCL 11 meg + +The larger size of the CMU system is probably an artifact of their way +of saving the system. + + + Compilation Time + +There are three possible ways to compile a Haskell program. All +Haskell programs must be translated into Lisp. The generated Lisp can +then be interpreted, using no additional compilation time; compiled +with a `fast' but nonoptimizing Lisp compiler; or compiled with the +`slow' compiler that aggressively attempts to perform as many +optimizations as possible. + +To time the `fast', nonoptimizing compiler, we have been using + +(PROCLAIM '(OPTIMIZE (SPEED 3) (SAFETY 0) (COMPILATION-SPEED 3))) + +and for the `slow', fully optimizing compiler, we have been using + +(PROCLAIM '(OPTIMIZE (SPEED 3) (SAFETY 0) (COMPILATION-SPEED 0))) + +so that the only difference is in the COMPILATION-SPEED quality. +Lucid does, in fact, provide two completely different compilers that +correspond to these optimize settings. For all three implementations, +it appears that that the effect of a higher compilation speed setting +is primarily in being less aggressive about inlining and making use of +type declarations. + +The Haskell system itself (including the Prelude) is normally built +with the fully optimizing compiler. + +To show just the Haskell to Lisp compilation time, here are the times +needed to compile the Prelude (about 2500 lines of Haskell code). +This does not include the time in the Lisp compiler or starting up the +system. + +Time to compile the Prelude into Lisp: (CPU times) + +Lucid 111 sec +CMU 87 sec +AKCL 576 sec + +Running the Lisp compiler on the generated code takes far longer than +running the Haskell compiler to produce the Lisp code. For example, +the optimizing Lucid compiler takes 47 minutes to compile the Prelude +(about x20 slower than Haskell -> Lisp). The nonoptimizing compiler +is significantly faster but generates poorer code. + +The following times are the Lisp compilation time for the Prolog +interpreter (found in the demo directory of our release): + +Lucid - interpreted 8.8 sec Haskell -> Lisp +Lucid - nonopt 20.0 sec Lisp -> Machine code +Lucid - optimizing 320.0 sec Lisp -> Machine code +CMU - interpreted 12.4 sec Haskell -> Lisp +CMU - nonopt 121.0 sec Lisp -> Machine code +CMU - optimizing 152.8 sec Lisp -> Machine code +AKCL - interpreted 47.8 sec Haskell -> Lisp +AKCL - nonopt ~180 sec Lisp -> Machine code +AKCL - optimizing ~360 sec Lisp -> Machine code + +The AKCL timings are only approximate, because the Lisp timing +functions do not capture the time spent in the C compiler. + + +Code Speed + +The speed of the Haskell program depends on whether the Lisp code +has been compiled with the optimizing or nonoptimizing compiler, or +is running interpretively. + +The first benchmark is nfib, which indicates the basic speed of +function calling and Int arithmetic. + +module Main where + +nfib :: Int -> Int +nfib 0 = 1 +nfib 1 = 1 +nfib n = nfib (n-1) + nfib (n-2) + + + nfib 20 nfib 30 +Lucid (Interpreted) 116 sec * +Lucid (nonopt) 0.14 sec 9.4 sec +Lucid (optimizing) 0.08 sec 4.8 sec +CMU (Interpreted) 23.8 sec * +CMU (nonopt) 0.24 sec 6.9 sec +CMU (optimizing) 0.11 sec 7.0 sec +AKCL (Interpreted) 141 sec * +AKCL (nonopt) 0.20 sec 21.3 sec +AKCL (optimizing) 0.15 sec 18.2 sec + +* Too slow to benchmark + +For other data types, there was no significant difference betwen +optimizing and nonoptimizing compilation in any of the systems. +Changing the signature of nfib to Integer -> Integer: + + nfib 20 nfib 30 +Lucid (interpreted) 140 sec * +Lucid (compiled) 0.18 sec 10.2 sec +CMU (interpreted) 24.2 sec * +CMU (compiled) 0.16 sec 10.5 sec +AKCL (interpreted) 145 sec * +AKCL (compiled) 1.07 sec 127 sec + +Nfib with signature Float -> Float: + + nfib 20 nfib 30 +Lucid (interpreted) 222 sec * +Lucid (compiled) 16.4 sec 2416 sec +CMU (interpreted) 44.2 sec * +CMU (compiled) 1.61 sec 352 sec +AKCL (interpreted) 161 sec * +AKCL (compiled) 103 sec * + +Overloaded functions run considerably slower than nonoverloaded +functions. By allowing nfib to remain overloaded, Num a => a -> a, +and using the Int overloading the same benchmarks run much slower. +Again, there is no real difference between the different compiler +optimization settings. + + nfib 15 nfib 20 +Lucid (interpreted) 14.2 sec 156 sec +Lucid (compiled) 0.97 sec 9.3 sec +CMU (interpreted) 23.8 sec 155 sec +CMU (compiled) 0.89 sec 15.6 sec +AKCL (interpreted) 30.8 sec 387 sec +AKCL (compiled) 10.3 sec 119 sec + +Basic Haskell data structuring operations (pattern matching and +construction) can be tested using another version of nfib which uses +natural numbers: + + data Nat = Z | S Nat + +The difference betwen CMU and Lucid here is consistent with other +benchmarks that manipulate structures. + + nfib 10 nfib 15 +Lucid (Interpreted) 1.39 sec 26.7 sec +Lucid (compiled) 0.26 sec 2.28 sec +CMU (interpreted) 3.1 sec <stack overflow> +CMU (compiled) 0.16 sec 0.54 sec +AKCL (Interpreted) 4.25 sec <stack overflow> +AKCL (compiled) 0.21 sec 13.9 sec + + + A Large Program + +For a final benchmark, we use the Prolog interpreter as a way of +getting a feel for general performance of larger programs. This +program is typical of symbolic (as opposed to numeric) computation. + +Time to solve append(X,Y,cons(a,cons(b,cons(c,nil)))): + +Lucid 12.2 sec +CMU 12.0 sec +AKCL 69.1 sec + +My interpretation of this result is that although Lucid is a bit +slower on the previous small benchmarks, it makes up for this is +larger programs where advantages like better instruction scheduling, +register allocation, or memory usage may make a difference. In +general, Lucid and CMU are very similar in performance for larger +programs. + + + Conclusions + +Briefly stated, the pluses and minuses of each system are as follows: + +Lucid (4.0.0): + + Development (nonoptimizing) compiler is very fast + + Fast Haskell -> Lisp compilation + + Generates good code + + Very robust + - Costs money + - Slow floating point code + - Fairly slow interpreter + - The production (optimizing) compiler is extremely slow. + +CMU (16e): + + Free + + As fast as Lucid for Haskell -> Lisp + + Good floating point performance + + Generated code is very fast + + Fast interpreter + - Slow Lisp -> machine code compilation + - Doesn't run on many systems + +AKCL (1.615): + + Free + + Widely portable + - Slow (generally 3 - 5 times slower, sometimes much worse) + - Flakey (tends to core dump on errors, choke on large programs, etc.) + +Generally, using the fully optimizing compiler seems to be useful only +in code involving Int arithmetic. + +The fast compiler for Lucid is a big advantage, delivering by far the +fastest compilation to machine code with relatively little loss in +speed compared to the optimizing compiler. + + + Yale Haskell Group + September 25, 1992 + diff --git a/doc/lisp-interface/lisp-interface.dvi b/doc/lisp-interface/lisp-interface.dvi Binary files differnew file mode 100644 index 0000000..b45e902 --- /dev/null +++ b/doc/lisp-interface/lisp-interface.dvi diff --git a/doc/manual/haskell.dvi b/doc/manual/haskell.dvi Binary files differnew file mode 100644 index 0000000..a789515 --- /dev/null +++ b/doc/manual/haskell.dvi diff --git a/doc/optimizer/optimizer.dvi b/doc/optimizer/optimizer.dvi Binary files differnew file mode 100644 index 0000000..8d0d2bc --- /dev/null +++ b/doc/optimizer/optimizer.dvi diff --git a/doc/tutorial/tutorial.ps b/doc/tutorial/tutorial.ps new file mode 100644 index 0000000..333d9da --- /dev/null +++ b/doc/tutorial/tutorial.ps @@ -0,0 +1,6257 @@ +%!PS-Adobe-2.0 +%%Creator: dvips, version 5.4 (C) 1986-90 Radical Eye Software +%%Title: tutorial.dvi +%%Pages: 53 1 +%%BoundingBox: 0 0 612 792 +%%EndComments +%%BeginProcSet: tex.pro +/TeXDict 200 dict def TeXDict begin /N /def load def /B{bind def}N /S /exch +load def /X{S N}B /TR /translate load N /isls false N /vsize 10 N /@rigin{ +isls{[0 1 -1 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale +Resolution VResolution vsize neg mul TR}B /@letter{/vsize 10 N}B /@landscape{ +/isls true N /vsize -1 N}B /@a4{/vsize 10.6929133858 N}B /@a3{/vsize 15.5531 N +}B /@ledger{/vsize 16 N}B /@legal{/vsize 13 N}B /@manualfeed{statusdict +/manualfeed true put}B /@copies{/#copies X}B /FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0 +]N /df{/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0 +]N df-tail}B /df-tail{/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N +/FontBBox FBB N string /base X array /BitMaps X /BuildChar{CharBuilder}N +/Encoding IE N end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[ +}B /E{pop nn dup definefont setfont}B /ch-image{ch-data dup type /stringtype +ne{ctr get /ctr ctr 1 add N}if}B /ch-width{ch-data dup length 5 sub get}B +/ch-height{ch-data dup length 4 sub get}B /ch-xoff{128 ch-data dup length 3 +sub get sub}B /ch-yoff{ch-data dup length 2 sub get 127 sub}B /ch-dx{ch-data +dup length 1 sub get}B /ctr 0 N /CharBuilder{save 3 1 roll S dup /base get 2 +index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx 0 ch-xoff ch-yoff +ch-height sub ch-xoff ch-width add ch-yoff setcachedevice ch-width ch-height +true[1 0 0 -1 -.1 ch-xoff sub ch-yoff .1 add]{ch-image}imagemask restore}B /D{ +/cc X dup type /stringtype ne{]}if nn /base get cc ctr put nn /BitMaps get S +ctr S sf 1 ne{dup dup length 1 sub dup 2 index S get sf div put}if put /ctr +ctr 1 add N}B /I{cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI +save N @rigin 0 0 moveto}B /eop{clear SI restore showpage userdict /eop-hook +known{eop-hook}if}B /@start{userdict /start-hook known{start-hook}if +/VResolution X /Resolution X 1000 div /DVImag X /IE 256 array N 0 1 255{IE S 1 +string dup 0 3 index put cvn put}for}B /p /show load N /RMat[1 0 0 -1 0 0]N +/BDot 8 string N /v{/ruley X /rulex X V}B /V{gsave TR -.1 -.1 TR rulex ruley +scale 1 1 false RMat{BDot}imagemask grestore}B /a{moveto}B /delta 0 N /tail{ +dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}B /d{ +-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 +-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 +{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 +/eos{clear SS restore}B end +%%EndProcSet +%%BeginProcSet: special.pro +TeXDict begin /SDict 200 dict N SDict begin /@SpecialDefaults{/hs 612 N /vs +792 N /ho 0 N /vo 0 N /hsc 1 N /vsc 1 N /ang 0 N /CLIP false N /BBcalc false N +/p 3 def}B /@scaleunit 100 N /@hscale{@scaleunit div /hsc X}B /@vscale{ +@scaleunit div /vsc X}B /@hsize{/hs X /CLIP true N}B /@vsize{/vs X /CLIP true +N}B /@hoffset{/ho X}B /@voffset{/vo X}B /@angle{/ang X}B /@rwi{10 div /rwi X} +B /@llx{/llx X}B /@lly{/lly X}B /@urx{/urx X}B /@ury{/ury X /BBcalc true N}B +/magscale true def end /@MacSetUp{userdict /md known{userdict /md get type +/dicttype eq{md begin /letter{}N /note{}N /legal{}N /od{txpose 1 0 mtx +defaultmatrix dtransform S atan/pa X newpath clippath mark{transform{ +itransform moveto}}{transform{itransform lineto}}{6 -2 roll transform 6 -2 +roll transform 6 -2 roll transform{itransform 6 2 roll itransform 6 2 roll +itransform 6 2 roll curveto}}{{closepath}}pathforall newpath counttomark array +astore /gc xdf pop ct 39 0 put 10 fz 0 fs 2 F/|______Courier fnt invertflag{ +PaintBlack}if}N /txpose{pxs pys scale ppr aload pop por{noflips{pop S neg S TR +pop 1 -1 scale}if xflip yflip and{pop S neg S TR 180 rotate 1 -1 scale ppr 3 +get ppr 1 get neg sub neg ppr 2 get ppr 0 get neg sub neg TR}if xflip yflip +not and{pop S neg S TR pop 180 rotate ppr 3 get ppr 1 get neg sub neg 0 TR}if +yflip xflip not and{ppr 1 get neg ppr 0 get neg TR}if}{noflips{TR pop pop 270 +rotate 1 -1 scale}if xflip yflip and{TR pop pop 90 rotate 1 -1 scale ppr 3 get +ppr 1 get neg sub neg ppr 2 get ppr 0 get neg sub neg TR}if xflip yflip not +and{TR pop pop 90 rotate ppr 3 get ppr 1 get neg sub neg 0 TR}if yflip xflip +not and{TR pop pop 270 rotate ppr 2 get ppr 0 get neg sub neg 0 S TR}if} +ifelse scaleby96{ppr aload pop 4 -1 roll add 2 div 3 1 roll add 2 div 2 copy +TR .96 dup scale neg S neg S TR}if}N /cp{pop pop showpage pm restore}N end}if} +if}N /normalscale{Resolution 72 div VResolution 72 div neg scale magscale{ +DVImag dup scale}if}N /psfts{S 65536 div N}N /startTexFig{/psf$SavedState save +N userdict maxlength dict begin /magscale false def normalscale currentpoint +TR /psf$ury psfts /psf$urx psfts /psf$lly psfts /psf$llx psfts /psf$y psfts +/psf$x psfts currentpoint /psf$cy X /psf$cx X /psf$sx psf$x psf$urx psf$llx +sub div N /psf$sy psf$y psf$ury psf$lly sub div N psf$sx psf$sy scale psf$cx +psf$sx div psf$llx sub psf$cy psf$sy div psf$ury sub TR /showpage{}N +/erasepage{}N /copypage{}N @MacSetUp}N /doclip{psf$llx psf$lly psf$urx psf$ury +currentpoint 6 2 roll newpath 4 copy 4 2 roll moveto 6 -1 roll S lineto S +lineto S lineto closepath clip newpath moveto}N /endTexFig{end psf$SavedState +restore}N /@beginspecial{SDict begin /SpecialSave save N gsave normalscale +currentpoint TR @SpecialDefaults}B /@setspecial{CLIP{newpath 0 0 moveto hs 0 +rlineto 0 vs rlineto hs neg 0 rlineto closepath clip}{initclip}ifelse ho vo TR +hsc vsc scale ang rotate BBcalc{rwi urx llx sub div dup scale llx neg lly neg +TR}if /showpage{}N /erasepage{}N /copypage{}N newpath}B /@endspecial{grestore +clear SpecialSave restore end}B /@defspecial{SDict begin}B /@fedspecial{end}B +/li{lineto}B /rl{rlineto}B /rc{rcurveto}B /np{/SaveX currentpoint /SaveY X N 1 +setlinecap newpath}B /st{stroke SaveX SaveY moveto}B /fil{fill SaveX SaveY +moveto}B /ellipse{/endangle X /startangle X /yrad X /xrad X /savematrix matrix +currentmatrix N TR xrad yrad scale 0 0 1 startangle endangle arc savematrix +setmatrix}B end +%%EndProcSet +TeXDict begin 1000 300 300 @start /Fa 3 84 df<00000000C000000001E000000003E000 +000003C000000007C00000000F800000001F000000001E000000003E000000007C00000000F800 +000000F000000001F000000003E000000007C000000007800000000F800000001F000000003E00 +0000003C000000007C00000000F800000001F000000001E000000003E000000007C00000000780 +0000000F800000001F000000003E000000003C000000007C00000000F800000001F000000001E0 +00000003E000000007C00000000F800000000F000000001F000000003E000000007C0000000078 +00000000F800000000F0000000006000000000232E82AB1F>19 D<00000000001800000000003C +0000000000FC0000000001F80000000003F00000000007E0000000001F80000000003F00000000 +007E0000000001FC0000000003F00000000007E0000000000FC0000000003F00000000007E0000 +000000FC0000000001F80000000007E0000000000FC0000000001F80000000007F0000000000FC +0000000001F80000000003F0000000000FC0000000001F80000000003F00000000007E00000000 +01F80000000003F00000000007E0000000001FC0000000003F00000000007E0000000000FC0000 +000000F000000000006000000000002E2582A22A>35 D<6000000000F000000000F80000000078 +000000007C000000003E000000001F000000000F000000000F8000000007C000000003E0000000 +01E000000001F000000000F8000000007C000000003C000000003E000000001F000000000F8000 +0000078000000007C000000003E000000001E000000001F000000000F8000000007C000000003C +000000003E000000001F000000000F80000000078000000007C000000003E000000001F0000000 +00F000000000F8000000007C000000003E000000001E000000001F000000000F8000000007C000 +000003C000000003E000000001E000000000C0232E82AB1F>83 D E /Fb +5 111 df<004000C000C003800D8001800180030003000300030006000600060006000C000C00 +0C000C001800FF800A157C9412>49 D<030706000000000000384C4C4C8C181818303262622438 +08177D960B>105 D<003000700020000000000000000000000000038004400460046008C000C0 +00C000C0018001800180018003000300030003006600E600CC0070000C1D81960B>I<1F000600 +0600060006000C000C000C000C001870189819381A30340038003E0033006300631063106310C3 +20C1C00D177D9610>I<387044984708460C8C180C180C180C1818301831186118623026303810 +0E7D8D14>110 D E /Fc 46 122 df<000FF07F00007FF9FF8000F83FC7C001E07F8FC003E07F +0FC007C07F0FC007C03F078007C01F000007C01F000007C01F000007C01F000007C01F0000FFFF +FFF800FFFFFFF80007C01F000007C01F000007C01F000007C01F000007C01F000007C01F000007 +C01F000007C01F000007C01F000007C01F000007C01F000007C01F000007C01F000007C01F0000 +07C01F000007C01F00003FF8FFF0003FF8FFF0002220809F1F>11 D<FFF0FFF0FFF0FFF00C047F +8B11>45 D<387CFEFEFE7C3807077C860F>I<00E00001E0000FE000FFE000F3E00003E00003E0 +0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0 +0003E00003E00003E00003E00003E00003E00003E000FFFF80FFFF80111D7C9C1A>49 +D<07F0001FFE00383F007C1F80FE0FC0FE0FC0FE0FE0FE07E07C07E03807E0000FE0000FC0000F +C0001F80001F00003E0000780000F00000E00001C0000380600700600E00601C00E01FFFC03FFF +C07FFFC0FFFFC0FFFFC0131D7D9C1A>I<01FC0007FF000E0F801E0FC03F07E03F07E03F07E03F +07E01E0FC0000FC0000F80001F0001FC0001FC00000F800007C00003E00003F00003F83803F87C +03F8FE03F8FE03F8FE03F0FC03F07807E03C0FC01FFF8003FC00151D7E9C1A>I<0001C00003C0 +0007C00007C0000FC0001FC0003BC00073C00063C000C3C00183C00383C00703C00E03C00C03C0 +1803C03803C07003C0E003C0FFFFFEFFFFFE0007C00007C00007C00007C00007C00007C000FFFE +00FFFE171D7F9C1A>I<3803803FFF803FFF003FFE003FFC003FF0003F80003000003000003000 +0030000033F80037FE003C1F00380F801007C00007C00007E00007E07807E0FC07E0FC07E0FC07 +E0FC07C0780FC0600F80381F001FFC0007F000131D7D9C1A>I<387CFEFEFE7C38000000000000 +387CFEFEFE7C3807147C930F>58 D<0000E000000000E000000001F000000001F000000001F000 +000003F800000003F800000006FC00000006FC0000000EFE0000000C7E0000000C7E000000183F +000000183F000000303F800000301F800000701FC00000600FC00000600FC00000C007E00000FF +FFE00001FFFFF000018003F000018003F000030001F800030001F800060001FC00060000FC000E +0000FE00FFE00FFFE0FFE00FFFE0231F7E9E28>65 D<FFFFFE00FFFFFFC007C007E007C003F007 +C001F807C001FC07C001FC07C001FC07C001FC07C001FC07C001F807C003F807C007F007C00FE0 +07FFFF8007FFFFC007C003F007C001F807C001FC07C000FC07C000FE07C000FE07C000FE07C000 +FE07C000FE07C000FC07C001FC07C003F807C007F0FFFFFFE0FFFFFF001F1F7E9E25>I<0007FC +02003FFF0E00FE03DE03F000FE07E0003E0FC0001E1F80001E3F00000E3F00000E7F0000067E00 +00067E000006FE000000FE000000FE000000FE000000FE000000FE000000FE0000007E0000007E +0000067F0000063F0000063F00000C1F80000C0FC0001807E0003803F0007000FE01C0003FFF80 +0007FC001F1F7D9E26>I<FFFFFE0000FFFFFFC00007E007F00007E001F80007E000FC0007E000 +7E0007E0003F0007E0003F0007E0001F8007E0001F8007E0001F8007E0001FC007E0001FC007E0 +001FC007E0001FC007E0001FC007E0001FC007E0001FC007E0001FC007E0001FC007E0001F8007 +E0001F8007E0001F8007E0003F0007E0003F0007E0007E0007E000FC0007E001F80007E007F000 +FFFFFFC000FFFFFE0000221F7E9E28>I<FFFFFFE0FFFFFFE007E007E007E001E007E000E007E0 +006007E0007007E0003007E0003007E0603007E0603007E0600007E0E00007E1E00007FFE00007 +FFE00007E1E00007E0E00007E0600007E0600C07E0600C07E0000C07E0001807E0001807E00018 +07E0003807E0007807E000F807E003F0FFFFFFF0FFFFFFF01E1F7E9E22>I<FFFFFFE0FFFFFFE0 +07E007E007E001E007E000E007E0006007E0007007E0003007E0003007E0603007E0603007E060 +0007E0E00007E1E00007FFE00007FFE00007E1E00007E0E00007E0600007E0600007E0600007E0 +000007E0000007E0000007E0000007E0000007E0000007E0000007E00000FFFF8000FFFF80001C +1F7E9E21>I<FFFF0FFFF0FFFF0FFFF007E0007E0007E0007E0007E0007E0007E0007E0007E000 +7E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007FF +FFFE0007FFFFFE0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007 +E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E0007E00FFFF0FFFF0 +FFFF0FFFF0241F7E9E29>72 D<FFFF8000FFFF800007E0000007E0000007E0000007E0000007E0 +000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007 +E0000007E0000007E0000007E000C007E000C007E000C007E001C007E001C007E001C007E00380 +07E0038007E00F8007E01F80FFFFFF80FFFFFF801A1F7E9E1F>76 D<FFE000FFF0FFF000FFF007 +F000060007F800060006FC000600067E000600063F000600063F800600061F800600060FC00600 +0607E006000603F006000601F806000601FC06000600FC060006007E060006003F060006001F86 +0006001FC60006000FE600060007E600060003F600060001FE00060000FE00060000FE00060000 +7E000600003E000600001E000600000E00FFF0000600FFF0000600241F7E9E29>78 +D<001FF80000FFFF0001F81F8007E007E00FC003F01F8001F81F0000F83F0000FC7F0000FE7E00 +007E7E00007EFE00007FFE00007FFE00007FFE00007FFE00007FFE00007FFE00007FFE00007FFE +00007F7E00007E7F0000FE7F0000FE3F0000FC3F8001FC1F8001F80FC003F007E007E001F81F80 +00FFFF00001FF800201F7D9E27>I<FFFFFE00FFFFFF8007E00FE007E003F007E001F807E001F8 +07E001FC07E001FC07E001FC07E001FC07E001FC07E001F807E001F807E003F007E00FE007FFFF +8007FFFE0007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0 +000007E0000007E0000007E00000FFFF0000FFFF00001E1F7E9E24>I<03FC080FFF381E03F838 +00F8700078700038F00038F00018F00018F80000FC00007FC0007FFE003FFF801FFFE00FFFF007 +FFF000FFF80007F80000FC00007C00003CC0003CC0003CC0003CE00038E00078F80070FE01E0E7 +FFC081FF00161F7D9E1D>83 D<7FFFFFFC7FFFFFFC7C07E07C7007E01C6007E00C6007E00CE007 +E00EC007E006C007E006C007E006C007E0060007E0000007E0000007E0000007E0000007E00000 +07E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E000 +0007E0000007E00003FFFFC003FFFFC01F1E7E9D24>I<FFFE0FFFC0FFE0FFFE0FFFC0FFE00FC0 +00FC000E000FE000FC000E0007E000FE000C0007E000FE000C0003F000FE00180003F001FF0018 +0003F001BF00180001F801BF00300001F8031F80300001FC031F80700000FC031F80600000FC06 +0FC06000007E060FC0C000007E0E0FE0C000007E0C07E0C000003F0C07E18000003F1803F18000 +003F9803F38000001F9803F30000001FB001FB0000000FF001FE0000000FF001FE0000000FE000 +FE00000007E000FC00000007C0007C00000007C0007C00000003C0007800000003800038000000 +018000300000331F7F9E36>87 D<07FC001FFF003F0F803F07C03F03E03F03E00C03E00003E000 +7FE007FBE01F03E03C03E07C03E0F803E0F803E0F803E0FC05E07E0DE03FF8FE0FE07E17147F93 +19>97 D<FF0000FF00001F00001F00001F00001F00001F00001F00001F00001F00001F00001F00 +001F1FC01F7FF01FE0F81F807C1F007E1F003E1F003E1F003F1F003F1F003F1F003F1F003F1F00 +3F1F003E1F003E1F007C1F807C1EC1F81C7FE0181F8018207E9F1D>I<01FE0007FF801F0FC03E +0FC03E0FC07C0FC07C0300FC0000FC0000FC0000FC0000FC0000FC00007C00007E00003E00603F +00C01F81C007FF0001FC0013147E9317>I<0007F80007F80000F80000F80000F80000F80000F8 +0000F80000F80000F80000F80000F801F8F80FFEF81F83F83E01F87E00F87C00F87C00F8FC00F8 +FC00F8FC00F8FC00F8FC00F8FC00F87C00F87C00F87E00F83E01F81F07F80FFEFF03F8FF18207E +9F1D>I<01FE0007FF800F83C01E01E03E00F07C00F07C00F8FC00F8FFFFF8FFFFF8FC0000FC00 +00FC00007C00007C00003E00181E00180F807007FFE000FF8015147F9318>I<001F8000FFC001 +F3E003E7E003C7E007C7E007C3C007C00007C00007C00007C00007C000FFFC00FFFC0007C00007 +C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007 +C00007C0003FFC003FFC0013207F9F10>I<01FC3C07FFFE0F079E1E03DE3E03E03E03E03E03E0 +3E03E03E03E01E03C00F07800FFF0009FC001800001800001C00001FFF800FFFF007FFF81FFFFC +3C007C70003EF0001EF0001EF0001E78003C78003C3F01F80FFFE001FF00171E7F931A>I<FF00 +00FF00001F00001F00001F00001F00001F00001F00001F00001F00001F00001F00001F0FC01F3F +E01F61F01FC0F81F80F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00 +F81F00F81F00F81F00F8FFE3FFFFE3FF18207D9F1D>I<1C003E007F007F007F003E001C000000 +00000000000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F +001F001F001F00FFE0FFE00B217EA00E>I<FF0000FF00001F00001F00001F00001F00001F0000 +1F00001F00001F00001F00001F00001F01FE1F01FE1F00F01F00C01F03801F07001F0C001F1800 +1F7C001FFC001F9E001F0F001E0F801E07C01E03C01E01E01E01F01E00F8FFC3FFFFC3FF18207E +9F1C>107 D<FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F +001F001F001F001F001F001F001F001F001F001F001F001F001F00FFE0FFE00B207E9F0E>I<FE +0FE03F80FE1FF07FC01E70F9C3E01E407D01F01E807E01F01F807E01F01F007C01F01F007C01F0 +1F007C01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01 +F01F007C01F01F007C01F0FFE3FF8FFEFFE3FF8FFE27147D932C>I<FE0FC0FE3FE01E61F01EC0 +F81E80F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00 +F81F00F8FFE3FFFFE3FF18147D931D>I<01FF0007FFC01F83F03E00F83E00F87C007C7C007CFC +007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00F83E00F81F83F007FFC001FF0017 +147F931A>I<FF1FC0FF7FF01FE1F81F80FC1F007E1F007E1F003E1F003F1F003F1F003F1F003F +1F003F1F003F1F003E1F007E1F007C1F80FC1FC1F81F7FE01F1F801F00001F00001F00001F0000 +1F00001F00001F0000FFE000FFE000181D7E931D>I<01F81807FE381F87783F01F83E01F87E00 +F87C00F8FC00F8FC00F8FC00F8FC00F8FC00F8FC00F87C00F87E00F87E00F83F01F81F87F80FFE +F803F8F80000F80000F80000F80000F80000F80000F80000F80007FF0007FF181D7E931C>I<FE +3E00FE7F801ECFC01E8FC01E8FC01F8FC01F03001F00001F00001F00001F00001F00001F00001F +00001F00001F00001F00001F0000FFF000FFF00012147E9316>I<0FE63FFE701E600EE006E006 +F800FFC07FF83FFC1FFE03FE001FC007C007E007F006F81EFFFCC7F010147E9315>I<01800180 +018003800380038007800F803F80FFFCFFFC0F800F800F800F800F800F800F800F800F800F800F +860F860F860F860F8607CC03F801F00F1D7F9C14>I<FF07F8FF07F81F00F81F00F81F00F81F00 +F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F01F81F01F80F06F807FC +FF03F8FF18147D931D>I<FFE07F80FFE07F801F001C000F8018000F80180007C0300007C03000 +03E0600003E0600001F0C00001F0C00001F9C00000F9800000FF8000007F0000007F0000003E00 +00003E0000001C0000001C000019147F931C>I<FFE1FF00FFE1FF000F80700007C0E00007E0C0 +0003E1800001F3800000FF0000007E0000003E0000003F0000007F8000006F800000C7C0000183 +E0000381F0000701F8000E00FC00FF81FF80FF81FF8019147F931C>120 +D<FFE07F80FFE07F801F001C000F8018000F80180007C0300007C0300003E0600003E0600001F0 +C00001F0C00001F9C00000F9800000FF8000007F0000007F0000003E0000003E0000001C000000 +1C0000001800000018000078300000FC300000FC600000C0E00000E1C000007F8000001E000000 +191D7F931C>I E /Fd 2 111 df<0300038003000000000000000000000000001C002400460046 +008C000C0018001800180031003100320032001C0009177F960C>105 D<383C0044C600470200 +4602008E06000C06000C06000C0C00180C00180C40181840181880300880300F00120E7F8D15> +110 D E /Fe 20 122 df<03CC0E2E181C381C301C701CE038E038E038E038C072C072C07260F2 +61341E180F107C8F14>97 D<7E000E000E000E001C001C001C001C00380038003BC03C30783070 +1870187018E038E038E038E038C070C060C0E060C063801E000D1A7C9912>I<01F006080C1818 +38301070006000E000E000E000E000E008E010602030C01F000D107C8F12>I<001F8000038000 +0380000380000700000700000700000700000E00000E0003CE000E2E00181C00381C00301C0070 +1C00E03800E03800E03800E03800C07200C07200C0720060F2006134001E1800111A7C9914>I< +01E006181C08380870087010FFE0E000E000E000E000E0086010602030C01F000D107C8F12>I< +1F80000380000380000380000700000700000700000700000E00000E00000E7C000F86001E0700 +1E07001C07001C0700380E00380E00380E00381C00701C80701C80703880703900E01900600E00 +111A7E9914>104 D<030706000000000000384C4E8E9C9C1C3838707272E2E4643808197C980C> +I<1F8003800380038007000700070007000E000E000E0E0E131C271C431C801F003C003F8039C0 +38E070E270E270E270E4E0646038101A7E9912>107 D<3F0707070E0E0E0E1C1C1C1C38383838 +70707070E4E4E4E46830081A7D990A>I<307C1E00598663009E0783809E0703809C0703809C07 +0380380E0700380E0700380E0700380E0E00701C0E40701C0E40701C1C40701C1C80E0380C8060 +1807001A107C8F1F>I<307C005986009E07009E07009C07009C0700380E00380E00380E00381C +00701C80701C80703880703900E01900600E0011107C8F16>I<01F006180C0C180E300E700E60 +0EE00EE00EE00CE01CE018E030606030C01F000F107C8F14>I<030F000590C009E0C009C06009 +C06009C0600380E00380E00380E00380E00701C00701800703800703000E8E000E78000E00000E +00001C00001C00001C00001C0000FF00001317808F14>I<03C20E2E181C381C301C701CE038E0 +38E038E038C070C070C07060F061E01EE000E000E001C001C001C001C01FF00F177C8F12>I<30 +F059189E389C189C009C0038003800380038007000700070007000E00060000D107C8F10>I<03 +E004300830187018601C001F801FC00FE000E00060E060E06080C041803E000C107D8F10>I<06 +000E000E000E000E001C001C00FFC01C0038003800380038007000700070007000E100E100E100 +E200640038000A177C960D>I<38064C074E0E8E0E9C0E9C0E1C1C381C381C381C703970397039 +3079389A0F0C10107C8F15>I<38184C1C4E1C8E0C9C0C9C0C1C08380838083808701070107020 +304018C00F000E107C8F12>I<38064C074E0E8E0E9C0E9C0E1C1C381C381C381C703870387038 +307838F00F700070006060E0E1C0C18047003C0010177C8F13>121 D E +/Ff 27 122 df<60F0F878181818303060C080050C789614>39 D<00C001C0030006000C001C00 +38003000700070006000E000E000E000E000E000E000E000600070007000300038001C000C0006 +00030001C000C00A1D7A9914>I<8000C0006000300018001C000E000600070007000300038003 +800380038003800380038003000700070006000E001C00180030006000C0008000091D7C9914> +I<01C00001C00001C00001C00001C00001C00001C000FFFF80FFFF80FFFF8001C00001C00001C0 +0001C00001C00001C00001C00011117F9314>43 D<70F8FCFC7C0C1830E0C0060A798414>I<70 +F8F8F8700505798414>46 D<0006000E000E001C001C003800380070007000E000E001C001C003 +8003800380070007000E000E001C001C003800380070007000E000E000C0000F1D7E9914>I<70 +F8F8F87000000000000070F8F8F8700510798F14>58 D<FFFF80FFFF807FFF8000000000000000 +00007FFF80FFFF80FFFF8011097F8F14>61 D<FFE0FFE0E000E000E000E000E000E000E000E000 +E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000FFE0FFE00B +1D799914>91 D<FFE0FFE000E000E000E000E000E000E000E000E000E000E000E000E000E000E0 +00E000E000E000E000E000E000E000E000E000E000E0FFE0FFE00B1D7F9914>93 +D<0818306060C0C0C0F0F87830050C799914>96 D<1FC0007FF000707800201800001C00001C00 +07FC001FFC003C1C00701C00E01C00E01C00E01C00707C003FFF800F8F8011107E8F14>I<03F8 +0FFC1C1C380870006000E000E000E000E00060007000380E1C1E0FFC03F00F107E8F14>99 +D<007E00007E00000E00000E00000E00000E00000E0007CE000FFE001C3E00301E00700E00E00E +00E00E00E00E00E00E00E00E00E00E00700E00301E00383E001FEFC007CFC012177F9614>I<07 +E00FF01C38301C700CE00EE00EFFFEFFFEE00060007000380E1C1E0FFC03F00F107E8F14>I<00 +7C00FE01CE03840380038003807FFEFFFE03800380038003800380038003800380038003800380 +03807FFC7FFC0F177F9614>I<030007800780030000000000000000007F807F80038003800380 +038003800380038003800380038003800380FFFCFFFC0E187D9714>105 +D<FF80FF8003800380038003800380038003800380038003800380038003800380038003800380 +03800380FFFEFFFE0F177E9614>108 D<FC7800FDFE001F86001E07001C07001C07001C07001C +07001C07001C07001C07001C07001C07001C0700FF8FE0FF8FE01310808F14>110 +D<07C01FF03C78701C701CE00EE00EE00EE00EE00EE00E701C783C3C781FF007C00F107E8F14> +I<03CE000FFE001C3E00301E00700E00E00E00E00E00E00E00E00E00E00E00E00E00700E00301E +001C3E000FEE0007CE00000E00000E00000E00000E00000E00000E00007FC0007FC012187F8F14 +>113 D<0FD83FF86038C038C038F0007F803FF007F8001C6006E006F006F81CFFF8CFE00F107E +8F14>115 D<030007000700070007007FFCFFFC07000700070007000700070007000700070E07 +0E070E070C03FC00F00F157F9414>I<FE3F80FE3F801C1C001C1C001C1C001C1C000E38000E38 +000E380006300007700007700007700003E00003E00003E00011107F8F14>118 +D<7E3F007E3F001E38000E780007700007E00003E00001C00003C00003E0000770000E78000E38 +001C1C00FE3F80FE3F8011107F8F14>120 D<FE3F80FE3F801C1C001C1C001C1C000E1C000E38 +000E380007380007300007300003700003700001E00001E00001E00001C00001C00001C0000380 +007380007700007E00003C000011187F8F14>I E /Fg 56 123 df<000FF000007FFC0001F80E +0003E01F0007C03F000F803F000F803F000F801E000F800C000F8000000F8000000F8000000F80 +0000FFFFFF00FFFFFF000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F +801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F00 +0F801F007FF0FFE07FF0FFE01B237FA21F>12 D<3803807C07C0FE0FE0FF0FF0FF0FF07F07F03B +03B00300300300300700700600600600600C00C01C01C018018070070020020014117EA21D>34 +D<387CFEFFFF7F3B03030706060C1C18702008117C8610>44 D<FFFCFFFCFFFCFFFC0E047F8C13 +>I<387CFEFEFE7C3807077C8610>I<0000180000380000380000700000700000E00000E00000E0 +0001C00001C0000380000380000380000700000700000700000E00000E00001C00001C00001C00 +00380000380000700000700000700000E00000E00001C00001C00001C000038000038000070000 +0700000700000E00000E00000E00001C00001C0000380000380000380000700000700000E00000 +E00000C0000015317DA41C>I<00180000780001F800FFF800FFF80001F80001F80001F80001F8 +0001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F8 +0001F80001F80001F80001F80001F80001F80001F80001F8007FFFE07FFFE013207C9F1C>49 +D<03FC000FFF003C1FC07007E07C07F0FE03F0FE03F8FE03F8FE01F87C01F83803F80003F80003 +F00003F00007E00007C0000F80001F00003E0000380000700000E01801C0180380180700180E00 +380FFFF01FFFF03FFFF07FFFF0FFFFF0FFFFF015207D9F1C>I<00FE0007FFC00F07E01E03F03F +03F03F81F83F81F83F81F81F03F81F03F00003F00003E00007C0001F8001FE0001FF000007C000 +01F00001F80000FC0000FC3C00FE7E00FEFF00FEFF00FEFF00FEFF00FC7E01FC7801F81E07F00F +FFC001FE0017207E9F1C>I<0000E00001E00003E00003E00007E0000FE0001FE0001FE00037E0 +0077E000E7E001C7E00187E00307E00707E00E07E00C07E01807E03807E07007E0E007E0FFFFFE +FFFFFE0007E00007E00007E00007E00007E00007E00007E000FFFE00FFFE17207E9F1C>I<1000 +201E01E01FFFC01FFF801FFF001FFE001FF8001BC00018000018000018000018000019FC001FFF +001E0FC01807E01803E00003F00003F00003F80003F83803F87C03F8FE03F8FE03F8FC03F0FC03 +F07007E03007C01C1F800FFF0003F80015207D9F1C>I<001F8000FFE003F07007C0F00F01F81F +01F83E01F83E01F87E00F07C00007C0000FC0800FC7FC0FCFFE0FD80F0FF00F8FE007CFE007CFC +007EFC007EFC007EFC007E7C007E7C007E7C007E3C007C3E007C1E00F80F00F00783E003FFC000 +FF0017207E9F1C>I<6000007800007FFFFE7FFFFE7FFFFC7FFFF87FFFF87FFFF0E00060E000C0 +C00180C00300C00300000600000C00001C0000180000380000780000780000F00000F00000F000 +01F00001F00001F00003F00003F00003F00003F00003F00003F00003F00001E00017227DA11C> +I<00FE0003FFC00703E00E00F01C00F01C00783C00783E00783F00783F80783FE0F01FF9E01FFF +C00FFF8007FFC003FFE007FFF01E7FF83C1FFC7807FC7801FEF000FEF0003EF0001EF0001EF000 +1CF8001C7800383C00381F01F00FFFC001FF0017207E9F1C>I<01FE0007FF800F83E01E01F03E +00F07C00F87C0078FC007CFC007CFC007CFC007EFC007EFC007EFC007E7C00FE7C00FE3E01FE1E +037E0FFE7E07FC7E00207E00007C00007C1E007C3F00F83F00F83F00F03F01E01E03C01C0F800F +FE0003F80017207E9F1C>I<387CFEFEFE7C380000000000000000387CFEFEFE7C3807167C9510> +I<000070000000007000000000F800000000F800000000F800000001FC00000001FC00000003FE +00000003FE00000003FE00000006FF000000067F0000000E7F8000000C3F8000000C3F80000018 +3FC00000181FC00000381FE00000300FE00000300FE00000600FF000006007F00000E007F80000 +FFFFF80000FFFFF800018001FC00018001FC00038001FE00030000FE00030000FE000600007F00 +0600007F00FFE00FFFF8FFE00FFFF825227EA12A>65 D<FFFFFF8000FFFFFFE00007F001F80007 +F000FC0007F0007E0007F0007E0007F0007F0007F0007F0007F0007F0007F0007F0007F0007F00 +07F0007E0007F000FE0007F000FC0007F003F80007FFFFF00007FFFFF00007F001FC0007F0007E +0007F0003F0007F0003F8007F0001F8007F0001FC007F0001FC007F0001FC007F0001FC007F000 +1FC007F0001FC007F0003F8007F0003F8007F0007F0007F001FE00FFFFFFF800FFFFFFC0002222 +7EA128>I<0003FE0080001FFF818000FF01E38001F8003F8003E0001F8007C0000F800F800007 +801F800007803F000003803F000003807F000001807E000001807E00000180FE00000000FE0000 +0000FE00000000FE00000000FE00000000FE00000000FE00000000FE000000007E000000007E00 +0001807F000001803F000001803F000003801F800003000F8000030007C000060003F0000C0001 +F800380000FF00F000001FFFC0000003FE000021227DA128>I<FFFFFF8000FFFFFFF00007F003 +FC0007F0007E0007F0003F0007F0001F8007F0000FC007F00007E007F00007E007F00007F007F0 +0003F007F00003F007F00003F007F00003F807F00003F807F00003F807F00003F807F00003F807 +F00003F807F00003F807F00003F807F00003F807F00003F007F00003F007F00003F007F00007E0 +07F00007E007F0000FC007F0001F8007F0003F0007F0007E0007F003FC00FFFFFFF000FFFFFF80 +0025227EA12B>I<FFFFFFFCFFFFFFFC07F000FC07F0003C07F0001C07F0000C07F0000E07F000 +0E07F0000607F0180607F0180607F0180607F0180007F0380007F0780007FFF80007FFF80007F0 +780007F0380007F0180007F0180007F0180307F0180307F0000307F0000607F0000607F0000607 +F0000E07F0000E07F0001E07F0003E07F001FCFFFFFFFCFFFFFFFC20227EA125>I<FFFFFFF8FF +FFFFF807F001F807F0007807F0003807F0001807F0001C07F0001C07F0000C07F0000C07F0180C +07F0180C07F0180007F0180007F0380007F0780007FFF80007FFF80007F0780007F0380007F018 +0007F0180007F0180007F0180007F0000007F0000007F0000007F0000007F0000007F0000007F0 +000007F00000FFFFE000FFFFE0001E227EA123>I<FFFFE0FFFFE003F80003F80003F80003F800 +03F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F800 +03F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F800 +FFFFE0FFFFE013227FA115>73 D<FFFFE000FFFFE00007F0000007F0000007F0000007F0000007 +F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F00000 +07F0000007F0000007F0000007F0000007F0000007F0001807F0001807F0001807F0001807F000 +3807F0003807F0007007F0007007F000F007F001F007F007F0FFFFFFF0FFFFFFF01D227EA122> +76 D<FFF000000FFFFFF800001FFF07F800001FE006FC000037E006FC000037E006FC000037E0 +067E000067E0067E000067E0063F0000C7E0063F0000C7E0061F800187E0061F800187E0060FC0 +0307E0060FC00307E0060FC00307E00607E00607E00607E00607E00603F00C07E00603F00C07E0 +0601F81807E00601F81807E00601F81807E00600FC3007E00600FC3007E006007E6007E006007E +6007E006003FC007E006003FC007E006001F8007E006001F8007E006001F8007E006000F0007E0 +FFF00F00FFFFFFF00600FFFF30227EA135>I<FFF8001FFEFFFC001FFE07FC0000C007FE0000C0 +06FF0000C0067F8000C0063FC000C0061FE000C0060FE000C0060FF000C00607F800C00603FC00 +C00601FE00C00600FE00C00600FF00C006007F80C006003FC0C006001FE0C006000FF0C0060007 +F0C0060007F8C0060003FCC0060001FEC0060000FFC00600007FC00600007FC00600003FC00600 +001FC00600000FC006000007C006000003C006000003C0FFF00001C0FFF00000C027227EA12C> +I<0007FC0000003FFF800000FC07E00003F001F80007E000FC000FC0007E001F80003F001F8000 +3F003F00001F803F00001F807F00001FC07E00000FC07E00000FC0FE00000FE0FE00000FE0FE00 +000FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE07E00000FC07F +00001FC07F00001FC03F00001F803F80003F801F80003F000FC0007E0007E000FC0003F001F800 +00FC07E000003FFF80000007FC000023227DA12A>I<FFFFFF00FFFFFFE007F007F007F001FC07 +F000FC07F0007E07F0007E07F0007F07F0007F07F0007F07F0007F07F0007F07F0007E07F0007E +07F000FC07F001FC07F007F007FFFFE007FFFF0007F0000007F0000007F0000007F0000007F000 +0007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F00000FFFF8000FFFF +800020227EA126>I<FFFFFE0000FFFFFFC00007F007F00007F001F80007F000FC0007F0007E00 +07F0007F0007F0007F0007F0007F0007F0007F0007F0007F0007F0007F0007F0007E0007F000FC +0007F001F80007F007F00007FFFFC00007FFFF800007F00FE00007F007F00007F003F80007F001 +FC0007F001FC0007F001FC0007F001FC0007F001FC0007F001FC0007F001FC0007F001FC0007F0 +01FC0607F000FE0607F000FF0CFFFF803FF8FFFF800FF027227EA12A>82 +D<01FC0407FF8C1F03FC3C007C7C003C78001C78001CF8000CF8000CFC000CFC0000FF0000FFE0 +007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FF00007F00003F00003FC0001FC000 +1FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF8018227DA11F>I<7FFFFFFF807FFF +FFFF807E03F80F807803F807807003F803806003F80180E003F801C0E003F801C0C003F800C0C0 +03F800C0C003F800C0C003F800C00003F800000003F800000003F800000003F800000003F80000 +0003F800000003F800000003F800000003F800000003F800000003F800000003F800000003F800 +000003F800000003F800000003F800000003F800000003F800000003F800000003F8000003FFFF +F80003FFFFF80022227EA127>I<FFFF803FFCFFFF803FFC07F000018007F000018007F0000180 +07F000018007F000018007F000018007F000018007F000018007F000018007F000018007F00001 +8007F000018007F000018007F000018007F000018007F000018007F000018007F000018007F000 +018007F000018007F000018007F000018007F000018007F000018003F000030003F800030001F8 +00060000FC000E00007E001C00003F80F800000FFFE0000001FF000026227EA12B>I<0400400E +00E0180180380380300300600600600600E00E00C00C00C00C00DC0DC0FE0FE0FF0FF0FF0FF07F +07F03E03E01C01C014117AA21D>92 D<07FC001FFF803F07C03F03E03F01E03F01F01E01F00001 +F00001F0003FF003FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF8 +7F07E03F18167E951B>97 D<FF000000FF0000001F0000001F0000001F0000001F0000001F0000 +001F0000001F0000001F0000001F0000001F0000001F0000001F0FE0001F3FF8001FF07C001F80 +1E001F001F001F000F801F000F801F000FC01F000FC01F000FC01F000FC01F000FC01F000FC01F +000FC01F000FC01F000F801F001F801F801F001FC03E001EE07C001C3FF800180FC0001A237EA2 +1F>I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000FC0000FC0000FC0000FC0000 +FC0000FC00007C00007E00007E00003E00301F00600FC0E007FF8000FE0014167E9519>I<0001 +FE000001FE0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000 +003E0000003E0000003E0001FC3E0007FFBE000F81FE001F007E003E003E007E003E007C003E00 +FC003E00FC003E00FC003E00FC003E00FC003E00FC003E00FC003E00FC003E007C003E007C003E +003E007E001E00FE000F83BE0007FF3FC001FC3FC01A237EA21F>I<00FE0007FF800F87C01E01 +E03E01F07C00F07C00F8FC00F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00 +003E00181F00300FC07003FFC000FF0015167E951A>I<003F8000FFC001E3E003C7E007C7E00F +87E00F83C00F80000F80000F80000F80000F80000F8000FFFC00FFFC000F80000F80000F80000F +80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F +80000F80007FF8007FF80013237FA211>I<03FC1E0FFF7F1F0F8F3E07CF3C03C07C03E07C03E0 +7C03E07C03E07C03E03C03C03E07C01F0F801FFF0013FC003000003000003800003FFF801FFFF0 +0FFFF81FFFFC3800FC70003EF0001EF0001EF0001EF0001E78003C7C007C3F01F80FFFE001FF00 +18217E951C>I<FF000000FF0000001F0000001F0000001F0000001F0000001F0000001F000000 +1F0000001F0000001F0000001F0000001F0000001F07E0001F1FF8001F307C001F403C001F803E +001F803E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F00 +3E001F003E001F003E001F003E001F003E001F003E00FFE1FFC0FFE1FFC01A237EA21F>I<1C00 +3E007F007F007F003E001C000000000000000000000000000000FF00FF001F001F001F001F001F +001F001F001F001F001F001F001F001F001F001F001F001F001F00FFE0FFE00B247EA310>I<FF +00FF001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00 +1F001F001F001F001F001F001F001F001F001F001F001F001F00FFE0FFE00B237EA210>108 +D<FF07F007F000FF1FFC1FFC001F303E303E001F403E403E001F801F801F001F801F801F001F00 +1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F +001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00 +1F001F00FFE0FFE0FFE0FFE0FFE0FFE02B167E9530>I<FF07E000FF1FF8001F307C001F403C00 +1F803E001F803E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E +001F003E001F003E001F003E001F003E001F003E001F003E00FFE1FFC0FFE1FFC01A167E951F> +I<00FE0007FFC00F83E01E00F03E00F87C007C7C007C7C007CFC007EFC007EFC007EFC007EFC00 +7EFC007EFC007E7C007C7C007C3E00F81F01F00F83E007FFC000FE0017167E951C>I<FF0FE000 +FF3FF8001FF07C001F803E001F001F001F001F801F001F801F000FC01F000FC01F000FC01F000F +C01F000FC01F000FC01F000FC01F000FC01F001F801F001F801F803F001FC03E001FE0FC001F3F +F8001F0FC0001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F000000FF +E00000FFE000001A207E951F>I<00FE030007FF87000FC1C7001F006F003F003F007E003F007E +001F007C001F00FC001F00FC001F00FC001F00FC001F00FC001F00FC001F00FC001F007E001F00 +7E001F003E003F001F007F000FC1DF0007FF9F0001FC1F0000001F0000001F0000001F0000001F +0000001F0000001F0000001F0000001F000000FFE00000FFE01B207E951E>I<FE1F00FE3FC01E +67E01EC7E01E87E01E87E01F83C01F00001F00001F00001F00001F00001F00001F00001F00001F +00001F00001F00001F00001F0000FFF000FFF00013167E9517>I<0FF3003FFF00781F00600700 +E00300E00300F00300FC00007FE0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380 +E00380F00700FC0E00EFFC00C7F00011167E9516>I<0180000180000180000180000380000380 +000780000780000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80 +000F80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000F8 +0011207F9F16>I<FF01FE00FF01FE001F003E001F003E001F003E001F003E001F003E001F003E +001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F00 +7E001F00FE000F81BE0007FF3FC001FC3FC01A167E951F>I<FFE01FE0FFE01FE00F8006000F80 +06000FC00E0007C00C0007E01C0003E0180003E0180001F0300001F0300000F8600000F8600000 +7CC000007CC000007FC000003F8000003F8000001F0000001F0000000E0000000E00001B167F95 +1E>I<FFE07FC0FFE07FC00F801C0007C0380003E0700003F0600001F8C00000F98000007F8000 +003F0000001F0000001F8000003FC0000037C0000063E00000C1F00001C0F8000380FC0007007E +000E003E00FF80FFE0FF80FFE01B167F951E>120 D<FFE01FE0FFE01FE00F8006000F8006000F +C00E0007C00C0007E01C0003E0180003E0180001F0300001F0300000F8600000F86000007CC000 +007CC000007FC000003F8000003F8000001F0000001F0000000E0000000E0000000C0000000C00 +000018000078180000FC380000FC300000FC60000069C000007F8000001F0000001B207F951E> +I<7FFFF07FFFF07C03E07007C0600FC0E01F80C01F00C03E00C07E0000FC0000F80001F00003F0 +3007E03007C0300F80701F80703F00603E00E07C03E0FFFFE0FFFFE014167E9519>I +E /Fh 11 121 df<70F8F8F87005057C840D>58 D<70F8FCFC74040404080810102040060E7C84 +0D>I<00F1800389C00707800E03801C03803C0380380700780700780700780700F00E00F00E00 +F00E00F00E10F01C20F01C20703C20705C40308C400F078014147E9318>97 +D<007C01C207010E011C013C013802780C7BF07C00F000F000F000F00070007001700230041838 +07C010147E9315>101 D<01E0000FE00001C00001C00001C00001C00003800003800003800003 +80000700000700000701E00706100E08700E10F00E20F00E40601C80001D00001E00001FC00038 +7000383800383800381C20703840703840703840701880E01880600F0014207E9F18>107 +D<1E07802318C023A06043C0704380704380708700E00700E00700E00700E00E01C00E01C00E01 +C00E03821C03841C07041C07081C03083803101801E017147E931B>110 +D<03C1E004621804741C08781C08701E08701E10E01E00E01E00E01E00E01E01C03C01C03C01C0 +3C01C0380380780380700380E003C1C0072380071E000700000700000E00000E00000E00000E00 +001C00001C0000FFC000171D819317>112 D<00C000E001C001C001C001C003800380FFF80380 +07000700070007000E000E000E000E001C001C001C001C10382038203820384018800F000D1C7F +9B10>116 D<0F00601180702180E021C0E041C0E04380E08381C00701C00701C00701C00E0380 +0E03800E03800E03840E07080C07080C07080E0F1006131003E1E016147E931A>I<0F01801183 +C02183E021C1E041C0E04380608380400700400700400700400E00800E00800E00800E01000E01 +000C02000E04000E040006180001E00013147E9316>I<03C1C00C62201034701038F02038F020 +386040700000700000700000700000E00000E00000E00000E02061C040F1C040F1C080E2C08044 +6300383C0014147E931A>120 D E /Fi 86 127 df<70F8F8F8F8F8F8F8F8F8F8F8F8F8F8F8F8 +70000000000070F8F8F870051C779B18>33 D<4010E038F078E038E038E038E038E038E038E038 +E038E038E03860300D0E7B9C18>I<00C00001C00001C00001C00003F0000FFC003FFE007DCF00 +71C700E1C380E1C780E1C780E1C780F1C00079C0003DC0001FE0000FF80003FC0001DE0001CF00 +01C70061C380F1C380F1C380E1C380E1C70071C70079DE003FFE001FF80007E00001C00001C000 +01C00000C00011247D9F18>36 D<3803007C07807C0780EE0F80EE0F00EE0F00EE1F00EE1E00EE +1E00EE3E007C3C007C3C00387C0000780000780000F80000F00001F00001E00001E00003E00003 +C00003C00007C0000783800787C00F87C00F0EE00F0EE01F0EE01E0EE01E0EE03E0EE03C07C03C +07C018038013247E9F18>I<01C00007E0000FF0000E70001C38001C38001C38001C38001C73F0 +1C73F01CE3F00FE3800FC7000F87000F07001F0E003F0E007B8E0073DC00E1DC00E0F800E0F800 +E07070E0787070FC707FFFE03FCFE00F03C0141C7F9B18>I<387C7C7E3E0E0E0E1C1C38F8F0C0 +070E789B18>I<007000F001E003C007800F001E001C00380038007000700070007000E000E000 +E000E000E000E000E000E0007000700070007000380038001C001E000F00078003C001F000F000 +700C24799F18>I<6000F00078003C001E000F000780038001C001C000E000E000E000E0007000 +7000700070007000700070007000E000E000E000E001C001C0038007800F001E003C007800F000 +60000C247C9F18>I<01C00001C00001C00001C000C1C180F1C780F9CF807FFF001FFC0007F000 +07F0001FFC007FFF00F9CF80F1C780C1C18001C00001C00001C00001C00011147D9718>I<0060 +0000F00000F00000F00000F00000F00000F00000F0007FFFC0FFFFE0FFFFE07FFFC000F00000F0 +0000F00000F00000F00000F00000F00000600013147E9718>I<1C3E7E7F3F1F070E1E7CF86008 +0C788518>I<7FFF00FFFF80FFFF807FFF0011047D8F18>I<3078FCFC78300606778518>I<0003 +00000780000780000F80000F00001F00001E00001E00003E00003C00007C0000780000780000F8 +0000F00001F00001E00003E00003C00003C00007C0000780000F80000F00000F00001F00001E00 +003E00003C00003C00007C0000780000F80000F00000F0000060000011247D9F18>I<01F00007 +FC000FFE001F1F001C07003803807803C07001C07001C0E000E0E000E0E000E0E000E0E000E0E0 +00E0E000E0E000E0E000E0F001E07001C07001C07803C03803801C07001F1F000FFE0007FC0001 +F000131C7E9B18>I<01800380038007800F803F80FF80FB804380038003800380038003800380 +03800380038003800380038003800380038003807FFCFFFE7FFC0F1C7B9B18>I<03F0000FFE00 +3FFF007C0F807003C0E001C0F000E0F000E06000E00000E00000E00001C00001C00003C0000780 +000F00001E00003C0000780000F00001E00007C0000F80001E00E03C00E07FFFE0FFFFE07FFFE0 +131C7E9B18>I<07F8001FFE003FFF007807807803C07801C03001C00001C00003C0000380000F +0003FF0003FE0003FF000007800003C00001C00000E00000E00000E0F000E0F000E0F001C0F003 +C07C07803FFF001FFE0003F800131C7E9B18>I<001F00003F0000770000770000E70001E70001 +C7000387000787000707000E07001E07003C0700380700780700F00700FFFFF8FFFFF8FFFFF800 +0700000700000700000700000700000700007FF000FFF8007FF0151C7F9B18>I<1FFF803FFF80 +3FFF803800003800003800003800003800003800003800003800003BF8003FFE003FFF003C0780 +1803C00001C00000E00000E06000E0F000E0F000E0E001C07003C07C0F803FFF001FFC0003F000 +131C7E9B18>I<007E0001FF0007FF800F83C01E03C01C03C0380180380000700000700000E1F8 +00E7FE00FFFF00FE0780F803C0F001C0F000E0E000E0F000E07000E07000E07000E03801C03C03 +C01E07800FFF0007FE0001F800131C7E9B18>I<E00000FFFFE0FFFFE0FFFFE0E003C0E0078000 +0700000E00001E00001C0000380000380000700000700000E00000E00000E00001C00001C00001 +C00001C00003C000038000038000038000038000038000038000038000131D7E9C18>I<03F800 +0FFE001FFF003E0F803803807001C07001C07001C07001C03803803C07801FFF0007FC000FFE00 +1F1F003C07807001C0F001E0E000E0E000E0E000E0E000E07001C07803C03E0F801FFF000FFE00 +03F800131C7E9B18>I<03F0000FFC001FFE003C0F00780780700380E001C0E001C0E001C0E001 +E0E001E07001E07803E03C0FE01FFFE00FFEE003F0E00000E00001C00001C00001C03003807807 +80780F00783E003FFC001FF00007C000131C7E9B18>I<3078FCFC783000000000000000003078 +FCFC78300614779318>I<183C7E7E3C180000000000000000183C7E7E3E1E0E1C3C78F060071A +789318>I<000300000780001F80003F00007E0001FC0003F00007E0001FC0003F00007E0000FC +0000FC00007E00003F00001FC00007E00003F00001FC00007E00003F00001F8000078000030011 +187D9918>I<7FFFC0FFFFE0FFFFE0FFFFE0000000000000000000000000FFFFE0FFFFE0FFFFE0 +7FFFC0130C7E9318>I<600000F00000FC00007E00003F00001FC00007E00003F00001FC00007E +00003F00001F80001F80003F00007E0001FC0003F00007E0001FC0003F00007E0000FC0000F000 +0060000011187D9918>I<007C0001FE0007FF000F87801E03C03C1DC0387FC070FFE071E3E071 +C1E0E1C1E0E380E0E380E0E380E0E380E0E380E0E380E0E1C1C071C1C071E3C070FF80387F003C +1C001E00E00F83E007FFC001FF80007E00131C7E9B18>64 D<00700000F80000F80000D80000D8 +0001DC0001DC0001DC00018C00038E00038E00038E00038E000306000707000707000707000707 +000FFF800FFF800FFF800E03800E03801C01C01C01C07F07F0FF8FF87F07F0151C7F9B18>I<FF +FC00FFFF00FFFF801C03C01C01C01C00E01C00E01C00E01C00E01C01E01C01C01C07C01FFF801F +FF001FFFC01C03C01C00E01C00F01C00701C00701C00701C00701C00F01C00E01C03E0FFFFC0FF +FF80FFFE00141C7F9B18>I<00F8E003FEE007FFE00F07E01E03E03C01E03800E07000E07000E0 +700000E00000E00000E00000E00000E00000E00000E00000E000007000007000E07000E03800E0 +3C00E01E01C00F07C007FF8003FE0000F800131C7E9B18>I<7FF800FFFE007FFF001C0F801C03 +C01C03C01C01E01C00E01C00E01C00F01C00701C00701C00701C00701C00701C00701C00701C00 +701C00F01C00E01C00E01C01E01C01C01C03C01C0F807FFF00FFFE007FF800141C7F9B18>I<FF +FFF0FFFFF0FFFFF01C00701C00701C00701C00701C00001C00001C0E001C0E001C0E001FFE001F +FE001FFE001C0E001C0E001C0E001C00001C00001C00381C00381C00381C00381C0038FFFFF8FF +FFF8FFFFF8151C7F9B18>I<FFFFE0FFFFE0FFFFE01C00E01C00E01C00E01C00E01C00001C0000 +1C1C001C1C001C1C001FFC001FFC001FFC001C1C001C1C001C1C001C00001C00001C00001C0000 +1C00001C00001C0000FFC000FFC000FFC000131C7E9B18>I<01F1C003FDC00FFFC01F0FC01C03 +C03803C03801C07001C07001C0700000E00000E00000E00000E00000E00000E00FF0E01FF0E00F +F07001C07001C07003C03803C03803C01C07C01F0FC00FFFC003FDC001F1C0141C7E9B18>I<7F +07F0FF8FF87F07F01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01FFFC01F +FFC01FFFC01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C01C07F07F0FF +8FF87F07F0151C7F9B18>I<7FFF00FFFF807FFF0001C00001C00001C00001C00001C00001C000 +01C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C000 +01C00001C00001C0007FFF00FFFF807FFF00111C7D9B18>I<7FE000FFE0007FE0000E00000E00 +000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00 +000E00000E00000E00700E00700E00700E00700E00707FFFF0FFFFF07FFFF0141C7F9B18>76 +D<FC01F8FE03F8FE03F83B06E03B06E03B06E03B06E03B8EE03B8EE0398CE0398CE039DCE039DC +E039DCE038D8E038D8E038F8E03870E03870E03800E03800E03800E03800E03800E03800E0FE03 +F8FE03F8FE03F8151C7F9B18>I<7E07F0FF0FF87F07F01D81C01D81C01D81C01DC1C01CC1C01C +C1C01CE1C01CE1C01CE1C01C61C01C71C01C71C01C31C01C39C01C39C01C39C01C19C01C19C01C +1DC01C0DC01C0DC01C0DC07F07C0FF87C07F03C0151C7F9B18>I<0FF8003FFE007FFF00780F00 +700700F00780E00380E00380E00380E00380E00380E00380E00380E00380E00380E00380E00380 +E00380E00380E00380E00380E00380F00780700700780F007FFF003FFE000FF800111C7D9B18> +I<FFFE00FFFF80FFFFC01C03C01C01E01C00E01C00701C00701C00701C00701C00701C00E01C01 +E01C03C01FFFC01FFF801FFE001C00001C00001C00001C00001C00001C00001C00001C0000FF80 +00FF8000FF8000141C7F9B18>I<7FF800FFFE007FFF001C0F801C03801C03C01C01C01C01C01C +01C01C03C01C03801C0F801FFF001FFE001FFE001C0F001C07001C03801C03801C03801C03801C +03801C039C1C039C1C039C7F01F8FF81F87F00F0161C7F9B18>82 D<03F3801FFF803FFF807C0F +80700780E00380E00380E00380E000007000007800003F00001FF00007FE0000FF00000F800003 +C00001C00000E00000E06000E0E000E0E001E0F001C0F80780FFFF80FFFE00E7F800131C7E9B18 +>I<7FFFF8FFFFF8FFFFF8E07038E07038E07038E0703800700000700000700000700000700000 +700000700000700000700000700000700000700000700000700000700000700000700000700007 +FF0007FF0007FF00151C7F9B18>I<FF07F8FF07F8FF07F81C01C01C01C01C01C01C01C00E0380 +0E03800E03800E03800F0780070700070700070700070700038E00038E00038E00038E00018C00 +01DC0001DC0001DC0000D80000F80000F800007000151C7F9B18>86 D<FE03F8FE03F8FE03F870 +00707000707000703800E03800E03800E03800E03800E038F8E038F8E039DCE039DCE019DCC019 +DCC019DCC0198CC01D8DC01D8DC01D8DC01D8DC00D8D800D05800F07800F07800E0380151C7F9B +18>I<7F8FE07F9FE07F8FE00E07000F0700070E00078E00039C0003DC0001F80001F80000F000 +00F00000700000F00000F80001F80001DC00039E00038E00070F000707000E07800E03801E03C0 +7F07F0FF8FF87F07F0151C7F9B18>I<FFF8FFF8FFF8E000E000E000E000E000E000E000E000E0 +00E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000 +E000E000FFF8FFF8FFF80D24779F18>91 D<600000F00000F00000F800007800007C00003C0000 +3C00003E00001E00001F00000F00000F00000F800007800007C00003C00003C00003E00001E000 +01F00000F00000F800007800007800007C00003C00003E00001E00001E00001F00000F00000F80 +00078000078000030011247D9F18>I<FFF8FFF8FFF80038003800380038003800380038003800 +380038003800380038003800380038003800380038003800380038003800380038003800380038 +00380038FFF8FFF8FFF80D247F9F18>I<018007C01FF07EFCF83EE00E0F067C9B18>I<7FFF00FF +FF80FFFF807FFF0011047D7F18>I<061E3E387070E0E0E0F8FC7C7C38070E789E18>I<1FE0003F +F8007FFC00781E00300E0000070000070000FF0007FF001FFF007F0700780700E00700E00700E0 +0700F00F00781F003FFFF01FFBF007E1F014147D9318>I<7E0000FE00007E00000E00000E0000 +0E00000E00000E00000E3E000EFF800FFFC00FC1E00F80E00F00700E00700E00380E00380E0038 +0E00380E00380E00380F00700F00700F80E00FC1E00FFFC00EFF80063E00151C809B18>I<01FE +0007FF001FFF803E0780380300700000700000E00000E00000E00000E00000E00000E000007000 +007001C03801C03E03C01FFF8007FF0001FC0012147D9318>I<001F80003F80001F8000038000 +038000038000038000038003E3800FFB801FFF803C1F80380F80700780700380E00380E00380E0 +0380E00380E00380E00380700780700780380F803C1F801FFFF00FFBF803E3F0151C7E9B18>I< +01F00007FC001FFE003E0F00380780700380700380E001C0E001C0FFFFC0FFFFC0FFFFC0E00000 +7000007001C03801C03E03C01FFF8007FF0001FC0012147D9318>I<001F80007FC000FFE000E1 +E001C0C001C00001C00001C0007FFFC0FFFFC0FFFFC001C00001C00001C00001C00001C00001C0 +0001C00001C00001C00001C00001C00001C00001C00001C0007FFF007FFF007FFF00131C7F9B18 +>I<01E1F007FFF80FFFF81E1E301C0E003807003807003807003807003807001C0E001E1E001F +FC001FF80039E0003800001C00001FFE001FFFC03FFFE07801F0700070E00038E00038E00038E0 +00387800F07E03F01FFFC00FFF8001FC00151F7F9318>I<7E0000FE00007E00000E00000E0000 +0E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E00E00E00E00E00E00E0 +0E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FCFFE7FE7FC3FC171C809B18>I<0380 +0007C00007C00007C0000380000000000000000000000000007FC000FFC0007FC00001C00001C0 +0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C000FFFF +00FFFF80FFFF00111D7C9C18>I<0038007C007C007C003800000000000000000FFC1FFC0FFC00 +1C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C +001C001C6038F078FFF07FE03F800E277E9C18>I<FE0000FE0000FE00000E00000E00000E0000 +0E00000E00000E3FF00E7FF00E3FF00E07800E0F000E1E000E3C000E78000EF0000FF8000FFC00 +0F9C000F0E000E0F000E07000E03800E03C0FFC7F8FFC7F8FFC7F8151C7F9B18>I<7FE000FFE0 +007FE00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0007FFFC0FFFFE07FFF +C0131C7E9B18>I<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C +001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C007F1F +1F00FFBFBF807F1F1F001914819318>I<7E3E00FEFF807FFFC00FC1C00F80E00F00E00E00E00E +00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FCFFE7FE7FC3FC17 +14809318>I<01F0000FFE001FFF003E0F803803807001C07001C0E000E0E000E0E000E0E000E0 +E000E0F001E07001C07803C03C07803E0F801FFF000FFE0001F00013147E9318>I<7E3E00FEFF +807FFFC00FC1E00F80E00F00700E00700E00380E00380E00380E00380E00380E00380F00700F00 +700F80E00FC1E00FFFC00EFF800E3E000E00000E00000E00000E00000E00000E00000E00007FC0 +00FFE0007FC000151E809318>I<01E38007FB801FFF803E1F80380F80700780700780E00380E0 +0380E00380E00380E00380E00380700780700780380F803C1F801FFF800FFB8003E38000038000 +0380000380000380000380000380000380003FF8003FF8003FF8151E7E9318>I<7F87E0FF9FF0 +7FBFF803F87803F03003E00003C00003C000038000038000038000038000038000038000038000 +0380000380007FFE00FFFF007FFE0015147F9318>I<07F7003FFF007FFF00780F00E00700E007 +00E007007C00007FE0001FFC0003FE00001F00600780E00380E00380F00380F80F00FFFF00FFFC +00E7F00011147D9318>I<0180000380000380000380000380007FFFC0FFFFC0FFFFC003800003 +80000380000380000380000380000380000380000380000380400380E00380E00380E001C1C001 +FFC000FF80003E0013197F9818>I<7E07E0FE0FE07E07E00E00E00E00E00E00E00E00E00E00E0 +0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E01E00F03E007FFFC03FFFE01FCFC171480 +9318>I<7F8FF0FF8FF87F8FF01E03C00E03800E03800E0380070700070700070700038E00038E +00038E00038E0001DC0001DC0001DC0000F80000F80000700015147F9318>I<FF8FF8FF8FF8FF +8FF83800E03800E03800E01C01C01C01C01C71C01CF9C01CF9C01CD9C01CD9C00DDD800DDD800D +DD800D8D800F8F800F8F8007070015147F9318>I<7F8FF07F9FF07F8FF0070700078E00039E00 +01DC0001F80000F80000700000F00000F80001DC00039E00038E000707000F07807F8FF0FF8FF8 +7F8FF015147F9318>I<7F8FF0FF8FF87F8FF00E01C00E03800E03800703800707000707000387 +00038600038E0001CE0001CE0000CC0000CC0000DC000078000078000078000070000070000070 +0000F00000E00079E0007BC0007F80003F00001E0000151E7F9318>I<3FFFF07FFFF07FFFF070 +01E07003C0700780000F00001E00003C0000F80001F00003C0000780000F00701E00703C007078 +0070FFFFF0FFFFF0FFFFF014147F9318>I<0007E0001FE0007FE000780000E00000E00000E000 +00E00000E00000E00000E00000E00000E00000E00000E00001E0007FC000FF8000FF80007FC000 +01E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E000007800 +007FE0001FE00007E013247E9F18>I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0 +F0F0F0F0F0F0F0F0F0F0F0F0600424769F18>I<7C0000FF0000FFC00003C00000E00000E00000 +E00000E00000E00000E00000E00000E00000E00000E00000E00000F000007FC0003FE0003FE000 +7FC000F00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00003 +C000FFC000FF00007C000013247E9F18>I<060C1F1E3FBEFBF8F1F060C00F067C9B18>I +E /Fj 59 123 df<0003E0001C1800381800703C00E03C00E03801C00001C00001C00001C00001 +C0000380007FFFF00380700380700380700380700700E00700E00700E00700E00700E00700E00E +01C00E01C00E01C00E01C00E01C00E01C01C03801E03C0FF0FF816207E9F19>12 +D<381C7C3E7C3E7E3F3A1D040204020402080408041008201040208040100E7A9F17>34 +D<1C3E7E7E3A0202040408081020C0070E7D840D>44 D<FFC0FFC00A027D8A0F>I<3078F87870 +05057C840D>I<00000400000C00000C0000180000180000300000300000600000600000C00000 +C0000180000180000300000300000600000600000C00000C000018000018000030000030000060 +0000600000C00000C0000180000180000300000300000600000600000600000C00000C00001800 +00180000300000300000600000600000C00000C00000800000162D7EA117>I<000C001C00FC0F +380038003800380038003800700070007000700070007000E000E000E000E000E000E001C001C0 +01C001C001C001C0038003C0FFFE0F1E7C9D17>49 D<003F8000C1E00100F00200780400780400 +780F007C0F807C0F807C0F00780600780000F80000F00001E00001C0000380000700000E00001C +0000380000600000C0000180000300200600200800401000403FFFC07FFF80FFFF80161E7E9D17 +>I<007F000183C00201E00400F00700F00F00F00F01F00F01F00001E00001E00003C000038000 +0700000E0000F800000E000007000007800007C00003C00007C03007C07807C0F807C0F807C0F0 +0780800F00400E00201C0018780007E000141F7D9D17>I<0000600000600000E00001C00003C0 +0005C0000DC00009C00011C000238000438000C380008380010380020380040700080700180700 +100700200700400700FFFFF0000E00000E00000E00000E00000E00001C00001E0001FFE0141E7E +9D17>I<01803001FFE003FFC003FF0003FC00020000020000020000040000040000040000047C +000587000603800C01800801C00001C00001E00001E00001E00001E07003C0F803C0F003C0E003 +80800780400700400E00201C0018700007C000141F7D9D17>I<000F8000704000C0200180E003 +01E00701E00E00C01E00001C00003C000038000078F800790E007A07007C0300F80380F80380F0 +03C0F003C0F003C0F003C0F00780E00780E00780E00700E00F00600E00701C0030180018700007 +C000131F7C9D17>I<2000003FFFE07FFFC07FFF80400100C00200800200800400000800001000 +0020000040000040000080000180000300000300000700000600000E00000E00001E00001C0000 +1C00003C00003C00003C0000780000780000780000300000131F799D17>I<003F0000C1C00100 +600200600400300C00300C00300C00300C00600E00600F80C00FC18007F60003FC0001FC0001FF +00063F800C0F801007C03003C06001C06000C0C000C0C000C0C000C0C00080C001006003003004 +0018180007E000141F7D9D17>I<007E0001C3000301800601C00E01C01C00C03C00E03C00E03C +01E07801E07801E07801E07801E07803E07803E03803C03807C01C0BC00C13C003E38000078000 +0780000700000E00600E00F01C00F01800E0300080600041C0003F0000131F7C9D17>I<000010 +0000001800000038000000380000007800000078000000FC000001BC0000013C0000033C000002 +3C0000063C0000043E0000081E0000081E0000101E0000101E0000201E0000200F0000400F0000 +400F0000FFFF0000800F0001000F8001000780020007800200078004000780040007800C0007C0 +3E0007C0FF807FFC1E207E9F22>65 D<07FFFF00007C01C0003C01E0003C00F0007800F8007800 +F8007800F8007800F8007800F8007800F000F001F000F001E000F003C000F00F8000FFFE0000F0 +0F0001E007C001E003C001E003E001E001E001E001E001E001E003C001E003C003E003C003E003 +C003C003C007C003C00F8007800F0007803E00FFFFF0001D1F7E9E20>I<0001F808000E061800 +380138007000F801E0007803C0007007800030078000300F0000301F0000301E0000303E000020 +3C0000007C0000007C0000007C0000007C000000F8000000F8000000F8000000F8000000F80000 +007800004078000080780000803C0000803C0001001C0002000E00020006000C000300100001C0 +E000003F00001D217B9F21>I<07FFFF00007C01E0003C00F0003C00780078003C0078003C0078 +001E0078001E0078001E0078001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F01 +E0001E01E0003E01E0003E01E0003E01E0003C01E0007C03C0007803C000F003C000F003C001E0 +03C003C003C0078007800F0007803C00FFFFE000201F7E9E23>I<07FFFFF8007C0078003C0038 +003C001800780018007800080078000800780008007800080078080800F0100000F0100000F010 +0000F0300000FFF00000F0700001E0200001E0200001E0200001E0200001E0000801E0001003C0 +001003C0001003C0002003C0002003C0006003C000C0078001C0078007C0FFFFFF801D1F7E9E1F +>I<07FFFFF8007C0078003C0038003C0018007800180078000800780008007800080078000800 +78000800F0100000F0100000F0100000F0300000F0700000FFF00001E0600001E0200001E02000 +01E0200001E0200001E0000003C0000003C0000003C0000003C0000003C0000003C00000078000 +0007C00000FFFE00001D1F7E9E1E>I<0001FC04000F030C003C009C0070007C00E0003C01C000 +3803800018078000180F0000181F0000181E0000183E0000103C0000007C0000007C0000007C00 +00007C000000F8000000F8000000F8007FFCF80003E0780001E0780001E0780003C0780003C03C +0003C03C0003C01C0003C00E0007C007000B800380118001E06080003F80001E217B9F24>I<07 +FFC7FFC0007C00F800003C007800003C007800007800F000007800F000007800F000007800F000 +007800F000007800F00000F001E00000F001E00000F001E00000F001E00000FFFFE00000F001E0 +0001E003C00001E003C00001E003C00001E003C00001E003C00001E003C00003C007800003C007 +800003C007800003C007800003C007800003C007800007800F000007C00F8000FFF8FFF800221F +7E9E22>I<07FFE0007C00003C00003C0000780000780000780000780000780000780000F00000 +F00000F00000F00000F00000F00001E00001E00001E00001E00001E00001E00003C00003C00003 +C00003C00003C00003C00007800007C000FFFC00131F7F9E10>I<07FFF000007E0000003C0000 +003C000000780000007800000078000000780000007800000078000000F0000000F0000000F000 +0000F0000000F0000000F0000001E0000001E0000001E0000001E0000001E0008001E0010003C0 +010003C0010003C0030003C0020003C0060003C0060007801E0007807C00FFFFFC00191F7E9E1C +>76 D<07FC0000FFC0007C0000F800003C00017800003C00017800004E0002F000004E0002F000 +004E0004F000004E0004F000004E0008F000004E0008F00000870011E00000870011E000008700 +21E00000870021E00000870041E00000838041E00001038083C00001038083C00001038103C000 +01038203C0000101C203C0000101C403C0000201C40780000201C80780000201C80780000201D0 +0780000200F00780000600E00780000600E00F00000F00C00F8000FFE0C1FFF8002A1F7E9E2A> +I<07FC01FFC0003E003E00003E001800003E001800004F001000004F0010000047801000004780 +10000043C010000043C010000083C020000081E020000081E020000080F020000080F020000080 +782000010078400001007C400001003C400001003C400001001E400001001E400002000F800002 +000F800002000F800002000780000200078000060003800006000300000F00010000FFE0010000 +221F7E9E22>I<0003F800001E0E000038070000E0038001C001C003C001E0078000E00F0000F0 +0F0000F01E0000F01E0000F83E0000F83C0000F87C0000F87C0000F87C0000F87C0000F8F80001 +F0F80001F0F80001F0F80001F0F80003E0780003E0780003C0780007C07C0007803C000F003C00 +1E001E001C000E0038000700F00003C3C00000FE00001D217B9F23>I<07FFFF00007C03C0003C +01E0003C00F0007800F0007800F8007800F8007800F8007800F8007800F000F001F000F001E000 +F003C000F0078000F00F0000FFF80001E0000001E0000001E0000001E0000001E0000001E00000 +03C0000003C0000003C0000003C0000003C0000003C000000780000007C00000FFFC00001D1F7E +9E1F>I<07FFFC00007C0700003C03C0003C01E0007801E0007801F0007801F0007801F0007801 +F0007801E000F003E000F003C000F0078000F00F0000F03C0000FFF00001E0300001E0380001E0 +1C0001E01C0001E01C0001E01E0003C03E0003C03E0003C03E0003C03E0003C03E0003C03E0207 +803E0407C01F04FFFC0F18000003E01F207E9E21>82 D<003F040060CC01803C03801C03001C07 +00180600080E00080E00080E00080E00000F00000F80000FE00007FE0003FF8001FFC0007FE000 +07E00001E00000E00000F00000F04000E04000E04000E04000E06000C0600180E00380F80300C6 +0C0081F80016217D9F19>I<3FFFFFF03C0780F03007803060078030400F0010400F0010C00F00 +10800F0010800F0010800F0010001E0000001E0000001E0000001E0000001E0000001E0000003C +0000003C0000003C0000003C0000003C0000003C00000078000000780000007800000078000000 +7800000078000000F0000001F800007FFFE0001C1F7A9E21>I<FFFC3FF80F8007C00780030007 +8003000F0002000F0002000F0002000F0002000F0002000F0002001E0004001E0004001E000400 +1E0004001E0004001E0004003C0008003C0008003C0008003C0008003C0008003C000800380010 +003800100038001000380020003C0040001C0040001C0080000E0100000706000001F800001D20 +799E22>I<FFF003FE1F8000F80F0000600F0000400F0000400F80008007800180078001000780 +02000780020007C0040003C0040003C0080003C0080003C0100003E0100001E0200001E0200001 +E0400001E0400001F0800000F1000000F1000000F2000000F2000000FC0000007C000000780000 +007800000070000000700000002000001F207A9E22>I<03FFC0FFC0007F007E00003E00380000 +1E003000001E002000000F004000000F008000000F81000000078200000007C600000003C40000 +0003E800000001F000000001F000000000F000000000F800000000F8000000017C000000023C00 +0000043C0000000C1E000000081E000000101F000000200F000000400F800000C0078000008007 +C000010003C000070003E0001F8007E000FFE01FFE00221F7F9E22>88 D<FFF003FF1F8000F80F +0000600F8000400780008007C0018003C0010003E0020001E0040001F00C0001F0080000F01000 +00F8200000786000007C4000003C8000003F0000001F0000001E0000001E0000001E0000001C00 +00003C0000003C0000003C0000003C0000003C00000038000000780000007C00000FFFC000201F +7A9E22>I<060308041008201020104020402080408040B85CF87CF87CF87C7038100E779F17> +92 D<07F8000C0C001E06001E07001C070000070000070000070000FF0007C7001E07003C0E00 +780E00F00E10F00E10F00E10F01E10F02E20784F401F878014147D9317>97 +D<0700003F00000F00000700000700000E00000E00000E00000E00000E00000E00001C00001C7C +001D87001E03801C01C01C01C03801C03801E03801E03801E03801E03801E07003C07003C07003 +80700780700700700E00E81C00C4380083E00013207B9F19>I<01FC07060E0F1C0F380E780070 +00F000F000F000F000E000E000E000E000F0027004300818300FC010147C9314>I<0000700003 +F00000F00000700000700000E00000E00000E00000E00000E00000E00001C000F9C00305C00E03 +C01C03C03801C0780380700380F00380F00380F00380F00380E00700E00700E00700E00700E007 +00700F00301E00186F000F8FE014207C9F19>I<00F800070E000E07001C070038038078038070 +0380F00380F00380FFFF80F00000E00000E00000E00000E00000F001007002003004001C180007 +E00011147D9314>I<0007800018C00031E00061E000E1C000C00001C00001C00001C00001C000 +01C0000380007FF800038000038000038000038000070000070000070000070000070000070000 +0E00000E00000E00000E00000E00000E00001C00001E0000FFE00013207E9F0E>I<00000E003E +1100E1A301C1C20381E00780E00701E00F01E00F01E00F01E00703C007038007870004FC000800 +000800001800001C00000FFF000FFFC007FFE01800F0300030600030C00030C00030C000306000 +603000C01C070007FC00181F809417>I<00E00007E00001E00000E00000E00001C00001C00001 +C00001C00001C00001C000038000038F800390E003A0E003C0600380600780E00700E00700E007 +00E00700E00700E00E01C00E01C00E01C00E01C00E01C00E01C01C03801E03C0FFCFF815207E9F +19>I<01C003E003E003C0018000000000000000000000000003801F8007800380038007000700 +07000700070007000E000E000E000E000E000E001C001E00FF800B1F7F9E0C>I<00E007E001E0 +00E000E001C001C001C001C001C001C00380038003800380038003800700070007000700070007 +000E000E000E000E000E000E001C001E00FFC00B207F9F0C>108 D<0387C07C001F9861860007 +A072070003C0340300038038030007807807000700700700070070070007007007000700700700 +07007007000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E001C01C01C +001E01E01E00FFCFFCFFC022147E9326>I<038F801F90E007A0E003C0600380600780E00700E0 +0700E00700E00700E00700E00E01C00E01C00E01C00E01C00E01C00E01C01C03801E03C0FFCFF8 +15147E9319>I<00FC000387000E01801C00C03800E03800E07000F0F000F0F000F0F000F0F000 +F0E001E0E001E0E001C0E003C0F00380700700380E001C1C0007E00014147D9317>I<00E3E007 +EC3800F01C00E01E00E00E01C00E01C00F01C00F01C00F01C00F01C00F03801E03801E03801C03 +803C0380380380700740E00721C0071F000700000700000700000E00000E00000E00000E00001E +0000FFC000181D809319>I<038E001FB38007C78003C780038300078000070000070000070000 +0700000700000E00000E00000E00000E00000E00000E00001C00001E0000FFE00011147E9312> +114 D<01F2060E080618061802380438001E001FE00FF003F8003C401C400C400C600C6018E010 +D0608FC00F147E9312>I<0080010001000100030007000F001E00FFF80E000E000E000E001C00 +1C001C001C001C001C00380038203820382038203840384018800F000D1C7C9B12>I<1C0380FC +1F803C07801C03801C0380380700380700380700380700380700380700700E00700E00700E0070 +0E00701E00701E00703C00305E001F9FC012147B9319>I<FF83F81E00E01C00C01C00800E0080 +0E01000E02000E02000F040007040007080007080007100003900003A00003E00003C000038000 +01800001000015147C9318>I<1FF0FF03C07801C06001C04000E08000E180007300007600003C +00003C00001C00002E00004E000087000107000203800603800C01C03E03E0FF07FC18147F9318 +>120 D<0FF83F8001E00E0001C00C0001C0080000E0180000E0100000E0200000E0200000F040 +000070400000708000007080000071000000390000003A0000003E0000003C0000003800000018 +0000001000000010000000200000002000000040000070C00000F0800000F1000000E20000007C +000000191D809318>I<07FFE00701E00401C00C0380080700080E00101C000038000070000070 +0000E00001C0000380800700800E00801C01001C0100380300700E00FFFE0013147F9314>I +E /Fk 55 123 df<00FC7C0183C607078E0607040E07000E07000E07000E07000E07000E0700FF +FFF00E07000E07000E07000E07000E07000E07000E07000E07000E07000E07000E07000E07000E +07000E07007F0FF0171A809916>11 D<00FC000182000703000607000E02000E00000E00000E00 +000E00000E0000FFFF000E07000E07000E07000E07000E07000E07000E07000E07000E07000E07 +000E07000E07000E07000E07007F0FE0131A809915>I<60F0F0F0F0F0F0606060606060606060 +60200000000060F0F060041A7D990B>33 D<60C0F1E0F9F068D0081008100810102010202040C1 +800C0B7F9913>I<60F0F868080808101020C0050B7D990B>39 D<00800100020004000C000800 +18003000300030006000600060006000E000E000E000E000E000E000E000E000E000E000600060 +0060006000300030003000180008000C00040002000100008009267D9B0F>I<80004000200010 +00180008000C000600060006000300030003000300038003800380038003800380038003800380 +038003000300030003000600060006000C0008001800100020004000800009267E9B0F>I<60F0 +F07010101020204080040B7D830B>44 D<FFC0FFC00A0280880D>I<60F0F06004047D830B>I<01 +E006100C1818383038300070006000E000E7C0E860F030F018E018E01CE01CE01C601C601C7018 +30183030186007C00E187E9713>54 D<078018603030201860186018601870103C303E600F8007 +C019F030F86038401CC00CC00CC00CC00C6008201018600FC00E187E9713>56 +D<60F0F060000000000000000060F0F06004107D8F0B>58 D<60F0F060000000000000000060F0 +F0701010102020408004177D8F0B>I<000C0000000C0000000C0000001E0000001E0000003F00 +0000270000002700000043800000438000004380000081C0000081C0000081C0000100E0000100 +E00001FFE000020070000200700006007800040038000400380008001C0008001C001C001E00FF +00FFC01A1A7F991D>65 D<FFFF000E01C00E00E00E00700E00780E00780E00780E00780E00780E +00F00E00E00E03C00FFF800E01E00E00700E00780E003C0E003C0E003C0E003C0E003C0E00380E +00780E00F00E01E0FFFF80161A7E991B>I<003F0201C0C603002E0E001E1C000E1C0006380006 +780002700002700002F00000F00000F00000F00000F00000F00000700002700002780002380004 +1C00041C00080E000803003001C0C0003F00171A7E991C>I<FFFFE00E00E00E00600E00200E00 +300E00100E00100E00100E04000E04000E04000E0C000FFC000E0C000E04000E04000E04000E00 +000E00000E00000E00000E00000E00000E00000E0000FFF000141A7E9919>70 +D<FFE7FF0E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700FFF +F00E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E0070FFE7 +FF181A7E991D>72 D<FFE00E000E000E000E000E000E000E000E000E000E000E000E000E000E00 +0E000E000E000E000E000E000E000E000E000E00FFE00B1A7F990E>I<FFF0000E00000E00000E +00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E +00000E00200E00200E00200E00600E00400E00400E00C00E03C0FFFFC0131A7E9918>76 +D<FF0003FC0F0003C00F0003C00B8005C00B8005C00B8005C009C009C009C009C009C009C008E0 +11C008E011C008E011C0087021C0087021C0083841C0083841C0083841C0081C81C0081C81C008 +1C81C0080F01C0080F01C0080F01C0080601C01C0601C0FF861FFC1E1A7E9923>I<FE01FF0F00 +380F00100B80100B801009C01008E01008E010087010087010083810081C10081C10080E10080E +100807100803900803900801D00801D00800F00800700800700800301C0030FF8010181A7E991D +>I<FFFF000E03C00E00E00E00700E00700E00780E00780E00780E00780E00700E00700E00E00E +03C00FFF000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0000FF +E000151A7E991A>80 D<FFFC00000E0780000E01C0000E00E0000E00F0000E00F0000E00F0000E +00F0000E00F0000E00E0000E01C0000E0780000FFC00000E0600000E0300000E0180000E01C000 +0E01C0000E01C0000E01E0000E01E0000E01E0000E01E0800E00F0800E007100FFE03E00191A7E +991C>82 D<0FC21836200E6006C006C002C002C002E00070007E003FE01FF807FC003E000E0007 +0003800380038003C002C006E004D81887E0101A7E9915>I<7FFFFF00701C0700401C0100401C +0100C01C0180801C0080801C0080801C0080001C0000001C0000001C0000001C0000001C000000 +1C0000001C0000001C0000001C0000001C0000001C0000001C0000001C0000001C0000001C0000 +001C0000001C000003FFE000191A7F991C>I<FF83FF0FF03C007801C01C007800801C00780080 +0E007801000E007801000E009C010007009C020007009C020007010E020007010E020003810E04 +000382070400038207040001C207080001C403880001C403880000E403900000E403900000E801 +D000007801E000007801E000007000E000007000E000003000C0000020004000241A7F9927>87 +D<1830204040804080810081008100B160F9F078F030600C0B7B9913>92 +D<3F8070C070E020700070007007F01C7030707070E070E071E071E0F171FB1E3C10107E8F13> +97 D<FC00001C00001C00001C00001C00001C00001C00001C00001C00001C00001CF8001F0E00 +1E07001C03801C01801C01C01C01C01C01C01C01C01C01C01C01C01C03801C03001E07001B0C00 +10F000121A7F9915>I<07F80C1C381C30087000E000E000E000E000E000E0007000300438080C +1807E00E107F8F11>I<007E00000E00000E00000E00000E00000E00000E00000E00000E00000E +0003CE000C3E00380E00300E00700E00E00E00E00E00E00E00E00E00E00E00E00E00600E00700E +00381E001C2E0007CFC0121A7F9915>I<07C01C3030187018600CE00CFFFCE000E000E000E000 +6000300438080C1807E00E107F8F11>I<01F0031807380E100E000E000E000E000E000E00FFC0 +0E000E000E000E000E000E000E000E000E000E000E000E000E000E007FE00D1A80990C>I<0FCE +187330307038703870387038303018602FC02000600070003FF03FFC1FFE600FC003C003C003C0 +036006381C07E010187F8F13>I<FC00001C00001C00001C00001C00001C00001C00001C00001C +00001C00001CF8001D0C001E0E001E0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E001C +0E001C0E001C0E001C0E00FF9FC0121A7F9915>I<18003C003C00180000000000000000000000 +0000FC001C001C001C001C001C001C001C001C001C001C001C001C001C001C00FF80091A80990A +>I<018003C003C001800000000000000000000000000FC001C001C001C001C001C001C001C001 +C001C001C001C001C001C001C001C001C001C001C041C0E180E3007E000A2182990C>I<FC0000 +1C00001C00001C00001C00001C00001C00001C00001C00001C00001C3F801C1E001C18001C1000 +1C20001C40001DC0001FE0001CE0001C70001C78001C38001C1C001C1E001C1F00FF3FC0121A7F +9914>I<FC001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C +001C001C001C001C001C001C001C00FF80091A80990A>I<FC7C1F001D8E63801E0781C01E0781 +C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C07 +01C01C0701C0FF9FE7F81D107F8F20>I<FCF8001D0C001E0E001E0E001C0E001C0E001C0E001C +0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E00FF9FC012107F8F15>I<07E01C38300C +700E6006E007E007E007E007E007E0076006700E381C1C3807E010107F8F13>I<FCF8001F0E00 +1E07001C03801C03801C01C01C01C01C01C01C01C01C01C01C01C01C03801C03001E07001F0C00 +1CF0001C00001C00001C00001C00001C00001C0000FF800012177F8F15>I<03C2000C2600381E +00300E00700E00E00E00E00E00E00E00E00E00E00E00E00E00700E00700E00381E001C2E0007CE +00000E00000E00000E00000E00000E00000E00007FC012177F8F14>I<FCE01D701E701E201C00 +1C001C001C001C001C001C001C001C001C001C00FFC00C107F8F0F>I<1F2060E04020C020C020 +F0007F003FC01FE000F080708030C030C020F0408F800C107F8F0F>I<0400040004000C000C00 +1C003C00FFC01C001C001C001C001C001C001C001C001C201C201C201C201C200E4003800B177F +960F>I<FC7E001C0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E001C0E +001C0E001C1E000C2E0007CFC012107F8F15>I<FF1F803C06001C04001C04001E0C000E08000E +080007100007100007900003A00003A00001C00001C00001C00000800011107F8F14>I<FF3F9F +803C0E0700380E06001C1604001C1704001E170C000E2308000E2388000F239800074190000741 +D00003C1E0000380E0000380E0000180C0000100400019107F8F1C>I<FF3F803C1C001C18000E +100007200007600003C00001C00001E00003E000027000043800083800181C00381E00FC3FC012 +107F8F14>I<FF1F803C06001C04001C04001E0C000E08000E080007100007100007900003A000 +03A00001C00001C00001C000008000008000010000010000E10000E20000E4000078000011177F +8F14>I<7FF86070407040E041C041C00380070007000E081C081C08381070107030FFF00D107F +8F11>I E /Fl 10 58 df<1F00318060C04040C060C060C060C060C060C060C060C060404060C0 +31801F000B107F8F0F>48 D<0C003C00CC000C000C000C000C000C000C000C000C000C000C000C +000C00FF8009107E8F0F>I<1F00618040C08060C0600060006000C00180030006000C00102020 +207FC0FFC00B107F8F0F>I<1F00218060C060C000C0008001800F00008000400060C060C06080 +4060801F000B107F8F0F>I<0300030007000F000B001300330023004300C300FFE00300030003 +0003001FE00B107F8F0F>I<20803F002C002000200020002F0030802040006000600060C06080 +C061801F000B107F8F0F>I<0780184030C060C06000C000CF00F080E040C060C060C060406060 +C030801F000B107F8F0F>I<40007FE07FC08080808001000200040004000C0008000800180018 +001800180018000B117E900F>I<1F00318060C060C060C071803F000F00338061C0C060C060C0 +60404060801F000B107F8F0F>I<1F00318060C0C040C060C060C06040E021E01E600060004060 +C0608043003E000B107F8F0F>I E /Fm 11 58 df<003000003000003000003000003000003000 +003000003000003000003000003000FFFFFCFFFFFC003000003000003000003000003000003000 +00300000300000300000300000300016187E931B>43 D<07C018303018701C600C600CE00EE00E +E00EE00EE00EE00EE00EE00EE00E600C600C701C30181C7007C00F157F9412>48 +D<03000700FF000700070007000700070007000700070007000700070007000700070007000700 +07007FF00C157E9412>I<0F8030E040708030C038E0384038003800700070006000C001800300 +06000C08080810183FF07FF0FFF00D157E9412>I<0FE030306018701C701C001C001800380060 +07E000300018000C000E000EE00EE00EC00C401830300FE00F157F9412>I<00300030007000F0 +01F001700270047008701870107020704070C070FFFE0070007000700070007003FE0F157F9412 +>I<20303FE03FC0240020002000200020002F8030E020700030003800384038E038E038803040 +6020C01F000D157E9412>I<01F00608080C181C301C70006000E000E3E0EC30F018F00CE00EE0 +0EE00E600E600E300C3018183007C00F157F9412>I<40007FFE7FFC7FF8C00880108020004000 +8000800100010003000200060006000E000E000E000E000E0004000F167E9512>I<07E0183020 +18600C600C700C78183E101F600FC00FF018F8607C601EC00EC006C006C004600C38300FE00F15 +7F9412>I<07C0183030186018E00CE00CE00EE00EE00E601E301E186E0F8E000E000C001C7018 +7018603020C01F800F157F9412>I E /Fn 9 121 df<FFFFFFC0FFFFFFC01A027C8B23>0 +D<01800180018001800180C183F18F399C0FF003C003C00FF0399CF18FC1830180018001800180 +018010147D9417>3 D<03C00FF01FF83FFC7FFE7FFEFFFFFFFFFFFFFFFFFFFFFFFF7FFE7FFE3F +FC1FF80FF003C010127D9317>15 D<FFFFFFF07FFFFFF000000000000000000000000000000000 +000000000000000000000000FFFFFFF0FFFFFFF000000000000000000000000000000000000000 +0000000000000000007FFFFFF0FFFFFFF01C147D9423>17 D<C0000000F00000003C0000000F00 +000003C0000000F0000000380000000E0000000780000001E0000000780000001E000000078000 +0001C00000078000001E00000078000001E00000078000000E00000038000000F0000003C00000 +0F0000003C00000070000000C00000000000000000000000000000000000000000000000000000 +00000000007FFFFF80FFFFFFC01A247C9C23>21 D<000002000000000300000000030000000001 +8000000000C000000000C00000000060007FFFFFF000FFFFFFFC000000000E0000000003800000 +0001F0000000007C00000000F000000003C000000007000000000C00FFFFFFF8007FFFFFF00000 +00006000000000C00000000180000000018000000003000000000300000000020000261A7D972D +>41 D<400001C0000360000660000660000630000C30000C30000C1800181800181800180FFFF0 +0FFFF00C00300600600600600600600300C00300C001818001818001818000C30000C30000C300 +006600006600006600003C00003C00003C000018000018001821809F19>56 +D<00040000000C0000000C0000000C0000000C0000000C0000000C0000000C0000000C0000000C +0000000C0000000C0000000C0000000C0000000C0000000C0000000C0000000C0000000C000000 +0C0000000C0000000C0000000C0000000C0000000C0000000C0000FFFFFFE0FFFFFFE01B1C7C9B +23>63 D<0F80184030207010E030E070E020E000E00060007000300018000600198030C0706060 +70E030E038E038E03860387030307018600CC0030000C000600070003000380038203870386038 +4070206010C00F800D297D9F14>120 D E /Fo 50 123 df<00003F03E00000C386700001878C +F00003879CF00003031860000700380000070038000007003800000E003800000E007000000E00 +7000000E00700000FFFFFF80001C007000001C00E000001C00E000001C00E000001C00E0000038 +00E000003801C000003801C000003801C000003801C000007001C0000070038000007003800000 +700380000070038000006003800000E007000000E007000000E007000000E007000000C0060000 +01C00E000001C00E000031860C0000798F180000F31E100000620C6000003C07C000002429829F +1C>11 D<00003FE00000E010000180380003807800030078000700300007000000070000000700 +00000E0000000E0000000E000000FFFFE0000E00E0001C01C0001C01C0001C01C0001C01C0001C +03800038038000380380003803800038070000380700007007000070071000700E2000700E2000 +700E2000E00E2000E0064000E0038000E0000000C0000001C0000001C000003180000079800000 +F3000000620000003C0000001D29829F1A>I<1C3C3C3C3C040408081020204080060E7D840E> +44 D<7FF0FFE07FE00C037D8A10>I<70F8F8F0E005057B840E>I<00000040000000C000000180 +000001800000030000000300000006000000060000000C00000018000000180000003000000030 +00000060000000C0000000C0000001800000018000000300000003000000060000000C0000000C +0000001800000018000000300000003000000060000000C0000000C00000018000000180000003 +00000003000000060000000C0000000C0000001800000018000000300000003000000060000000 +C0000000C0000000800000001A2D7FA117>I<000F800030E000E07001C0700380300380380700 +380F00780F00780E00781E00781E00703C00F03C00F03C00F03C00F07801E07801E07801E07801 +C07003C0F003C0F00380F00780F00700700700700E00701C003038001870000FC000151F7C9D17 +>I<000200020006000E003C00DC031C001C0038003800380038007000700070007000E000E000 +E000E001C001C001C001C003800380038003800780FFF80F1E7B9D17>I<001F000061800080E0 +0100E00200700220700420700410700820F00820F00820F00840E00881E00703C0000380000700 +000C000018000060000080000300000400000800401000401000802001807E030047FF0041FE00 +80FC00807800141F7C9D17>I<070F1F1F0E0000000000000000000070F8F8F0E008147B930E> +58 D<00000200000006000000060000000E0000001E0000001E0000003F0000002F0000004F00 +00004F0000008F0000010F0000010F0000020F0000020F0000040F00000C0F0000080F0000100F +0000100F0000200F80003FFF800040078000C00780008007800100078001000780020007800200 +0780060007801E000F80FF807FF81D207E9F22>65 D<0000FE0200078186001C004C0038003C00 +60003C00C0001C01C0001803800018070000180F0000181E0000101E0000103C0000003C000000 +78000000780000007800000078000000F0000000F0000000F0000000F0000000F0000080700000 +8070000080700001003800010038000200180004000C001800060020000381C00000FE00001F21 +7A9F21>67 D<01FFFFFC001E0038001E0018001E0008001E0008003C0008003C0008003C000800 +3C00080078001000780800007808000078080000F0100000F0300000FFF00000F0300001E02000 +01E0200001E0200001E0200003C0000003C0000003C0000003C000000780000007800000078000 +00078000000F800000FFF800001E1F7D9E1E>70 D<0000FC040007030C001C00980030007800E0 +007801C000380380003003800030070000300E0000301E0000201E0000203C0000003C00000078 +000000780000007800000078000000F0000000F000FFF0F0000780F0000780F0000F0070000F00 +70000F0070000F0070001E0038001E0018003E001C002E000E00CC000383040000FC00001E217A +9F23>I<01FFF3FFE0001F003E00001E003C00001E003C00001E003C00003C007800003C007800 +003C007800003C007800007800F000007800F000007800F000007800F00000F001E00000FFFFE0 +0000F001E00000F001E00001E003C00001E003C00001E003C00001E003C00003C007800003C007 +800003C007800003C007800007800F000007800F000007800F000007800F00000F801F0000FFF1 +FFE000231F7D9E22>I<01FFF0001F00001E00001E00001E00003C00003C00003C00003C000078 +0000780000780000780000F00000F00000F00000F00001E00001E00001E00001E00003C00003C0 +0003C00003C0000780000780000780000780000F8000FFF800141F7D9E12>I<01FFF800001F00 +00001E0000001E0000001E0000003C0000003C0000003C0000003C000000780000007800000078 +00000078000000F0000000F0000000F0000000F0000001E0000001E0000001E0000001E0008003 +C0010003C0010003C0030003C00200078006000780060007800C0007801C000F007800FFFFF800 +191F7D9E1D>76 D<01FE00007FC0001E0000FC00001E0000F80000170001780000170001780000 +270002F00000270004F00000270004F00000270008F00000470009E00000470011E00000470021 +E00000470021E00000870043C00000838043C00000838083C00000838083C00001038107800001 +03820780000103820780000103840780000203840F00000203880F00000203900F00000203900F +00000401E01E00000401E01E00000401C01E00000C01801E00001C01803E0000FF8103FFC0002A +1F7D9E29>I<01FF007FE0001F000F00001F0004000017800400001780040000278008000023C0 +08000023C008000023C008000041E010000041E010000041F010000040F010000080F020000080 +7820000080782000008078200001003C400001003C400001003C400001001E400002001E800002 +001E800002000F800002000F800004000F0000040007000004000700000C000700001C00020000 +FF80020000231F7D9E22>I<0001FC0000070700001C01C0003000E000E0006001C00070038000 +7007800038070000380E0000381E0000381C0000383C0000383C00003878000078780000787800 +007878000078F00000F0F00000F0F00000E0F00001E0F00001C0F00003C0700003807000070078 +000F0038001E0038003C001C0070000E00E0000783800001FC00001D217A9F23>I<01FFFF8000 +1E00E0001E0070001E0038001E003C003C003C003C003C003C003C003C003C0078007800780078 +007800F0007800E000F003C000F00F0000FFFC0000F0000001E0000001E0000001E0000001E000 +0003C0000003C0000003C0000003C00000078000000780000007800000078000000F800000FFF0 +00001E1F7D9E1F>I<0007E040001C18C0003005800060038000C0038001C00180018001000380 +010003800100038001000380000003C0000003C0000003F8000001FF800001FFE000007FF00000 +1FF0000001F8000000780000007800000038000000380020003800200038002000300060007000 +600060006000E0007000C000E8038000C606000081F800001A217D9F1A>83 +D<0FFFFFF01E0780E0180780201007802020078020200F0020600F0020400F0020400F0020801E +0040001E0000001E0000001E0000003C0000003C0000003C0000003C0000007800000078000000 +7800000078000000F0000000F0000000F0000000F0000001E0000001E0000001E0000001E00000 +03E00000FFFF00001C1F789E21>I<FFF007FC0F8000E00F0000C00F0000800F0001000F000100 +0F0002000F0004000F0004000F8008000780080007801000078020000780200007804000078040 +0007808000078100000781000007C2000003C2000003C4000003C8000003C8000003D0000003D0 +000003E0000003C0000003C000000380000001800000010000001E20779E22>86 +D<00F1800389C00707800E03801C03803C0380380700780700780700780700F00E00F00E00F00E +00F00E20F01C40F01C40703C40705C40308C800F070013147C9317>97 D<07803F800700070007 +0007000E000E000E000E001C001C001CF01D0C3A0E3C0E380F380F700F700F700F700FE01EE01E +E01EE01CE03CE038607060E031C01F0010207B9F15>I<007E0001C1000300800E07801E07801C +07003C0200780000780000780000F00000F00000F00000F00000F0000070010070020030040018 +380007C00011147C9315>I<0000780003F80000700000700000700000700000E00000E00000E0 +0000E00001C00001C000F1C00389C00707800E03801C03803C0380380700780700780700780700 +F00E00F00E00F00E00F00E20F01C40F01C40703C40705C40308C800F070015207C9F17>I<007C +01C207010E011C013C013802780C7BF07C00F000F000F000F0007000700170023804183807C010 +147C9315>I<00007800019C00033C00033C000718000700000700000E00000E00000E00000E00 +000E0001FFE0001C00001C00001C00001C00003800003800003800003800003800007000007000 +00700000700000700000700000E00000E00000E00000E00000C00001C00001C000018000318000 +7B0000F300006600003C00001629829F0E>I<003C6000E27001C1E00380E00700E00F00E00E01 +C01E01C01E01C01E01C03C03803C03803C03803C03803C07003C07001C0F001C17000C2E0003CE +00000E00000E00001C00001C00301C00783800F0700060E0003F8000141D7E9315>I<01E0000F +E00001C00001C00001C00001C000038000038000038000038000070000070000071E000763000E +81800F01C00E01C00E01C01C03801C03801C03801C0380380700380700380700380E10700E2070 +0C20701C20700C40E00CC060070014207D9F17>I<00C001E001E001C000000000000000000000 +000000000E003300230043804300470087000E000E000E001C001C001C00384038803080708031 +0033001C000B1F7C9E0E>I<0001800003C00003C0000380000000000000000000000000000000 +000000000000003C00004600008700008700010700010700020E00000E00000E00000E00001C00 +001C00001C00001C0000380000380000380000380000700000700000700000700000E00000E000 +30E00079C000F180006300003C00001228829E0E>I<01E0000FE00001C00001C00001C00001C0 +000380000380000380000380000700000700000703C00704200E08E00E11E00E21E00E40C01C80 +001D00001E00001FC00038E000387000387000383840707080707080707080703100E03100601E +0013207D9F15>I<03C01FC0038003800380038007000700070007000E000E000E000E001C001C +001C001C0038003800380038007000700070007100E200E200E200E200640038000A207C9F0C> +I<1C0F80F0002630C318004740640C004780680E004700700E004700700E008E00E01C000E00E0 +1C000E00E01C000E00E01C001C01C038001C01C038001C01C038001C01C0708038038071003803 +806100380380E10038038062007007006600300300380021147C9325>I<1C0F802630C0474060 +4780604700704700708E00E00E00E00E00E00E00E01C01C01C01C01C01C01C0384380388380308 +3807083803107003303001C016147C931A>I<007C0001C3000301800E01C01E01C01C01E03C01 +E07801E07801E07801E0F003C0F003C0F003C0F00780F00700700F00700E0030180018700007C0 +0013147C9317>I<01C1E002621804741C04781C04701E04701E08E01E00E01E00E01E00E01E01 +C03C01C03C01C03C01C0380380780380700380E003C1C0072380071E000700000700000E00000E +00000E00000E00001C00001C0000FFC000171D809317>I<00F0400388C00705800E03801C0380 +3C0380380700780700780700780700F00E00F00E00F00E00F00E00F01C00F01C00703C00705C00 +30B8000F380000380000380000700000700000700000700000E00000E0000FFE00121D7C9315> +I<1C1E002661004783804787804707804703008E00000E00000E00000E00001C00001C00001C00 +001C000038000038000038000038000070000030000011147C9313>I<00FC030206010C030C07 +0C060C000F800FF007F803FC003E000E700EF00CF00CE008401020601F8010147D9313>I<0180 +01C0038003800380038007000700FFF007000E000E000E000E001C001C001C001C003800380038 +003820704070407080708031001E000C1C7C9B0F>I<0E00C03300E02301C04381C04301C04701 +C08703800E03800E03800E03801C07001C07001C07001C07101C0E20180E20180E201C1E200C26 +4007C38014147C9318>I<0E03803307802307C04383C04301C04700C08700800E00800E00800E +00801C01001C01001C01001C02001C02001C04001C04001C08000E300003C00012147C9315>I< +0E00C1C03300E3C02301C3E04381C1E04301C0E04701C060870380400E0380400E0380400E0380 +401C0700801C0700801C0700801C0701001C0701001C0602001C0F02000C0F04000E13080003E1 +F0001B147C931E>I<0383800CC4401068E01071E02071E02070C040E00000E00000E00000E000 +01C00001C00001C00001C040638080F38080F38100E5810084C60078780013147D9315>I<0E00 +C03300E02301C04381C04301C04701C08703800E03800E03800E03801C07001C07001C07001C07 +001C0E00180E00180E001C1E000C3C0007DC00001C00001C00003800F03800F07000E06000C0C0 +004380003E0000131D7C9316>I<01C04003E08007F1800C1F0008020000040000080000100000 +20000040000080000100000200000401000802001002003E0C0063FC0041F80080E00012147D93 +13>I E /Fp 81 125 df<001F83E000F06E3001C078780380F8780300F0300700700007007000 +0700700007007000070070000700700007007000FFFFFF80070070000700700007007000070070 +000700700007007000070070000700700007007000070070000700700007007000070070000700 +7000070070000700700007007000070070007FE3FF001D20809F1B>11 D<003F0000E0C001C0C0 +0381E00701E00701E0070000070000070000070000070000070000FFFFE00700E00700E00700E0 +0700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E0 +0700E00700E07FC3FE1720809F19>I<003FE000E0E001C1E00381E00700E00700E00700E00700 +E00700E00700E00700E00700E0FFFFE00700E00700E00700E00700E00700E00700E00700E00700 +E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E07FE7FE1720809F19 +>I<001F81F80000F04F040001C07C06000380F80F000300F00F000700F00F0007007000000700 +7000000700700000070070000007007000000700700000FFFFFFFF000700700700070070070007 +007007000700700700070070070007007007000700700700070070070007007007000700700700 +070070070007007007000700700700070070070007007007000700700700070070070007007007 +007FE3FE3FF02420809F26>I<70F8F8F8F8F8F8F8707070707070707070702020202020000000 +000070F8F8F87005217CA00D>33 D<7038F87CFC7EFC7E743A0402040204020804080410081008 +201040200F0E7E9F17>I<70F8FCFC74040404080810102040060E7C9F0D>39 +D<0020004000800100020006000C000C00180018003000300030007000600060006000E000E000 +E000E000E000E000E000E000E000E000E000E0006000600060007000300030003000180018000C +000C000600020001000080004000200B2E7DA112>I<800040002000100008000C000600060003 +00030001800180018001C000C000C000C000E000E000E000E000E000E000E000E000E000E000E0 +00E000C000C000C001C001800180018003000300060006000C00080010002000400080000B2E7D +A112>I<70F8FCFC74040404080810102040060E7C840D>44 D<FFC0FFC00A027F8A0F>I<70F8F8 +F87005057C840D>I<000100030003000600060006000C000C000C001800180018003000300030 +00600060006000C000C000C00180018001800300030003000600060006000C000C000C00180018 +001800300030003000600060006000C000C000C000102D7DA117>I<03F0000E1C001C0E001806 +00380700700380700380700380700380F003C0F003C0F003C0F003C0F003C0F003C0F003C0F003 +C0F003C0F003C0F003C0F003C0F003C07003807003807003807807803807001806001C0E000E1C +0003F000121F7E9D17>I<018003800F80F3800380038003800380038003800380038003800380 +0380038003800380038003800380038003800380038003800380038007C0FFFE0F1E7C9D17>I< +03F0000C1C00100E00200700400780800780F007C0F803C0F803C0F803C02007C00007C0000780 +000780000F00000E00001C0000380000700000600000C0000180000300000600400C0040180040 +1000803FFF807FFF80FFFF80121E7E9D17>I<03F0000C1C00100E00200F00780F807807807807 +80380F80000F80000F00000F00000E00001C0000380003F000003C00000E00000F000007800007 +800007C02007C0F807C0F807C0F807C0F00780400780400F00200E001C3C0003F000121F7E9D17 +>I<000600000600000E00000E00001E00002E00002E00004E00008E00008E00010E00020E0002 +0E00040E00080E00080E00100E00200E00200E00400E00C00E00FFFFF0000E00000E00000E0000 +0E00000E00000E00000E0000FFE0141E7F9D17>I<1803001FFE001FFC001FF8001FE000100000 +10000010000010000010000010000011F000161C00180E001007001007800003800003800003C0 +0003C00003C07003C0F003C0F003C0E00380400380400700200600100E000C380003E000121F7E +9D17>I<007C000182000701000E03800C07801C0780380300380000780000700000700000F1F0 +00F21C00F40600F80700F80380F80380F003C0F003C0F003C0F003C0F003C07003C07003C07003 +803803803807001807000C0E00061C0001F000121F7E9D17>I<4000007FFFC07FFF807FFF8040 +010080020080020080040000080000080000100000200000200000400000400000C00000C00001 +C00001800003800003800003800003800007800007800007800007800007800007800007800003 +0000121F7D9D17>I<03F0000C0C00100600300300200180600180600180600180700180780300 +3E03003F06001FC8000FF00003F80007FC000C7E00103F00300F806003804001C0C001C0C000C0 +C000C0C000C0C000806001802001001002000C0C0003F000121F7E9D17>I<03F0000E18001C0C +00380600380700700700700380F00380F00380F003C0F003C0F003C0F003C0F003C07007C07007 +C03807C0180BC00E13C003E3C0000380000380000380000700300700780600780E00700C002018 +001070000FC000121F7E9D17>I<70F8F8F8700000000000000000000070F8F8F87005147C930D> +I<70F8F8F8700000000000000000000070F0F8F878080808101010202040051D7C930D>I<7FFF +FFE0FFFFFFF00000000000000000000000000000000000000000000000000000000000000000FF +FFFFF07FFFFFE01C0C7D9023>61 D<0FC0307040384038E03CF03CF03C603C0038007000E000C0 +01800180010003000200020002000200020002000000000000000000000007000F800F800F8007 +000E207D9F15>63 D<000100000003800000038000000380000007C0000007C0000007C0000009 +E0000009E0000009E0000010F0000010F0000010F00000207800002078000020780000403C0000 +403C0000403C0000801E0000801E0000FFFE0001000F0001000F0001000F000200078002000780 +02000780040003C00E0003C01F0007E0FFC03FFE1F207F9F22>65 D<FFFFE0000F80380007801E +0007801F0007800F0007800F8007800F8007800F8007800F8007800F8007800F0007801F000780 +1E0007803C0007FFF00007803C0007801E0007800F0007800F8007800780078007C0078007C007 +8007C0078007C0078007C00780078007800F8007800F0007801F000F803C00FFFFF0001A1F7E9E +20>I<000FC040007030C001C009C0038005C0070003C00E0001C01E0000C01C0000C03C0000C0 +7C0000407C00004078000040F8000000F8000000F8000000F8000000F8000000F8000000F80000 +00F8000000F8000000780000007C0000407C0000403C0000401C0000401E0000800E0000800700 +01000380020001C0040000703800000FC0001A217D9F21>I<FFFFE0000F803C0007801E000780 +070007800380078003C0078001E0078001E0078001F0078000F0078000F0078000F8078000F807 +8000F8078000F8078000F8078000F8078000F8078000F8078000F8078000F0078000F0078000F0 +078001E0078001E0078003C0078003800780070007800E000F803C00FFFFE0001D1F7E9E23>I< +FFFFFF000F800F0007800300078003000780010007800180078000800780008007800080078080 +800780800007808000078080000781800007FF8000078180000780800007808000078080000780 +8000078000200780002007800020078000400780004007800040078000C0078000C0078001800F +800F80FFFFFF801B1F7E9E1F>I<FFFFFF000F800F000780030007800300078001000780018007 +800080078000800780008007800080078080000780800007808000078080000781800007FF8000 +078180000780800007808000078080000780800007800000078000000780000007800000078000 +000780000007800000078000000FC00000FFFE0000191F7E9E1E>I<000FE0200078186000E004 +E0038002E0070001E00F0000E01E0000601E0000603C0000603C0000207C00002078000020F800 +0000F8000000F8000000F8000000F8000000F8000000F8000000F8007FFCF80003E0780001E07C +0001E03C0001E03C0001E01E0001E01E0001E00F0001E0070001E0038002E000E0046000781820 +000FE0001E217D9F24>I<FFF8FFF80F800F8007800F0007800F0007800F0007800F0007800F00 +07800F0007800F0007800F0007800F0007800F0007800F0007800F0007FFFF0007800F0007800F +0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F000780 +0F0007800F0007800F000F800F80FFF8FFF81D1F7E9E22>I<FFFC0FC007800780078007800780 +078007800780078007800780078007800780078007800780078007800780078007800780078007 +80078007800FC0FFFC0E1F7F9E10>I<0FFFC0007C00003C00003C00003C00003C00003C00003C +00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C +00003C00003C00203C00F83C00F83C00F83C00F0380040780040700030E0000F800012207E9E17 +>I<FFFC0FFC0FC003E00780018007800100078002000780040007800800078010000780200007 +80400007808000078100000783000007878000078F80000793C0000791E00007A1E00007C0F000 +0780F0000780780007803C0007803C0007801E0007801E0007800F000780078007800780078007 +C00FC007E0FFFC3FFC1E1F7E9E23>I<FFFE000FC0000780000780000780000780000780000780 +000780000780000780000780000780000780000780000780000780000780000780000780000780 +0207800207800207800207800607800407800407800C07801C0F807CFFFFFC171F7E9E1C>I<FF +80001FF80F80001F800780001F0005C0002F0005C0002F0005C0002F0004E0004F0004E0004F00 +0470008F000470008F000470008F000438010F000438010F000438010F00041C020F00041C020F +00041C020F00040E040F00040E040F00040E040F000407080F000407080F000407080F00040390 +0F000403900F000401E00F000401E00F000401E00F000E00C00F001F00C01F80FFE0C1FFF8251F +7E9E2A>I<FF803FF807C007C007C0038005E0010005E0010004F001000478010004780100043C +0100043C0100041E0100040F0100040F010004078100040781000403C1000401E1000401E10004 +00F1000400F1000400790004003D0004003D0004001F0004001F0004000F000400070004000700 +0E0003001F000300FFE001001D1F7E9E22>I<001F800000F0F00001C0380007801E000F000F00 +0E0007001E0007803C0003C03C0003C07C0003E0780001E0780001E0F80001F0F80001F0F80001 +F0F80001F0F80001F0F80001F0F80001F0F80001F0F80001F0780001E07C0003E07C0003E03C00 +03C03C0003C01E0007800E0007000F000F0007801E0001C0380000F0F000001F80001C217D9F23 +>I<FFFFE0000F80780007801C0007801E0007800F0007800F8007800F8007800F8007800F8007 +800F8007800F8007800F0007801E0007801C000780780007FFE000078000000780000007800000 +078000000780000007800000078000000780000007800000078000000780000007800000078000 +000FC00000FFFC0000191F7E9E1F>I<FFFF80000F80F0000780780007803C0007801E0007801E +0007801F0007801F0007801F0007801F0007801E0007801E0007803C00078078000780F00007FF +80000781C0000780E0000780F0000780700007807800078078000780780007807C0007807C0007 +807C0007807C0407807E0407803E040FC01E08FFFC0F10000003E01E207E9E21>82 +D<07E0800C1980100780300380600180600180E00180E00080E00080E00080F00000F000007800 +007F00003FF0001FFC000FFE0003FF00001F800007800003C00003C00001C08001C08001C08001 +C08001C0C00180C00380E00300F00600CE0C0081F80012217D9F19>I<7FFFFFE0780F01E0600F +0060400F0020400F0020C00F0030800F0010800F0010800F0010800F0010000F0000000F000000 +0F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000 +000F0000000F0000000F0000000F0000000F0000000F0000000F0000001F800007FFFE001C1F7E +9E21>I<FFFC3FF80FC007C0078003800780010007800100078001000780010007800100078001 +000780010007800100078001000780010007800100078001000780010007800100078001000780 +01000780010007800100078001000780010007800100038002000380020001C0020001C0040000 +E008000070180000382000000FC0001D207E9E22>I<FFF003FE1F8000F80F0000600F80006007 +8000400780004003C0008003C0008003C0008001E0010001E0010001F0010000F0020000F00200 +00F806000078040000780400003C0800003C0800003C0800001E1000001E1000001F3000000F20 +00000F20000007C0000007C0000007C000000380000003800000038000000100001F207F9E22> +I<FFF07FF81FF01F800FC007C00F00078003800F00078001000F0007C00100078007C002000780 +07C00200078007C0020003C009E0040003C009E0040003C009E0040003E010F00C0001E010F008 +0001E010F0080001F02078080000F02078100000F02078100000F0403C10000078403C20000078 +403C20000078C03E2000003C801E4000003C801E4000003C801E4000001F000F8000001F000F80 +00001F000F8000001E00078000000E00070000000E00070000000C000300000004000200002C20 +7F9E2F>I<FFF003FF1F8000F80F8000600780004007C0004003E0008001E0008001F0010000F0 +030000F80200007C0400003C0400003E0800001E0800001F1000000FB0000007A0000007C00000 +03C0000003C0000003C0000003C0000003C0000003C0000003C0000003C0000003C0000003C000 +0003C0000007C000007FFE00201F7F9E22>89 D<FEFEC0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0 +C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0FEFE072D7CA10D>91 +D<080410082010201040204020804080408040B85CFC7EFC7E7C3E381C0F0E7B9F17>I<FEFE06 +060606060606060606060606060606060606060606060606060606060606060606060606060606 +06FEFE072D7FA10D>I<1FE000303000781800781C00300E00000E00000E00000E0000FE00078E +001E0E00380E00780E00F00E10F00E10F00E10F01E10781E103867200F83C014147E9317>97 +D<0E0000FE00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E3E +000EC3800F01C00F00E00E00E00E00700E00700E00780E00780E00780E00780E00780E00780E00 +700E00700E00E00F00E00D01C00CC300083E0015207F9F19>I<03F80E0C1C1E381E380C700070 +00F000F000F000F000F000F00070007000380138011C020E0C03F010147E9314>I<000380003F +8000038000038000038000038000038000038000038000038000038000038003E380061B801C07 +80380380380380700380700380F00380F00380F00380F00380F00380F003807003807003803803 +803807801C07800E1B8003E3F815207E9F19>I<03F0000E1C001C0E0038070038070070070070 +0380F00380F00380FFFF80F00000F00000F000007000007000003800801800800C010007060001 +F80011147F9314>I<007C00C6018F038F07060700070007000700070007000700FFF007000700 +07000700070007000700070007000700070007000700070007000700070007007FF01020809F0E +>I<0000E003E3300E3C301C1C30380E00780F00780F00780F00780F00780F00380E001C1C001E +380033E0002000002000003000003000003FFE001FFF800FFFC03001E0600070C00030C00030C0 +0030C000306000603000C01C038003FC00141F7F9417>I<0E0000FE00000E00000E00000E0000 +0E00000E00000E00000E00000E00000E00000E00000E3E000E43000E81800F01C00F01C00E01C0 +0E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C0 +FFE7FC16207F9F19>I<1C001E003E001E001C000000000000000000000000000E007E000E000E +000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E00FFC00A1F809E0C> +I<00E001F001F001F000E0000000000000000000000000007007F000F000700070007000700070 +00700070007000700070007000700070007000700070007000700070007000706070F060F0C061 +803F000C28829E0E>I<0E0000FE00000E00000E00000E00000E00000E00000E00000E00000E00 +000E00000E00000E0FF00E03C00E03000E02000E04000E08000E10000E30000E70000EF8000F38 +000E1C000E1E000E0E000E07000E07800E03800E03C00E03E0FFCFF815207F9F18>I<0E00FE00 +0E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E +000E000E000E000E000E000E000E000E000E00FFE00B20809F0C>I<0E1F01F000FE618618000E +81C81C000F00F00E000F00F00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E00 +0E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E +000E00E00E00FFE7FE7FE023147F9326>I<0E3E00FE43000E81800F01C00F01C00E01C00E01C0 +0E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C0FFE7FC +16147F9319>I<01F800070E001C03803801C03801C07000E07000E0F000F0F000F0F000F0F000 +F0F000F0F000F07000E07000E03801C03801C01C0380070E0001F80014147F9317>I<0E3E00FE +C3800F01C00F00E00E00E00E00F00E00700E00780E00780E00780E00780E00780E00780E00700E +00F00E00E00F01E00F01C00EC3000E3E000E00000E00000E00000E00000E00000E00000E00000E +0000FFE000151D7F9319>I<03E0800619801C05803C0780380380780380700380F00380F00380 +F00380F00380F00380F003807003807803803803803807801C0B800E138003E380000380000380 +000380000380000380000380000380000380003FF8151D7E9318>I<0E78FE8C0F1E0F1E0F0C0E +000E000E000E000E000E000E000E000E000E000E000E000E000E00FFE00F147F9312>I<1F9030 +704030C010C010C010E00078007F803FE00FF00070803880188018C018C018E030D0608F800D14 +7E9312>I<020002000200060006000E000E003E00FFF80E000E000E000E000E000E000E000E00 +0E000E000E000E080E080E080E080E080610031001E00D1C7F9B12>I<0E01C0FE1FC00E01C00E +01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E +03C00603C0030DC001F1FC16147F9319>I<FF83F81E01E01C00C00E00800E00800E0080070100 +07010003820003820003820001C40001C40001EC0000E80000E800007000007000007000002000 +15147F9318>I<FF9FE1FC3C0780701C0300601C0380200E0380400E0380400E03C0400707C080 +0704C0800704E080038861000388710003C8730001D0320001D03A0000F03C0000E01C0000E01C +0000601800004008001E147F9321>I<7FC3FC0F01E00701C007018003810001C20000E40000EC +00007800003800003C00007C00004E000087000107000303800201C00601E01E01E0FF07FE1714 +809318>I<FF83F81E01E01C00C00E00800E00800E008007010007010003820003820003820001 +C40001C40001EC0000E80000E800007000007000007000002000002000004000004000004000F0 +8000F08000F100006200003C0000151D7F9318>I<3FFF380E200E201C40384078407000E001E0 +01C00380078007010E011E011C0338027006700EFFFE10147F9314>I<FFFFFC1601808C17>I<FF +FFFFFFFFF02C01808C2D>I E /Fq 48 122 df<1C0038007F00FE007F00FE00FF81FF00FFC1FF +80FFC1FF807FC0FF807FC0FF801CC0398000C0018000C001800180030001800300018003000300 +06000300060006000C000C00180018003000300060002000400019157EA924>34 +D<1C007F007F00FF80FFC0FFC07FC07FC01CC000C000C00180018001800300030006000C001800 +300020000A157B8813>44 D<00000300000007800000078000000F8000000F0000000F0000001F +0000001E0000003E0000003C0000003C0000007C0000007800000078000000F8000000F0000001 +F0000001E0000001E0000003E0000003C0000003C0000007C00000078000000F8000000F000000 +0F0000001F0000001E0000003E0000003C0000003C0000007C0000007800000078000000F80000 +00F0000001F0000001E0000001E0000003E0000003C0000003C0000007C00000078000000F8000 +000F0000000F0000001F0000001E0000001E0000003E0000003C0000007C000000780000007800 +0000F8000000F0000000F000000060000000193C7CAC22>47 D<003F800001FFF00007E0FC000F +C07E001F803F001F803F003F001F803F001F807F001FC07F001FC07F001FC07F001FC0FF001FE0 +FF001FE0FF001FE0FF001FE0FF001FE0FF001FE0FF001FE0FF001FE0FF001FE0FF001FE0FF001F +E0FF001FE0FF001FE0FF001FE0FF001FE07F001FC07F001FC07F001FC07F001FC03F001F803F00 +1F801F803F001F803F000FC07E0007E0FC0001FFF000003F80001B277DA622>I<000E00001E00 +007E0007FE00FFFE00FFFE00F8FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE00 +00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE00 +00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE007FFFFE7FFFFE7FFFFE17277BA622> +I<00FF800003FFF0000FFFFC001F03FE003800FF007C007F80FE003FC0FF003FC0FF003FE0FF00 +1FE0FF001FE07E001FE03C003FE000003FE000003FC000003FC000007F8000007F000000FE0000 +00FC000001F8000003F0000003E00000078000000F0000001E0000003C00E0007000E000E000E0 +01C001C0038001C0070001C00FFFFFC01FFFFFC03FFFFFC07FFFFFC0FFFFFF80FFFFFF80FFFFFF +801B277DA622>I<007F800003FFF00007FFFC000F81FE001F00FF003F80FF003F807F803F807F +803F807F801F807F800F007F800000FF000000FF000000FE000001FC000001F8000007F00000FF +C00000FFF0000001FC0000007E0000007F0000007F8000003FC000003FC000003FE000003FE03C +003FE07E003FE0FF003FE0FF003FE0FF003FC0FF007FC07E007F807C007F003F01FE001FFFFC00 +07FFF00000FF80001B277DA622>I<00000E0000001E0000003E0000007E000000FE000000FE00 +0001FE000003FE0000077E00000E7E00000E7E00001C7E0000387E0000707E0000E07E0000E07E +0001C07E0003807E0007007E000E007E000E007E001C007E0038007E0070007E00E0007E00FFFF +FFF8FFFFFFF8FFFFFFF80000FE000000FE000000FE000000FE000000FE000000FE000000FE0000 +00FE00007FFFF8007FFFF8007FFFF81D277EA622>I<0C0003000F803F000FFFFE000FFFFC000F +FFF8000FFFF0000FFFE0000FFFC0000FFE00000E0000000E0000000E0000000E0000000E000000 +0E0000000E7FC0000FFFF8000F80FC000E003E000C003F0000001F8000001FC000001FC000001F +E000001FE018001FE07C001FE0FE001FE0FE001FE0FE001FE0FE001FC0FC001FC078003F807800 +3F803C007F001F01FE000FFFF80003FFF00000FF80001B277DA622>I<0007F000003FFC0000FF +FE0001FC0F0003F01F8007E03F800FC03F801FC03F801F803F803F801F003F8000007F0000007F +0000007F000000FF000000FF0FC000FF3FF800FF707C00FFC03E00FFC03F00FF801F80FF801FC0 +FF001FC0FF001FE0FF001FE0FF001FE07F001FE07F001FE07F001FE07F001FE03F001FE03F001F +C01F801FC01F803F800FC03F0007E07E0003FFFC0000FFF000003FC0001B277DA622>I<380000 +003E0000003FFFFFF03FFFFFF03FFFFFF07FFFFFE07FFFFFC07FFFFF807FFFFF0070000E007000 +0E0070001C00E0003800E0007000E000E0000000E0000001C00000038000000780000007800000 +0F0000000F0000001F0000001F0000003F0000003E0000003E0000007E0000007E0000007E0000 +007E000000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE0000007C00 +00003800001C297CA822>I<003FC00001FFF00003FFFC0007C07E000F003F001E001F001E000F +803E000F803E000F803F000F803F000F803FC00F003FF01F001FFC1E001FFE3C000FFFF80007FF +E00003FFF80001FFFC0001FFFE0007FFFF000F0FFF801E03FFC03C01FFC07C007FE078001FE0F8 +0007E0F80007E0F80003E0F80003E0F80003E0F80003C07C0003C07C0007803F000F001FC03E00 +0FFFFC0003FFF800007FC0001B277DA622>I<007F800001FFF00007FFF8000FE0FC001F807E00 +3F803F007F003F007F001F80FF001F80FF001FC0FF001FC0FF001FC0FF001FE0FF001FE0FF001F +E0FF001FE07F001FE07F003FE03F003FE01F807FE00F807FE007C1DFE003FF9FE0007E1FE00000 +1FE000001FC000001FC000001FC000003F801F003F803F803F003F803F003F807E003F807C001F +01F8001E03F0000FFFE00007FF800001FE00001B277DA622>I<000003800000000007C0000000 +0007C0000000000FE0000000000FE0000000000FE0000000001FF0000000001FF0000000003FF8 +000000003FF8000000003FF80000000073FC0000000073FC00000000F3FE00000000E1FE000000 +00E1FE00000001C0FF00000001C0FF00000003C0FF80000003807F80000007807FC0000007003F +C0000007003FC000000E003FE000000E001FE000001E001FF000001C000FF000001FFFFFF00000 +3FFFFFF800003FFFFFF80000780007FC0000700003FC0000700003FC0000E00001FE0000E00001 +FE0001E00001FF0001C00000FF0001C00000FF00FFFE001FFFFEFFFE001FFFFEFFFE001FFFFE2F +297EA834>65 D<00003FF001800003FFFE0380000FFFFF8780003FF007DF8000FF8001FF8001FE +00007F8003FC00003F8007F000001F800FF000000F801FE0000007801FE0000007803FC0000007 +803FC0000003807FC0000003807F80000003807F8000000000FF8000000000FF8000000000FF80 +00000000FF8000000000FF8000000000FF8000000000FF8000000000FF8000000000FF80000000 +007F80000000007F80000000007FC0000003803FC0000003803FC0000003801FE0000003801FE0 +000007000FF00000070007F000000E0003FC00001E0001FE00003C0000FF8000F800003FF007E0 +00000FFFFFC0000003FFFF000000003FF8000029297CA832>67 D<FFFFFFFFE0FFFFFFFFE0FFFF +FFFFE003FC001FE003FC0007F003FC0001F003FC0001F003FC0000F003FC00007003FC00007003 +FC00007003FC01C07803FC01C03803FC01C03803FC01C03803FC03C00003FC03C00003FC0FC000 +03FFFFC00003FFFFC00003FFFFC00003FC0FC00003FC03C00003FC03C00003FC01C00E03FC01C0 +0E03FC01C00E03FC01C01C03FC00001C03FC00001C03FC00001C03FC00003C03FC00003803FC00 +007803FC0000F803FC0001F803FC0003F803FC001FF8FFFFFFFFF0FFFFFFFFF0FFFFFFFFF02729 +7DA82D>69 D<FFFFFFFFC0FFFFFFFFC0FFFFFFFFC003FC003FC003FC000FE003FC0003E003FC00 +01E003FC0001E003FC0000E003FC0000E003FC0000E003FC0000F003FC03807003FC03807003FC +03807003FC03800003FC07800003FC07800003FC1F800003FFFF800003FFFF800003FFFF800003 +FC1F800003FC07800003FC07800003FC03800003FC03800003FC03800003FC03800003FC000000 +03FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC0000 +00FFFFFC0000FFFFFC0000FFFFFC000024297DA82B>I<00007FE003000003FFFC0700001FFFFF +0F00003FF00FFF0000FF8001FF0001FE0000FF0003F800003F0007F000003F000FF000001F001F +E000000F001FE000000F003FC000000F003FC0000007007FC0000007007F80000007007F800000 +0000FF8000000000FF8000000000FF8000000000FF8000000000FF8000000000FF8000000000FF +8000000000FF8000000000FF8001FFFFF87F8001FFFFF87F8001FFFFF87FC00000FF003FC00000 +FF003FC00000FF001FE00000FF001FE00000FF000FF00000FF0007F00000FF0003F80000FF0001 +FE0000FF0000FF8001FF00003FF007BF00001FFFFF1F000003FFFE0F0000007FF003002D297CA8 +36>I<FFFFFCFFFFFCFFFFFC01FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE00 +01FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE00 +01FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE0001FE00 +FFFFFCFFFFFCFFFFFC16297EA81A>73 D<FFFE0000001FFFC0FFFE0000001FFFC0FFFF0000003F +FFC003FF0000003FF00003FF0000003FF00003BF80000077F00003BF80000077F000039FC00000 +E7F000039FC00000E7F000038FE00001C7F000038FE00001C7F0000387F0000387F0000387F000 +0387F0000387F0000387F0000383F8000707F0000383F8000707F0000381FC000E07F0000381FC +000E07F0000380FE001C07F0000380FE001C07F0000380FF003807F00003807F003807F0000380 +7F003807F00003803F807007F00003803F807007F00003801FC0E007F00003801FC0E007F00003 +800FE1C007F00003800FE1C007F00003800FE1C007F000038007F38007F000038007F38007F000 +038003FF0007F000038003FF0007F000038001FE0007F000038001FE0007F000038000FC0007F0 +00038000FC0007F000FFFE00FC01FFFFC0FFFE007801FFFFC0FFFE007801FFFFC03A297DA841> +77 D<0000FFE000000007FFFC0000003FC07F8000007F001FC00001FC0007F00003F80003F800 +07F00001FC000FF00001FE001FE00000FF001FE00000FF003FC000007F803FC000007F807FC000 +007FC07F8000003FC07F8000003FC07F8000003FC0FF8000003FE0FF8000003FE0FF8000003FE0 +FF8000003FE0FF8000003FE0FF8000003FE0FF8000003FE0FF8000003FE0FF8000003FE0FF8000 +003FE07F8000003FC07FC000007FC07FC000007FC03FC000007F803FC000007F801FE00000FF00 +1FE00000FF000FF00001FE0007F00001FC0003F80003F80001FC0007F00000FF001FE000003FC0 +7F8000000FFFFE00000000FFE000002B297CA834>79 D<FFFFFFF800FFFFFFFF00FFFFFFFFC003 +FC003FE003FC000FF003FC0007F803FC0007FC03FC0003FC03FC0003FE03FC0003FE03FC0003FE +03FC0003FE03FC0003FE03FC0003FE03FC0003FE03FC0003FC03FC0007FC03FC0007F803FC000F +F003FC003FE003FFFFFF8003FFFFFE0003FC00000003FC00000003FC00000003FC00000003FC00 +000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC +00000003FC00000003FC00000003FC000000FFFFF00000FFFFF00000FFFFF0000027297DA82F> +I<FFFFFFE00000FFFFFFFE0000FFFFFFFF800003FC007FE00003FC000FF00003FC0007F80003FC +0007FC0003FC0003FC0003FC0003FE0003FC0003FE0003FC0003FE0003FC0003FE0003FC0003FE +0003FC0003FE0003FC0003FC0003FC0007F80003FC0007F80003FC001FE00003FC007FC00003FF +FFFE000003FFFFF0000003FC00FC000003FC007F000003FC003F800003FC003F800003FC001FC0 +0003FC001FE00003FC001FE00003FC001FE00003FC001FE00003FC001FE00003FC001FF00003FC +001FF00003FC001FF00003FC001FF00703FC001FF80703FC000FF80703FC0007F80EFFFFF003FE +1CFFFFF001FFF8FFFFF0003FF030297DA834>82 D<7FFFFFFFFFC07FFFFFFFFFC07FFFFFFFFFC0 +7F803FC03FC07E003FC007C078003FC003C078003FC003C070003FC001C0F0003FC001E0F0003F +C001E0E0003FC000E0E0003FC000E0E0003FC000E0E0003FC000E0E0003FC000E000003FC00000 +00003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003F +C0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC00000 +00003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003F +C0000000003FC00000007FFFFFE000007FFFFFE000007FFFFFE0002B287EA730>84 +D<FFFFF0003FFF80FFFFF0003FFF80FFFFF0003FFF8003FE000001E00001FE000001C00001FF00 +0003C00000FF000003800000FF0000038000007F8000070000007F8000070000007FC0000F0000 +003FC0000E0000003FE0001E0000001FE0001C0000001FF0001C0000000FF000380000000FF000 +3800000007F8007000000007F8007000000007FC00F000000003FC00E000000003FE01E0000000 +01FE01C000000001FF01C000000000FF038000000000FF038000000000FF8780000000007F8700 +000000007FCF00000000003FCE00000000003FFE00000000001FFC00000000001FFC0000000000 +0FF800000000000FF800000000000FF8000000000007F0000000000007F0000000000003E00000 +00000003E0000000000001C000000031297FA834>86 D<010002000300060006000C000C001800 +1800300030006000300060006000C0006000C0006000C000C0018000C0018000CE019C00FF81FF +00FF81FF00FFC1FF80FFC1FF807FC0FF803F807F003F807F000E001C00191578A924>92 +D<01FF800007FFF0000F81F8001FC07E001FC07E001FC03F000F803F8007003F8000003F800000 +3F8000003F80000FFF8000FFFF8007FC3F800FE03F803F803F803F003F807F003F80FE003F80FE +003F80FE003F80FE003F807E007F807F00DF803F839FFC0FFF0FFC01FC03FC1E1B7E9A21>97 +D<001FF80000FFFE0003F01F0007E03F800FC03F801F803F803F801F007F800E007F0000007F00 +0000FF000000FF000000FF000000FF000000FF000000FF000000FF0000007F0000007F0000007F +8000003F8001C01F8001C00FC0038007E0070003F01E0000FFFC00001FE0001A1B7E9A1F>99 +D<00003FF80000003FF80000003FF800000003F800000003F800000003F800000003F800000003 +F800000003F800000003F800000003F800000003F800000003F800000003F800000003F800001F +E3F80000FFFBF80003F03FF80007E00FF8000FC007F8001F8003F8003F8003F8007F0003F8007F +0003F8007F0003F800FF0003F800FF0003F800FF0003F800FF0003F800FF0003F800FF0003F800 +FF0003F8007F0003F8007F0003F8007F0003F8003F8003F8001F8003F8000F8007F80007C00FF8 +0003F03BFF8000FFF3FF80003FC3FF80212A7EA926>I<003FE00001FFF80003F07E0007C01F00 +0F801F801F800F803F800FC07F000FC07F0007C07F0007E0FF0007E0FF0007E0FFFFFFE0FFFFFF +E0FF000000FF000000FF0000007F0000007F0000007F0000003F8000E01F8000E00FC001C007E0 +038003F81F0000FFFE00001FF0001B1B7E9A20>I<0007F0003FFC00FE3E01F87F03F87F03F07F +07F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007F000 +07F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F000 +07F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF80182A7EA915>I<00FF +81F003FFE7F80FC1FE7C1F80FC7C1F007C383F007E107F007F007F007F007F007F007F007F007F +007F007F007F003F007E001F007C001F80FC000FC1F8001FFFE00018FF80003800000038000000 +3C0000003E0000003FFFF8001FFFFF001FFFFF800FFFFFC007FFFFE01FFFFFF03E0007F07C0001 +F8F80000F8F80000F8F80000F8F80000F87C0001F03C0001E01F0007C00FC01F8003FFFE00007F +F0001E287E9A22>I<FFE0000000FFE0000000FFE00000000FE00000000FE00000000FE0000000 +0FE00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE00000 +000FE00000000FE07F00000FE1FFC0000FE787E0000FEE03F0000FF803F0000FF803F8000FF003 +F8000FF003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE0 +03F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000F +E003F8000FE003F800FFFE3FFF80FFFE3FFF80FFFE3FFF80212A7DA926>I<07000F801FC03FE0 +3FE03FE01FC00F8007000000000000000000000000000000FFE0FFE0FFE00FE00FE00FE00FE00F +E00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE +0F2B7DAA14>I<FFE00000FFE00000FFE000000FE000000FE000000FE000000FE000000FE00000 +0FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE01FFC0FE01FFC0FE01F +FC0FE007800FE00F000FE01E000FE03C000FE078000FE0E0000FE3C0000FE7C0000FEFE0000FFF +E0000FFFF0000FF3F8000FE3F8000FC1FC000FC0FE000FC07F000FC07F000FC03F800FC01FC00F +C00FC00FC00FE0FFFC3FFEFFFC3FFEFFFC3FFE1F2A7EA924>107 D<FFE0FFE0FFE00FE00FE00F +E00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0 +0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2A7DA914 +>I<FFC07F800FF000FFC1FFE03FFC00FFC383F0707E000FC603F8C07F000FCC01F9803F000FD8 +01FF003F800FF001FE003F800FF001FE003F800FE001FC003F800FE001FC003F800FE001FC003F +800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001 +FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F80 +0FE001FC003F800FE001FC003F80FFFE1FFFC3FFF8FFFE1FFFC3FFF8FFFE1FFFC3FFF8351B7D9A +3A>I<FFC07F0000FFC1FFC000FFC787E0000FCE03F0000FD803F0000FD803F8000FF003F8000F +F003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F800 +0FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8 +000FE003F800FFFE3FFF80FFFE3FFF80FFFE3FFF80211B7D9A26>I<003FE00001FFFC0003F07E +000FC01F801F800FC03F800FE03F0007E07F0007F07F0007F07F0007F0FF0007F8FF0007F8FF00 +07F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F87F0007F07F0007F03F800FE03F800FE01F +800FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22>I<FFE1FE0000FFE7FF8000FFFE07 +E0000FF803F0000FF001F8000FE000FC000FE000FE000FE000FF000FE0007F000FE0007F000FE0 +007F800FE0007F800FE0007F800FE0007F800FE0007F800FE0007F800FE0007F800FE0007F000F +E000FF000FE000FF000FE000FE000FE001FC000FF001F8000FF803F0000FFE0FE0000FE7FF8000 +0FE1FC00000FE00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE00000 +000FE00000000FE0000000FFFE000000FFFE000000FFFE00000021277E9A26>I<FFC1F0FFC7FC +FFCE3E0FD87F0FD87F0FF07F0FF03E0FF01C0FE0000FE0000FE0000FE0000FE0000FE0000FE000 +0FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000FFFF00FFFF00FFFF00181B7E +9A1C>114 D<03FE300FFFF01E03F03800F0700070F00070F00070F80070FC0000FFE0007FFE00 +7FFF803FFFE01FFFF007FFF800FFF80003FC0000FC60007CE0003CF0003CF00038F80038FC0070 +FF01E0F7FFC0C1FF00161B7E9A1B>I<00700000700000700000700000F00000F00000F00001F0 +0003F00003F00007F0001FFFF0FFFFF0FFFFF007F00007F00007F00007F00007F00007F00007F0 +0007F00007F00007F00007F00007F00007F00007F03807F03807F03807F03807F03807F03803F0 +3803F87001F86000FFC0001F8015267FA51B>I<FFE03FF800FFE03FF800FFE03FF8000FE003F8 +000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003 +F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE0 +03F8000FE003F8000FE007F80007E007F80007E00FF80003F03BFF8001FFF3FF80003FC3FF8021 +1B7D9A26>I<FFFE03FF80FFFE03FF80FFFE03FF8007F000700007F000700007F800F00003F800 +E00003FC01E00001FC01C00001FC01C00000FE03800000FE038000007F070000007F070000007F +8F0000003F8E0000003FDE0000001FDC0000001FDC0000000FF80000000FF80000000FF8000000 +07F000000007F000000003E000000003E000000001C00000211B7F9A24>I<FFFE7FFC0FFEFFFE +7FFC0FFEFFFE7FFC0FFE0FE007E000E007F003F001C007F003F001C007F807F803C003F807F803 +8003F807F8038001FC0EFC070001FC0EFC070001FE1EFC0F0000FE1C7E0E0000FE1C7E0E0000FF +383F1E00007F383F1C00007F783F3C00003FF01FB800003FF01FB800003FF01FF800001FE00FF0 +00001FE00FF000000FC007E000000FC007E000000FC007E00000078003C00000078003C0002F1B +7F9A32>I<FFFC0FFF00FFFC0FFF00FFFC0FFF0007F003C00003F807800001FC07800000FE0F00 +0000FF1E0000007F3C0000003FF80000001FF00000000FF00000000FF000000007F000000007F8 +0000000FFC0000001FFE0000001EFE0000003C7F000000783F800000F01FC00001E01FE00001C0 +0FE00003C007F000FFF01FFF80FFF01FFF80FFF01FFF80211B7F9A24>I<FFFE03FF80FFFE03FF +80FFFE03FF8007F000700007F000700007F800F00003F800E00003FC01E00001FC01C00001FC01 +C00000FE03800000FE038000007F070000007F070000007F8F0000003F8E0000003FDE0000001F +DC0000001FDC0000000FF80000000FF80000000FF800000007F000000007F000000003E0000000 +03E000000001C000000001C000000003800000000380000038078000007C07000000FE0F000000 +FE0E000000FE1E000000FE3C0000007C780000003FE00000000FC000000021277F9A24>I +E /Fr 33 122 df<70F8F8F87005057C840E>46 D<0001800000018000000180000003C0000003 +C0000003C0000005E0000005E000000DF0000008F0000008F0000010F800001078000010780000 +203C0000203C0000203C0000401E0000401E0000401E0000800F0000800F0000FFFF0001000780 +01000780030007C0020003C0020003C0040003E0040001E0040001E00C0000F00C0000F03E0001 +F8FF800FFF20237EA225>65 D<0007E0100038183000E0063001C00170038000F0070000F00E00 +00701E0000701C0000303C0000303C0000307C0000107800001078000010F8000000F8000000F8 +000000F8000000F8000000F8000000F8000000F800000078000000780000107C0000103C000010 +3C0000101C0000201E0000200E000040070000400380008001C0010000E0020000381C000007E0 +001C247DA223>67 D<FFFFF0000F801E0007800700078003C0078001C0078000E0078000F00780 +0078078000780780007C0780003C0780003C0780003C0780003E0780003E0780003E0780003E07 +80003E0780003E0780003E0780003E0780003E0780003C0780003C0780007C0780007807800078 +078000F0078000E0078001E0078003C0078007000F801E00FFFFF8001F227EA125>I<FFFFFFC0 +0F8007C0078001C0078000C0078000400780004007800060078000200780002007800020078020 +20078020000780200007802000078060000780E00007FFE0000780E00007806000078020000780 +200007802000078020000780000007800000078000000780000007800000078000000780000007 +800000078000000FC00000FFFE00001B227EA120>70 D<FFFC3FFF0FC003F0078001E0078001E0 +078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001 +E0078001E0078001E007FFFFE0078001E0078001E0078001E0078001E0078001E0078001E00780 +01E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E00FC003F0FF +FC3FFF20227EA125>72 D<03FFF0001F00000F00000F00000F00000F00000F00000F00000F0000 +0F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F0000 +0F00000F00000F00000F00700F00F80F00F80F00F80E00F01E00401C0020380018700007C00014 +237EA119>74 D<FFFE00000FC00000078000000780000007800000078000000780000007800000 +078000000780000007800000078000000780000007800000078000000780000007800000078000 +000780000007800000078000000780000007800080078000800780008007800080078001800780 +018007800100078003000780030007800F000F803F00FFFFFF0019227EA11E>76 +D<FF8007FF07C000F807C0007005E0002004F0002004F0002004780020047C0020043C0020041E +0020041F0020040F002004078020040780200403C0200401E0200401E0200400F0200400F82004 +00782004003C2004003E2004001E2004000F2004000F20040007A0040003E0040003E0040001E0 +040001E0040000E00E0000601F000060FFE0002020227EA125>78 D<FFFFF0000F803C0007800F +0007800780078007C0078003C0078003E0078003E0078003E0078003E0078003E0078003E00780 +03C0078007C00780078007800F0007803C0007FFF0000780000007800000078000000780000007 +800000078000000780000007800000078000000780000007800000078000000780000007800000 +0FC00000FFFC00001B227EA121>80 D<03F0200C0C601802603001E07000E0600060E00060E000 +60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003FC00007 +E00001E00000F00000F0000070800070800070800070800070C00060C00060E000C0F000C0C801 +80C6070081FC0014247DA21B>83 D<FFFC07FF0FC000F807800070078000200780002007800020 +078000200780002007800020078000200780002007800020078000200780002007800020078000 +200780002007800020078000200780002007800020078000200780002007800020078000200780 +00200380004003C0004003C0004001C0008000E000800060010000300600001C08000003F00020 +237EA125>85 D<FFF0007FC01F80001F000F80000C00078000080007C000180003E000100001E0 +00200001F000200000F000400000F800C000007C008000003C010000003E010000001E02000000 +1F040000000F84000000078800000007D800000003D000000003E000000001E000000001E00000 +0001E000000001E000000001E000000001E000000001E000000001E000000001E000000001E000 +000001E000000001E000000003E00000003FFF000022227FA125>89 D<0FE0001838003C0C003C +0E0018070000070000070000070000FF0007C7001E07003C0700780700700700F00708F00708F0 +0708F00F087817083C23900FC1E015157E9418>97 D<0E0000FE00001E00000E00000E00000E00 +000E00000E00000E00000E00000E00000E00000E00000E00000E1F000E61C00E80600F00300E00 +380E003C0E001C0E001E0E001E0E001E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00 +700C80600C41C0083F0017237FA21B>I<01FE000703000C07801C0780380300780000700000F0 +0000F00000F00000F00000F00000F00000F000007000007800403800401C00800C010007060001 +F80012157E9416>I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E0 +0000E00000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0 +F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE17237E +A21B>I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F00000F00000F000 +00F00000F000007000007800203800201C00400E008007030000FC0013157F9416>I<003C00C6 +018F038F030F070007000700070007000700070007000700FFF807000700070007000700070007 +000700070007000700070007000700070007000700070007807FF8102380A20F>I<0E0000FE00 +001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E1F +800E60C00E80E00F00700F00700E00700E00700E00700E00700E00700E00700E00700E00700E00 +700E00700E00700E00700E00700E00700E0070FFE7FF18237FA21B>104 +D<1C001E003E001E001C00000000000000000000000000000000000E00FE001E000E000E000E00 +0E000E000E000E000E000E000E000E000E000E000E000E000E000E00FFC00A227FA10E>I<0E00 +00FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00 +000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8000F1C000E1E000E0E +000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE17237FA21A>107 +D<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E00 +0E000E000E000E000E000E000E000E000E000E000E000E000E000E000E00FFE00B237FA20E>I< +0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E003800E00E003800E00E003800 +E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038 +00E00E003800E00E003800E00E003800E00E003800E0FFE3FF8FFE27157F942A>I<0E1F80FE60 +C01E80E00F00700F00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00 +700E00700E00700E00700E00700E0070FFE7FF18157F941B>I<01FC000707000C01801800C038 +00E0700070700070F00078F00078F00078F00078F00078F00078F000787000707800F03800E01C +01C00E038007070001FC0015157F9418>I<0E1F00FE61C00E80600F00700E00380E003C0E001C +0E001E0E001E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C0 +0E3F000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B> +I<0E3CFE461E8F0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E00 +0F00FFF010157F9413>114 D<0F8830786018C018C008C008E008F0007F803FE00FF001F8003C +801C800C800CC00CC008E018D0308FC00E157E9413>I<02000200020002000600060006000E00 +1E003E00FFF80E000E000E000E000E000E000E000E000E000E000E000E040E040E040E040E040E +040708030801F00E1F7F9E13>I<0E0070FE07F01E00F00E00700E00700E00700E00700E00700E +00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006017003827800FC7F18 +157F941B>I<FFC1FE1E00780E00300E00200E002007004007004003808003808003808001C100 +01C10000E20000E20000E20000740000740000380000380000380000100017157F941A>I<FFC1 +FE1E00780E00300E00200E002007004007004003808003808003808001C10001C10000E20000E2 +0000E200007400007400003800003800003800001000001000002000002000002000004000F040 +00F08000F180004300003C0000171F7F941A>121 D E /Fs 17 118 df<000003000000000003 +00000000000300000000000780000000000780000000000FC0000000000FC0000000000FC00000 +000017E00000000013E00000000013E00000000023F00000000021F00000000021F00000000040 +F80000000040F80000000040F800000000807C00000000807C00000001807E00000001003E0000 +0001003E00000002003F00000002001F00000002001F00000004000F80000004000F8000000400 +0F800000080007C00000080007C00000180007E000001FFFFFE000001FFFFFE00000200003F000 +00200001F00000200001F00000400001F80000400000F80000400000F800008000007C00008000 +007C00008000007C00010000003E00010000003E00030000003F00030000001F00070000001F00 +1F8000003F80FFE00003FFFCFFE00003FFFC2E327EB132>65 D<00001FE000800000FFFC018000 +07F00F0180000F80018380003E0000C38000780000278000F00000178001E000000F8003C00000 +0F800780000007800780000003800F00000003801F00000001801E00000001803E00000001803C +00000001803C00000000807C00000000807C0000000080780000000000F80000000000F8000000 +0000F80000000000F80000000000F80000000000F80000000000F80000000000F80000000000F8 +0000000000F80000000000F800000FFFFC7800000FFFFC7C0000001FC07C0000000F803C000000 +0F803C0000000F803E0000000F801E0000000F801F0000000F800F0000000F80078000000F8007 +C000000F8003C000000F8001E000000F8000F000001780007C00001780003E00006380000F8000 +C3800007F00781800000FFFE008000001FF000002E337CB134>71 D<FFFF807FFFC0FFFF807FFF +C007F00003F80003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E0 +0001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F0 +0003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E0 +0001F00003E00001F00003FFFFFFF00003FFFFFFF00003E00001F00003E00001F00003E00001F0 +0003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E0 +0001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00003E00001F0 +0003E00001F00003E00001F00003E00001F00003E00001F00003E00001F00007F00003F800FFFF +807FFFC0FFFF807FFFC02A317CB032>I<FFFF80FFFF8007F00003E00003E00003E00003E00003 +E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003 +E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003 +E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00007 +F000FFFF80FFFF8011317DB017>I<00FE00000303C0000C00E00010007000100038003C003C00 +3E001C003E001E003E001E0008001E0000001E0000001E0000001E00000FFE0000FC1E0003E01E +000F801E001F001E003E001E003C001E007C001E00F8001E04F8001E04F8001E04F8003E04F800 +3E0478003E047C005E043E008F080F0307F003FC03E01E1F7D9E21>97 D<003F8000E060038018 +0700040F00041E001E1C003E3C003E7C003E7C0008780000F80000F80000F80000F80000F80000 +F80000F80000F80000F800007800007C00007C00003C00011E00011E00020F0002070004038018 +00E060003F80181F7D9E1D>99 D<000001E000003FE000003FE0000003E0000001E0000001E000 +0001E0000001E0000001E0000001E0000001E0000001E0000001E0000001E0000001E0000001E0 +000001E0000001E0000001E0001F81E000F061E001C019E0078005E00F0003E00E0003E01E0001 +E03C0001E03C0001E07C0001E0780001E0F80001E0F80001E0F80001E0F80001E0F80001E0F800 +01E0F80001E0F80001E0F80001E0780001E0780001E03C0001E03C0001E01C0001E01E0003E00E +0005E0070009E0038011F000E061FF003F81FF20327DB125>I<003F800000E0E0000380380007 +003C000E001E001E001E001C000F003C000F007C000F0078000F8078000780F8000780F8000780 +FFFFFF80F8000000F8000000F8000000F8000000F8000000F8000000780000007C0000003C0000 +003C0000801E0000800E0001000F0002000780020001C00C0000F03000001FC000191F7E9E1D> +I<07000F801F801F800F800700000000000000000000000000000000000000000000000780FF80 +FF800F800780078007800780078007800780078007800780078007800780078007800780078007 +800780078007800780078007800FC0FFF8FFF80D307EAF12>105 D<07800000FF800000FF8000 +000F80000007800000078000000780000007800000078000000780000007800000078000000780 +000007800000078000000780000007800000078000000780000007801FFC07801FFC078007E007 +800780078006000780040007800800078010000780600007808000078100000783800007878000 +078FC0000793C00007A1E00007C1F0000780F0000780780007807C0007803C0007803E0007801F +0007800F0007800F80078007C0078003C0078003E00FC007F8FFFC0FFFFFFC0FFF20327EB123> +107 D<0780FF80FF800F8007800780078007800780078007800780078007800780078007800780 +078007800780078007800780078007800780078007800780078007800780078007800780078007 +800780078007800780078007800780078007800FC0FFFCFFFC0E327EB112>I<0780FE0000FF83 +078000FF8C03C0000F9001E00007A001E00007A000F00007C000F00007C000F000078000F00007 +8000F000078000F000078000F000078000F000078000F000078000F000078000F000078000F000 +078000F000078000F000078000F000078000F000078000F000078000F000078000F000078000F0 +00078000F000078000F000078000F0000FC001F800FFFC1FFF80FFFC1FFF80211F7E9E25>110 +D<001FC00000F0780001C01C00070007000F0007801E0003C01C0001C03C0001E03C0001E07800 +00F0780000F0780000F0F80000F8F80000F8F80000F8F80000F8F80000F8F80000F8F80000F8F8 +0000F8780000F07C0001F03C0001E03C0001E01E0003C01E0003C00F00078007800F0001C01C00 +00F07800001FC0001D1F7E9E21>I<0783E0FF8C18FF907C0F907C07A07C07C03807C00007C000 +07C000078000078000078000078000078000078000078000078000078000078000078000078000 +0780000780000780000780000780000780000780000FC000FFFE00FFFE00161F7E9E19>114 +D<01FC100E03301800F0300070600030E00030E00010E00010E00010F00010F800007E00003FF0 +001FFF000FFFC003FFE0003FF00001F80000F880003C80003C80001CC0001CC0001CE0001CE000 +18F00038F00030CC0060C301C080FE00161F7E9E1A>I<00400000400000400000400000400000 +C00000C00000C00001C00001C00003C00007C0000FC0001FFFE0FFFFE003C00003C00003C00003 +C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003 +C01003C01003C01003C01003C01003C01003C01003C01001C02001E02000E0400078C0001F0014 +2C7FAB19>I<078000F000FF801FF000FF801FF0000F8001F000078000F000078000F000078000 +F000078000F000078000F000078000F000078000F000078000F000078000F000078000F0000780 +00F000078000F000078000F000078000F000078000F000078000F000078000F000078000F00007 +8000F000078001F000078001F000078001F000038002F00003C004F00001C008F800007030FF80 +001FC0FF80211F7E9E25>I E end +%%EndProlog +%%BeginSetup +%%Feature: *Resolution 300 +TeXDict begin @letter /letter where {pop letter} if +%%EndSetup +%%Page: 1 1 +bop 501 287 a Fs(A)21 b(Gen)n(tle)h(In)n(tro)r(duction)g(to)g(Hask)n(ell)432 +443 y Fr(P)o(aul)16 b(Hudak)395 501 y(Y)l(ale)g(Univ)o(ersit)o(y)203 +559 y(Departmen)o(t)e(of)j(Computer)e(Science)1228 443 y(Joseph)i(H.)f(F)l +(asel)1145 501 y(Univ)o(ersit)o(y)e(of)i(California)1044 559 +y(Los)h(Alamos)e(National)h(Lab)q(oratory)0 788 y Fq(1)69 b(In)n(tro)r +(duction)0 920 y Fp(Our)20 b(purp)q(ose)h(in)f(writing)g(this)h(tutorial)e +(is)i(not)e(to)g(teac)o(h)h(programming,)g(nor)f(ev)o(en)h(to)f(teac)o(h)h +(functional)0 977 y(programming.)j(Rather,)17 b(it)f(is)h(in)o(tended)h(to)e +(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 +(],)f(whic)o(h)h(is)0 1033 y(otherwise)11 b(a)g(rather)g(dense)h(tec)o +(hnical)g(exp)q(osition.)20 b(Our)11 b(goal)g(is)h(to)e(pro)o(vide)i(a)f(gen) +o(tle)g(in)o(tro)q(duction)i(to)d(Hask)o(ell)0 1090 y(for)k(someone)g(who)g +(has)g(exp)q(erience)j(with)e(at)f(least)g(one)h(other)f(language,)g +(preferably)h(a)f(functional)i(language)0 1146 y(\(ev)o(en)k(if)h(only)g(an)f +(\\almost-functional")h(language)f(suc)o(h)h(as)f(ML)g(or)g(Sc)o(heme\).)35 +b(If)21 b(the)f(reader)h(wishes)g(to)0 1202 y(learn)15 b(more)g(ab)q(out)g +(the)g(functional)h(programming)e(st)o(yle,)h(w)o(e)f(highly)j(recommend)e +(Bird)g(and)h(W)l(adler's)e(text)0 1259 y Fo(Intr)n(o)n(duction)k(to)g(F)m +(unctional)f(Pr)n(o)n(gr)n(amming)g Fp([1)o(],)g(whic)o(h)i(uses)e(a)g +(language)h(su\016cien)o(tly)h(similar)f(to)f(Hask)o(ell)0 +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 +(quite)i(easy)l(.)30 b(F)l(or)18 b(a)h(useful)g(surv)o(ey)g(of)f(functional)i +(programming)0 1372 y(languages)14 b(and)g(tec)o(hniques,)h(including)h(some) +e(of)f(the)h(language)g(design)h(principals)h(used)e(in)h(Hask)o(ell,)f(see)g +([2].)71 1457 y(Our)j(general)g(strategy)f(for)g(in)o(tro)q(ducing)i +(language)f(features)g(is)g(this:)24 b(motiv)m(ate)17 b(the)g(idea,)g +(de\014ne)h(some)0 1514 y(terms,)12 b(giv)o(e)i(some)e(examples,)i(and)f +(then)g(p)q(oin)o(t)g(to)g(the)g(Rep)q(ort)g(for)f(details.)20 +b(W)l(e)13 b(suggest,)g(ho)o(w)o(ev)o(er,)f(that)g(the)0 1570 +y(reader)17 b(completely)h(ignore)f(the)g(details)g(un)o(til)h(this)f(do)q +(cumen)o(t)g(has)g(b)q(een)h(completely)g(read.)24 b(On)18 +b(the)e(other)0 1627 y(hand,)g(Hask)o(ell's)h(Standard)f(Prelude)i(\(in)e +(App)q(endix)i(A)f(of)e(the)i(Rep)q(ort\))f(con)o(tains)g(lots)g(of)g(useful) +h(examples)0 1683 y(of)h(Hask)o(ell)h(co)q(de;)i(w)o(e)d(encourage)g(a)h +(thorough)e(reading)i(once)g(this)g(tutorial)g(is)g(completed.)30 +b(This)19 b(will)h(not)0 1740 y(only)d(giv)o(e)g(the)f(reader)h(a)f(feel)i +(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) +h(also)e(familiarize)j(her)e(with)0 1796 y(Hask)o(ell's)f(standard)e(set)h +(of)g(prede\014ned)i(functions)f(and)f(t)o(yp)q(es.)71 1882 +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 +(ying)h(out)g(a)f(plethora)h(of)f(lexical)j(syn)o(tax)d(rules)h(at)f(the)h +(outset.)0 1938 y(Rather,)i(w)o(e)g(in)o(tro)q(duce)h(them)f(incremen)o +(tally)i(as)e(our)f(examples)i(demand,)g(and)f(enclose)h(them)f(in)h(brac)o +(k)o(ets,)0 1995 y(as)f(with)i(this)f(paragraph.)24 b(This)18 +b(is)f(in)h(stark)e(con)o(trast)f(to)h(the)h(organization)g(of)g(the)g(Rep)q +(ort,)g(although)g(the)0 2051 y(Rep)q(ort)h(remains)g(the)f(authoritativ)o(e) +g(source)h(for)e(details)j(\(references)e(suc)o(h)h(as)f(\\)p +Fn(x)p Fp(2.1")f(refer)h(to)g(sections)h(in)0 2107 y(the)d(Rep)q(ort\).])71 +2193 y(Hask)o(ell)g(is)h(a)e Fo(typ)n(eful)h Fp(programming)f(language:)922 +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 +(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 +(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 +(Hask)o(ell's)h(t)o(yp)q(e)g(system)f(from)g(the)h(outset.)19 +b(F)l(or)0 2306 y(those)12 b(whose)g(only)g(exp)q(erience)i(is)f(with)f +(relativ)o(ely)h(\\un)o(t)o(yp)q(eful")g(languages)f(suc)o(h)g(as)g(Basic)g +(or)g(Lisp,)h(this)g(ma)o(y)0 2362 y(b)q(e)f(a)e(di\016cult)i(adjustmen)o(t;) +g(for)e(those)h(familiar)g(with)h(P)o(ascal,)f(Mo)q(dula,)h(or)e(ev)o(en)h +(ML,)g(the)g(adjustmen)o(t)f(should)0 2419 y(b)q(e)19 b(easier)h(but)e(still) +j(not)d(insigni\014can)o(t,)j(since)f(Hask)o(ell's)f(t)o(yp)q(e)g(system)f +(is)i(di\013eren)o(t)f(and)f(somewhat)g(ric)o(her)0 2475 y(than)g(most.)29 +b(In)19 b(an)o(y)g(case,)g(\\t)o(yp)q(eful)g(programming")e(is)i(part)f(of)g +(the)h(Hask)o(ell)g(programming)f(exp)q(erience,)0 2532 y(and)d(cannot)g(b)q +(e)h(a)o(v)o(oided.)p 0 2571 780 2 v 52 2598 a Fl(1)69 2614 +y Fk(A)d(phrase)h(due)f(to)g(Luca)g(Cardelli.)940 2738 y Fp(T-1)p +eop +%%Page: 2 2 +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 +(GOODIES)0 105 y Fq(2)69 b(V)-6 b(alues,)23 b(T)n(yp)r(es,)g(and)g(Other)g +(Go)r(o)r(dies)0 228 y Fp(Because)g(Hask)o(ell)g(is)f(a)g(purely)i +(functional)f(language,)h(all)f(computations)f(are)g(done)g(via)g(the)h(ev)m +(aluation)0 285 y(of)18 b Fo(expr)n(essions)e Fp(\(syn)o(tactic)i(terms\))f +(to)g(yield)j Fo(values)e Fp(\(abstract)f(en)o(tities)h(that)g(w)o(e)g +(regard)f(as)h(answ)o(ers\).)27 b(In)0 341 y(particular,)12 +b(there)g(are)f(no)g Fo(c)n(ommands)g Fp(that)f(op)q(erate)h(b)o(y)g +(implicit)j(side)e(e\013ects)f(to)g(a)g(global)h(store.)17 +b(In)12 b(addition,)0 398 y(ev)o(ery)j(v)m(alue)g(has)g(an)f(asso)q(ciated)h +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 +(t)o(yp)q(es)f(as)g(sets)h(of)f(v)m(alues.\))20 b(Examples)0 +454 y(of)f(expressions)g(include)j(atomic)c(v)m(alues)j(suc)o(h)e(as)g(the)g +(in)o(teger)g Fi(5)p Fp(,)g(the)g(c)o(haracter)f Fi('a')p Fp(,)i(and)f(the)g +(successor)0 511 y(function)d Fi(succ)o Fp(,)f(as)g(w)o(ell)h(as)f +(structured)g(v)m(alues)i(suc)o(h)e(as)g(the)g(list)h Fi([1,2,3])e +Fp(and)i(the)f(pair)h Fi(\('b',4\))o Fp(.)71 589 y(Just)f(as)h(expressions)g +(denote)g(v)m(alues,)h Fo(typ)n(e)f(expr)n(essions)f Fp(are)g(syn)o(tactic)h +(terms)f(that)g(denote)h Fo(typ)n(e)g(values)0 645 y Fp(\(or)10 +b(just)h Fo(typ)n(es)p Fp(\).)18 b(Examples)11 b(of)g(t)o(yp)q(e)g +(expressions)h(include)i(the)d(atomic)g(t)o(yp)q(es)g Fi(Int)f +Fp(\(\014xed-precision)k(in)o(tegers\),)0 702 y Fi(Char)h Fp(\(ascii)h(c)o +(haracters\),)d Fi(Int->Int)h Fp(\(functions)i(mapping)g Fi(Int)f +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) +0 758 y Fi([Int])f Fp(\(homogeneous)h(lists)h(of)f(in)o(tegers\))g(and)g +Fi(\(Char,Int\))f Fp(\(c)o(haracter/in)o(teger)g(pairs\).)71 +837 y(All)h(Hask)o(ell)g(v)m(alues)g(are)f(\\\014rst-class"|they)g(ma)o(y)g +(b)q(e)g(passed)h(as)e(argumen)o(ts)h(to)f(functions,)i(returned)f(as)0 +893 y(results,)i(placed)g(in)h(data)e(structures,)g(etc.)21 +b(Hask)o(ell)16 b(t)o(yp)q(es,)g(on)f(the)h(other)f(hand,)h(are)f +Fo(not)h Fp(\014rst-class.)21 b(T)o(yp)q(es)0 949 y(in)16 b(a)e(sense)h +Fo(describ)n(e)f Fp(v)m(alues,)i(and)f(the)f(asso)q(ciation)i(of)e(a)g(v)m +(alue)i(with)f(its)g(t)o(yp)q(e)g(is)g(called)i(a)d Fo(typing)p +Fp(.)20 b(Using)15 b(the)0 1006 y(examples)h(of)f(v)m(alues)h(and)f(t)o(yp)q +(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 +1115 y Fi(5)48 b(::)23 b(Int)667 1171 y('a')h(::)f(Char)643 +1228 y(succ)h(::)f(Int)h(->)f(Int)572 1284 y([1,2,3])g(::)g([Int])572 +1341 y(\('b',4\))g(::)g(\(Char,Int\))0 1450 y Fp(The)15 b Fi(::)g +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 +(Hask)o(ell)g(are)f(normally)h(de\014ned)h(b)o(y)e(a)f(series)i(of)f +Fo(e)n(quations)p Fp(.)22 b(F)l(or)16 b(example,)h(the)f(successor)0 +1585 y(function)g Fi(succ)f Fp(can)g(b)q(e)h(de\014ned)g(b)o(y)g(the)f +(single)h(equation:)71 1694 y Fi(succ)23 b(n)238 b(=)24 b(n+1)0 +1803 y Fp(An)16 b(equation)g(is)g(an)g(example)h(of)e(a)g Fo(de)n(clar)n +(ation)p Fp(.)21 b(Another)16 b(kind)h(of)e(declaration)i(is)f(a)f +Fo(typ)n(e)i(signatur)n(e)f(de)n(cla-)0 1859 y(r)n(ation)f +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 +(explicit)i(t)o(yping)f(for)e Fi(succ)p Fp(:)71 1971 y Fi(succ)285 +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 +(h)g(more)g(to)f(sa)o(y)h(ab)q(out)g(function)h(de\014nitions)h(in)f(Section) +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 +(to)e(indicate)j(that)d(an)h(expression)h Fh(e)1562 2165 y +Fm(1)1601 2158 y Fp(ev)m(aluates,)h(or)d(\\re-)0 2214 y(duces,")d(to)g +(another)g(expression)h(or)e(v)m(alue)j Fh(e)795 2221 y Fm(2)815 +2214 y Fp(,)e(w)o(e)f(will)j(write:)838 2307 y Fh(e)859 2314 +y Fm(1)952 2307 y Fn(\))74 b Fh(e)1092 2314 y Fm(2)0 2400 y +Fp(F)l(or)15 b(example,)g(note)g(that:)712 2457 y Fi(succ)23 +b(\(succ)g(3\))73 b Fn(\))h Fi(5)71 2557 y Fp(Hask)o(ell's)17 +b Fo(static)h(typ)n(e)h(system)d Fp(de\014nes)j(the)e(formal)g(relationship)i +(b)q(et)o(w)o(een)f(t)o(yp)q(es)f(and)h(v)m(alues)g(\()p Fn(x)p +Fp(4.1.3\).)0 2614 y(The)11 b(static)f(t)o(yp)q(e)h(system)f(ensures)i(that)d +(Hask)o(ell)j(programs)d(are)i Fo(typ)n(e)h(safe)p Fp(;)f(that)f(is,)i(that)e +(the)h(programmer)e(has)p eop +%%Page: 3 3 +bop 0 -40 a Fj(2.1)45 b(P)o(olymorphic)15 b(T)o(yp)q(es)1390 +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 +(y)l(.)19 b(F)l(or)12 b(example,)i(w)o(e)f(cannot)h(generally)g(add)g +(together)e(t)o(w)o(o)g(c)o(haracters,)0 162 y(so)17 b(the)g(expression)h +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 +(of)f(statically)i(t)o(yp)q(ed)f(languages)g(is)h(w)o(ell-)0 +218 y(kno)o(wn:)g(All)c(t)o(yp)q(e)e(errors)g(are)g(detected)h(at)f +(compile-time.)21 b(This)13 b(not)f(only)g(aids)h(the)g(user)f(in)i +(reasoning)e(ab)q(out)0 274 y(programs,)17 b(but)h(also)g(p)q(ermits)g(a)f +(compiler)j(to)d(generate)g(more)h(e\016cien)o(t)g(co)q(de)h(\(for)d +(example,)j(no)f(run-time)0 331 y(t)o(yp)q(e)d(tags)f(or)h(tests)g(are)g +(required\).)71 410 y(The)h(t)o(yp)q(e)g(system)f(also)h(ensures)h(that)e +(user-supplied)k(t)o(yp)q(e)d(signatures)g(are)g(correct.)22 +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 +(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 +(t)o(yp)q(e)h(signatures)f(at)g(all,)1743 450 y Fm(2)1781 467 +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 +(system)g Fo(infers)g Fp(the)g(correct)g(t)o(yp)q(es)h(for)e(us.)20 +b(Nev)o(ertheless,)15 b(judicious)h(placemen)o(t)0 580 y(of)f(t)o(yp)q(e)g +(signatures)g(is)h(a)f(go)q(o)q(d)g(idea,)h(as)e(w)o(e)h(did)i(for)d +Fi(succ)p Fp(,)g(since)j(it)e(impro)o(v)o(es)g(readabilit)o(y)i(and)e(helps)h +(bring)0 636 y(programming)f(errors)f(to)h(ligh)o(t.)71 715 +y([The)e(reader)g(will)j(note)d(that)g(w)o(e)g(ha)o(v)o(e)g(capitalized)j +(iden)o(ti\014ers)f(that)e(denote)g(sp)q(eci\014c)j(t)o(yp)q(es,)d(suc)o(h)h +(as)f Fi(Int)0 772 y Fp(and)18 b Fi(Char)o Fp(,)g(but)g(not)g(iden)o +(ti\014ers)h(that)e(denote)h(v)m(alues,)h(suc)o(h)f(as)g Fi(succ)o +Fp(.)28 b(This)18 b(is)g(not)g(just)f(a)h(con)o(v)o(en)o(tion:)25 +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 +(In)c(fact,)f(the)h(case)f(of)h(the)f(other)h(c)o(haracters)e(matters,)h(to)q +(o:)20 b Fi(foo)o Fp(,)0 885 y Fi(fOo)p Fp(,)14 b(and)i Fi(fOO)e +Fp(are)h(all)i(distinct)f(iden)o(ti\014ers.])0 1028 y Fg(2.1)56 +b(P)n(olymorphic)17 b(T)n(yp)r(es)0 1137 y Fp(Hask)o(ell)k(also)g(incorp)q +(orates)f Fo(p)n(olymorphic)h Fp(t)o(yp)q(es|t)o(yp)q(es)g(that)f(are)g(univ) +o(ersally)i(quan)o(ti\014ed)g(in)f(some)f(w)o(a)o(y)0 1194 +y(o)o(v)o(er)d Fo(al)r(l)g Fp(t)o(yp)q(es.)27 b(P)o(olymorphic)18 +b(t)o(yp)q(e)f(expressions)i(essen)o(tially)g(describ)q(e)g +Fo(families)e Fp(of)g(t)o(yp)q(es.)27 b(F)l(or)16 b(example,)0 +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 +(yp)q(es)f(consisting)i(of,)g(for)e(ev)o(ery)h(t)o(yp)q(e)g +Fi(a)p Fp(,)h(the)f(t)o(yp)q(e)g(of)g(lists)h(of)e Fi(a)p Fp(.)40 +b(Lists)22 b(of)0 1306 y(in)o(tegers)15 b(\(e.g.)f Fi([1,2,3])o +Fp(\),)g(lists)i(of)f(c)o(haracters)f(\()p Fi(['a','b','c'])n +Fp(\),)g(ev)o(en)h(lists)h(of)f(lists)h(of)e(in)o(tegers,)h(etc.,)f(are)0 +1363 y(all)j(mem)o(b)q(ers)e(of)h(this)g(family)l(.)22 b(\(Note,)15 +b(ho)o(w)o(ev)o(er,)f(that)h Fi([2,'b'])g Fp(is)h Fo(not)f +Fp(a)h(v)m(alid)h(example,)f(since)h(there)f(is)g(no)0 1419 +y(single)h(t)o(yp)q(e)e(that)f(con)o(tains)i(b)q(oth)f Fi(2)g +Fp(and)g Fi('b')p Fp(.\))71 1499 y([Iden)o(ti\014ers)21 b(suc)o(h)f(as)44 +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 +Fp(,)g(and)f(are)g(uncapitalized)j(to)d(distinguish)0 1555 +y(them)d(from)g(sp)q(eci\014c)i(t)o(yp)q(es)f(suc)o(h)f(as)g +Fi(Int)p Fp(.)26 b(F)l(urthermore,)17 b(since)i(Hask)o(ell)f(has)f(only)h +(univ)o(ersally)h(quan)o(ti\014ed)0 1612 y(t)o(yp)q(es,)c(there)g(is)h(no)f +(need)h(to)f(explicitly)j(write)d(out)g(the)g(sym)o(b)q(ol)g(for)g(univ)o +(ersal)h(quan)o(ti\014cation,)g(and)f(th)o(us)g(w)o(e)0 1668 +y(simply)g(write)f Fi([a])f Fp(in)i(the)f(example)g(ab)q(o)o(v)o(e.)19 +b(In)c(other)e(w)o(ords,)g(all)i(t)o(yp)q(e)f(v)m(ariables)h(are)e +(implicitly)k(univ)o(ersally)0 1725 y(quan)o(ti\014ed.])71 +1804 y(Lists)g(are)g(a)g(commonly)h(used)g(data)e(structure)i(in)g +(functional)g(languages,)g(and)f(are)g(a)g(go)q(o)q(d)g(v)o(ehicle)j(for)0 +1860 y(explaining)f(the)e(principals)j(of)c(p)q(olymorphism.)27 +b(The)17 b(list)h Fi([1,2,3])e Fp(in)i(Hask)o(ell)f(is)h(actually)g +(shorthand)f(for)0 1917 y(the)i(list)g Fi(1:\(2:\(3:[]\)\))o +Fp(,)g(where)g Fi([])f Fp(is)i(the)e(empt)o(y)h(list)g(and)g +Fi(:)g Fp(is)g(the)g(in\014x)h(op)q(erator)e(that)g(adds)g(its)h(\014rst)0 +1973 y(argumen)o(t)f(to)g(the)h(fron)o(t)f(of)h(its)g(second)g(argumen)o(t)f +(\(a)g(list\).)1093 1957 y Fm(3)1145 1973 y Fp(Since)i Fi(:)f +Fp(is)g(righ)o(t)g(asso)q(ciativ)o(e,)g(w)o(e)g(can)g(also)0 +2030 y(write)c(this)h(list)g(as)f Fi(1:2:3:[])o Fp(.)71 2109 +y(As)c(an)h(example)g(of)f(a)h(user-de\014ned)h(function)f(that)f(op)q +(erates)h(on)f(lists,)i(consider)f(the)g(problem)g(of)g(coun)o(ting)0 +2165 y(the)j(n)o(um)o(b)q(er)h(of)f(elemen)o(ts)g(in)h(a)f(list:)71 +2266 y Fi(length)428 b(::)24 b([a])f(->)h(Int)71 2322 y(length)46 +b([])334 b(=)24 b(0)71 2379 y(length)f(\(x:xs\))261 b(=)24 +b(1)g(+)f(length)h(xs)0 2488 y Fp(This)14 b(de\014nition)i(is)e(almost)g +(self-explanatory)l(.)20 b(W)l(e)14 b(can)g(read)g(the)g(equations)g(as)f(sa) +o(ying:)19 b(\\The)14 b(length)g(of)g(the)p 0 2525 780 2 v +52 2552 a Fl(2)69 2568 y Fk(With)g(a)f(few)g(exceptions)i(to)d(b)q(e)i +(describ)q(ed)h(later.)52 2598 y Fl(3)69 2614 y Ff(:)e Fk(and)g +Ff([])f Fk(are)h(lik)o(e)i(Lisp's)e Ff(cons)f Fk(and)h Ff(nil)o +Fk(,)g(resp)q(ectiv)o(ely)m(.)p eop +%%Page: 4 4 +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 +(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 +(list)g(whose)g(\014rst)f(elemen)o(t)h(is)h Fi(x)e Fp(and)h(remainder)g(is)g +Fi(xs)g Fp(is)g(1)f(plus)i(the)0 162 y(length)g(of)f Fi(xs)p +Fp(.")26 b(\(Note)16 b(the)i(naming)f(con)o(v)o(en)o(tion)h(used)g(here;)g +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 +(read)0 218 y(that)c(w)o(a)o(y)l(.\))71 300 y(Although)20 b(in)o(tuitiv)o(e,) +h(this)f(example)g(highligh)o(ts)h(an)e(imp)q(ortan)o(t)g(asp)q(ect)h(of)f +(Hask)o(ell)h(that)f(is)h(y)o(et)f(to)f(b)q(e)0 357 y(explained:)k +Fo(p)n(attern)17 b(matching)p Fp(.)j(The)15 b(left-hand)i(sides)f(of)f(the)g +(equations)h(con)o(tain)f Fo(p)n(atterns)g Fp(suc)o(h)h(as)f +Fi([])g Fp(and)0 413 y Fi(x:xs)o Fp(.)28 b(In)19 b(a)e(function)i +(application)g(these)f(patterns)g(are)f Fo(matche)n(d)i Fp(against)e(actual)h +(parameters)f(in)i(a)e(fairly)0 469 y(in)o(tuitiv)o(e)c(w)o(a)o(y)d(\()p +Fi([])h Fp(only)h(matc)o(hes)f(the)h(empt)o(y)f(list,)i(and)e +Fi(x:xs)g Fp(will)i(successfully)h(matc)o(h)d(an)o(y)g(list)h(with)g(at)f +(least)0 526 y(one)17 b(elemen)o(t,)g(binding)i Fi(x)d Fp(to)g(the)h(\014rst) +f(elemen)o(t)i(and)e Fi(xs)h Fp(to)f(the)h(rest)f(of)g(the)h(list\).)24 +b(If)17 b(the)g(matc)o(h)f(succeeds,)0 582 y(the)h(righ)o(t-hand)g(side)g(is) +h(ev)m(aluated)f(and)g(returned)g(as)f(the)h(result)g(of)f(the)h +(application.)26 b(If)17 b(it)g(fails,)g(the)g(next)0 639 y(equation)f(is)f +(tried,)h(and)f(if)h(all)g(equations)f(fail,)h(an)f(error)g(results.)71 +721 y(De\014ning)e(functions)g(b)o(y)f(pattern)f(matc)o(hing)i(is)f(quite)h +(common)f(in)h(Hask)o(ell,)g(and)g(the)f(user)g(should)h(b)q(ecome)0 +777 y(familiar)j(with)g(the)f(v)m(arious)h(kinds)g(of)f(patterns)g(that)g +(are)g(allo)o(w)o(ed;)g(w)o(e)g(will)i(return)e(to)g(this)h(issue)g(in)g +(Section)0 834 y(3.14.)71 916 y Fi(length)i Fp(is)i(also)f(an)g(example)i(of) +e(a)g Fo(p)n(olymorphic)h(function)p Fp(.)32 b(It)20 b(can)f(b)q(e)h(applied) +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 +(e.)20 b(F)l(or)15 b(example:)600 1071 y Fi(length)23 b([1,2,3])245 +b Fn(\))102 b Fp(3)600 1128 y Fi(length)23 b(['a','b','c'])101 +b Fn(\))h Fp(3)600 1184 y Fi(length)23 b([[],[],[]])173 b Fn(\))102 +b Fp(3)71 1309 y(Here)15 b(are)g(t)o(w)o(o)f(other)h(useful)h(p)q(olymorphic) +h(functions)f(on)f(lists)h(that)e(will)j(b)q(e)f(used)g(later:)71 +1418 y Fi(head)476 b(::)24 b([a])f(->)h(a)71 1475 y(head)f(\(x:xs\))309 +b(=)48 b(x)71 1554 y(tail)476 b(::)24 b([a])f(->)h([a])71 1611 +y(tail)f(\(x:xs\))309 b(=)48 b(xs)71 1770 y Fp(With)10 b(p)q(olymorphic)i(t)o +(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 +(sense)g(strictly)g Fo(mor)n(e)h(gener)n(al)d Fp(than)i(others.)0 +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 +(general)h(than)f Fi([Char])o Fp(.)29 b(In)19 b(other)f(w)o(ords,)f(the)i +(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 +(former)f(b)o(y)h(a)g(suitable)h(substitution)g(for)e Fi(a)p +Fp(.)18 b(With)12 b(regard)e(to)g(this)i(generalization)g(ordering,)0 +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 +(imp)q(ortan)o(t)h(prop)q(erties:)32 b(First,)22 b(ev)o(ery)e(w)o(ell-t)o(yp) +q(ed)j(expression)e(is)0 1996 y(guaran)o(teed)16 b(to)f(ha)o(v)o(e)h(a)g +(unique)i Fo(princip)n(al)d Fp(t)o(yp)q(e)i(\(explained)g(b)q(elo)o(w\),)g +(and)f(second,)h(the)f(principal)j(t)o(yp)q(e)d(can)0 2053 +y(b)q(e)k Fo(inferr)n(e)n(d)f Fp(automatically)h(\()p Fn(x)o +Fp(4.1.3\).)31 b(In)20 b(comparison)g(to)f(a)g Fo(monomorphic)n(al)r(ly)i +(typ)n(e)n(d)e Fp(language)h(suc)o(h)f(as)0 2109 y(P)o(ascal,)c(the)h(reader) +g(will)i(\014nd)e(that)f Fo(p)n(olymorphism)i Fp(impro)o(v)o(es)e(expressiv)o +(eness,)i(and)f Fo(typ)n(e)h(infer)n(enc)n(e)d Fp(lessens)0 +2166 y(the)h(burden)h(of)f(t)o(yp)q(es)g(on)h(the)f(programmer.)71 +2248 y(An)f(expression's)h(or)e(function's)i(principal)h(t)o(yp)q(e)f(is)f +(the)g(least)h(general)f(t)o(yp)q(e)h(that,)e(in)o(tuitiv)o(ely)l(,)j(\\con)o +(tains)0 2304 y(all)22 b(instances)f(of)f(the)h(expression.")37 +b(F)l(or)20 b(example,)j(the)e(principal)i(t)o(yp)q(e)d(of)h +Fi(head)f Fp(is)h Fi([a]->a)o Fp(;)i(the)e(t)o(yp)q(es)0 2361 +y Fi([b]->a)o Fp(,)15 b Fi(a->a)o Fp(,)f(or)g(ev)o(en)39 b +Fi(a)g Fp(are)14 b Fo(to)n(o)i(gener)n(al)p Fp(,)d(whereas)i(something)g(lik) +o(e)g Fi([Int]->Int)f Fp(is)h Fo(to)n(o)h(sp)n(e)n(ci\014c)p +Fp(.)i(The)0 2417 y(existence)c(of)e(unique)h(principal)i(t)o(yp)q(es)d(is)h +(the)g(hallmark)g(feature)f(of)g(the)g Fo(Hind)r(ley-Milner)h(typ)n(e)g +(system)p Fp(,)f(whic)o(h)0 2473 y(forms)g(the)g(basis)h(of)f(the)h(t)o(yp)q +(e)f(systems)g(of)g(Hask)o(ell,)h(ML,)g(Miranda,)1191 2457 +y Fm(4)1223 2473 y Fp(and)g(sev)o(eral)f(other)g(\(mostly)g(functional\))0 +2530 y(languages.)p 0 2571 780 2 v 52 2598 a Fl(4)69 2614 y +Fk(\\Miranda")j(is)f(a)f(trademark)h(of)e(Researc)o(h)i(Soft)o(w)o(are,)f +(Ltd.)p eop +%%Page: 5 5 +bop 0 -40 a Fj(2.2)45 b(User-De\014ned)16 b(T)o(yp)q(es)1384 +b Fp(T-5)0 105 y Fg(2.2)56 b(User-De\014ned)17 b(T)n(yp)r(es)0 +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 +(ell)g(using)g(a)f Fi(data)f Fp(declaration,)i(whic)o(h)g(w)o(e)f(in)o(tro)q +(duce)h(via)f(a)g(series)0 273 y(of)f(examples)h(\()p Fn(x)p +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 +(Hask)o(ell)g(is)g(that)e(of)h(truth)g(v)m(alues:)71 464 y +Fi(data)23 b(Bool)357 b(=)24 b(False)f(|)h(True)0 573 y Fp(The)17 +b(t)o(yp)q(e)h(b)q(eing)g(de\014ned)h(here)e(is)h Fi(Bool)o +Fp(,)g(and)f(it)g(has)g(exactly)h(t)o(w)o(o)e(v)m(alues:)25 +b Fi(True)16 b Fp(and)i Fi(False)o Fp(.)26 b Fi(Bool)16 b Fp(is)i(an)0 +630 y(example)g(of)e(a)h(\(n)o(ullary\))g Fo(typ)n(e)h(c)n(onstructor)p +Fp(,)f(and)h Fi(True)e Fp(and)h Fi(False)g Fp(are)f(\(also)h(n)o(ullary\))h +Fo(data)g(c)n(onstructors)0 686 y Fp(\(or)c(just)h Fo(c)n(onstructors)p +Fp(,)g(for)f(short\).)71 768 y(Similarly)l(,)j(w)o(e)e(migh)o(t)g(wish)g(to)g +(de\014ne)h(a)f(color)g(t)o(yp)q(e:)71 877 y Fi(data)23 b(Color)333 +b(=)24 b(Red)f(|)h(Green)f(|)h(Blue)f(|)h(Indigo)f(|)h(Violet)0 +986 y Fp(Both)18 b Fi(Bool)f Fp(and)h Fi(Color)f Fp(are)g(examples)i(of)e +Fo(enumer)n(ate)n(d)h(typ)n(es)p Fp(,)g(since)h(they)f(consist)g(of)f(a)h +(\014nite)g(n)o(um)o(b)q(er)g(of)0 1043 y(n)o(ullary)e(data)f(constructors.) +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) +h(data)e(constructor:)71 1234 y Fi(data)23 b(Point)g(a)286 +b(=)24 b(Pt)g(a)f(a)0 1343 y Fp(Because)13 b(of)g(the)g(single)h +(constructor,)e(a)g(t)o(yp)q(e)h(lik)o(e)h Fi(Point)e Fp(is)i(often)e(called) +j(a)d Fo(tuple)i(typ)n(e)p Fp(,)f(since)h(it)f(is)g(essen)o(tially)0 +1399 y(just)h(a)h(cartesian)f(pro)q(duct)h(\(in)g(this)g(case)g(binary\))g +(of)f(other)g(t)o(yp)q(es.)1189 1383 y Fm(5)1228 1399 y Fp(In)i(con)o(trast,) +d(m)o(ulti-constructor)h(t)o(yp)q(es,)0 1456 y(suc)o(h)i(as)e +Fi(Bool)h Fp(and)g Fi(Color)p Fp(,)f(are)h(called)i(\(disjoin)o(t\))e +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 +(ev)o(er,)f Fi(Point)g Fp(is)i(an)e(example)i(of)e(a)h Fo(p)n(olymorphic)g +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 +(de\014nes)0 1594 y(the)17 b(t)o(yp)q(e)h(of)f(cartesian)g(p)q(oin)o(ts)h +(that)f(use)g Fh(t)h Fp(as)f(the)h(co)q(ordinate)f(t)o(yp)q(e.)27 +b Fi(Point)17 b Fp(can)g(no)o(w)g(b)q(e)h(seen)g(clearly)g(as)0 +1651 y(a)g(unary)g(t)o(yp)q(e)g(constructor,)f(since)j(from)d(the)h(t)o(yp)q +(e)g Fh(t)h Fp(it)f(constructs)g(a)f(new)i(t)o(yp)q(e)f Fi(Point)23 +b Fh(t)p Fp(.)29 b(\(In)18 b(the)g(same)0 1707 y(sense,)e(using)h(the)f(list) +h(example)g(giv)o(en)g(earlier,)g Fi([)p 884 1707 14 2 v 16 +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) +o(e)f(used)i(\\)p 1914 1707 V 16 w(")0 1764 y(to)g(denote)i(the)f(missing)h +(argumen)o(t\):)24 b(giv)o(en)19 b(an)o(y)f(t)o(yp)q(e)g Fh(t)g +Fp(w)o(e)g(can)g(\\apply")h Fi([)p 1404 1764 V 16 w(])f Fp(to)f(yield)j(a)e +(new)g(t)o(yp)q(e)g Fi([)p Fh(t)p Fi(])p Fp(.)0 1820 y(Similarly)l(,)p +203 1820 V 32 w Fi(->)p 267 1820 V 28 w Fp(is)c(a)e(t)o(yp)q(e)h +(constructor:)18 b(giv)o(en)13 b(t)o(w)o(o)f(t)o(yp)q(es)g +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) +f(of)h(functions)g(mapping)0 1876 y(elemen)o(ts)j(of)f(t)o(yp)q(e)g +Fh(t)g Fp(to)g(elemen)o(ts)h(of)f(t)o(yp)q(e)g Fh(u)p Fp(.\))71 +1958 y(Note)f(that)g(the)g(t)o(yp)q(e)h(of)f(the)h(binary)g(constructor)f +Fi(Pt)g Fp(is)h Fi(a)24 b(->)g(a)f(->)h(Point)f(a)p Fp(,)14 +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 +2124 y Fi(Pt)47 b(2.0)g(3.0)286 b(::)24 b(Point)f(Float)71 +2180 y(Pt)47 b('a')g('b')286 b(::)24 b(Point)f(Char)71 2237 +y(Pt)g(True)g(False)262 b(::)24 b(Point)f(Bool)0 2346 y Fp(On)16 +b(the)f(other)g(hand,)g(an)g(expression)h(suc)o(h)g(as)f Fi(Pt)23 +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 +(to)g(distinguish)i(b)q(et)o(w)o(een)f(applying)g(a)f Fo(c)n(onstructor)h +Fp(to)f(yield)i(a)e Fo(value)p Fp(,)g(and)g(applying)i(a)0 +2484 y Fo(typ)n(e)i(c)n(onstructor)e Fp(to)h(yield)h(a)f Fo(typ)n(e)p +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) +h(compute)g(things)p 0 2525 780 2 v 52 2552 a Fl(5)69 2568 +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 +Fk(in)i(other)g(languages,)h(except)f(that)g(the)g(elemen)o(ts)g(are)g(p)q +(ositional,)i(rather)e(than)g(ha)o(ving)0 2614 y(names)h(\(lab)q(els\))g +(asso)q(ciated)h(with)f(them.)p eop +%%Page: 6 6 +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 +(GOODIES)0 105 y Fp(in)g(Hask)o(ell,)h(whereas)e(the)h(latter)f(happ)q(ens)i +(at)e(compile-time)i(and)f(is)g(part)f(of)g(the)h(t)o(yp)q(e)g(system's)f +(pro)q(cess)g(of)0 162 y(ensuring)h(t)o(yp)q(e)f(safet)o(y)l(.)0 +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) +h(also)f(b)q(e)h(recursiv)o(e,)f(as)g(in:)71 511 y Fi(data)23 +b(Tree)g(a)310 b(=)24 b(Leaf)f(a)h(|)g(Branch)f(\(Tree)g(a\))h(\(Tree)f(a\))0 +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 +(binary)g(tree)e(t)o(yp)q(e)h(whose)g(elemen)o(ts)g(are)g(either)h(leaf)f(no) +q(des)g(con)o(taining)0 677 y(a)k(v)m(alue)h(of)f(t)o(yp)q(e)g +Fi(a)p Fp(,)g(or)g(in)o(ternal)h(no)q(des)g(\(\\branc)o(hes"\))e(con)o +(taining)i(\(recursiv)o(ely\))g(t)o(w)o(o)e(sub-trees.)71 751 +y(When)e(reading)g(data)f(declarations)h(suc)o(h)g(as)f(this,)i(remem)o(b)q +(er)f(that)f Fi(Tree)g Fp(is)h(a)f(t)o(yp)q(e)h(constructor,)f(whereas)0 +808 y Fi(Branch)k Fp(and)i Fi(Leaf)f Fp(are)g(data)f(constructors.)22 +b(Aside)c(from)d(establishing)j(a)e(connection)i(b)q(et)o(w)o(een)e(these)h +(con-)0 864 y(structors,)d(the)h(ab)q(o)o(v)o(e)g(declaration)h(is)g(essen)o +(tially)g(de\014ning)h(the)e(follo)o(wing)h(t)o(yp)q(es)f(for)g +Fi(Branch)f Fp(and)i Fi(Leaf)o Fp(:)71 973 y Fi(Branch)428 +b(::)24 b(Tree)f(a)h(->)g(Tree)f(a)h(->)f(Tree)g(a)71 1030 +y(Leaf)476 b(::)24 b(a)g(->)f(Tree)h(a)71 1182 y Fp(With)18 +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 +(su\016cien)o(tly)i(ric)o(h)f(to)e(allo)o(w)i(de\014ning)g(some)f(in)o +(teresting)0 1238 y(\(recursiv)o(e\))f(functions)h(that)e(use)h(it.)26 +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 +(function)h Fi(fringe)e Fp(that)0 1295 y(returns)c(a)h(list)g(of)f(all)h(the) +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 +(righ)o(t.)18 b(It's)13 b(usually)g(helpful)i(to)d(write)0 +1351 y(do)o(wn)k(the)g(t)o(yp)q(e)g(of)g(new)g(functions)h(\014rst;)f(in)h +(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 +Fi(Tree)23 b(a)h(->)g([a])o Fp(.)0 1408 y(That)16 b(is,)h Fi(fringe)e +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 +Fi(a)p Fp(,)h(maps)f(trees)g(of)g Fi(a)g Fp(in)o(to)g(lists)i(of)e +Fi(a)o Fp(.)24 b(A)0 1464 y(suitable)16 b(de\014nition)h(follo)o(ws:)71 +1564 y Fi(fringe)23 b(::)g(Tree)h(a)f(->)h([a])71 1621 y(fringe)f(\(Leaf)g +(x\))286 b(=)24 b([x])71 1677 y(fringe)f(\(Branch)g(left)g(right\))g(=)h +(fringe)f(left)g(++)h(fringe)f(right)0 1789 y Fp(Where)13 b +Fi(++)f Fp(is)i(the)f(in\014x)h(op)q(erator)e(that)g(concatenates)g(t)o(w)o +(o)g(lists)h(\(its)g(full)h(de\014nition)h(will)g(b)q(e)e(giv)o(en)g(in)h +(Section)0 1845 y(3.2\).)20 b(As)15 b(with)h(the)g Fi(length)e +Fp(example)j(giv)o(en)f(earlier,)g Fi(fringe)f Fp(is)h(de\014ned)h(using)f +(pattern)f(matc)o(hing,)g(except)0 1902 y(that)j(here)g(w)o(e)g(see)h +(patterns)f(in)o(v)o(olving)i(user-de\014ned)g(constructors:)25 +b Fi(Leaf)18 b Fp(and)g Fi(Branch)o Fp(.)30 b([Note)17 b(that)h(the)0 +1958 y(formal)d(parameters)f(are)h(easily)h(iden)o(ti\014ed)i(as)c(the)i +(ones)f(b)q(eginning)i(with)f(lo)o(w)o(er-case)f(letters.])0 +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 +(enience,)i(Hask)o(ell)g(pro)o(vides)e(a)h(w)o(a)o(y)e(to)h(de\014ne)h +Fo(typ)n(e)h(synonyms)p Fp(;)e(i.e.)g(names)h(for)f(commonly)g(used)0 +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 +(a)f Fi(type)g Fp(declaration)h(\()p Fn(x)p Fp(4.2.2\).)h(Here)f(are)f(sev)o +(eral)g(examples:)71 2367 y Fi(type)23 b(String)309 b(=)24 +b([Char])71 2423 y(type)f(Person)309 b(=)24 b(\(Name,Address\))71 +2480 y(type)f(Name)357 b(=)24 b(String)71 2536 y(data)f(Address)285 +b(=)24 b(None)f(|)h(Addr)f(String)p eop +%%Page: 7 7 +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) +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 +(new)f(t)o(yp)q(es,)f(but)h(simply)h(giv)o(e)e(new)h(names)f(for)g(existing)h +(t)o(yp)q(es.)30 b(F)l(or)0 162 y(example,)15 b(the)g(t)o(yp)q(e)f +Fi(Person)23 b(->)h(Name)14 b Fp(is)h(precisely)h(equiv)m(alen)o(t)h(to)d +Fi(\(String,Address\))21 b(->)j(String)o Fp(.)c(The)0 218 y(new)f(names)f +(are)g(often)g(shorter)g(than)g(the)h(t)o(yp)q(es)f(they)g(are)h(synon)o +(ymous)f(with,)h(but)f(this)h(is)g(not)f(the)g(only)0 274 y(purp)q(ose)13 +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 +(readabilit)o(y)h(of)e(programs)g(b)o(y)h(b)q(eing)h(more)e(mnemonic;)0 +331 y(indeed,)17 b(the)e(ab)q(o)o(v)o(e)g(examples)h(highligh)o(t)g(this.)21 +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) +o(yp)q(es:)71 440 y Fi(type)23 b(AssocList)g(a)g(b)334 b(=)24 +b([\(a,b\)])0 549 y Fp(This)16 b(is)f(the)h(t)o(yp)q(e)f(of)g(\\asso)q +(ciation)g(lists")h(whic)o(h)g(asso)q(ciate)f(v)m(alues)h(of)f(t)o(yp)q(e)g +Fi(a)g Fp(with)h(those)f(of)g(t)o(yp)q(e)g Fi(b)p Fp(.)0 723 +y Fg(2.5)56 b(Built-in)17 b(T)n(yp)r(es)h(Are)g(Not)g(Sp)r(ecial)0 +845 y Fp(Earlier)12 b(w)o(e)e(in)o(tro)q(duced)j(sev)o(eral)e(\\built-in")i +(t)o(yp)q(es)d(suc)o(h)i(as)e(lists,)j(tuples,)f(in)o(tegers,)f(and)h(c)o +(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 +(new)g(user-de\014ned)i(t)o(yp)q(es)f(can)f(b)q(e)h(de\014ned.)21 +b(Aside)c(from)d(sp)q(ecial)j(syn)o(tax,)d(are)h(the)h(built-in)0 +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) +g(user-de\014ned)i(ones?)k(The)14 b(answ)o(er)g(is)h Fo(no)p +Fp(.)k(The)14 b(sp)q(ecial)i(syn)o(tax)d(is)0 1015 y(for)i(con)o(v)o(enience) +h(and)g(for)e(consistency)i(with)g(historical)g(con)o(v)o(en)o(tion,)f(but)h +(has)f(no)g(seman)o(tic)g(consequence.)71 1104 y(W)l(e)d(can)h(emphasize)h +(this)f(p)q(oin)o(t)g(b)o(y)f(considering)i(what)e(the)h(t)o(yp)q(e)f +(declarations)h(w)o(ould)g(lo)q(ok)g(lik)o(e)h(for)e(these)0 +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 +(w)o(ed)g(to)f(use)h(the)g(sp)q(ecial)h(syn)o(tax)e(in)i(de\014ning)g(them.) +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 +(b)q(e)h(written)f(as:)71 1326 y Fi(data)23 b(Char)166 b(=)24 +b('a')g(|)f('b')h(|)f('c')h(|)g(...)214 b(--)24 b(This)f(is)h(not)f(valid)452 +1382 y(|)h('A')g(|)f('B')h(|)f('C')h(|)g(...)214 b(--)24 b(Haskell)f(code!) +452 1439 y(|)h('1')g(|)f('2')h(|)f('3')h(|)g(...)452 1495 y(...)0 +1604 y Fp(These)14 b(constructor)f(names)h(are)g(not)f(syn)o(tactically)i(v)m +(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 +(something)0 1661 y(lik)o(e:)71 1761 y Fi(data)23 b(Char)166 +b(=)24 b(Ca)g(|)f(Cb)h(|)g(Cc)f(|)h(...)452 1818 y(|)g(CA)g(|)f(CB)h(|)g(CC)f +(|)h(...)452 1874 y(|)g(C1)g(|)f(C2)h(|)g(C3)f(|)h(...)452 +1930 y(...)0 2040 y Fp(Ev)o(en)18 b(though)g(these)g(constructors)f(are)g +(more)h(concise,)h(they)f(are)g(quite)g(uncon)o(v)o(en)o(tional)h(for)e +(represen)o(ting)0 2096 y(c)o(haracters.)71 2185 y(In)k(an)o(y)g(case,)h +(writing)g(\\pseudo-Hask)o(ell")g(co)q(de)g(in)g(this)g(w)o(a)o(y)e(helps)i +(us)f(to)g(see)g(through)g(the)g(sp)q(ecial)0 2242 y(syn)o(tax.)h(W)l(e)16 +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) +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 +2298 y(constructors.)j(Thinking)d(of)e Fi(Char)g Fp(in)i(this)f(w)o(a)o(y)e +(mak)o(es)h(it)h(clear)g(wh)o(y)l(,)g(for)f(example,)h(w)o(e)f(can)h +(pattern-matc)o(h)0 2355 y(against)j(c)o(haracters)g(in)i(function)f +(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 +(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.) +71 2501 y([This)20 b(example)i(also)e(demonstrates)g(the)h(use)g(of)f +Fo(c)n(omments)f Fp(in)j(Hask)o(ell;)i(the)c(c)o(haracters)g +Fi(--)g Fp(and)h(all)0 2557 y(subsequen)o(t)f(c)o(haracters)e(to)g(the)h(end) +g(of)g(the)g(line)h(are)f(ignored.)32 b(Hask)o(ell)19 b(also)g(p)q(ermits)h +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 +Fi({-)o Fh(:)8 b(:)g(:)n Fi(-})15 b Fp(and)h(can)f(app)q(ear)g(an)o(ywhere)g +(\()p Fn(x)p Fp(2.2\).])p eop +%%Page: 8 8 +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 +(GOODIES)71 105 y Fp(Similarly)l(,)h(w)o(e)e(could)h(de\014ne)g +Fi(Int)f Fp(and)g Fi(Integer)f Fp(b)o(y:)71 215 y Fi(data)23 +b(Int)119 b(=)24 b(-65532)f(|)g(...)h(|)f(-1)h(|)g(0)g(|)f(1)h(|)g(...)f(|)h +(65532)47 b(--)24 b(more)f(pseudo-code)71 272 y(data)g(Integer)g(=)167 +b(...)23 b(-2)h(|)f(-1)h(|)g(0)g(|)f(1)h(|)g(2)f(...)0 381 +y Fp(where)15 b Fi(-65532)g Fp(and)g Fi(65532)p Fp(,)f(sa)o(y)l(,)h(are)g +(the)g(maxim)o(um)g(and)h(minim)o(um)g(\014xed)g(precision)h(in)o(tegers)e +(for)g(a)f(giv)o(en)0 437 y(implemen)o(tation.)22 b Fi(Int)15 +b Fp(is)h(a)f(m)o(uc)o(h)h(larger)f(en)o(umeration)h(than)f +Fi(Char)p Fp(,)g(but)h(it's)f(still)i(\014nite!)22 b(In)16 +b(con)o(trast,)e(the)0 494 y(pseudo-co)q(de)h(for)f Fi(Integer)f +Fp(\(the)g(t)o(yp)q(e)h(of)g(arbitrary)f(precision)j(in)o(tegers\))e(is)g(in) +o(tended)h(to)f(con)o(v)o(ey)g(an)f Fo(in\014nite)0 550 y Fp(en)o(umeration.) +71 671 y(T)l(uples)j(are)f(also)g(easy)g(to)g(de\014ne)h(pla)o(ying)g(this)g +(game:)71 780 y Fi(data)23 b(\(a,b\))333 b(=)24 b(\(a,b\))596 +b(--)24 b(more)f(pseudo-code)71 836 y(data)g(\(a,b,c\))285 +b(=)24 b(\(a,b,c\))71 893 y(data)f(\(a,b,c,d\))237 b(=)24 b(\(a,b,c,d\))94 +949 y(.)597 b(.)94 1006 y(.)g(.)94 1062 y(.)g(.)0 1171 y Fp(Eac)o(h)12 +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) +h(particular)h(length,)g(with)f Fi(\(...\))g Fp(pla)o(ying)h(a)e(role)i(in)g +(b)q(oth)0 1228 y(the)g(expresssion)g(syn)o(tax)f(\(as)f(data)h +(constructor\))g(and)g(t)o(yp)q(e-expression)i(syn)o(tax)e(\(as)f(t)o(yp)q(e) +i(constructor\).)18 b(The)0 1284 y(v)o(ertical)11 b(dots)f(after)g(the)g +(last)h(declaration)g(are)f(in)o(tended)i(to)e(con)o(v)o(ey)g(an)h +(in\014nite)h(n)o(um)o(b)q(er)f(of)f(suc)o(h)h(declarations,)0 +1341 y(re\015ecting)16 b(the)f(fact)g(that)g(tuples)h(of)e(all)j(lengths)e +(are)g(allo)o(w)o(ed)h(in)g(Hask)o(ell.)71 1461 y(Lists)f(are)g(also)g +(easily)i(handled,)f(and)f(more)g(in)o(terestingly)l(,)h(they)g(are)f +(recursiv)o(e:)94 1570 y Fi(data)24 b([a])357 b(=)24 b([])g(|)f(a)h(:)g([a]) +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 +(clearly)i(what)d(w)o(e)h(describ)q(ed)i(ab)q(out)e(lists)h(earlier:)20 +b Fi([])12 b Fp(is)i(the)f(empt)o(y)g(list,)h(and)f Fi(:)g +Fp(is)h(the)f(in\014x)0 1736 y(list)20 b(constructor;)f(th)o(us)g +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 +Fi(1:2:3:[])o Fp(.)31 b(\()p Fi(:)18 b Fp(is)i(righ)o(t)e(asso)q(ciativ)o +(e.\))0 1792 y(The)d(t)o(yp)q(e)h(of)e Fi([])h Fp(is)h Fi([a])p +Fp(,)e(and)i(the)f(t)o(yp)q(e)g(of)g Fi(:)g Fp(is)h Fi(a->[a]->[a])n +Fp(.)71 1913 y([The)i(w)o(a)o(y)f Fi(:)h Fp(is)h(de\014ned)h(here)f(is)g +(actually)g(legal)g(syn)o(tax|in\014x)h(constructors)d(are)h(p)q(ermitted)h +(in)h Fi(data)0 1969 y Fp(declarations,)13 b(and)f(are)g(distinguished)j +(from)c(in\014x)j(op)q(erators)d(\(for)g(pattern-matc)o(hing)h(purp)q(oses\)) +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 +Fi(:)g Fp(\(a)g(prop)q(ert)o(y)g(trivially)i(satis\014ed)e(b)o(y)g +Fi(:)p Fp(\).])71 2146 y(A)o(t)i(this)i(p)q(oin)o(t)f(the)g(reader)g(should)h +(note)f(carefully)h(the)f(di\013erences)i(b)q(et)o(w)o(een)e(tuples)h(and)f +(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 +(abundan)o(tly)h(clear.)31 b(In)19 b(particular,)h(note)e(the)h(recursiv)o(e) +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 +(homogeneous)h(and)g(of)g(arbitrary)f(length,)i(and)f(the)g(non-recursiv)o(e) +h(nature)f(of)f(a)0 2316 y(\(particular\))g(tuple)h(t)o(yp)q(e)f(whose)g +(elemen)o(ts)h(are)e(heterogenous)h(and)g(of)g(\014xed)g(length.)23 +b(The)17 b(t)o(yping)f(rules)h(for)0 2372 y(tuples)f(and)f(lists)h(should)h +(no)o(w)d(also)h(b)q(e)h(clear:)71 2493 y(F)l(or)e Fi(\()p +Fh(e)197 2500 y Fm(1)216 2493 y Fi(,)p Fh(e)261 2500 y Fm(2)281 +2493 y Fi(,)8 b Fh(:)g(:)g(:)d Fi(,)p Fh(e)418 2500 y Fd(n)442 +2493 y Fi(\))p Fh(;)22 b(n)13 b Fn(\025)g Fp(2,)h(if)h Fh(t)696 +2500 y Fd(i)725 2493 y Fp(is)h(the)e(t)o(yp)q(e)h(of)g Fh(e)1023 +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 +(is)h Fi(\()p Fh(t)1678 2500 y Fm(1)1698 2493 y Fi(,)p Fh(t)1738 +2500 y Fm(2)1758 2493 y Fi(,)7 b Fh(:)h(:)g(:)e Fi(,)p Fh(t)1890 +2500 y Fd(n)1914 2493 y Fi(\))o Fp(.)71 2614 y(F)l(or)14 b +Fi([)p Fh(e)197 2621 y Fm(1)217 2614 y Fi(,)p Fh(e)262 2621 +y Fm(2)282 2614 y Fi(,)7 b Fh(:)h(:)g(:)e Fi(,)p Fh(e)419 2621 +y Fd(n)442 2614 y Fi(])p Fh(;)22 b(n)13 b Fn(\025)g Fp(0,)i(eac)o(h)g +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 +(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 +Fi([)p Fh(t)p Fi(])p Fp(.)p eop +%%Page: 9 9 +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) +1157 b Fp(T-9)0 105 y Fc(2.5.1)52 b(List)18 b(Comprehensions)e(and)i +(Arithmetic)g(Sequences)0 211 y Fp(As)13 b(with)g(Lisp)h(dialects,)h(lists)e +(are)g(p)q(erv)m(asiv)o(e)h(in)g(Hask)o(ell,)g(and)f(as)f(with)i(other)e +(functional)i(languages,)f(there)g(is)0 268 y(y)o(et)e(more)g(syn)o(tactic)h +(sugar)f(to)f(aid)j(in)f(their)g(creation.)19 b(Aside)12 b(from)f(the)h +(constructors)e(for)h(lists)i(just)e(discussed,)0 324 y(Hask)o(ell)16 +b(pro)o(vides)g(an)f(expression)h(kno)o(wn)f(as)g(a)g Fo(list)g(c)n(ompr)n +(ehension)f Fp(that)h(is)g(b)q(est)h(explained)h(b)o(y)e(example:)71 +433 y Fi([)23 b(f)h(x)g(|)f(x)h(<-)g(xs)f(])0 542 y Fp(This)17 +b(expression)f(can)h(in)o(tuitiv)o(ely)h(b)q(e)e(read)g(as)g(\\the)g(list)g +(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 +(from)f Fi(xs)p Fp(.")22 b(The)0 599 y(similarit)o(y)d(to)f(set)g(notation)f +(is)i(not)e(a)h(coincidence.)31 b(The)19 b(phrase)f Fi(x<-xs)f +Fp(is)i(called)g(a)f Fo(gener)n(ator)p Fp(,)g(of)g(whic)o(h)0 +655 y(more)d(than)g(one)g(is)h(allo)o(w)o(ed,)f(as)g(in:)71 +764 y Fi([)23 b(\(x,y\))g(|)h(x<-xs,)f(y<-ys)g(])0 873 y Fp(This)17 +b(list)f(comprehension)i(forms)d(the)h(cartesian)g(pro)q(duct)g(of)g(the)g(t) +o(w)o(o)e(lists)j Fi(xs)f Fp(and)g Fi(ys)o Fp(.)22 b(The)17 +b(elemen)o(ts)f(are)0 930 y(selected)f(as)f(if)h(the)f(generators)g(w)o(ere)g +(\\nested")g(from)f(left)i(to)e(righ)o(t)h(\(with)h(the)f(righ)o(tmost)f +(generator)g(v)m(arying)0 986 y(fastest\);)g(th)o(us,)i(if)h +Fi(xs)f Fp(is)g Fi([1,2])g Fp(and)g Fi(ys)g Fp(is)h Fi([3,4])o +Fp(,)f(the)g(result)h(is)g Fi([\(1,3\),\(1,4\),\(2,3\),\(2,4)o(\)])m +Fp(.)71 1063 y(Besides)h(generators,)e(b)q(o)q(olean)i(expressions)g(called)g +Fo(guar)n(ds)g Fp(are)e(p)q(ermitted.)24 b(Guards)15 b(place)i(constrain)o +(ts)0 1119 y(on)d(the)g(elemen)o(ts)h(generated.)k(F)l(or)13 +b(example,)i(here)f(is)h(a)f(concise)h(de\014nition)h(of)d(ev)o(eryb)q(o)q +(dy's)h(fa)o(v)o(orite)f(sorting)0 1176 y(algorithm:)71 1285 +y Fi(quicksort)46 b([])262 b(=)48 b([])71 1341 y(quicksort)22 +b(\(x:xs\))190 b(=)48 b(quicksort)23 b([y)g(|)h(y)g(<-)f(xs,)h(y<x)f(])643 +1398 y(++)h([x])643 1454 y(++)g(quicksort)f([y)g(|)h(y)g(<-)f(xs,)h(y>=x])71 +1609 y Fp(T)l(o)16 b(further)h(supp)q(ort)g(the)g(use)g(of)g(lists,)h(Hask)o +(ell)f(has)g(sp)q(ecial)i(syn)o(tax)d(for)h Fo(arithmetic)h(se)n(quenc)n(es)p +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) +g(examples:)360 1750 y Fi([1..10])133 b Fn(\))88 b Fi([1,2,3,4,5,6,7,8,9,10]) +360 1806 y([1,3..10])d Fn(\))j Fi([1,3,5,7,9])360 1862 y([1,3..])133 +b Fn(\))88 b Fi([1,3,5,7,9,)22 b(...)76 b Fp(\(in\014nite)16 +b(sequence\))0 1947 y(More)f(will)h(b)q(e)g(said)g(ab)q(out)f(arithmetic)h +(sequences)g(in)g(Section)g(5.2,)e(and)i(\\in\014nite)g(lists")g(in)g +(Section)g(3.4.)0 2085 y Fc(2.5.2)52 b(Strings)0 2192 y Fp(As)15 +b(another)f(example)h(of)f(syn)o(tactic)h(sugar)f(for)g(built-in)j(t)o(yp)q +(es,)d(w)o(e)h(note)f(that)g(the)g(literal)i(string)f Fi("hello")e +Fp(is)0 2248 y(actually)h(shorthand)f(for)f(the)h(list)h(of)f(c)o(haracters)f +Fi(['h','e','l','l','o'])m Fp(.)19 b(Indeed,)c(the)e(t)o(yp)q(e)g(of)g +Fi("hello")0 2305 y Fp(is)j Fi(String)o Fp(,)f(where)g Fi(String)f +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) +o(e)f(as)h(an)g(earlier)h(example\):)71 2416 y Fi(type)23 b(String)309 +b(=)24 b([Char])0 2525 y Fp(This)16 b(means)f(w)o(e)g(can)g(use)h +(prede\014ned)h(p)q(olymorphic)f(list)g(functions)g(to)f(op)q(erate)g(on)g +(strings.)20 b(F)l(or)14 b(example:)497 2614 y Fi("hello")23 +b(++)h(")f(world")73 b Fn(\))h Fi("hello)23 b(world")p eop +%%Page: 10 10 +bop 0 -40 a Fp(T-10)1513 b Fj(3)45 b(FUNCTIONS)0 105 y Fq(3)69 +b(F)-6 b(unctions)0 266 y Fp(Since)15 b(Hask)o(ell)g(is)f(a)f(functional)i +(language,)f(one)f(w)o(ould)h(exp)q(ect)h(functions)f(to)f(pla)o(y)h(a)f(ma)s +(jor)g(role,)g(and)h(indeed)0 323 y(they)h(do.)20 b(In)c(this)g(section,)f(w) +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 +(ell.)71 428 y(First,)e(consider)i(this)g(de\014nition)h(of)e(a)g(function)h +(whic)o(h)g(adds)f(its)g(t)o(w)o(o)f(argumen)o(ts:)71 537 y +Fi(add)500 b(::)24 b(Int)f(->)h(Int)f(->)h(Int)71 593 y(add)f(x)h(y)405 +b(=)24 b(x)g(+)f(y)0 709 y Fp(This)18 b(is)g(an)f(example)i(of)e(a)g +Fo(currie)n(d)h Fp(function.)826 692 y Fm(6)873 709 y Fp(An)g(application)h +(of)e Fi(add)g Fp(has)g(the)h(form)f Fi(add)23 b Fh(e)1720 +716 y Fm(1)1757 709 y Fh(e)1778 716 y Fm(2)1798 709 y Fp(,)18 +b(and)f(is)0 765 y(equiv)m(alen)o(t)c(to)d Fi(\(add)24 b Fh(e)404 +772 y Fm(1)423 765 y Fi(\))g Fh(e)492 772 y Fm(2)512 765 y +Fp(,)12 b(since)g(function)g(application)h(asso)q(ciates)e(to)f(the)h +Fo(left)p Fp(.)18 b(In)12 b(other)f(w)o(ords,)g(applying)0 +822 y Fi(add)k Fp(to)g(one)h(argumen)o(t)f(yields)i(a)f(new)g(function)g +(whic)o(h)h(is)f(then)g(applied)i(to)d(the)g(second)i(argumen)o(t.)j(This)c +(is)0 878 y(consisten)o(t)g(with)h(the)f(t)o(yp)q(e)g(of)f +Fi(add)p Fp(,)h Fi(Int->Int->Int)n Fp(,)g(whic)o(h)h(is)f(equiv)m(alen)o(t)i +(to)d Fi(Int->\(Int->Int\))n Fp(;)h(i.e.)g Fi(->)0 934 y Fp(asso)q(ciates)f +(to)f(the)h Fo(right)p Fp(.)21 b(Indeed,)16 b(using)g Fi(add)o +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) +o(y)f(from)h(what)f(w)o(e)h(did)0 991 y(earlier:)71 1091 y +Fi(succ)476 b(=)24 b(add)f(1)0 1200 y Fp(This)16 b(is)h(an)f(example)g(of)g +(the)g Fo(p)n(artial)h(applic)n(ation)f Fp(of)f(a)h(curried)h(function,)f +(and)g(is)h(one)f(w)o(a)o(y)e(that)i(a)f(function)0 1257 y(can)20 +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 +(in)g(whic)o(h)g(it's)f(useful)h(to)e(pass)h(a)g(function)h(as)f(an)0 +1313 y(argumen)o(t.)f(The)d(w)o(ell-kno)o(wn)g Fi(map)e Fp(function)i(is)g(a) +f(p)q(erfect)h(example:)71 1423 y Fi(map)500 b(::)24 b(\(a->b\))f(->)h([a])f +(->)h([b])71 1480 y(map)f(f)48 b([])357 b(=)24 b([])71 1536 +y(map)f(f)h(\(x:xs\))285 b(=)24 b(f)g(x)f(:)h(map)g(f)f(xs)0 +1648 y Fp([F)l(unction)16 b(application)h(has)f(higher)g(precedence)i(than)d +(an)o(y)h(in\014x)g(op)q(erator,)f(and)h(th)o(us)f(the)h(righ)o(t-hand)g +(side)0 1704 y(of)h(the)h(second)g(equation)f(parses)h(as)f +Fi(\(f)23 b(x\))h(:)g(\(map)f(f)h(xs\))o Fp(.])52 b Fi(map)17 +b Fp(is)h(a)f(p)q(olymorphic)i(function,)f(and)g(its)0 1761 +y(t)o(yp)q(e)j(indicates)h(clearly)g(that)e(its)g(\014rst)h(argumen)o(t)f(is) +h(a)f(function;)k(note)c(also)h(that)f(the)h(t)o(w)o(o)e Fi(a)p +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 +(yp)q(e)g(\(lik)o(ewise)i(for)d(the)i Fi(b)p Fp('s\).)27 b(As)19 +b(an)f(example)h(of)e(the)i(use)f(of)g Fi(map)o Fp(,)h(w)o(e)f(can)0 +1874 y(incremen)o(t)e(the)f(elemen)o(ts)h(in)g(a)f(list:)569 +2011 y Fi(map)23 b(\(add)h(1\))f([1,2,3])72 b Fn(\))i Fi([2,3,4])71 +2197 y Fp(These)18 b(examples)h(demonstrate)e(the)h(\014rst-class)g(nature)g +(of)g(functions,)h(whic)o(h)g(when)f(used)h(in)g(this)f(w)o(a)o(y)0 +2254 y(are)d(usually)h(called)h Fo(higher-or)n(der)f Fp(functions.)p +0 2341 780 2 v 52 2368 a Fl(6)69 2383 y Fk(The)i(name)h Fe(curry)e +Fk(deriv)o(es)i(from)f(the)h(p)q(erson)g(who)f(p)q(opularized)j(the)e(idea:) +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 +(an)0 2429 y Fe(uncurrie)n(d)11 b Fk(function,)j(w)o(e)e(could)j(use)e(a)g +Fe(tuple)p Fk(,)e(as)i(in:)71 2518 y Ff(add)18 b(\(x,y\))292 +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) +o(ersion)i(of)e Ff(add)e Fk(is)j(really)h(just)e(a)g(function)h(of)f(one)g +(argumen)o(t!)p eop +%%Page: 11 11 +bop 0 -40 a Fj(3.1)45 b(Lam)o(b)q(da)15 b(Abstractions)1324 +b Fp(T-11)0 105 y Fg(3.1)56 b(Lam)n(b)r(da)17 b(Abstractions)0 +215 y Fp(Instead)c(of)f(using)i(equations)e(to)g(de\014ne)i(functions,)g(w)o +(e)e(can)h(also)f(de\014ne)i(them)f(\\anon)o(ymously")f(via)h(a)f +Fo(lamb)n(da)0 271 y(abstr)n(action)p Fp(.)19 b(F)l(or)c(example,)g(a)g +(function)h(equiv)m(alen)o(t)g(to)f Fi(succ)f Fp(could)i(b)q(e)g(written)f +(as)f Fi(\\x)24 b(->)g(x+1)o Fp(.)c(Similarly)l(,)0 328 y(the)15 +b(function)h Fi(add)f Fp(is)h(equiv)m(alen)o(t)h(to)e Fi(\\x)23 +b(->)h(\\y)f(->)h(x+y)p Fp(.)c(Nested)15 b(lam)o(b)q(da)h(abstractions)f(suc) +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 +(alen)o(t)i(shorthand)e(notation)g Fi(\\x)24 b(y)f(->)h(x+y)p +Fp(.)19 b(In)d(fact,)e(the)i(equations:)71 494 y Fi(succ)23 +b(x)429 b(=)24 b(x+1)71 551 y(add)47 b(x)24 b(y)381 b(=)24 +b(x+y)0 660 y Fp(are)15 b(really)h(shorthand)f(for:)71 769 +y Fi(succ)476 b(=)24 b(\\x)71 b(->)24 b(x+1)71 825 y(add)500 +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 +(to)f(sa)o(y)h(ab)q(out)g(suc)o(h)g(equiv)m(alences)j(later.)71 +1015 y(In)d(general,)h(giv)o(en)f(that)g Fi(x)g Fp(has)g(t)o(yp)q(e)g +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 +Fh(t)1162 1022 y Fm(2)1182 1015 y Fp(,)g(then)g Fi(\\x->exp)g +Fp(has)g(t)o(yp)q(e)g Fh(t)1695 1022 y Fm(1)1715 1015 y Fi(->)p +Fh(t)1779 1022 y Fm(2)1799 1015 y Fp(.)0 1160 y Fg(3.2)56 b(In\014x)18 +b(Op)r(erators)0 1270 y Fp(In\014x)c(op)q(erators)d(are)i(really)h(just)e +(functions,)i(and)f(can)g(also)f(b)q(e)i(de\014ned)g(using)f(equations.)20 +b(F)l(or)12 b(example,)i(here)0 1326 y(is)i(the)f(de\014nition)i(of)e(Hask)o +(ell's)g(list)h(concatenation)g(op)q(erator:)71 1435 y Fi(\(++\))476 +b(::)24 b([a])f(->)h([a])f(->)h([a])71 1491 y([])119 b(++)23 +b(ys)286 b(=)48 b(ys)71 1548 y(\(x:xs\))23 b(++)g(ys)286 b(=)48 +b(x)24 b(:)f(\(xs++ys\))0 1660 y Fp([Lexically)l(,)17 b(in\014x)f(op)q +(erators)d(consist)i(en)o(tirely)h(of)f(\\sym)o(b)q(ols,")f(as)g(opp)q(osed)i +(to)e(normal)g(iden)o(ti\014ers)j(whic)o(h)e(are)0 1716 y(alphan)o(umeric)20 +b(\()p Fn(x)p Fp(2.3\).)30 b(Hask)o(ell)20 b(has)e(no)h(pre\014x)h(op)q +(erators,)e(with)h(the)g(exception)h(of)f(min)o(us)g(\()p Fi(-)p +Fp(\),)g(whic)o(h)g(is)0 1772 y(b)q(oth)c(in\014x)i(and)e(pre\014x.])71 +1853 y(As)f(another)h(example,)g(an)f(imp)q(ortan)o(t)h(in\014x)g(op)q +(erator)f(on)h(functions)g(is)g(that)f(for)g Fo(function)i(c)n(omp)n(osition) +p Fp(:)71 1962 y Fi(\(.\))500 b(::)24 b(\(b->c\))f(->)h(\(a->b\))f(->)g +(\(a->c\))71 2018 y(f)g(.)h(g)453 b(=)24 b(\\)g(x)f(->)h(f)g(\(g)f(x\))0 +2239 y Fc(3.2.1)52 b(Sections)0 2349 y Fp(Since)16 b(in\014x)g(op)q(erators)e +(are)h(really)h(just)f(functions,)g(it)g(mak)o(es)f(sense)i(to)e(b)q(e)i +(able)f(to)g(partially)h(apply)f(them)g(as)0 2405 y(w)o(ell.)21 +b(In)16 b(Hask)o(ell)g(the)f(partial)h(application)g(of)f(an)g(in\014x)i(op)q +(erator)d(is)i(called)g(a)f Fo(se)n(ction)p Fp(.)k(F)l(or)c(example:)676 +2500 y Fi(\(x+\))102 b Fn(\021)126 b Fi(\\y)24 b(->)f(x+y)676 +2557 y(\(+y\))102 b Fn(\021)126 b Fi(\\x)24 b(->)f(x+y)688 +2613 y(\(+\))114 b Fn(\021)102 b Fi(\\x)24 b(y)g(->)f(x+y)p +eop +%%Page: 12 12 +bop 0 -40 a Fp(T-12)1513 b Fj(3)45 b(FUNCTIONS)0 105 y Fp([The)15 +b(paren)o(theses)g(are)g(mandatory)l(.])71 199 y(The)20 b(last)f(form)g(of)g +(section)i(giv)o(en)f(ab)q(o)o(v)o(e)f(essen)o(tially)i(co)q(erces)g(an)e +(in\014x)i(op)q(erator)e(in)o(to)h(an)f(equiv)m(alen)o(t)0 +255 y(functional)h(v)m(alue,)h(and)e(is)g(handy)g(when)h(passing)f(an)g +(in\014x)h(op)q(erator)e(as)g(an)h(argumen)o(t)f(to)h(a)f(function,)i(as)0 +312 y(in)i Fi(map)h(\(+\))g([1,2,3])d Fp(\(the)h(reader)f(should)i(v)o(erify) +f(that)f(this)h(returns)f(a)h(list)g(of)g(functions!\).)36 +b(It)21 b(is)g(also)0 368 y(necessary)15 b(when)g(giving)g(a)g(function)g(t)o +(yp)q(e)g(signature,)f(as)h(in)g(the)g(examples)g(of)f Fi(\(++\))g +Fp(and)h Fi(\(.\))f Fp(giv)o(en)h(earlier.)71 462 y(W)l(e)20 +b(can)h(no)o(w)g(see)g(that)f Fi(add)g Fp(de\014ned)i(earlier)g(is)f(just)g +Fi(\(+\))p Fp(,)g(and)g Fi(succ)f Fp(is)i(just)e Fi(\(+1\))p +Fp(!)36 b(Indeed,)24 b(these)0 518 y(de\014nitions)17 b(w)o(ould)f(do)f(just) +g(\014ne:)71 627 y Fi(succ)476 b(=)24 b(\(+1\))71 684 y(add)500 +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 +(erator)e(in)o(to)h(a)g(functional)h(v)m(alue,)g(but)g(can)f(w)o(e)g(go)f +(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 +(iden)o(ti\014er)h(b)q(ound)g(to)e(a)h(functional)h(v)m(alue)g(in)g(bac)o +(kquotes.)27 b(F)l(or)17 b(example,)i Fi(x)24 b(`add`)f(y)0 +968 y Fp(is)17 b(the)g(same)g(as)f Fi(add)23 b(x)h(y)p Fp(.)480 +952 y Fm(7)524 968 y Fp(Some)17 b(functions)h(read)e(b)q(etter)h(this)g(w)o +(a)o(y)l(.)24 b(An)17 b(example)h(is)f(the)g(prede\014ned)h(list)0 +1025 y(mem)o(b)q(ership)13 b(predicate)g Fi(elem)p Fp(;)f(the)g(expression)h +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 +(\\)p Fi(x)h Fp(is)g(an)g(elemen)o(t)0 1081 y(of)j Fi(xs)o +Fp(.")71 1175 y([There)c(are)g(some)g(sp)q(ecial)i(rules)f(regarding)g +(sections)g(in)o(v)o(olving)g(the)g(pre\014x/in\014x)g(op)q(erator)f +Fi(-)g Fp(\()p Fn(x)p Fp(3.4,)p Fn(x)o Fp(3.3\).])71 1269 y(A)o(t)16 +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 +(ving)i(so)f(man)o(y)g(w)o(a)o(ys)f(to)g(de\014ne)j(a)e(function!)27 +b(The)0 1325 y(decision)18 b(to)d(pro)o(vide)h(these)g(mec)o(hanisms)g +(partly)g(re\015ects)g(historical)h(con)o(v)o(en)o(tions,)e(and)h(partly)g +(re\015ects)g(the)0 1382 y(desire)g(for)f(consistency)h(\(for)e(example,)i +(in)g(the)f(treatmen)o(t)f(of)h(in\014x)h(vs.)k(regular)15 +b(functions\).)0 1568 y Fc(3.2.2)52 b(Fixit)o(y)17 b(Declarations)0 +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 +(for)f(an)o(y)g(in\014x)i(op)q(erator)e(or)g(constructor)g(\(including)j +(those)e(made)g(from)0 1754 y(ordinary)j(iden)o(ti\014ers,)j(suc)o(h)d(as)g +Fi(`elem`)o Fp(\).)754 1737 y Fm(8)805 1754 y Fp(This)h(declaration)g(sp)q +(eci\014es)g(a)f(precedence)i(lev)o(el)g(from)d(0)h(to)f(9)0 +1810 y(\(with)e(9)g(b)q(eing)i(the)e(strongest;)f(normal)i(application)h(is)e +(assumed)h(to)e(ha)o(v)o(e)h(a)g(precedence)i(lev)o(el)g(of)e(10\),)f(and)0 +1867 y(left-,)g(righ)o(t-,)g(or)g(non-asso)q(ciativit)o(y)l(.)21 +b(F)l(or)14 b(example,)i(the)f(\014xit)o(y)h(declarations)f(for)g +Fi(++)g Fp(and)g Fi(.)g Fp(are:)71 1976 y Fi(infixr)23 b(5)g(++)71 +2032 y(infixr)g(9)g(.)0 2141 y Fp(Both)18 b(of)g(these)g(sp)q(ecify)i(righ)o +(t-asso)q(ciativit)o(y)l(,)f(the)g(\014rst)e(with)i(a)f(precedence)i(lev)o +(el)g(of)d(5,)i(the)f(other)g(9.)29 b(Left)0 2198 y(asso)q(ciativit)o(y)15 +b(is)h(sp)q(eci\014ed)g(via)g Fi(infixl)o Fp(,)e(and)h(non-asso)q(ciativit)o +(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 +(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 +(the)e(same)h(\014xit)o(y)g(declaration.)21 b(If)15 b(no)f(\014xit)o(y)h +(declaration)h(is)f(giv)o(en)h(for)0 2310 y(a)c(particular)h(op)q(erator,)f +(it)h(defaults)g(to)f Fi(infixl)23 b(9)p Fp(.)c(\(See)13 b +Fn(x)p Fp(5.7)e(for)h(a)g(detailed)i(de\014nition)h(of)d(the)h(asso)q +(ciativit)o(y)0 2367 y(rules.\))p 0 2434 780 2 v 52 2461 a +Fl(7)69 2477 y Fk(Note)g(carefully)i(that)e Ff(add)f Fk(is)i(enclosed)h(in)e +Fe(b)n(ackquotes)p Fk(,)c(not)14 b Fe(ap)n(ostr)n(ophes)9 b +Fk(as)14 b(used)f(in)h(the)g(syn)o(tax)g(of)e(c)o(haracters;)i(i.e.)j +Ff('f')12 b Fk(is)0 2522 y(a)g(c)o(haracter,)h(whereas)g Ff(`f`)e +Fk(is)i(an)f(in\014x)i(op)q(erator.)k(F)m(ortunately)m(,)13 +b(most)f(ASCI)q(I)g(terminals)i(distingui)q(sh)h(these)e(m)o(uc)o(h)g(b)q +(etter)f(than)0 2568 y(the)h(t)o(yp)q(efon)o(t)h(used)f(in)h(this)g(man)o +(uscript.)52 2598 y Fl(8)69 2614 y Fk(Fixit)o(y)f(declarations)i(m)o(ust)c +(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 +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 +eop +%%Page: 13 13 +bop 0 -40 a Fj(3.3)45 b(F)l(unctions)15 b(are)g(Non-strict)1269 +b Fp(T-13)0 105 y Fg(3.3)56 b(F)-5 b(unctions)19 b(are)f(Non-strict)0 +215 y Fp(Supp)q(ose)e Fi(bot)f Fp(is)h(de\014ned)g(b)o(y:)71 +324 y Fi(bot)500 b(=)24 b(bot)0 433 y Fp(In)c(other)e(w)o(ords,)h +Fi(bot)g Fp(is)h(a)e(non-terminating)i(expression.)33 b(Abstractly)l(,)20 +b(w)o(e)e(denote)i(the)f Fo(value)g Fp(of)g(a)g(non-)0 489 +y(terminating)d(expression)h(as)f Fn(?)g Fp(\(read)g(\\b)q(ottom"\).)21 +b(Expressions)16 b(that)g(result)g(in)h(some)f(kind)h(of)e(a)h(run-time)0 +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 +(alue.)71 626 y(A)f(function)i Fi(f)e Fp(is)h(said)g(to)f(b)q(e)i +Fo(strict)e Fp(if,)h(when)g(applied)h(to)e(a)h(non)o(terminating)g +(expression,)g(it)g(also)f(fails)i(to)0 682 y(terminate.)j(In)14 +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 +Fi(f)24 b(bot)13 b Fp(is)h Fn(?)p Fp(.)20 b(F)l(or)13 b(most)f(programming)h +(languages,)0 739 y Fo(al)r(l)k Fp(functions)h(are)e(strict.)25 +b(But)17 b(this)h(is)f(not)g(so)g(in)g(Hask)o(ell.)27 b(As)17 +b(a)f(simple)j(example,)f(consider)g Fi(const1)o Fp(,)f(the)0 +795 y(constan)o(t)d(1)h(function,)h(de\014ned)g(b)o(y:)71 904 +y Fi(const1)23 b(x)381 b(=)24 b(1)0 1013 y Fp(The)18 b(v)m(alue)h(of)f +Fi(const1)23 b(bot)17 b Fp(in)i(Hask)o(ell)f(is)h Fi(1)p Fp(.)27 +b(Op)q(erationally)20 b(sp)q(eaking,)f(since)g Fi(const1)e +Fp(do)q(es)h(not)g(\\need")0 1070 y(the)d(v)m(alue)g(of)f(its)h(argumen)o(t,) +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 +(er)h(gets)f(caugh)o(t)g(in)h(a)f(non)o(ter-)0 1126 y(minating)k +(computation.)26 b(F)l(or)16 b(this)i(reason,)f(non-strict)h(functions)g(are) +e(also)i(called)g(\\lazy)g(functions,")g(and)0 1183 y(are)d(said)h(to)e(ev)m +(aluate)i(their)g(argumen)o(ts)e(\\lazily)l(,")i(or)f(\\b)o(y)g(need.")71 +1263 y(Since)e(error)e(and)h(non)o(terminating)h(v)m(alues)g(are)e(seman)o +(tically)j(the)e(same)f(in)i(Hask)o(ell,)g(the)f(ab)q(o)o(v)o(e)g(argumen)o +(t)0 1319 y(also)j(holds)h(for)f(errors.)k(F)l(or)14 b(example,)i +Fi(const1)23 b(\(1/0\))15 b Fp(also)g(ev)m(aluates)h(prop)q(erly)g(to)e +Fi(1)p Fp(.)71 1400 y(Non-strict)h(functions)i(are)f(extremely)g(useful)h(in) +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) +f(is)i(that)0 1456 y(they)d(free)f(the)h(programmer)f(from)f(man)o(y)i +(concerns)g(ab)q(out)f(ev)m(aluation)i(order.)k(Computationally)14 +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 +(argumen)o(ts)h(to)g(functions)h(without)f(fear)g(of)g(them)g(b)q(eing)h +(computed)g(if)g(they)f(are)0 1569 y(not)f(needed.)21 b(An)15 +b(imp)q(ortan)o(t)g(example)h(of)f(this)h(is)f(a)g(p)q(ossibly)i +Fo(in\014nite)d Fp(data)g(structure.)0 1714 y Fg(3.4)56 b(\\In\014nite")17 +b(Data)i(Structures)0 1824 y Fp(One)13 b(adv)m(an)o(tage)f(of)g(the)g +(non-strict)h(nature)f(of)g(Hask)o(ell)h(is)g(that)f(data)g(constructors)f +(are)h(non-strict,)h(to)q(o.)18 b(This)0 1880 y(should)h(not)e(b)q(e)i +(surprising,)g(since)g(constructors)e(are)g(really)i(just)e(a)h(sp)q(ecial)h +(kind)g(of)e(function)i(\(the)e(distin-)0 1937 y(guishing)h(feature)e(b)q +(eing)i(that)e(they)g(can)h(b)q(e)g(used)g(in)g(pattern)f(matc)o(hing\).)24 +b(F)l(or)16 b(example,)h(the)g(constructor)0 1993 y(for)e(lists,)g +Fi(\(:\))p Fp(,)g(is)g(non-strict.)71 2073 y(Non-strict)g(constructors)f(p)q +(ermit)h(the)g(de\014nition)i(of)e(\(conceptually\))h Fo(in\014nite)d +Fp(data)i(structures.)k(Here)c(is)0 2130 y(an)g(in\014nite)i(list)f(of)f +(ones:)71 2230 y Fi(ones)476 b(=)24 b(1)g(:)f(ones)0 2339 y +Fp(P)o(erhaps)15 b(more)g(in)o(teresting)h(is)f(the)h(function)g +Fi(numsFrom)o Fp(:)71 2448 y Fi(numsFrom)22 b(n)334 b(=)24 +b(n)g(:)f(numsFrom)g(\(n+1\))0 2557 y Fp(Th)o(us)10 b Fi(numsFrom)23 +b(n)11 b Fp(is)g(the)f(in\014nite)j(list)e(of)f(successiv)o(e)i(in)o(tegers)e +(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 +(construct)0 2614 y(an)15 b(in\014nite)i(list)f(of)f(squares:)p +eop +%%Page: 14 14 +bop 0 -40 a Fp(T-14)1513 b Fj(3)45 b(FUNCTIONS)71 160 y Fi(squares)404 +b(=)24 b(map)f(\(^2\))h(\(numsfrom)e(0\))0 271 y Fp(\(Note)15 +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 +(tiation)f(op)q(erator.\))71 353 y(Of)c(course,)h(ev)o(en)o(tually)g(w)o(e)f +(exp)q(ect)i(to)d(extract)h(some)g(\014nite)i(p)q(ortion)e(of)g(the)h(list)g +(for)f(actual)g(computation,)0 409 y(and)17 b(there)f(are)h(lots)f(of)g +(prede\014ned)j(functions)e(in)h(Hask)o(ell)f(that)f(do)g(this)i(sort)d(of)h +(thing:)24 b Fi(take)o Fp(,)17 b Fi(takeWhile)n Fp(,)0 466 +y Fi(filter)o Fp(,)g(and)h(others)f(\(see)g(the)g(p)q(ortion)h(of)e(the)i +(Standard)f(Prelude)h(called)h Fi(PreludeList)n Fp(\).)26 b(F)l(or)16 +b(example,)0 522 y Fi(take)f Fp(remo)o(v)o(es)f(the)h(\014rst)g +Fi(n)g Fp(elemen)o(ts)h(from)e(a)h(list:)569 625 y Fi(take)23 +b(5)h(squares)72 b Fn(\))i Fi([0,1,4,9,16])71 753 y Fp(The)14 +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 +(a)f Fo(cir)n(cular)j(list)p Fp(.)i(In)d(most)e(circumstances)i(this)f(has)g +(an)0 809 y(imp)q(ortan)o(t)h(impact)h(on)g(e\016ciency)l(,)h(since)g(an)f +(implemen)o(tation)h(can)f(b)q(e)h(exp)q(ected)g(to)e(implemen)o(t)i(the)f +(list)g(as)0 866 y(a)f(true)g(circular)h(structure,)f(th)o(us)g(sa)o(ving)g +(space.)71 947 y(F)l(or)10 b(another)h(example)i(of)e(the)g(use)h(of)f +(circularit)o(y)l(,)i(the)f(Fib)q(onacci)h(sequence)f(can)g(b)q(e)g(computed) +g(e\016cien)o(tly)0 1004 y(as)j(the)g(follo)o(wing)h(in\014nite)h(sequence:) +71 1113 y Fi(fib)309 b(=)24 b(1)g(:)g(1)f(:)h([)g(a+b)f(|)h(\(a,b\))f(<-)h +(zip)f(fib)h(\(tail)f(fib\))g(])0 1222 y Fp(where)e Fi(zip)g +Fp(is)g(a)g(Standard)g(Prelude)h(function)g(that)e(returns)h(the)g(pairwise)h +(in)o(terlea)o(ving)g(of)e(its)i(t)o(w)o(o)d(list)0 1278 y(argumen)o(ts:)71 +1387 y Fi(zip)k(\(x:xs\))g(\(y:ys\))166 b(=)24 b(\(x,y\))f(:)h(zip)f(xs)h(ys) +71 1444 y(zip)47 b(xs)119 b(ys)238 b(=)24 b([])0 1553 y Fp(Note)16 +b(ho)o(w)g Fi(fib)o Fp(,)g(an)h(in\014nite)h(list,)f(is)f(de\014ned)i(in)f +(terms)f(of)g(itself,)h(as)e(if)i(it)g(w)o(ere)f(\\c)o(hasing)g(its)g(tail.") +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 +(computation)g(as)g(sho)o(wn)g(in)h(Figure)g(1a.)71 1691 y(F)l(or)e(another)h +(application)i(of)e(in\014nite)i(lists,)e(see)h(Section)g(4.4.)0 +1839 y Fg(3.5)56 b(The)18 b(Error)g(F)-5 b(unction)0 1950 y +Fp(Hask)o(ell)20 b(has)f(a)g(built-in)i(function)f(called)h +Fi(error)d Fp(whose)h(t)o(yp)q(e)g(is)h Fi(String->a)o Fp(.)31 +b(This)20 b(is)f(a)g(somewhat)g(o)q(dd)0 2007 y(function:)k(F)l(rom)15 +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 +(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 +2063 y(kno)o(ws)e(nothing,)g(since)h(it)g(nev)o(er)f(receiv)o(es)h(a)f(v)m +(alue)h(of)f(that)g(t)o(yp)q(e)g(as)g(an)g(argumen)o(t!)71 +2145 y(In)h(fact,)f(there)h Fo(is)g Fp(one)g(v)m(alue)h(\\shared")e(b)o(y)h +(all)h(t)o(yp)q(es:)k Fn(?)p Fp(.)h(Indeed,)c(seman)o(tically)f(that)e(is)h +(exactly)h(what)0 2201 y(v)m(alue)c(is)g(alw)o(a)o(ys)e(returned)h(b)o(y)g +Fi(error)f Fp(\(recall)i(that)e(all)i(errors)e(ha)o(v)o(e)h(v)m(alue)h +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 +2258 y(a)g(reasonable)g(implemen)o(tation)i(will)g(prin)o(t)e(the)g(string)h +(argumen)o(t)e(to)g Fi(error)h Fp(for)f(diagnostic)i(purp)q(oses.)20 +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 +(terminate)g(a)g(program)g(when)h(something)f(has)g(\\gone)g(wrong.")0 +2371 y(F)l(or)e(example,)g(the)h(actual)f(de\014nition)i(of)e +Fi(head)f Fp(tak)o(en)h(from)f(the)i(Standard)f(Prelude)h(is:)71 +2480 y Fi(head)23 b(\(x:xs\))309 b(=)48 b(x)71 2536 y(head)f([])381 +b(=)48 b(error)23 b("head{PreludeList}:)e(head)j([]")p eop +%%Page: 15 15 +bop 1857 -40 a Fp(T-15)33 869 y @beginspecial 5.156800 @llx +435.382507 @lly 327.294495 @urx 781.187195 @ury 1800 @rwi @setspecial +%%BeginDocument: fib.eps +/FHIODict 30 dict def +FHIODict begin +/bdf{bind def}bind def +/d{setdash}bdf +/h{closepath}bdf +/H{}bdf +/J{setlinecap}bdf +/j{setlinejoin}bdf +/M{setmiterlimit}bdf +/n{newpath}bdf +/N{newpath}bdf +/q{gsave}bdf +/Q{grestore}bdf +/w{setlinewidth}bdf +/u{}bdf +/U{}bdf +/sepdef{ +dup where not +{ +FreeHandSepDict +} +if +3 1 roll exch put +}bdf +/` +{end %. FreeHandDict +/-save0- save def +pop pop pop pop pop +concat +userdict begin +/showpage {} def +0 setgray 0 setlinecap 1 setlinewidth +0 setlinejoin 10 setmiterlimit [] 0 setdash newpath +/languagelevel where {pop languagelevel 1 ne{false setstrokeadjust false setoverprint}if}if +} bdf +/~ +{end +-save0- restore +FreeHandDict begin +}bdf +/FreeHandDict 190 dict def +FreeHandDict begin +/currentpacking where{pop true setpacking}if +/xdf{exch def}bdf +/ndf{1 index where{pop pop pop}{dup xcheck{bind}if def}ifelse}bdf +/min{2 copy gt{exch}if pop}bdf +/max{2 copy lt{exch}if pop}bdf +/isLino statusdict /product get (Lino) anchorsearch{pop pop true}{pop false}ifelse def +/dr{transform .25 sub round .25 add +exch .25 sub round .25 add exch itransform}bdf +/C{dr curveto}bdf +/L{dr lineto}bdf +/m{dr moveto}bdf +/printerRes +gsave +matrix defaultmatrix setmatrix +72 72 dtransform +abs exch abs +max +grestore +def +/maxsteps 256 def +/calcgraysteps { +currentscreen pop exch +printerRes exch div exch +2 copy +sin mul round dup mul +3 1 roll +cos mul round dup mul +add 1 add +dup maxsteps gt {pop maxsteps} if +} bdf +/bottom -0 def +/delta -0 def +/frac -0 def +/left -0 def +/numsteps -0 def +/numsteps1 -0 def +/radius -0 def +/right -0 def +/top -0 def +/xt -0 def +/yt -0 def +/df currentflat def +/tempstr 1 string def +/clipflatness currentflat def +/inverted? +0 currenttransfer exec .5 ge def +/colorexists +systemdict/setcmykcolor known def +/tc1 [0 0 0 1] def +/tc2 [0 0 0 1] def +/fc [0 0 0 1] def +/sc [0 0 0 1] def +/concatprocs{ +/proc2 exch cvlit def/proc1 exch cvlit def +/newproc proc1 length proc2 length add array def +newproc 0 proc1 putinterval newproc proc1 length proc2 putinterval +newproc cvx}bdf +/storerect{/top xdf/right xdf/bottom xdf/left xdf}bdf +/rectpath{newpath left bottom m left top L +right top L right bottom L closepath}bdf +/i{dup 0 eq +{pop df dup} +{dup} ifelse +/clipflatness xdf setflat +}bdf +version cvr 38.0 le +{/setrgbcolor{ +currenttransfer exec 3 1 roll +currenttransfer exec 3 1 roll +currenttransfer exec 3 1 roll +setrgbcolor}bdf}if +/gettint{0 get}bdf +/puttint{0 exch put}bdf +/vms {/vmsv save def} bdf +/vmr {vmsv restore} bdf +/vmrs{vmsv restore /vmsv save def}bdf +/eomode{ +{/filler /eofill load def /clipper /eoclip load def} +{/filler /fill load def /clipper /clip load def} +ifelse +}bdf +/CD{/NF exch def{exch dup/FID ne 1 index/UniqueID ne and{exch NF 3 1 roll put} +{pop pop}ifelse}forall NF}bdf +/MN{1 index length/Len exch def +dup length Len add string dup +Len 4 -1 roll putinterval dup 0 4 -1 roll putinterval}bdf +/RC{4 -1 roll /ourvec xdf 256 string cvs(|______)anchorsearch +{1 index MN cvn/NewN exch def cvn +findfont dup maxlength dict CD dup/FontName NewN put dup +/Encoding ourvec put NewN exch definefont pop}{pop}ifelse}bdf +/RF{dup FontDirectory exch known{pop 3 -1 roll pop}{RC}ifelse}bdf +/FF{dup 256 string cvs(|______)exch MN cvn dup FontDirectory exch known +{exch pop findfont 3 -1 roll pop}{pop dup findfont dup maxlength dict CD dup dup +/Encoding exch /Encoding get 256 array copy 7 -1 roll {3 -1 roll dup 4 -2 roll put}forall put definefont}ifelse}bdf +userdict begin /BDFontDict 20 dict def end +BDFontDict begin +/bu{}def +/bn{}def +/setTxMode{av 70 ge{pop}if pop}def +/gm{m}def +/show{pop}def +/gr{pop}def +/fnt{pop pop pop}def +/fs{pop}def +/fz{pop}def +/lin{pop pop}def +end +/MacVec 256 array def +MacVec 0 /Helvetica findfont +/Encoding get 0 128 getinterval putinterval +MacVec 127 /DEL put MacVec 16#27 /quotesingle put MacVec 16#60 /grave put +/NUL/SOH/STX/ETX/EOT/ENQ/ACK/BEL/BS/HT/LF/VT/FF/CR/SO/SI +/DLE/DC1/DC2/DC3/DC4/NAK/SYN/ETB/CAN/EM/SUB/ESC/FS/GS/RS/US +MacVec 0 32 getinterval astore pop +/Adieresis/Aring/Ccedilla/Eacute/Ntilde/Odieresis/Udieresis/aacute +/agrave/acircumflex/adieresis/atilde/aring/ccedilla/eacute/egrave +/ecircumflex/edieresis/iacute/igrave/icircumflex/idieresis/ntilde/oacute +/ograve/ocircumflex/odieresis/otilde/uacute/ugrave/ucircumflex/udieresis +/dagger/degree/cent/sterling/section/bullet/paragraph/germandbls +/register/copyright/trademark/acute/dieresis/notequal/AE/Oslash +/infinity/plusminus/lessequal/greaterequal/yen/mu/partialdiff/summation +/product/pi/integral/ordfeminine/ordmasculine/Omega/ae/oslash +/questiondown/exclamdown/logicalnot/radical/florin/approxequal/Delta/guillemotleft +/guillemotright/ellipsis/nbspace/Agrave/Atilde/Otilde/OE/oe +/endash/emdash/quotedblleft/quotedblright/quoteleft/quoteright/divide/lozenge +/ydieresis/Ydieresis/fraction/currency/guilsinglleft/guilsinglright/fi/fl +/daggerdbl/periodcentered/quotesinglbase/quotedblbase +/perthousand/Acircumflex/Ecircumflex/Aacute +/Edieresis/Egrave/Iacute/Icircumflex/Idieresis/Igrave/Oacute/Ocircumflex +/apple/Ograve/Uacute/Ucircumflex/Ugrave/dotlessi/circumflex/tilde +/macron/breve/dotaccent/ring/cedilla/hungarumlaut/ogonek/caron +MacVec 128 128 getinterval astore pop +/fps{ +currentflat +exch +dup 0 le{pop 1}if +{ +dup setflat 3 index stopped +{1.3 mul dup 3 index gt{pop setflat pop pop stop}if} +{exit} +ifelse +}loop +pop setflat pop pop +}bdf +/fp{100 currentflat fps}bdf +/clipper{clip}bdf +/W{/clipper load 100 clipflatness fps}bdf +/fixtrans1 { +dup{ic mul ic sub 1 add}concatprocs exch +dup{im mul im sub 1 add}concatprocs exch +dup{iy mul iy sub 1 add}concatprocs exch +{ik mul ik sub 1 add}concatprocs +}bdf +/fixtrans2 { +currentcolortransfer +5 -1 roll exch concatprocs 7 1 roll +4 -1 roll exch concatprocs 6 1 roll +3 -1 roll exch concatprocs 5 1 roll +concatprocs 4 1 roll +setcolortransfer +}bdf +end%. FreeHandDict +end%. FHIODict +FHIODict begin +FreeHandDict begin +5.1568 435.3825 327.2945 781.1872 storerect rectpath clip newpath +/onlyk{false}ndf +/ccmyk{dup 5 -1 roll sub 0 max exch}ndf +/setcmykcolor{1 exch sub ccmyk ccmyk ccmyk pop setrgbcolor}ndf +/setcmykcoloroverprint{4{dup -1 eq{pop 0}if 4 1 roll}repeat setcmykcolor}ndf +/findcmykcustomcolor{5 /packedarray where{pop packedarray}{array astore readonly}ifelse}ndf +/setcustomcolor{exch aload pop pop 4{4 index mul 4 1 roll}repeat setcmykcolor pop}ndf +/setseparationgray{1 exch sub dup dup dup setcmykcolor}ndf +/setoverprint{pop}ndf +/currentoverprint false ndf +/colorimage{pop pop +[5 -1 roll/exec cvx 6 -1 roll/exec cvx 7 -1 roll/exec cvx 8 -1 roll/exec cvx +/cmykbufs2gray cvx]cvx image} +version cvr 47.1 le isLino and{userdict begin bdf end}{ndf}ifelse +/cci1 { +currentcolortransfer +{ik mul ik sub 1 add}concatprocs 4 1 roll +{iy mul iy sub 1 add}concatprocs 4 1 roll +{im mul im sub 1 add}concatprocs 4 1 roll +{ic mul ic sub 1 add}concatprocs 4 1 roll +setcolortransfer +}ndf +/cci2 { +{invbuf dup length magentabuf length ne +{dup length dup dup +/magentabuf exch string def +/yellowbuf exch string def +/blackbuf exch string def}if +dup magentabuf copy yellowbuf copy blackbuf copy pop}concatprocs +}ndf +/customcolorimage{colorexists{ +aload pop pop 4 array astore +setimagecmyk +cci1 +/magentabuf 0 string def +/yellowbuf 0 string def +/blackbuf 0 string def +cci2 {magentabuf}{yellowbuf}{blackbuf}true 4 colorimage} +{pop image}ifelse}ndf +/separationimage{image}ndf +/newcmykcustomcolor{6 /packedarray where{pop packedarray}{array astore readonly}ifelse}ndf +/inkoverprint false ndf +/setinkoverprint{pop}ndf +/overprintprocess{pop}ndf +/setspotcolor +{spots exch get 0 5 getinterval exch setcustomcolor}ndf +/currentcolortransfer{currenttransfer dup dup dup}ndf +/setcolortransfer{systemdict begin settransfer end pop pop pop}ndf +/getcmyk { +dup length 4 eq +{aload pop} +{aload pop spots exch get 0 4 getinterval aload pop 4 +{4 index mul 4 1 roll}repeat 5 -1 roll pop} ifelse +}bdf +/setimagecmyk{ +getcmyk/ik xdf /iy xdf /im xdf /ic xdf +}ndf +/autospread{pop}ndf +/fhsetspreadsize{pop}ndf +/strokeopf false def +/fillopf false def +/R{0 ne /strokeopf xdf}bdf +/O{0 ne /fillopf xdf}bdf +/filler{fill}bdf +/F{fc fhsetcolor fillopf setoverprint false autospread +gsave /filler load fp grestore false setoverprint}bdf +/f{closepath F}bdf +/S{sc fhsetcolor strokeopf setoverprint true autospread {stroke}fp false setoverprint}bdf +/s{closepath S}bdf +/B{fc fhsetcolor fillopf setoverprint gsave /filler load fp grestore +sc fhsetcolor strokeopf setoverprint true autospread {stroke}fp false setoverprint}bdf +/b{closepath B}bdf +colorexists not{/setcolorscreen {setscreen pop pop pop pop pop pop pop pop pop}bdf}if +/fhsetcolor{dup length 4 eq +{aload overprintprocess setcmykcolor} +{aload 1 get spots exch get 5 get setinkoverprint setspotcolor} +ifelse +}ndf +/settextcolor{dup fhsetcolor dup length 4 eq +{onlyk{3 get 1.0 eq{true setinkoverprint}if}{pop}ifelse} +{pop} +ifelse +}ndf +/ka{/fc xdf}bdf +/Ka{/sc xdf}bdf +/xa{/fc xdf} bdf +/Xa{/sc xdf} bdf +/bc2[0 0]def +/bc4[0 0 0 0]def +/absmax{2 copy abs exch abs gt{exch}if pop}bdf +/calcstep +{ colorexists not and{calcgraysteps}{maxsteps}ifelse +tc1 length 4 eq +{ +0 1 3 +{tc1 1 index get +tc2 3 -1 roll get +sub +}for +absmax absmax absmax +} +{ +bc2 tc1 1 get 1 exch put +tc1 gettint tc2 gettint +sub abs +} +ifelse +mul abs round dup 0 eq{pop 1}if +dup /numsteps xdf 1 sub dup 0 eq{pop 1}if /numsteps1 xdf +}bdf +/cblend{ +tc1 length 4 eq +{ +0 1 3 +{bc4 exch +tc1 1 index get +tc2 2 index get +1 index sub +frac mul add put +}for bc4 +} +{ +bc2 +tc1 gettint +tc2 gettint +1 index sub +frac mul add +puttint bc2 +} +ifelse +fhsetcolor +}bdf +/logtaper{/frac frac 9 mul 1 add log def}bdf +FHIODict begin +/origmtx matrix currentmatrix def +/iminv false def +/invbuf{0 1 2 index length 1 sub{dup 2 index exch get 255 exch sub 2 index 3 1 roll put}for}bdf +/cyanrp{currentfile cyanbuf readhexstring pop iminv{invbuf}if}def +/magentarp{cyanbuf magentabuf copy}bdf +/yellowrp{cyanbuf yellowbuf copy}bdf +/blackrp{cyanbuf blackbuf copy}bdf +/fixtransfer{ +colorexists +{fixtrans1 fixtrans2} +{{dup 1 exch sub currentgray mul add}concatprocs +currenttransfer exch concatprocs +systemdict begin settransfer end}ifelse +}ndf +/cmykbufs2gray{ +dup length 0 1 3 -1 roll 1 sub +{4 index 1 index get +4 index 2 index get +4 index 3 index get +4 index 4 index get +255 exch sub ccmyk ccmyk ccmyk pop 5 mul exch 45 mul add exch 14 mul add -6 bitshift +2 index 3 1 roll put}for +4 1 roll pop pop pop +}bdf +end +/textopf false def +/curtextmtx{}def +/otw .25 def +/msf{dup/curtextmtx xdf makefont setfont}bdf +/makesetfont/msf load def +/curtextheight{.707104 .707104 curtextmtx dtransform +dup mul exch dup mul add sqrt}bdf +/ta{1 index +{tempstr 0 2 index put tempstr 2 index +gsave exec grestore +tempstr stringwidth rmoveto +5 index eq{6 index 6 index rmoveto}if +3 index 3 index rmoveto +}forall 7{pop}repeat}bdf +/sts{settextcolor textopf setoverprint/ts{awidthshow}def exec false setoverprint}bdf +/stol{setlinewidth settextcolor textopf setoverprint newpath +/ts{{false charpath stroke}ta}def exec false setoverprint}bdf +/currentpacking where{pop false setpacking}if +/spots[1 0 0 0 (Process Cyan) false newcmykcustomcolor +0 1 0 0 (Process Magenta) false newcmykcustomcolor +0 0 1 0 (Process Yellow) false newcmykcustomcolor +0 0 0 1 (Process Black) false newcmykcustomcolor +0 0 0 0 (White) false +newcmykcustomcolor +]def +0 dict dup begin +end +/f0 /Symbol FF def +[] 0 d +3.863708 M +1 w +0 j +0 J +0 O +0 R +0 i +false eomode +[0 0 0 1] Ka +[0 0 0 1] ka +vms +u +vmrs +MacVec 256 array copy +/f1 /|______Helvetica-Bold dup RF findfont def +{ +f1 [18 0 0 18 0 0] makesetfont +9.656845 613.020248 m +0 0 32 0 0 (1) ts +} +[0 0 0 1] +sts +78.6568 699.0202 m +78.6568 745.0202 L +2 J +S +78.6568 745.0202 m +83.6568 745.0202 L +78.6568 757.0202 L +73.6568 745.0202 L +78.6568 745.0202 L +f +n +160.6568 624.0202 m +162.6568 627.0202 L +165.6568 631.0202 L +168.6568 634.0202 L +171.6568 636.0202 L +175.6568 639.0202 L +178.6568 641.0202 L +180.6568 642.0202 L +182.6568 643.0202 L +184.6568 644.0202 L +186.6568 645.0202 L +188.6568 646.0202 L +190.6568 647.0202 L +192.6568 647.0202 L +194.6568 648.0202 L +196.6568 648.0202 L +198.6568 649.0202 L +200.6568 649.0202 L +202.6568 650.0202 L +205.6568 650.0202 L +207.6568 650.0202 L +209.6568 650.0202 L +211.6568 651.0202 L +213.6568 651.0202 L +215.6568 651.0202 L +217.6568 650.0202 L +219.6568 650.0202 L +221.6568 650.0202 L +223.6568 650.0202 L +225.6568 649.0202 L +227.6568 649.0202 L +231.6568 648.0202 L +235.6568 646.0202 L +238.6568 644.0202 L +241.6568 642.0202 L +244.6568 640.0202 L +247.6568 637.0202 L +249.6568 635.0202 L +251.6568 632.0202 L +253.6568 630.0202 L +255.6568 628.0202 L +257.6568 625.0202 L +258.6568 623.0202 L +260.6568 621.0202 L +262.6568 618.0202 L +263.6568 616.0202 L +265.6568 613.0202 L +267.6568 611.0202 L +268.6568 608.0202 L +270.6568 606.0202 L +271.6568 603.0202 L +272.6568 601.0202 L +274.6568 598.0202 L +275.6568 595.0202 L +276.6568 593.0202 L +277.6568 590.0202 L +279.6568 588.0202 L +280.6568 585.0202 L +281.6568 582.0202 L +282.6568 580.0202 L +283.6568 577.0202 L +284.6568 574.0202 L +285.6568 572.0202 L +286.6568 569.0202 L +286.6568 566.0202 L +287.6568 563.0202 L +288.6568 561.0202 L +289.6568 558.0202 L +289.6568 555.0202 L +290.6568 552.0202 L +291.6568 550.0202 L +291.6568 547.0202 L +292.6568 544.0202 L +292.6568 541.0202 L +293.6568 538.0202 L +293.6568 536.0202 L +293.6568 533.0202 L +294.6568 530.0202 L +294.6568 527.0202 L +294.6568 524.0202 L +295.6568 521.0202 L +295.6568 519.0202 L +295.6568 516.0202 L +295.6568 513.0202 L +295.6568 510.0202 L +295.6568 506.0202 L +295.6568 503.0202 L +295.6568 500.0202 L +294.6568 498.0202 L +294.6568 495.0202 L +293.6568 493.0202 L +293.6568 491.0202 L +292.6568 489.0202 L +291.6568 487.0202 L +290.6568 486.0202 L +289.6568 484.0202 L +288.6568 483.0202 L +286.6568 481.0202 L +284.6568 480.0202 L +281.6568 481.0202 L +279.6568 481.0202 L +276.6568 482.0202 L +274.6568 484.0202 L +235.6568 520.0202 L +S +91.6568 694.0202 m +93.6568 696.0202 L +95.6568 698.0202 L +97.6568 700.0202 L +100.6568 702.0202 L +102.6568 703.0202 L +104.6568 705.0202 L +107.6568 706.0202 L +109.6568 708.0202 L +112.6568 709.0202 L +114.6568 710.0202 L +117.6568 711.0202 L +119.6568 713.0202 L +122.6568 714.0202 L +125.6568 715.0202 L +128.6568 715.0202 L +130.6568 716.0202 L +133.6568 717.0202 L +136.6568 718.0202 L +139.6568 718.0202 L +142.6568 719.0202 L +145.6568 719.0202 L +148.6568 720.0202 L +151.6568 720.0202 L +154.6568 720.0202 L +156.6568 720.0202 L +159.6568 720.0202 L +162.6568 720.0202 L +165.6568 720.0202 L +168.6568 720.0202 L +171.6568 720.0202 L +174.6568 720.0202 L +177.6568 720.0202 L +180.6568 720.0202 L +183.6568 719.0202 L +186.6568 719.0202 L +189.6568 719.0202 L +192.6568 718.0202 L +195.6568 718.0202 L +198.6568 717.0202 L +201.6568 716.0202 L +203.6568 716.0202 L +206.6568 715.0202 L +209.6568 714.0202 L +212.6568 714.0202 L +214.6568 713.0202 L +217.6568 712.0202 L +220.6568 711.0202 L +222.6568 710.0202 L +225.6568 709.0202 L +228.6568 707.0202 L +232.6568 706.0202 L +235.6568 704.0202 L +238.6568 703.0202 L +241.6568 701.0202 L +244.6568 699.0202 L +246.6568 697.0202 L +249.6568 695.0202 L +252.6568 693.0202 L +255.6568 691.0202 L +257.6568 689.0202 L +260.6568 687.0202 L +262.6568 684.0202 L +265.6568 682.0202 L +267.6568 679.0202 L +270.6568 677.0202 L +272.6568 674.0202 L +274.6568 672.0202 L +276.6568 669.0202 L +278.6568 666.0202 L +280.6568 663.0202 L +282.6568 660.0202 L +284.6568 657.0202 L +286.6568 655.0202 L +288.6568 652.0202 L +290.6568 649.0202 L +292.6568 646.0202 L +294.6568 642.0202 L +295.6568 639.0202 L +297.6568 636.0202 L +298.6568 633.0202 L +300.6568 630.0202 L +301.6568 626.0202 L +303.6568 623.0202 L +304.6568 620.0202 L +305.6568 617.0202 L +307.6568 613.0202 L +308.6568 610.0202 L +309.6568 607.0202 L +310.6568 603.0202 L +311.6568 600.0202 L +312.6568 597.0202 L +313.6568 593.0202 L +314.6568 590.0202 L +315.6568 587.0202 L +315.6568 583.0202 L +316.6568 580.0202 L +316.6568 578.0202 L +317.6568 575.0202 L +318.6568 573.0202 L +318.6568 570.0202 L +319.6568 567.0202 L +319.6568 564.0202 L +320.6568 562.0202 L +320.6568 559.0202 L +321.6568 556.0202 L +321.6568 553.0202 L +322.6568 550.0202 L +322.6568 547.0202 L +323.6568 544.0202 L +323.6568 541.0202 L +324.6568 538.0202 L +324.6568 534.0202 L +324.6568 531.0202 L +325.6568 528.0202 L +325.6568 525.0202 L +325.6568 522.0202 L +325.6568 519.0202 L +326.6568 515.0202 L +326.6568 512.0202 L +326.6568 509.0202 L +326.6568 506.0202 L +326.6568 503.0202 L +325.6568 500.0202 L +325.6568 497.0202 L +325.6568 494.0202 L +324.6568 491.0202 L +324.6568 488.0202 L +323.6568 486.0202 L +323.6568 483.0202 L +322.6568 480.0202 L +321.6568 477.0202 L +320.6568 475.0202 L +319.6568 472.0202 L +318.6568 470.0202 L +317.6568 468.0202 L +315.6568 466.0202 L +314.6568 464.0202 L +312.6568 462.0202 L +311.6568 460.0202 L +309.6568 458.0202 L +307.6568 456.0202 L +305.6568 455.0202 L +302.6568 453.0202 L +300.6568 452.0202 L +297.6568 451.0202 L +294.6568 449.0202 L +291.6568 448.0202 L +288.6568 447.0202 L +285.6568 446.0202 L +282.6568 445.0202 L +279.6568 444.0202 L +276.6568 443.0202 L +273.6568 442.0202 L +270.6568 441.0202 L +267.6568 440.0202 L +263.6568 439.0202 L +260.6568 439.0202 L +257.6568 438.0202 L +253.6568 438.0202 L +250.6568 437.0202 L +247.6568 437.0202 L +244.6568 437.0202 L +240.6568 436.0202 L +237.6568 436.0202 L +234.6568 436.0202 L +230.6568 436.0202 L +227.6568 436.0202 L +224.6568 436.0202 L +221.6568 436.0202 L +218.6568 437.0202 L +214.6568 437.0202 L +211.6568 437.0202 L +208.6568 438.0202 L +205.6568 439.0202 L +202.6568 439.0202 L +199.6568 440.0202 L +196.6568 441.0202 L +194.6568 442.0202 L +191.6568 443.0202 L +188.6568 444.0202 L +185.6568 445.0202 L +183.6568 447.0202 L +180.6568 448.0202 L +178.6568 450.0202 L +176.6568 451.0202 L +173.6568 453.0202 L +171.6568 455.0202 L +169.6568 456.0202 L +167.6568 458.0202 L +165.6568 461.0202 L +164.6568 463.0202 L +162.6568 465.0202 L +161.6568 467.0202 L +160.6568 469.0202 L +160.6568 471.0202 L +160.6568 473.0202 L +160.6568 476.0202 L +160.6568 478.0202 L +161.6568 481.0202 L +162.6568 483.0202 L +163.6568 486.0202 L +165.6568 488.0202 L +166.6568 491.0202 L +168.6568 494.0202 L +170.6568 496.0202 L +172.6568 499.0202 L +174.6568 502.0202 L +177.6568 505.0202 L +179.6568 507.0202 L +181.6568 510.0202 L +184.6568 513.0202 L +186.6568 515.0202 L +188.6568 518.0202 L +191.6568 520.0202 L +193.6568 523.0202 L +195.6568 525.0202 L +S +u +134.6568 623.0202 m +101.6568 657.0202 L +S +101.6568 657.0202 m +105.6568 661.0202 L +93.6568 666.0202 L +98.6568 653.0202 L +101.6568 657.0202 L +f +n +U +u +202.6568 554.0202 m +171.6568 586.0202 L +S +171.6568 586.0202 m +174.6568 590.0202 L +162.6568 595.0202 L +167.6568 582.0202 L +171.6568 586.0202 L +f +n +U +u +u +60.1568 680.5202 m +60.1568 691.0138 68.6633 699.5202 79.1568 699.5202 C +89.6504 699.5202 98.1568 691.0138 98.1568 680.5202 C +98.1568 670.0267 89.6504 661.5202 79.1568 661.5202 C +68.6633 661.5202 60.1568 670.0267 60.1568 680.5202 C +[0 0 0 0] ka +b +U +vmrs +0 dict dup begin +end +/f2 /Symbol FF def +{ +f2 [36 0 0 36 0 0] makesetfont +73.656845 672.020248 m +0 0 32 0 0 (:) ts +} +[0 0 0 1] +sts +U +u +u +129.1568 610.5202 m +129.1568 621.0138 137.6633 629.5202 148.1568 629.5202 C +158.6504 629.5202 167.1568 621.0138 167.1568 610.5202 C +167.1568 600.0267 158.6504 591.5202 148.1568 591.5202 C +137.6633 591.5202 129.1568 600.0267 129.1568 610.5202 C +[0 0 0 0] ka +2 J +b +U +vmrs +0 dict dup begin +end +/f2 /Symbol FF def +{ +f2 [36 0 0 36 0 0] makesetfont +142.656845 602.020248 m +0 0 32 0 0 (:) ts +} +[0 0 0 1] +sts +U +u +199.1568 541.5202 m +199.1568 552.0138 207.6633 560.5202 218.1568 560.5202 C +228.6504 560.5202 237.1568 552.0138 237.1568 541.5202 C +237.1568 531.0267 228.6504 522.5202 218.1568 522.5202 C +207.6633 522.5202 199.1568 531.0267 199.1568 541.5202 C +[0 0 0 0] ka +2 J +b +U +vmrs +0 dict dup begin +end +/f2 /Symbol FF def +{ +f2 [36 0 0 36 0 0] makesetfont +208.12738 532.080994 m +0 0 32 0 0 (+) ts +} +[0 0 0 1] +sts +u +22.6568 624.0202 m +55.6568 658.0202 L +2 J +S +55.6568 658.0202 m +58.6568 654.0202 L +63.6568 667.0202 L +51.6568 662.0202 L +55.6568 658.0202 L +f +n +U +u +90.6568 551.0202 m +123.6568 585.0202 L +S +123.6568 585.0202 m +126.6568 581.0202 L +131.6568 594.0202 L +119.6568 589.0202 L +123.6568 585.0202 L +f +n +U +u +192.6568 520.0202 m +191.6568 519.0202 L +S +191.6568 519.0202 m +195.6568 515.0202 L +200.6568 528.0202 L +187.6568 523.0202 L +191.6568 519.0202 L +f +n +U +u +237.6568 518.0202 m +240.6568 515.0202 L +S +240.6568 515.0202 m +244.6568 519.0202 L +231.6568 524.0202 L +236.6568 511.0202 L +240.6568 515.0202 L +f +n +U +vmrs +MacVec 256 array copy +/f1 /|______Helvetica-Bold dup RF findfont def +{ +f1 [18 0 0 18 0 0] makesetfont +76.656845 538.020248 m +0 0 32 0 0 (1) ts +} +[0 0 0 1] +sts +vmrs +MacVec 256 array copy +/f1 /|______Helvetica-Bold dup RF findfont def +{ +f1 [18 0 0 18 0 0] makesetfont +126.656845 724.020248 m +0 0 32 0 0 (1,1,2,3,5,...) ts +} +[0 0 0 1] +sts +vmrs +MacVec 256 array copy +/f1 /|______Helvetica-Bold dup RF findfont def +{ +f1 [18 0 0 18 0 0] makesetfont +164.656845 655.020248 m +0 0 32 0 0 (1,2,3,5,8,...) ts +} +[0 0 0 1] +sts +vmrs +MacVec 256 array copy +/f3 /|______Times-BoldItalic dup RF findfont def +{ +f3 [18 0 0 18 0 0] makesetfont +69.656845 763.020248 m +0 0 32 0 0 (fib) ts +} +[0 0 0 1] +sts +U +vmr +end % FreeHandDict +end % FHIODict +%%EndDocument + @endspecial 1134 w @beginspecial 14.258400 @llx 620.398376 +@lly 377.258392 @urx 783.398376 @ury 1800 @rwi @setspecial +%%BeginDocument: io.eps +/FHIODict 30 dict def +FHIODict begin +/bdf{bind def}bind def +/d{setdash}bdf +/h{closepath}bdf +/H{}bdf +/J{setlinecap}bdf +/j{setlinejoin}bdf +/M{setmiterlimit}bdf +/n{newpath}bdf +/N{newpath}bdf +/q{gsave}bdf +/Q{grestore}bdf +/w{setlinewidth}bdf +/u{}bdf +/U{}bdf +/sepdef{ +dup where not +{ +FreeHandSepDict +} +if +3 1 roll exch put +}bdf +/` +{end %. FreeHandDict +/-save0- save def +pop pop pop pop pop +concat +userdict begin +/showpage {} def +0 setgray 0 setlinecap 1 setlinewidth +0 setlinejoin 10 setmiterlimit [] 0 setdash newpath +/languagelevel where {pop languagelevel 1 ne{false setstrokeadjust false setoverprint}if}if +} bdf +/~ +{end +-save0- restore +FreeHandDict begin +}bdf +/FreeHandDict 190 dict def +FreeHandDict begin +/currentpacking where{pop true setpacking}if +/xdf{exch def}bdf +/ndf{1 index where{pop pop pop}{dup xcheck{bind}if def}ifelse}bdf +/min{2 copy gt{exch}if pop}bdf +/max{2 copy lt{exch}if pop}bdf +/isLino statusdict /product get (Lino) anchorsearch{pop pop true}{pop false}ifelse def +/dr{transform .25 sub round .25 add +exch .25 sub round .25 add exch itransform}bdf +/C{dr curveto}bdf +/L{dr lineto}bdf +/m{dr moveto}bdf +/printerRes +gsave +matrix defaultmatrix setmatrix +72 72 dtransform +abs exch abs +max +grestore +def +/maxsteps 256 def +/calcgraysteps { +currentscreen pop exch +printerRes exch div exch +2 copy +sin mul round dup mul +3 1 roll +cos mul round dup mul +add 1 add +dup maxsteps gt {pop maxsteps} if +} bdf +/bottom -0 def +/delta -0 def +/frac -0 def +/left -0 def +/numsteps -0 def +/numsteps1 -0 def +/radius -0 def +/right -0 def +/top -0 def +/xt -0 def +/yt -0 def +/df currentflat def +/tempstr 1 string def +/clipflatness currentflat def +/inverted? +0 currenttransfer exec .5 ge def +/colorexists +systemdict/setcmykcolor known def +/tc1 [0 0 0 1] def +/tc2 [0 0 0 1] def +/fc [0 0 0 1] def +/sc [0 0 0 1] def +/concatprocs{ +/proc2 exch cvlit def/proc1 exch cvlit def +/newproc proc1 length proc2 length add array def +newproc 0 proc1 putinterval newproc proc1 length proc2 putinterval +newproc cvx}bdf +/storerect{/top xdf/right xdf/bottom xdf/left xdf}bdf +/rectpath{newpath left bottom m left top L +right top L right bottom L closepath}bdf +/i{dup 0 eq +{pop df dup} +{dup} ifelse +/clipflatness xdf setflat +}bdf +version cvr 38.0 le +{/setrgbcolor{ +currenttransfer exec 3 1 roll +currenttransfer exec 3 1 roll +currenttransfer exec 3 1 roll +setrgbcolor}bdf}if +/gettint{0 get}bdf +/puttint{0 exch put}bdf +/vms {/vmsv save def} bdf +/vmr {vmsv restore} bdf +/vmrs{vmsv restore /vmsv save def}bdf +/eomode{ +{/filler /eofill load def /clipper /eoclip load def} +{/filler /fill load def /clipper /clip load def} +ifelse +}bdf +/CD{/NF exch def{exch dup/FID ne 1 index/UniqueID ne and{exch NF 3 1 roll put} +{pop pop}ifelse}forall NF}bdf +/MN{1 index length/Len exch def +dup length Len add string dup +Len 4 -1 roll putinterval dup 0 4 -1 roll putinterval}bdf +/RC{4 -1 roll /ourvec xdf 256 string cvs(|______)anchorsearch +{1 index MN cvn/NewN exch def cvn +findfont dup maxlength dict CD dup/FontName NewN put dup +/Encoding ourvec put NewN exch definefont pop}{pop}ifelse}bdf +/RF{dup FontDirectory exch known{pop 3 -1 roll pop}{RC}ifelse}bdf +/FF{dup 256 string cvs(|______)exch MN cvn dup FontDirectory exch known +{exch pop findfont 3 -1 roll pop}{pop dup findfont dup maxlength dict CD dup dup +/Encoding exch /Encoding get 256 array copy 7 -1 roll {3 -1 roll dup 4 -2 roll put}forall put definefont}ifelse}bdf +userdict begin /BDFontDict 20 dict def end +BDFontDict begin +/bu{}def +/bn{}def +/setTxMode{av 70 ge{pop}if pop}def +/gm{m}def +/show{pop}def +/gr{pop}def +/fnt{pop pop pop}def +/fs{pop}def +/fz{pop}def +/lin{pop pop}def +end +/MacVec 256 array def +MacVec 0 /Helvetica findfont +/Encoding get 0 128 getinterval putinterval +MacVec 127 /DEL put MacVec 16#27 /quotesingle put MacVec 16#60 /grave put +/NUL/SOH/STX/ETX/EOT/ENQ/ACK/BEL/BS/HT/LF/VT/FF/CR/SO/SI +/DLE/DC1/DC2/DC3/DC4/NAK/SYN/ETB/CAN/EM/SUB/ESC/FS/GS/RS/US +MacVec 0 32 getinterval astore pop +/Adieresis/Aring/Ccedilla/Eacute/Ntilde/Odieresis/Udieresis/aacute +/agrave/acircumflex/adieresis/atilde/aring/ccedilla/eacute/egrave +/ecircumflex/edieresis/iacute/igrave/icircumflex/idieresis/ntilde/oacute +/ograve/ocircumflex/odieresis/otilde/uacute/ugrave/ucircumflex/udieresis +/dagger/degree/cent/sterling/section/bullet/paragraph/germandbls +/register/copyright/trademark/acute/dieresis/notequal/AE/Oslash +/infinity/plusminus/lessequal/greaterequal/yen/mu/partialdiff/summation +/product/pi/integral/ordfeminine/ordmasculine/Omega/ae/oslash +/questiondown/exclamdown/logicalnot/radical/florin/approxequal/Delta/guillemotleft +/guillemotright/ellipsis/nbspace/Agrave/Atilde/Otilde/OE/oe +/endash/emdash/quotedblleft/quotedblright/quoteleft/quoteright/divide/lozenge +/ydieresis/Ydieresis/fraction/currency/guilsinglleft/guilsinglright/fi/fl +/daggerdbl/periodcentered/quotesinglbase/quotedblbase +/perthousand/Acircumflex/Ecircumflex/Aacute +/Edieresis/Egrave/Iacute/Icircumflex/Idieresis/Igrave/Oacute/Ocircumflex +/apple/Ograve/Uacute/Ucircumflex/Ugrave/dotlessi/circumflex/tilde +/macron/breve/dotaccent/ring/cedilla/hungarumlaut/ogonek/caron +MacVec 128 128 getinterval astore pop +/fps{ +currentflat +exch +dup 0 le{pop 1}if +{ +dup setflat 3 index stopped +{1.3 mul dup 3 index gt{pop setflat pop pop stop}if} +{exit} +ifelse +}loop +pop setflat pop pop +}bdf +/fp{100 currentflat fps}bdf +/clipper{clip}bdf +/W{/clipper load 100 clipflatness fps}bdf +/fixtrans1 { +dup{ic mul ic sub 1 add}concatprocs exch +dup{im mul im sub 1 add}concatprocs exch +dup{iy mul iy sub 1 add}concatprocs exch +{ik mul ik sub 1 add}concatprocs +}bdf +/fixtrans2 { +currentcolortransfer +5 -1 roll exch concatprocs 7 1 roll +4 -1 roll exch concatprocs 6 1 roll +3 -1 roll exch concatprocs 5 1 roll +concatprocs 4 1 roll +setcolortransfer +}bdf +end%. FreeHandDict +end%. FHIODict +FHIODict begin +FreeHandDict begin +14.2584 620.3984 377.2584 783.3984 storerect rectpath clip newpath +/onlyk{false}ndf +/ccmyk{dup 5 -1 roll sub 0 max exch}ndf +/setcmykcolor{1 exch sub ccmyk ccmyk ccmyk pop setrgbcolor}ndf +/setcmykcoloroverprint{4{dup -1 eq{pop 0}if 4 1 roll}repeat setcmykcolor}ndf +/findcmykcustomcolor{5 /packedarray where{pop packedarray}{array astore readonly}ifelse}ndf +/setcustomcolor{exch aload pop pop 4{4 index mul 4 1 roll}repeat setcmykcolor pop}ndf +/setseparationgray{1 exch sub dup dup dup setcmykcolor}ndf +/setoverprint{pop}ndf +/currentoverprint false ndf +/colorimage{pop pop +[5 -1 roll/exec cvx 6 -1 roll/exec cvx 7 -1 roll/exec cvx 8 -1 roll/exec cvx +/cmykbufs2gray cvx]cvx image} +version cvr 47.1 le isLino and{userdict begin bdf end}{ndf}ifelse +/cci1 { +currentcolortransfer +{ik mul ik sub 1 add}concatprocs 4 1 roll +{iy mul iy sub 1 add}concatprocs 4 1 roll +{im mul im sub 1 add}concatprocs 4 1 roll +{ic mul ic sub 1 add}concatprocs 4 1 roll +setcolortransfer +}ndf +/cci2 { +{invbuf dup length magentabuf length ne +{dup length dup dup +/magentabuf exch string def +/yellowbuf exch string def +/blackbuf exch string def}if +dup magentabuf copy yellowbuf copy blackbuf copy pop}concatprocs +}ndf +/customcolorimage{colorexists{ +aload pop pop 4 array astore +setimagecmyk +cci1 +/magentabuf 0 string def +/yellowbuf 0 string def +/blackbuf 0 string def +cci2 {magentabuf}{yellowbuf}{blackbuf}true 4 colorimage} +{pop image}ifelse}ndf +/separationimage{image}ndf +/newcmykcustomcolor{6 /packedarray where{pop packedarray}{array astore readonly}ifelse}ndf +/inkoverprint false ndf +/setinkoverprint{pop}ndf +/overprintprocess{pop}ndf +/setspotcolor +{spots exch get 0 5 getinterval exch setcustomcolor}ndf +/currentcolortransfer{currenttransfer dup dup dup}ndf +/setcolortransfer{systemdict begin settransfer end pop pop pop}ndf +/getcmyk { +dup length 4 eq +{aload pop} +{aload pop spots exch get 0 4 getinterval aload pop 4 +{4 index mul 4 1 roll}repeat 5 -1 roll pop} ifelse +}bdf +/setimagecmyk{ +getcmyk/ik xdf /iy xdf /im xdf /ic xdf +}ndf +/autospread{pop}ndf +/fhsetspreadsize{pop}ndf +/strokeopf false def +/fillopf false def +/R{0 ne /strokeopf xdf}bdf +/O{0 ne /fillopf xdf}bdf +/filler{fill}bdf +/F{fc fhsetcolor fillopf setoverprint false autospread +gsave /filler load fp grestore false setoverprint}bdf +/f{closepath F}bdf +/S{sc fhsetcolor strokeopf setoverprint true autospread {stroke}fp false setoverprint}bdf +/s{closepath S}bdf +/B{fc fhsetcolor fillopf setoverprint gsave /filler load fp grestore +sc fhsetcolor strokeopf setoverprint true autospread {stroke}fp false setoverprint}bdf +/b{closepath B}bdf +colorexists not{/setcolorscreen {setscreen pop pop pop pop pop pop pop pop pop}bdf}if +/fhsetcolor{dup length 4 eq +{aload overprintprocess setcmykcolor} +{aload 1 get spots exch get 5 get setinkoverprint setspotcolor} +ifelse +}ndf +/settextcolor{dup fhsetcolor dup length 4 eq +{onlyk{3 get 1.0 eq{true setinkoverprint}if}{pop}ifelse} +{pop} +ifelse +}ndf +/ka{/fc xdf}bdf +/Ka{/sc xdf}bdf +/xa{/fc xdf} bdf +/Xa{/sc xdf} bdf +/bc2[0 0]def +/bc4[0 0 0 0]def +/absmax{2 copy abs exch abs gt{exch}if pop}bdf +/calcstep +{ colorexists not and{calcgraysteps}{maxsteps}ifelse +tc1 length 4 eq +{ +0 1 3 +{tc1 1 index get +tc2 3 -1 roll get +sub +}for +absmax absmax absmax +} +{ +bc2 tc1 1 get 1 exch put +tc1 gettint tc2 gettint +sub abs +} +ifelse +mul abs round dup 0 eq{pop 1}if +dup /numsteps xdf 1 sub dup 0 eq{pop 1}if /numsteps1 xdf +}bdf +/cblend{ +tc1 length 4 eq +{ +0 1 3 +{bc4 exch +tc1 1 index get +tc2 2 index get +1 index sub +frac mul add put +}for bc4 +} +{ +bc2 +tc1 gettint +tc2 gettint +1 index sub +frac mul add +puttint bc2 +} +ifelse +fhsetcolor +}bdf +/logtaper{/frac frac 9 mul 1 add log def}bdf +FHIODict begin +/origmtx matrix currentmatrix def +/iminv false def +/invbuf{0 1 2 index length 1 sub{dup 2 index exch get 255 exch sub 2 index 3 1 roll put}for}bdf +/cyanrp{currentfile cyanbuf readhexstring pop iminv{invbuf}if}def +/magentarp{cyanbuf magentabuf copy}bdf +/yellowrp{cyanbuf yellowbuf copy}bdf +/blackrp{cyanbuf blackbuf copy}bdf +/fixtransfer{ +colorexists +{fixtrans1 fixtrans2} +{{dup 1 exch sub currentgray mul add}concatprocs +currenttransfer exch concatprocs +systemdict begin settransfer end}ifelse +}ndf +/cmykbufs2gray{ +dup length 0 1 3 -1 roll 1 sub +{4 index 1 index get +4 index 2 index get +4 index 3 index get +4 index 4 index get +255 exch sub ccmyk ccmyk ccmyk pop 5 mul exch 45 mul add exch 14 mul add -6 bitshift +2 index 3 1 roll put}for +4 1 roll pop pop pop +}bdf +end +/textopf false def +/curtextmtx{}def +/otw .25 def +/msf{dup/curtextmtx xdf makefont setfont}bdf +/makesetfont/msf load def +/curtextheight{.707104 .707104 curtextmtx dtransform +dup mul exch dup mul add sqrt}bdf +/ta{1 index +{tempstr 0 2 index put tempstr 2 index +gsave exec grestore +tempstr stringwidth rmoveto +5 index eq{6 index 6 index rmoveto}if +3 index 3 index rmoveto +}forall 7{pop}repeat}bdf +/sts{settextcolor textopf setoverprint/ts{awidthshow}def exec false setoverprint}bdf +/stol{setlinewidth settextcolor textopf setoverprint newpath +/ts{{false charpath stroke}ta}def exec false setoverprint}bdf +/currentpacking where{pop false setpacking}if +/spots[1 0 0 0 (Process Cyan) false newcmykcustomcolor +0 1 0 0 (Process Magenta) false newcmykcustomcolor +0 0 1 0 (Process Yellow) false newcmykcustomcolor +0 0 0 1 (Process Black) false newcmykcustomcolor +0 0 0 0 (White) false +newcmykcustomcolor +]def +0 dict dup begin +end +/f0 /Symbol FF def +[] 0 d +3.863708 M +1 w +0 j +0 J +0 O +0 R +0 i +false eomode +[0 0 0 1] Ka +[0 0 0 1] ka +vms +u +u +u +u +u +14.7584 767.5217 m +119.7584 767.5217 L +119.7584 710.5217 L +14.7584 710.5217 L +14.7584 767.5217 L +[0 0 0 0] ka +2 J +b +U +vmrs +MacVec 256 array copy +/f1 /|______Helvetica-Bold dup RF findfont def +{ +f1 [24 0 0 24 0 0] makesetfont +34.258438 731.021698 m +0 0 32 0 0 (client) ts +} +[0 0 0 1] +sts +U +u +271.7584 767.5217 m +376.7584 767.5217 L +376.7584 710.5217 L +271.7584 710.5217 L +271.7584 767.5217 L +[0 0 0 0] ka +2 J +b +U +vmrs +MacVec 256 array copy +/f1 /|______Helvetica-Bold dup RF findfont def +{ +f1 [24 0 0 24 0 0] makesetfont +286.258438 732.021698 m +0 0 32 0 0 (server) ts +} +[0 0 0 1] +sts +u +119.2584 756.0217 m +254.2584 756.0217 L +2 J +S +254.2584 756.0217 m +254.2584 751.0217 L +266.2584 756.0217 L +254.2584 761.0217 L +254.2584 756.0217 L +f +n +U +u +271.2584 721.0217 m +135.2584 721.0217 L +S +135.2584 721.0217 m +135.2584 726.0217 L +123.2584 721.0217 L +135.2584 716.0217 L +135.2584 721.0217 L +f +n +U +u +65.2584 653.0217 m +65.2584 694.0217 L +S +65.2584 694.0217 m +70.2584 694.0217 L +65.2584 706.0217 L +60.2584 694.0217 L +65.2584 694.0217 L +f +n +U +vmrs +MacVec 256 array copy +/f2 /|______Courier-Bold dup RF findfont def +{ +f2 [24 0 0 24 0 0] makesetfont +163.258438 760.021698 m +0 0 32 0 0 (reqs) ts +} +[0 0 0 1] +sts +vmrs +MacVec 256 array copy +/f2 /|______Courier-Bold dup RF findfont def +{ +f2 [24 0 0 24 0 0] makesetfont +158.258438 705.021698 m +0 0 32 0 0 (resps) ts +} +[0 0 0 1] +sts +vmrs +MacVec 256 array copy +/f2 /|______Courier-Bold dup RF findfont def +{ +f2 [24 0 0 24 0 0] makesetfont +38.258438 633.021698 m +0 0 32 0 0 (init) ts +} +[0 0 0 1] +sts +U +U +U +vmr +end % FreeHandDict +end % FHIODict +%%EndDocument + @endspecial 106 967 a(Figure)15 b(1:)20 b(\(a\))14 b(Circular)i(Fib)q +(onacci)h(Sequence)331 b(\(b\))15 b(Serv)o(er/Clien)o(t)h(Sim)o(ulation)0 +1093 y Fq(4)69 b(Case)23 b(Expressions)g(and)h(P)n(attern)f(Matc)n(hing)0 +1215 y Fp(Earlier)c(w)o(e)e(ga)o(v)o(e)g(sev)o(eral)h(examples)h(of)e +(pattern)h(matc)o(hing)g(in)g(de\014ning)i(functions|for)e(example)h +Fi(length)0 1271 y Fp(and)f Fi(fringe)o Fp(.)28 b(In)19 b(this)f(section)g(w) +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 +(uc)o(h)f(greater)f(detail)0 1328 y(\()p Fn(x)p Fp(3.14\).)151 +1311 y Fm(9)71 1404 y Fp(P)o(atterns)e(are)i(not)f(\\\014rst-class;")h(there) +g(is)h(only)f(a)g(\014xed)g(set)g(of)f(di\013eren)o(t)i(kinds)f(of)g +(patterns.)24 b(W)l(e)17 b(ha)o(v)o(e)0 1461 y(already)c(seen)g(sev)o(eral)g +(examples)h(of)e Fo(data)j(c)n(onstructor)e Fp(patterns;)f(b)q(oth)h +Fi(length)f Fp(and)h Fi(fringe)f Fp(de\014ned)i(earlier)0 1517 +y(use)i(suc)o(h)h(patterns,)e(the)h(former)f(on)h(the)g(constructors)f(of)g +(a)h(\\built-in")i(t)o(yp)q(e)e(\(lists\),)g(the)g(latter)f(on)h(a)g(user-)0 +1574 y(de\014ned)e(t)o(yp)q(e)e(\()p Fi(Tree)o Fp(\).)19 b(Indeed,)14 +b(matc)o(hing)e(is)h(p)q(ermitted)g(using)h(the)e(constructors)g(of)g(an)o(y) +g(t)o(yp)q(e,)g(user-de\014ned)0 1630 y(or)19 b(not.)31 b(This)20 +b(includes)h(tuples,)g(strings,)f(n)o(um)o(b)q(ers,)g(c)o(haracters,)f(etc.) +32 b(F)l(or)18 b(example,)j(here's)e(a)g(con)o(triv)o(ed)0 +1686 y(function)d(that)f(matc)o(hes)f(against)h(a)g(tuple)h(of)f(\\constan)o +(ts:")71 1795 y Fi(contrived)22 b(::)i(\([a],)f(Char,)g(\(Int,)g(Float\),)g +(String,)g(Bool\))g(->)h(Bool)71 1852 y(contrived)94 b(\([],)47 +b('b',)g(\(1,)71 b(2.0\),)g("hi",)g(True\))23 b(=)h(False)0 +1964 y Fp(This)16 b(example)g(also)f(demonstrates)f(that)h +Fo(nesting)f Fp(of)g(patterns)h(is)h(p)q(ermitted)g(\(to)e(arbitrary)h +(depth\).)71 2040 y(T)l(ec)o(hnically)21 b(sp)q(eaking,)f Fo(formal)g(p)n(ar) +n(ameters)881 2024 y Fm(10)937 2040 y Fp(are)f(also)f(patterns|it's)h(just)f +(that)g(they)h Fo(never)g(fail)h(to)0 2097 y(match)f(a)g(value)p +Fp(.)28 b(As)18 b(a)f(\\side)h(e\013ect")g(of)f(the)h(successful)h(matc)o(h,) +e(the)h(formal)g(parameter)f(is)h(b)q(ound)h(to)e(the)0 2153 +y(v)m(alue)j(it)e(is)h(b)q(eing)h(matc)o(hed)e(against.)30 +b(F)l(or)18 b(this)g(reason)h(patterns)e(in)j(an)o(y)e(one)g(equation)h(are)f +(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 +(ccurrence)i(of)f(the)g(same)f(formal)g(parameter)g(\(a)h(prop)q(ert)o(y)f +(called)i Fo(line)n(arity)e Fn(x)q Fp(3.14,)0 2266 y Fn(x)p +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 +(parameters)g(that)g(nev)o(er)g(fail)h(to)f(matc)o(h)g(are)g(said)h(to)e(b)q +(e)i Fo(irr)n(efutable)p Fp(,)g(in)g(con)o(trast)0 2399 y(to)g +Fo(r)n(efutable)h Fp(patterns)f(suc)o(h)h(as)f(the)h(ones)g(giv)o(en)g(in)h +(the)e Fi(contrived)g Fp(example)h(ab)q(o)o(v)o(e.)19 b(There)13 +b(are)g(three)f(other)p 0 2434 780 2 v 52 2461 a Fl(9)69 2477 +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 +(t)h(from)e(that)g(found)h(in)h(logic)g(programming)g(languages)g(suc)o(h)f +(as)g(Prolog;)0 2522 y(in)e(particular,)h(it)e(can)g(b)q(e)h(view)o(ed)g(as)f +(\\one-w)o(a)o(y")g(matc)o(hing,)h(whereas)g(Prolog)g(allo)o(ws)g(\\t)o(w)o +(o-w)o(a)o(y")f(matc)o(hing)i(\(via)e(uni\014cation\),)0 2568 +y(along)h(with)g(implicit)i(bac)o(ktrac)o(king)f(in)f(its)f(ev)n(aluation)j +(mec)o(hanism.)37 2598 y Fl(10)69 2614 y Fk(The)d(Rep)q(ort)h(calls)g(these)g +Fe(variables)p Fk(.)p eop +%%Page: 16 16 +bop 0 -40 a Fp(T-16)700 b Fj(4)45 b(CASE)15 b(EXPRESSIONS)i(AND)e(P)l(A)l +(TTERN)h(MA)l(TCHING)0 105 y Fp(kinds)k(of)f(irrefutable)i(patterns,)e(t)o(w) +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 +(other)f(w)o(e)g(will)i(dela)o(y)f(un)o(til)0 162 y(Section)c(4.4\).)0 +308 y Fc(As-patterns.)45 b Fp(Sometimes)16 b(it)h(is)f(con)o(v)o(enien)o(t)h +(to)e(name)h(a)g(pattern)g(for)f(use)h(on)g(the)h(righ)o(t-hand)f(side.)24 +b(F)l(or)0 365 y(example,)16 b(a)f(function)h(that)e(duplicates)j(the)e +(\014rst)g(elemen)o(t)h(in)g(a)f(list)h(migh)o(t)f(b)q(e)h(written)f(as:)71 +474 y Fi(f)23 b(\(x:xs\))381 b(=)24 b(x:x:xs)0 585 y Fp(\(Recall)17 +b(that)d Fi(:)h Fp(asso)q(ciates)g(to)g(the)g(righ)o(t.\))k(Note)c(that)g +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 +642 y(side,)k(and)f(an)f(expression)h(on)g(the)g(righ)o(t-hand)g(side.)28 +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 +(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 +(hiev)o(e)h(using)g(an)f Fo(as-p)n(attern)g Fp(as)g(follo)o(ws:)1353 +682 y Fm(11)71 807 y Fi(f)23 b(s@\(x:xs\))309 b(=)24 b(x:s)0 +919 y Fp(T)l(ec)o(hnically)17 b(sp)q(eaking,)d(as-patterns)g(alw)o(a)o(ys)f +(result)i(in)g(a)f(successful)h(matc)o(h,)f(although)g(the)g(sub-pattern)g +(\(in)0 975 y(this)i(case)f Fi(x:xs)o Fp(\))g(could,)h(of)f(course,)g(fail.)0 +1122 y Fc(Wild-cards.)46 b Fp(Another)12 b(common)e(situation)i(is)g(matc)o +(hing)f(against)g(a)g(v)m(alue)h(w)o(e)f(really)i(care)e(nothing)g(ab)q(out.) +0 1179 y(F)l(or)k(example,)g(the)h(functions)f Fi(head)g Fp(and)g +Fi(tail)g Fp(de\014ned)i(in)f(Section)g(2.1)e(can)h(b)q(e)h(rewritten)f(as:) +71 1288 y Fi(head)23 b(\(_:xs\))309 b(=)24 b(x)71 1344 y(tail)f(\(x:_\))333 +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 +(ertised")h(the)f(fact)g(that)g(w)o(e)g(don't)g(care)h(what)f(a)g(certain)h +(part)f(of)g(the)h(input)g(is.)20 b(Eac)o(h)0 1510 y(wild-card)15 +b(will)g(indep)q(enden)o(tly)h(matc)o(h)d(an)o(ything,)h(but)f(in)h(con)o +(trast)f(to)f(a)h(formal)g(parameter,)g(eac)o(h)h(will)h(bind)0 +1566 y(nothing;)g(for)g(this)h(reason)e(more)h(than)g(one)g(are)g(allo)o(w)o +(ed)h(in)g(an)f(equation.)0 1713 y Fc(n)p Fi(+)p Fc(k-patterns.)45 +b Fp(There)21 b(is)h(one)f(other)f(kind)i(of)e Fo(r)n(efutable)h +Fp(pattern)f(in)i(Hask)o(ell,)h(called)f(an)f Fo(n)p Fi(+)o +Fo(k-p)n(attern)p Fp(,)0 1769 y(whic)o(h)15 b(is)g(useful)h(when)f(writing)g +(inductiv)o(e)h(de\014nitions)g(o)o(v)o(er)e(in)o(tegers.)20 +b(F)l(or)13 b(example,)j(here's)e(a)g(de\014nition)i(of)0 1826 +y(an)f(in\014x)h(op)q(erator)f Fi(^)g Fp(that)f(raises)i(its)f(\014rst)g +(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:) +71 1935 y Fi(x)23 b(^)48 b(0)429 b(=)24 b(1)71 1991 y(x)f(^)h(\(n+1\))357 +b(=)24 b(x*\(x^n\))0 2103 y Fp(\(A)15 b(more)g(e\016cien)o(t)h(de\014nition)h +(of)d Fi(^)h Fp(is)h(giv)o(en)g(in)g(the)f(Standard)g(Prelude.\))71 +2185 y(In)e(general,)h(the)f(pattern)g Fi(n+)p Fh(k)h Fp(matc)o(hes)f(an)o(y) +g(in)o(teger)g(v)m(alue)i Fh(v)f Fn(\025)f Fh(k)q Fp(,)g(and)h(binds)g +Fi(n)f Fp(to)g Fh(v)7 b Fn(\000)f Fh(k)q Fp(.)20 b(n)p Fi(+)p +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 +(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 +(similar)h(to)e(the)h(corresp)q(onding)0 2298 y(mathematical)g(de\014nition:) +858 2342 y Fh(x)884 2326 y Fm(0)945 2342 y Fp(=)42 b(1)809 +2399 y Fh(x)835 2382 y Fd(n)p Fm(+1)945 2399 y Fp(=)g Fh(x)10 +b Fn(\003)g Fh(x)1117 2382 y Fd(n)0 2482 y Fp(\(See)15 b Fn(x)q +Fp(3.14)f(for)g(a)h(formal)g(translation)g(of)g(n)p Fi(+)p +Fp(k-patterns)g(in)o(to)g(a)g(more)g(primitiv)o(e)h(form.\))p +0 2525 780 2 v 37 2552 a Fl(11)69 2568 y Fk(Another)e(adv)n(an)o(tage)h(to)e +(doing)i(this)g(is)f(that)f(a)h(naiv)o(e)h(implemen)o(tation)h(migh)o(t)f +(completely)g(reconstruct)g Ff(x:xs)c Fk(rather)j(than)0 2614 +y(re-use)f(the)g(v)n(alue)i(b)q(eing)f(matc)o(hed)g(against.)p +eop +%%Page: 17 17 +bop 0 -40 a Fj(4.1)45 b(P)o(attern-Matc)o(hing)14 b(Seman)o(tics)1187 +b Fp(T-17)0 105 y Fg(4.1)56 b(P)n(attern-Matc)n(hing)19 b(Seman)n(tics)0 +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 +(patterns)c(are)h(matc)o(hed,)g(ho)o(w)f(some)h(are)f(refutable,)i(some)e +(are)0 277 y(irrefutable,)i(etc.)26 b(But)17 b(what)g(driv)o(es)h(the)f(o)o +(v)o(erall)g(pro)q(cess?)27 b(In)18 b(what)e(order)h(are)g(the)g(matc)o(hes)g +(attempted?)0 333 y(What)e(if)g(none)h(succeed?)22 b(These)15 +b(are)g(the)g(questions)h(addressed)g(in)g(this)g(section.)71 +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) +e(actually)h(yield)g(one)g(of)e(three)h(results:)19 b Fo(failur)n(e)p +Fp(;)13 b Fo(suc)n(c)n(ess)0 474 y Fp(\(returning)h(a)f(binding)i(for)d(eac)o +(h)i(formal)f(parameter)f(in)i(the)g(pattern\);)f(or)f Fo(diver)n(genc)n(e)g +Fp(\(i.e.)h(non)o(termination\).)0 531 y(The)i(matc)o(hing)h(pro)q(cess)f +(itself)h(o)q(ccurs)g(\\top-do)o(wn,)e(left-to-righ)o(t.")20 +b(F)l(ailure)c(of)f(a)g(pattern)g(an)o(ywhere)g(in)h(one)0 +587 y(equation)c(results)g(in)g(failure)h(of)e(the)h(whole)g(equation,)h(and) +e(the)h(next)g(equation)g(is)g(then)g(tried.)19 b(If)12 b(all)h(equations)0 +644 y(fail,)j(the)f(v)m(alue)h(of)f(the)g(function)h(application)h(is)f +Fn(?)p Fp(,)f(and)h(results)f(in)h(a)f(run-time)h(error.)71 +728 y(F)l(or)i(example,)k(if)e Fi([1,2])e Fp(is)i(matc)o(hed)g(against)f +Fi([0,bot])o Fp(,)h(then)g Fi(1)f Fp(fails)i(to)e(matc)o(h)g +Fi(0)o Fp(,)i(so)e(the)g(result)h(is)0 785 y(a)f(failed)j(matc)o(h.)33 +b(But)19 b(if)i Fi([1,2])e Fp(is)h(matc)o(hed)g(against)f Fi([bot,0])o +Fp(,)i(then)f(matc)o(hing)f Fi(1)h Fp(against)f Fi(bot)h Fp(causes)0 +841 y(div)o(ergence)c(\(i.e.)f Fn(?)p Fp(\).)71 926 y(The)d(only)h(other)f(t) +o(wist)g(to)f(this)i(set)f(of)g(rules)h(is)g(that)e(top-lev)o(el)j(patterns)e +(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 +Fp(,)0 982 y(as)h(in)h(this)f(de\014nition)i(of)e(a)g(function)h(that)f +(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 +1091 y Fi(sign)23 b(x)h(|)47 b(x)24 b(>)48 b(0)190 b(=)72 b(1)238 +1147 y(|)47 b(x)24 b(==)g(0)190 b(=)72 b(0)238 1204 y(|)47 +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 +(of)e(guards)g(ma)o(y)f(b)q(e)i(pro)o(vided)g(for)f(the)g(same)g(pattern;)g +(as)g(with)g(patterns,)g(they)g(are)0 1370 y(ev)m(aluated)g(top-do)o(wn,)f +(and)g(the)g(\014rst)g(that)g(ev)m(aluates)h(to)e Fi(True)h +Fp(results)g(in)h(a)f(successful)i(matc)o(h.)0 1527 y Fg(4.2)56 +b(An)19 b(Example)0 1642 y Fp(The)i(pattern-matc)o(hing)f(rules)i(can)f(ha)o +(v)o(e)f(subtle)h(e\013ects)g(on)f(the)h(meaning)g(of)f(functions.)37 +b(F)l(or)20 b(example,)0 1698 y(consider)c(this)g(de\014nition)h(of)e +Fi(take)o Fp(:)71 1799 y Fi(take)47 b(0)119 b(_)262 b(=)48 +b([])71 1855 y(take)f(_)119 b([])238 b(=)48 b([])71 1912 y(take)23 +b(\(n+1\))g(\(x:xs\))166 b(=)48 b(x)24 b(:)f(take)h(n)f(xs)0 +2023 y Fp(and)15 b(this)h(sligh)o(tly)g(di\013eren)o(t)g(v)o(ersion)f(\(the)g +(\014rst)g(2)g(equations)g(ha)o(v)o(e)g(b)q(een)i(rev)o(ersed\):)71 +2135 y Fi(take1)47 b(_)119 b([])214 b(=)48 b([])71 2191 y(take1)f(0)119 +b(_)238 b(=)48 b([])71 2248 y(take1)23 b(\(n+1\))g(\(x:xs\))142 +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 +(follo)o(wing:)698 2414 y Fi(take)47 b(0)24 b(bot)111 b Fn(\))87 +b Fi([])698 2470 y(take1)23 b(0)h(bot)111 b Fn(\))87 b(?)698 +2557 y Fi(take)47 b(bot)24 b([])87 b Fn(\))g(?)698 2613 y Fi(take1)23 +b(bot)h([])87 b Fn(\))g Fi([])p eop +%%Page: 18 18 +bop 0 -40 a Fp(T-18)700 b Fj(4)45 b(CASE)15 b(EXPRESSIONS)i(AND)e(P)l(A)l +(TTERN)h(MA)l(TCHING)0 105 y Fp(W)l(e)h(see)h(that)f Fi(take)g +Fp(is)h(\\more)e(de\014ned")j(with)f(resp)q(ect)f(to)g(its)h(second)g +(argumen)o(t,)e(whereas)i Fi(take1)e Fp(is)i(more)0 162 y(de\014ned)h(with)f +(resp)q(ect)g(to)f(its)h(\014rst.)27 b(It)18 b(is)g(di\016cult)h(to)f(sa)o(y) +f(in)h(this)g(case)g(whic)o(h)h(de\014nition)g(is)f(b)q(etter.)28 +b(Just)0 218 y(remem)o(b)q(er)16 b(that)f(in)i(certain)g(applications,)g(it)g +(ma)o(y)e(mak)o(e)g(a)h(di\013erence.)24 b(\(The)15 b(Standard)h(Prelude)i +(includes)0 274 y(a)d(de\014nition)i(corresp)q(onding)f(to)f +Fi(take)o Fp(.\))0 423 y Fg(4.3)56 b(Case)19 b(Expressions)0 +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 +(\\dispatc)o(h)g(con)o(trol")f(based)h(on)g(structural)g(prop)q(erties)g(of)g +(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 +(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) +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) +h(only)g(sho)o(wn)g(ho)o(w)g(to)f(do)h(pattern)g(matc)o(hing)g(in)h(function) +f(de\014nitions.)25 b(Hask)o(ell's)0 704 y Fo(c)n(ase)16 b(expr)n(ession)e +Fp(pro)o(vides)i(a)f(w)o(a)o(y)g(to)f(solv)o(e)i(this)g(problem.)21 +b(Indeed,)c(the)f(meaning)g(of)f(pattern)g(matc)o(hing)g(in)0 +761 y(function)k(de\014nitions)i(is)e(sp)q(eci\014ed)h(in)g(the)e(Rep)q(ort)h +(in)h(terms)e(of)g(case)g(expressions,)i(whic)o(h)f(are)g(considered)0 +817 y(more)c(primitiv)o(e.)21 b(In)16 b(particular,)f(a)g(function)h +(de\014nition)h(of)e(the)g(form:)787 916 y Fi(f)h Fo(p)850 +923 y Fb(11)917 916 y Fh(:)8 b(:)g(:)22 b Fo(p)1017 923 y Fb(1k)1074 +916 y Fi(=)16 b Fo(e)1135 923 y Fb(1)787 973 y Fh(:)8 b(:)g(:)787 +1029 y Fi(f)16 b Fo(p)850 1036 y Fb(n1)919 1029 y Fh(:)8 b(:)g(:)22 +b Fo(p)1019 1036 y Fb(nk)1077 1029 y Fi(=)16 b Fo(e)1138 1036 +y Fb(n)0 1129 y Fp(where)f(eac)o(h)h Fo(p)257 1136 y Fb(ij)301 +1129 y Fp(is)g(a)e(pattern,)h(is)g(seman)o(tically)i(equiv)m(alen)o(t)g(to:) +288 1232 y Fi(f)23 b(x1)h(x2)g Fh(:)8 b(:)g(:)21 b Fi(xk)j(=)g(case)f(\(x1,) +31 b Fh(:)8 b(:)g(:)e Fi(,)23 b(xk\))h(of)c(\()p Fo(p)1240 +1239 y Fb(11)1283 1232 y Fh(;)k(:)8 b(:)g(:)d(;)24 b Fo(p)1440 +1239 y Fb(1k)1480 1232 y Fi(\))g(->)16 b Fo(e)1613 1239 y Fb(1)1193 +1288 y Fh(:)8 b(:)g(:)1193 1344 y Fi(\()p Fo(p)1240 1351 y +Fb(n1)1285 1344 y Fh(;)24 b(:)8 b(:)g(:)d(;)24 b Fo(p)1442 +1351 y Fb(nk)1484 1344 y Fi(\))g(->)16 b Fo(e)1617 1351 y Fb(n)0 +1446 y Fp(where)f(the)g Fi(xi)f Fp(are)h(new)g(iden)o(ti\014ers.)21 +b(\(F)l(or)14 b(a)g(more)h(general)g(translation)g(that)f(includes)j(guards,) +d(see)h Fn(x)p Fp(4.4.2.\))0 1503 y(F)l(or)g(example,)g(the)h(de\014nition)h +(of)d Fi(take)h Fp(giv)o(en)h(earlier)g(is)f(equiv)m(alen)o(t)i(to:)71 +1612 y Fi(take)23 b(m)h(ys)357 b(=)24 b(case)f(\(m,ys\))g(of)739 +1668 y(\(0,_\))166 b(->)48 b([])739 1725 y(\(_,[]\))142 b(->)48 +b([])739 1781 y(\(n+1,x:xs\))e(->)i(x)23 b(:)h(take)f(n)h(xs)71 +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 +(yp)q(e)h(correctness,)g(the)h(t)o(yp)q(es)f(of)g(the)g(righ)o(t-hand)g +(sides)h(of)f(a)g(case)0 1997 y(expression)h(or)e(set)h(of)f(equations)h +(comprising)h(a)e(function)i(de\014nition)h(m)o(ust)d(all)i(b)q(e)f(the)g +(same;)g(more)f(precisely)l(,)0 2054 y(they)j(m)o(ust)g(all)h(share)f(a)g +(common)g(principal)i(t)o(yp)q(e.)71 2136 y(The)j(pattern-matc)o(hing)g +(rules)g(for)g(case)g(expressions)h(are)e(the)h(same)g(as)g(w)o(e)g(ha)o(v)o +(e)f(giv)o(en)i(for)e(function)0 2192 y(de\014nitions,)h(so)d(there)h(is)g +(really)h(nothing)f(new)g(to)f(learn)h(here,)h(other)e(than)h(to)f(note)h +(the)f(con)o(v)o(enience)j(that)0 2248 y(case)d(expressions)g(o\013er.)24 +b(Indeed,)19 b(there's)d(one)h(use)g(of)g(a)f(case)h(expression)h(that)e(is)h +(so)f(common)h(that)f(it)h(has)0 2305 y(sp)q(ecial)k(syn)o(tax:)27 +b(the)19 b Fo(c)n(onditional)g(expr)n(ession)p Fp(.)31 b(In)20 +b(Hask)o(ell,)g(conditional)h(expressions)f(ha)o(v)o(e)f(the)g(familiar)0 +2361 y(form:)756 2419 y Fi(if)c Fh(e)840 2426 y Fm(1)875 2419 +y Fi(then)g Fh(e)1007 2426 y Fm(2)1042 2419 y Fi(else)g Fh(e)1174 +2426 y Fm(3)0 2503 y Fp(whic)o(h)h(is)g(really)g(short-hand)f(for:)724 +2557 y Fi(case)f Fh(e)855 2564 y Fm(1)890 2557 y Fi(of)41 b(True)48 +b(->)15 b Fh(e)1207 2564 y Fm(2)979 2613 y Fi(False)24 b(->)15 +b Fh(e)1207 2620 y Fm(3)p eop +%%Page: 19 19 +bop 0 -40 a Fj(4.4)45 b(Lazy)15 b(P)o(atterns)1473 b Fp(T-19)0 +105 y(F)l(rom)15 b(this)g(expansion)i(it)e(should)i(b)q(e)f(clear)g(that)e +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 +Fi(Bool)o Fp(,)g(and)h Fh(e)1489 112 y Fm(2)1524 105 y Fp(and)g +Fh(e)1634 112 y Fm(3)1669 105 y Fp(m)o(ust)f(ha)o(v)o(e)g(the)0 +162 y(same)e(\(but)g(otherwise)h(arbitrary\))e(t)o(yp)q(e.)19 +b(In)14 b(other)f(w)o(ords,)f Fi(if)p 1104 162 14 2 v 16 w(then)p +1216 162 V 16 w(else)p 1327 162 V 29 w Fp(when)i(view)o(ed)g(as)f(a)g +(function)h(has)0 218 y(t)o(yp)q(e)h Fi(Bool->a->a->a)n Fp(.)0 +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 +(kind)h(of)f(pattern)g(allo)o(w)o(ed)h(in)g(Hask)o(ell.)21 +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 +(form)0 533 y Fi(~)p Fh(pat)p Fp(.)28 b(Lazy)18 b(patterns)f(are)h +Fo(irr)n(efutable)p Fp(:)25 b(matc)o(hing)18 b(a)f(v)m(alue)j +Fh(v)f Fp(against)e Fi(~)p Fh(pat)h Fp(alw)o(a)o(ys)g(succeeds,)h(regardless) +0 589 y(of)c Fh(pat)p Fp(.)20 b(Op)q(erationally)d(sp)q(eaking,)f(if)g(an)f +(iden)o(ti\014er)i(in)f Fh(pat)f Fp(is)h(later)f(\\used")h(on)f(the)g(righ)o +(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 +(of)g(the)f(v)m(alue)i(that)f(w)o(ould)g(result)g(if)g Fh(v)h +Fp(w)o(ere)f(to)f(successfully)j(matc)o(h)d Fh(pat)p Fp(,)h(and)g +Fn(?)0 702 y Fp(otherwise.)71 784 y(Lazy)22 b(patterns)g(are)g(useful)i(in)f +(con)o(texts)f(where)h(in\014nite)h(lists)g(are)e(b)q(eing)h(de\014ned)h +(recursiv)o(ely)l(.)44 b(F)l(or)0 840 y(example,)16 b(in\014nite)h(lists)e +(are)g(an)g(excellen)o(t)i(v)o(ehicle)g(for)e(writing)g Fo(simulation)g +Fp(programs,)f(and)h(in)h(this)g(con)o(text)0 897 y(the)h(in\014nite)j(lists) +e(are)f(often)g(called)i Fo(str)n(e)n(ams)p Fp(.)25 b(Consider)18 +b(the)g(simple)g(case)g(of)f(sim)o(ulating)h(the)g(in)o(teractions)0 +953 y(b)q(et)o(w)o(een)g(a)f(serv)o(er)g(pro)q(cess)h Fi(server)f +Fp(and)g(a)h(clien)o(t)g(pro)q(cess)g Fi(client)o Fp(,)g(where)g +Fi(client)e Fp(sends)i(a)g(sequence)g(of)0 1010 y Fo(r)n(e)n(quests)c +Fp(to)h Fi(server)o Fp(,)g(and)g Fi(server)g Fp(replies)i(to)d(eac)o(h)i +(request)f(with)h(some)f(kind)h(of)f Fo(r)n(esp)n(onse)p Fp(.)k(This)d +(situation)0 1066 y(is)i(sho)o(wn)e(pictorially)j(in)f(Figure)f(1b,)g(just)g +(as)f(w)o(e)h(did)h(with)g(the)f(Fib)q(onacci)h(example.)26 +b(\(Note)17 b(that)f Fi(client)0 1122 y Fp(also)g(tak)o(es)f(an)h(initial)i +(message)d(as)h(argumen)o(t.\))21 b(Using)c(streams)e(to)g(sim)o(ulate)h(the) +h(message)e(sequences,)i(the)0 1179 y(Hask)o(ell)f(co)q(de)g(corresp)q +(onding)g(to)f(this)g(diagram)g(is:)71 1288 y Fi(reqs)500 b(=)24 +b(client)f(init)g(resps)71 1344 y(resps)476 b(=)24 b(server)f(reqs)0 +1453 y Fp(These)16 b(recursiv)o(e)f(equations)h(are)f(a)g(direct)h(lexical)h +(transliteration)e(of)g(the)g(diagram.)71 1535 y(Let)g(us)g(further)g(assume) +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 +(something)h(lik)o(e)g(this:)71 1644 y Fi(client)23 b(init)g(\(resp:resps\))f +(=)i(init)f(:)h(client)f(\(next)g(resp\))g(resps)71 1700 y(server)142 +b(\(req:reqs\))70 b(=)24 b(process)f(req)g(:)h(server)f(reqs)0 +1809 y Fp(where)18 b(w)o(e)g(assume)g(that)g Fi(next)f Fp(is)i(a)f(function)h +(that,)f(giv)o(en)g(a)g(resp)q(onse)h(from)e(the)i(serv)o(er,)f(determines)h +(the)0 1866 y(next)i(request,)g(and)g Fi(process)f Fp(is)h(a)g(function)g +(that)f(pro)q(cesses)h(a)f(request)h(from)f(the)h(clien)o(t,)i(returning)e +(an)0 1922 y(appropriate)15 b(resp)q(onse.)71 2004 y(Unfortunately)l(,)d +(this)f(program)f(has)h(a)g(serious)h(problem:)18 b(it)12 b(will)h(not)e(pro) +q(duce)h(an)o(y)e(output!)19 b(The)11 b(problem)0 2060 y(is)h(that)e +Fi(client)o Fp(,)i(as)f(used)g(in)h(the)g(recursiv)o(e)g(setting)f(of)g +Fi(reqs)f Fp(and)i Fi(resps)o Fp(,)f(attempts)g(a)f(matc)o(h)h(on)g(the)g +(resp)q(onse)0 2117 y(list)18 b(b)q(efore)g(it)g(has)g(submitted)g(its)g +(\014rst)f(request!)27 b(In)19 b(other)e(w)o(ords,)g(the)h(pattern)f(matc)o +(hing)h(is)g(b)q(eing)h(done)0 2173 y(\\to)q(o)14 b(early)l(.")20 +b(One)c(w)o(a)o(y)f(to)f(\014x)h(this)h(is)g(to)e(rede\014ne)j +Fi(client)d Fp(as)h(follo)o(ws:)71 2282 y Fi(client)23 b(init)g(resps)214 +b(=)24 b(init)f(:)h(client)f(\(next)g(\(head)g(resps\)\))g(\(tail)g(resps\))0 +2391 y Fp(Although)15 b(w)o(ork)m(able,)f(this)g(solution)h(do)q(es)g(not)e +(read)h(as)g(w)o(ell)h(as)f(that)f(giv)o(en)i(earlier.)20 b(A)14 +b(b)q(etter)g(solution)h(is)g(to)0 2448 y(use)h(a)e(lazy)i(pattern:)71 +2557 y Fi(client)23 b(init)g(~\(resp:resps\))f(=)i(init)f(:)h(client)f +(\(next)g(resp\))g(resps)p eop +%%Page: 20 20 +bop 0 -40 a Fp(T-20)700 b Fj(4)45 b(CASE)15 b(EXPRESSIONS)i(AND)e(P)l(A)l +(TTERN)h(MA)l(TCHING)0 105 y Fp(Because)22 b(lazy)h(patterns)e(are)g +(irrefutable,)j(the)e(matc)o(h)f(will)j(immediately)f(succeed,)h(allo)o(wing) +f(the)f(initial)0 162 y(request)17 b(to)f(b)q(e)i(\\submitted,")g(in)f(turn)g +(allo)o(wing)h(the)f(\014rst)g(resp)q(onse)h(to)e(b)q(e)i(generated;)f(the)h +(engine)g(is)f(no)o(w)0 218 y(\\primed,")e(and)h(the)f(recursion)h(tak)o(es)e +(care)h(of)g(the)g(rest.)71 306 y(As)g(an)g(example)h(of)f(this)g(program)f +(in)i(action,)f(if)h(w)o(e)f(de\014ne:)71 415 y Fi(init)476 +b(=)24 b(0)71 472 y(next)f(resp)357 b(=)24 b(resp)71 528 y(process)e(req)310 +b(=)24 b(req+1)0 637 y Fp(then)16 b(w)o(e)e(see)i(that:)485 +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 +830 y Fp(The)13 b(serv)o(er/clien)o(t)h(example)g(w)o(as)e(delib)q(erately)k +(c)o(hosen)d(to)f(demonstrate)h(a)g(t)o(ypical)h(use)f(of)g(lazy)g(patterns)0 +887 y(and)19 b(streams,)f(and)g(also)h(to)f(aid)h(the)f(user)h(in)o(terested) +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 +Fp(,)g(in)h(whic)o(h)g(a)0 943 y(Hask)o(ell)14 b(program)f(is)g(essen)o +(tially)i(the)f(clien)o(t,)g(with)g(the)g(op)q(erating)f(system)g(acting)h +(as)f(serv)o(er)g(\()p Fn(x)p Fp(7\).)18 b(Although)0 1000 +y(in)d(this)g(tutorial)f(w)o(e)g(will)i(only)f(discuss)g Fo(c)n +(ontinuation-b)n(ase)n(d)g(I/O)f Fp(\(see)g(Section)h(8\),)e(the)i +(stream-based)f(alter-)0 1056 y(nativ)o(e)j(is)h(an)f(excellen)o(t)i(example) +f(of)e(the)h(use)h(of)e(lazy)i(patterns)f(and)g(streams.)24 +b(Indeed,)19 b(the)e(stream-based)0 1113 y(I/O)f(example)g(in)g(the)f(Rep)q +(ort)h(uses)f(lazy)h(patterns.)71 1201 y(As)11 b(another)g(example)i(of)e +(the)h(use)g(of)f(lazy)h(patterns,)g(consider)h(the)e(de\014nition)j(of)d +(Fib)q(onacci)i(giv)o(en)f(earlier:)71 1310 y Fi(fib)309 b(=)24 +b(1)g(:)g(1)f(:)h([)g(a+b)f(|)h(\(a,b\))f(<-)h(zip)f(fib)h(\(tail)f(fib\))g +(])0 1419 y Fp(W)l(e)15 b(migh)o(t)g(try)g(rewriting)h(this)f(using)h(an)f +(as-pattern:)71 1528 y Fi(fib@\(1:tfib\))70 b(=)23 b(1)h(:)g(1)f(:)h([)g(a+b) +f(|)h(\(a,b\))f(<-)h(zip)f(fib)h(tfib)f(])0 1639 y Fp(This)16 +b(v)o(ersion)g(of)f Fi(fib)g Fp(has)h(the)f(\(small)h(adv)m(an)o(tage\))f(of) +g(not)g(using)i Fi(tail)e Fp(on)g(the)h(righ)o(t-hand)g(side,)g(since)h(it)e +(is)0 1696 y(a)o(v)m(ailable)i(in)f(\\destructured")f(form)f(on)i(the)f +(left-hand)h(side)g(as)f Fi(tfib)o Fp(.)71 1784 y([This)f(kind)h(of)f +(equation)g(is)h(called)h(a)e Fo(p)n(attern)h(binding)e Fp(b)q(ecause)i(it)g +(is)f(a)g(top-lev)o(el)h(equation)g(in)g(whic)o(h)g(the)0 1840 +y(en)o(tire)k(left-hand)g(side)g(is)g(a)f(pattern;)h(i.e.)f(b)q(oth)g +Fi(fib)g Fp(and)h Fi(tfib)e Fp(b)q(ecome)i(b)q(ound)g(within)h(the)e(scop)q +(e)h(of)f(the)0 1897 y(declaration.])71 1985 y(No)o(w,)12 b(using)h(the)g +(same)g(reasoning)g(w)o(e)f(did)i(earlier,)g(w)o(e)f(should)h(b)q(e)f(led)h +(to)e(b)q(eliev)o(e)j(that)d(this)i(program)d(will)0 2041 y(not)j(generate)h +(an)o(y)f(output.)19 b(Curiously)l(,)d(ho)o(w)o(ev)o(er,)d(it)i +Fo(do)n(es)p Fp(,)f(and)h(the)f(reason)h(is)g(simple:)21 b(in)15 +b(Hask)o(ell,)g(pattern)0 2098 y(bindings)i(are)e(assumed)g(to)f(ha)o(v)o(e)h +(an)f(implicit)k Fi(~)d Fp(in)h(fron)o(t)e(of)g(them,)h(re\015ecting)h(the)f +(most)f(common)g(b)q(eha)o(vior)0 2154 y(exp)q(ected)h(of)f(pattern)g +(bindings,)i(and)e(a)o(v)o(oiding)h(some)f(anomalous)g(situations)g(whic)o(h) +h(are)f(b)q(ey)o(ond)h(the)f(scop)q(e)0 2211 y(of)f(this)h(tutorial.)19 +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 +(ortan)o(t)f(role)g(in)i(Hask)o(ell,)f(if)g(only)g(implicitly)l(.)0 +2380 y Fg(4.5)56 b(Lexical)16 b(Scoping)j(and)g(Nested)f(F)-5 +b(orms)0 2501 y Fp(It)14 b(is)h(often)f(desirable)i(to)e(create)g(a)g(nested) +h(scop)q(e)g(within)g(an)f(expression,)h(for)f(the)g(purp)q(ose)h(of)f +(creating)h(lo)q(cal)0 2557 y(bindings)i(not)f(seen)g(elsewhere|i.e.)23 +b(some)15 b(kind)h(of)g(\\blo)q(c)o(k-structuring")g(form.)k(In)c(Hask)o(ell) +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 +eop +%%Page: 21 21 +bop 0 -40 a Fj(4.6)45 b(La)o(y)o(out)1614 b Fp(T-21)0 105 y +Fc(Let)23 b(Expressions.)44 b Fp(Hask)o(ell's)19 b Fo(let)h(expr)n(essions)d +Fp(are)i(useful)h(whenev)o(er)g(a)e(nested)i(set)f(of)f(bindings)j(is)f(re-)0 +162 y(quired.)h(As)15 b(a)g(simple)i(example,)e(consider:)71 +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 +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 +(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 +(cursive)p Fp(,)e(and)g(pattern)f(bindings)j(are)0 549 y(treated)c(as)g(lazy) +i(patterns)e(\(i.e.)27 b(they)18 b(carry)f(an)h(implicit)i +Fi(~)p Fp(\).)27 b(The)18 b(only)g(kind)h(of)e(declarations)h(p)q(ermitted)0 +605 y(are)d Fo(typ)n(e)h(signatur)n(es)p Fp(,)e Fo(function)i(bindings)p +Fp(,)d(and)j Fo(p)n(attern)g(bindings)p Fp(.)0 780 y Fc(Where)j(Clauses.)45 +b Fp(Sometimes)18 b(it)f(is)h(con)o(v)o(enien)o(t)g(to)e(scop)q(e)i(bindings) +h(o)o(v)o(er)d(sev)o(eral)i(guarded)f(equations,)0 836 y(whic)o(h)f(requires) +g(a)f Fo(wher)n(e)h(clause)p Fp(:)71 945 y Fi(f)23 b(x)h(y)48 +b(|)f(y>z)262 b(=)48 b(...)238 1001 y(|)f(y==z)238 b(=)48 b(...)238 +1058 y(|)f(y<z)262 b(=)48 b(...)643 1114 y(where)23 b(z)h(=)g(x*x)0 +1224 y Fp(Note)14 b(that)h(this)g(cannot)f(b)q(e)i(done)f(with)g(a)g +Fi(let)f Fp(expression,)h(whic)o(h)h(only)f(scop)q(es)h(o)o(v)o(er)e(the)g +(expression)i(whic)o(h)0 1280 y(it)f(encloses.)20 b(A)15 b +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) +i(of)e(a)g(set)g(of)g(equations)h(or)f(case)g(expression.)0 +1336 y(The)e(same)g(prop)q(erties)g(and)g(constrain)o(ts)g(on)g(bindings)h +(in)g Fi(let)e Fp(expressions)i(apply)g(to)e(those)h(in)g Fi(where)g +Fp(clauses.)71 1426 y(These)k(t)o(w)o(o)f(forms)g(of)h(nested)h(scop)q(e)f +(seem)h(v)o(ery)e(similar,)j(but)e(remem)o(b)q(er)g(that)g(a)g +Fi(let)f Fp(expression)i(is)g(an)0 1483 y Fo(expr)n(ession)p +Fp(,)12 b(whereas)h(a)g Fi(where)f Fp(clause)i(is)g(not|it)f(is)h(part)e(of)h +(the)g(syn)o(tax)f(of)h(function)h(declarations)g(and)f(case)0 +1539 y(expressions.)0 1715 y Fg(4.6)56 b(La)n(y)n(out)0 1839 +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) +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 +(semicolons,)0 1895 y(or)e(some)h(other)f(kind)i(of)e(line)i(terminator,)e +(to)g(mark)g(the)h(end)g(of)g(equations,)g(declarations,)g(etc.)19 +b(F)l(or)12 b(example,)0 1952 y(consider)k(this)g Fi(let)f +Fp(expression)h(from)e(the)h(last)g(section:)71 2061 y Fi(let)23 +b(y)71 b(=)24 b(a*b)166 2117 y(f)g(x)f(=)h(\(x+y\)/y)71 2174 +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 +(kno)o(w)g(not)g(to)f(parse)h(this)h(as:)71 2392 y Fi(let)23 +b(y)71 b(=)24 b(a*b)g(f)166 2448 y(x)71 b(=)24 b(\(x+y\)/y)71 +2504 y(in)f(f)h(c)g(+)f(f)h(d)0 2614 y Fp(?)p eop +%%Page: 22 22 +bop 0 -40 a Fp(T-22)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g +(AND)f(\\OOP")71 105 y Fp(The)j(answ)o(er)f(is)i(that)e(Hask)o(ell)i(uses)f +(a)g(t)o(w)o(o-dimensional)h(syn)o(tax)e(called)i Fo(layout)g +Fp(that)e(essen)o(tially)j(relies)0 162 y(on)e(declarations)h(b)q(eing)h +(\\lined)g(up)f(in)g(columns.")30 b(In)19 b(the)f(ab)q(o)o(v)o(e)g(example,)i +(note)e(that)g Fi(y)g Fp(and)g Fi(f)g Fp(b)q(egin)i(in)0 218 +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 +(elled)i(out)e(in)h(detail)g(in)g(the)f(Rep)q(ort)h(\()p Fn(x)p +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 +(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 +(o)e(things:)71 358 y(First,)j(the)g(next)g(c)o(haracter)g(follo)o(wing)h(an) +o(y)f(of)g(the)g(k)o(eyw)o(ords)f Fi(where)p Fp(,)h Fi(let)p +Fp(,)g(or)g Fi(of)g Fp(is)g(what)g(determines)0 415 y(the)c(starting)f +(column)i(for)e(the)h(declarations)h(in)g(the)f(where,)g(let,)g(or)g(case)g +(expression)g(b)q(eing)i(written)d(\(the)h(rule)0 471 y(also)i(applies)i(to)d +Fi(where)g Fp(used)i(in)g(the)f(class)h(and)f(instance)h(declarations)f(to)g +(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 +(egin)i(the)e(declarations)h(on)f(the)g(same)g(line)i(as)e(the)g(k)o(eyw)o +(ord,)f(the)h(next)h(line,)g(etc.)71 612 y(Second,)h(just)f(b)q(e)h(sure)f +(that)g(the)g(starting)g(column)h(is)g(further)f(to)g(the)h(righ)o(t)f(than)g +(the)g(starting)g(column)0 668 y(asso)q(ciated)f(with)g(the)g(immediately)i +(surrounding)f(clause)g(\(otherwise)f(it)g(w)o(ould)g(b)q(e)h(am)o +(biguous\).)j(The)c(\\ter-)0 725 y(mination")e(of)f(a)h(declaration)g(happ)q +(ens)h(when)f(something)g(app)q(ears)g(at)f(or)g(to)g(the)h(left)g(of)f(the)h +(starting)f(column)0 781 y(asso)q(ciated)j(with)h(that)e(binding)k(form.)689 +765 y Fm(12)71 865 y Fp(La)o(y)o(out)e(is)h(actually)h(shorthand)f(for)g(an)g +Fo(explicit)f Fp(grouping)i(mec)o(hanism,)g(whic)o(h)f(deserv)o(es)h(men)o +(tion)f(b)q(e-)0 921 y(cause)e(it)h(can)f(b)q(e)h(useful)g(under)g(certain)g +(circumstances.)21 b(The)15 b Fi(let)g Fp(example)h(ab)q(o)o(v)o(e)f(is)g +(equiv)m(alen)o(t)i(to:)71 1030 y Fi(let)23 b({)h(y)71 b(=)24 +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) +0 1252 y Fp(Note)15 b(the)h(explicit)i(curly)e(braces)g(and)g(semicolons.)22 +b(One)16 b(w)o(a)o(y)f(in)h(whic)o(h)h(this)f(explicit)h(notation)f(is)g +(useful)g(is)0 1309 y(when)g(more)e(than)i(one)f(declaration)h(is)g(desired)g +(on)f(a)g(line;)h(for)f(example,)h(this)f(is)h(a)f(v)m(alid)i(expression:)71 +1418 y Fi(let)23 b(y)71 b(=)24 b(a*b;)47 b(z)24 b(=)g(a/b)166 +1474 y(f)g(x)f(=)h(\(x+y\)/z)71 1531 y(in)f(f)h(c)g(+)f(f)h(d)0 +1640 y Fp(F)l(or)15 b(another)f(example)i(of)f(the)g(expansion)i(of)d(la)o(y) +o(out)h(in)o(to)g(explicit)i(delimiters,)g(see)f Fn(x)p Fp(1.5.)71 +1724 y(The)i(use)h(of)e(la)o(y)o(out)h(greatly)g(reduces)h(the)f(syn)o +(tactic)g(clutter)h(asso)q(ciated)f(with)h(declaration)g(lists,)g(th)o(us)0 +1780 y(enhancing)e(readabilit)o(y)l(.)k(It)15 b(is)h(easy)f(to)f(learn,)i +(and)f(its)h(use)f(is)h(encouraged.)0 1957 y Fq(5)69 b(T)n(yp)r(e)23 +b(Classes,)f(Ov)n(erloading,)g(and)i(\\OOP")0 2087 y Fp(There)17 +b(is)g(one)f(\014nal)i(feature)e(of)g(Hask)o(ell's)h(t)o(yp)q(e)g(system)f +(that)g(sets)g(it)h(apart)e(from)h(other)g(languages,)h(and)f(is)0 +2144 y(probably)h(the)f(most)f(inno)o(v)m(ativ)o(e)i(asp)q(ect)f(of)g(Hask)o +(ell's)g(design.)24 b(The)16 b(kind)h(of)f(p)q(olymorphism)h(that)f(w)o(e)f +(ha)o(v)o(e)0 2200 y(talk)o(ed)g(ab)q(out)h(so)e(far)h(is)h(commonly)f +(called)i Fo(p)n(ar)n(ametric)f Fp(p)q(olymorphism.)21 b(There)16 +b(is)f(another)g(kind)i(called)g Fo(ad)0 2256 y(ho)n(c)c Fp(p)q(olymorphism,) +i(b)q(etter)f(kno)o(wn)f(as)g Fo(overlo)n(ading)p Fp(.)19 b(Here)13 +b(are)h(some)f(examples)h(of)f(ad)g(ho)q(c)h(p)q(olymorphism:)68 +2382 y Fn(\017)23 b Fp(The)15 b(literals)h Fi(1)p Fp(,)f Fi(2)p +Fp(,)f(etc.)20 b(are)15 b(often)g(used)g(to)g(represen)o(t)g(b)q(oth)g +(\014xed)h(and)f(arbitrary)g(precision)h(in)o(tegers.)68 2480 +y Fn(\017)23 b Fp(Numeric)16 b(op)q(erators)e(suc)o(h)i(as)e +Fi(+)h Fp(are)g(often)g(de\014ned)i(to)d(w)o(ork)h(on)g(man)o(y)f(di\013eren) +o(t)i(kinds)g(of)f(n)o(um)o(b)q(ers.)p 0 2525 780 2 v 37 2552 +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 +(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 +(e)g(tak)o(en)g(when)g(using)h(an)f(editor)h(whic)o(h)0 2614 +y(ma)o(y)g(observ)o(e)h(some)f(other)h(con)o(v)o(en)o(tion.)p +eop +%%Page: 23 23 +bop 1857 -40 a Fp(T-23)68 105 y Fn(\017)23 b Fp(The)13 b(equalit)o(y)h(op)q +(erator)e(\()p Fi(==)g Fp(in)i(Hask)o(ell\))g(usually)g(w)o(orks)e(on)h(n)o +(um)o(b)q(ers)g(and)h(man)o(y)e(other)h(\(but)g(not)f(all\))114 +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 +(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 +(fact)f(the)h(b)q(eha)o(vior)g(is)g(sometimes)0 320 y(unde\014ned,)g(or)f +(error\),)e(whereas)i(in)g(parametric)g(p)q(olymorphism)g(the)g(t)o(yp)q(e)g +(truly)g(do)q(es)g(not)f(matter)g(\()p Fi(fringe)n Fp(,)0 377 +y(for)f(example,)i(really)g(do)q(esn't)f(care)g(what)g(kind)h(of)f(elemen)o +(ts)g(are)g(found)g(in)h(the)g(lea)o(v)o(es)f(of)f(a)h(tree\).)19 +b(In)13 b(Hask)o(ell,)0 433 y Fo(typ)n(e)j(classes)e Fp(pro)o(vide)i(a)e +(structured)i(w)o(a)o(y)e(to)g(con)o(trol)h(ad)g(ho)q(c)h(p)q(olymorphism,)g +(or)f(o)o(v)o(erloading.)71 510 y(Let's)d(start)g(with)i(a)e(simple,)j(but)e +(imp)q(ortan)o(t,)g(example:)19 b Fo(e)n(quality)p Fp(.)g(There)14 +b(are)e(man)o(y)h(t)o(yp)q(es)g(for)f(whic)o(h)i(w)o(e)0 566 +y(w)o(ould)f(lik)o(e)h(equalit)o(y)g(de\014ned,)g(but)f(some)f(for)g(whic)o +(h)i(w)o(e)f(w)o(ould)g(not.)18 b(F)l(or)13 b(example,)g(comparing)g(the)g +(equalit)o(y)0 623 y(of)g(functions)g(is)h(generally)g(considered)h +(computationally)f(in)o(tractable,)f(whereas)g(w)o(e)g(often)g(w)o(an)o(t)f +(to)g(compare)0 679 y(t)o(w)o(o)j(lists)i(for)e(equalit)o(y)l(.)418 +663 y Fm(13)480 679 y Fp(T)l(o)h(highligh)o(t)h(the)g(issue,)g(consider)g +(this)f(de\014nition)i(of)e(the)g(function)h Fi(elem)f Fp(whic)o(h)0 +736 y(tests)f(for)f(mem)o(b)q(ership)j(in)f(a)e(list:)71 845 +y Fi(x)23 b(`elem`)47 b([])286 b(=)24 b(False)71 901 y(x)f(`elem`)g(\(y:ys\)) +214 b(=)24 b(x==y)f(||)h(\(x)g(`elem`)f(ys\))0 1013 y Fp([F)l(or)16 +b(the)h(st)o(ylistic)h(reason)f(w)o(e)f(discussed)j(in)f(Section)g(3.1,)e(w)o +(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 +(form.)0 1069 y Fi(==)d Fp(and)g Fi(||)g Fp(are)g(the)g(in\014x)i(op)q +(erators)d(for)g(equalit)o(y)i(and)g(logical)g(or,)e(resp)q(ectiv)o(ely)l(.]) +0 1146 y(In)o(tuitiv)o(ely)h(sp)q(eaking,)f(the)g(t)o(yp)q(e)f(of)g +Fi(elem)g Fp(\\ough)o(t")f(to)g(b)q(e:)20 b Fi(a->[a]->Bool)n +Fp(.)f(But)14 b(this)f(w)o(ould)h(imply)h(that)d Fi(==)0 1202 +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 +(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 +(de\014ned)g(for)e(all)i(t)o(yp)q(es.)71 1279 y(F)l(urthermore,)20 +b(as)g(w)o(e)f(ha)o(v)o(e)h(noted)g(earlier,)i(ev)o(en)e(if)h +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 +(w)o(o)0 1335 y(lists)e(for)e(equalit)o(y)i(is)g Fo(very)g(di\013er)n(ent)e +Fp(from)h(comparing)g(t)o(w)o(o)f(in)o(tegers.)25 b(In)18 b(this)g(sense,)f +(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 +Fp(to)g(carry)f(on)i(these)f(v)m(arious)h(tasks.)71 1468 y +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) +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 +(yp)q(es)0 1525 y(are)13 b Fo(instanc)n(es)e Fp(of)i(whic)o(h)i(class,)e(and) +h(to)f(pro)o(vide)g(de\014nitions)j(of)c(the)i(o)o(v)o(erloaded)f +Fo(op)n(er)n(ations)g Fp(asso)q(ciated)h(with)0 1581 y(a)h(class.)20 +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 +(taining)g(an)f(equalit)o(y)h(op)q(erator:)71 1690 y Fi(class)23 +b(Eq)g(a)h(where)118 1747 y(\(==\))429 b(::)24 b(a)g(->)f(a)h(->)g(Bool)0 +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) +g(de\014ned,)g(and)f Fi(==)g Fp(is)g(the)g(single)h(op)q(eration)f(in)h(the)f +(class.)28 b(This)0 1912 y(declaration)13 b(ma)o(y)f(b)q(e)h(read)g(\\a)f(t)o +(yp)q(e)g Fi(a)h Fp(is)g(an)f(instance)i(of)e(the)h(class)f +Fi(Eq)h Fp(if)g(there)f(is)h(an)g(\(o)o(v)o(erloaded\))f(op)q(eration)0 +1969 y Fi(==)p Fp(,)i(of)g(the)h(appropriate)g(t)o(yp)q(e,)f(de\014ned)i(on)f +(it.")20 b(\(Note)14 b(that)g Fi(==)g Fp(is)h(only)h(de\014ned)g(on)e(pairs)h +(of)g(ob)s(jects)f(of)g(the)0 2025 y(same)h(t)o(yp)q(e.\))71 +2102 y(The)i(constrain)o(t)f(that)h(a)f(t)o(yp)q(e)i Fi(a)e +Fp(m)o(ust)h(b)q(e)h(an)f(instance)g(of)g(the)g(class)g Fi(Eq)g +Fp(is)h(written)f Fi(Eq)23 b(a)p Fp(.)j(Th)o(us)17 b Fi(Eq)23 +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 +(expresses)f(a)g(constrain)o(t)f(on)h(a)g(t)o(yp)q(e,)g(and)g(is)h(called)g +(a)f Fo(c)n(ontext)p Fp(.)0 2215 y(Con)o(texts)14 b(are)h(app)q(ended)i(to)e +(the)g(fron)o(t)f(of)h(t)o(yp)q(e)h(expressions.)21 b(F)l(or)14 +b(example,)i(the)f(e\013ect)g(of)g(the)h(ab)q(o)o(v)o(e)f(class)0 +2271 y(declaration)h(is)g(to)e(assign)i(the)f(follo)o(wing)h(t)o(yp)q(e)f(to) +g Fi(==)o Fp(:)71 2380 y Fi(\(==\))476 b(::)24 b(\(Eq)f(a\))h(=>)g(a)f(->)h +(a)g(->)f(Bool)p 0 2480 780 2 v 37 2506 a Fl(13)69 2522 y Fk(The)15 +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 +(alue)h(equalit)o(y)m(,")h(and)e(opp)q(osed)i(to)d(the)h(\\p)q(oin)o(ter)h +(equalit)o(y")h(found,)0 2568 y(for)f(example,)h(in)g(Lisp's)g +Ff(eq)o Fk(.)26 b(P)o(oin)o(ter)17 b(equalit)o(y)h(is)e(not)h(referen)o +(tially)h(transparen)o(t,)g(and)e(th)o(us)h(do)q(es)f(not)g(sit)h(w)o(ell)g +(in)f(a)g(purely)0 2614 y(functional)f(language.)p eop +%%Page: 24 24 +bop 0 -40 a Fp(T-24)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g +(AND)f(\\OOP")0 105 y Fp(This)e(should)g(b)q(e)g(read,)f(\\F)l(or)f(ev)o(ery) +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 +Fi(Eq)o Fp(,)g Fi(==)f Fp(has)g(t)o(yp)q(e)g Fi(a->a->Bool)o +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 +(for)e Fi(==)g Fp(in)h(the)g Fi(elem)f Fp(example,)h(and)g(indeed)h(the)f +(constrain)o(t)f(imp)q(osed)0 218 y(b)o(y)i(the)g(con)o(text)g(propagates)f +(to)h(the)g(principal)j(t)o(yp)q(e)d(for)f Fi(elem)p Fp(:)71 +327 y Fi(elem)476 b(::)24 b(\(Eq)f(a\))h(=>)g(a)f(->)h([a])f(->)h(Bool)0 +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) +g Fi(a)g Fp(that)f(is)i(an)f(instance)h(of)f(the)g(class)g +Fi(Eq)p Fp(,)h Fi(elem)e Fp(has)i(t)o(yp)q(e)f Fi(a->[a]->Bool)n +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) +g(the)g(fact)g(that)f Fi(elem)g Fp(is)i(not)e(de\014ned)j(on)e +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 +(kno)o(w)f(ho)o(w)h(to)f(compare)h(its)h(elemen)o(ts)g(for)e(equalit)o(y)l(.) +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 +(ecify)h(whic)o(h)g(t)o(yp)q(es)f(are)f(instances)i(of)e(the)h(class)g +Fi(Eq)p Fp(,)g(and)g(the)g(actual)0 682 y(b)q(eha)o(vior)i(of)f +Fi(==)f Fp(on)i(eac)o(h)f(of)g(those)f(t)o(yp)q(es?)21 b(This)16 +b(is)g(done)f(with)h(an)f Fo(instanc)n(e)g(de)n(clar)n(ation)p +Fp(.)k(F)l(or)c(example:)71 791 y Fi(instance)22 b(Eq)i(Int)f(where)118 +847 y(x)h(==)g(y)381 b(=)48 b(intEq)23 b(x)h(y)0 956 y Fp(The)15 +b(de\014nition)h(of)e Fi(==)g Fp(is)i(called)g(a)e Fo(metho)n(d)p +Fp(.)20 b Fi(intEq)14 b Fp(happ)q(ens)h(to)f(b)q(e)i(the)e(primitiv)o(e)i +(function)f(that)f(compares)0 1013 y(in)o(tegers)i(for)g(equalit)o(y)l(,)h +(but)f(in)h(general)g(an)o(y)f(v)m(alid)h(expression)g(is)g(allo)o(w)o(ed)g +(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 +(function)h(de\014nition.)21 b(The)15 b(o)o(v)o(erall)f(declaration)h(is)g +(essen)o(tially)g(sa)o(ying:)k(\\The)c(t)o(yp)q(e)f Fi(Int)f +Fp(is)i(an)0 1126 y(instance)j(of)f(the)h(class)g Fi(Eq)p Fp(,)f(and)h(here)g +(is)g(the)g(de\014nition)h(of)e(the)h(metho)q(d)g(corresp)q(onding)g(to)f +(the)h(op)q(eration)0 1182 y Fi(==)p Fp(.")31 b(Giv)o(en)19 +b(this)h(declaration,)g(w)o(e)f(can)g(no)o(w)f(compare)h(\014xed)h(precision) +h(in)o(tegers)e(for)f(equalit)o(y)i(using)g Fi(==)o Fp(.)0 +1239 y(Similarly:)71 1347 y Fi(instance)i(Eq)i(Float)f(where)118 +1404 y(x)h(==)g(y)381 b(=)48 b(floatEq)23 b(x)h(y)0 1513 y +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 +(ers)f(using)h Fi(==)p Fp(.)71 1589 y(Recursiv)o(e)g(t)o(yp)q(es)f(suc)o(h)h +(as)f Fi(Tree)f Fp(de\014ned)j(earlier)f(can)f(also)g(b)q(e)h(handled:)71 +1698 y Fi(instance)22 b(\(Eq)i(a\))f(=>)h(Eq)g(\(Tree)f(a\))g(where)118 +1755 y(Leaf)h(a)214 b(==)24 b(Leaf)f(b)239 b(=)47 b(a)24 b(==)g(b)118 +1811 y(\(Branch)f(l1)h(r1\))f(==)h(\(Branch)f(l2)g(r2\))48 +b(=)f(\(l1==l2\))23 b(&&)h(\(r1==r2\))118 1868 y(_)334 b(==)24 +b(_)358 b(=)47 b(False)0 1979 y Fp(Note)16 b(the)g(con)o(text)40 +b Fi(Eq)23 b(a)40 b Fp(in)17 b(the)g(\014rst)e(line|this)k(is)e(necessary)g +(b)q(ecause)g(the)f(elemen)o(ts)h(in)g(the)f(lea)o(v)o(es)h(\(of)0 +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 +(line)h(2.)i(The)c(additional)i(constrain)o(t)d(is)i(essen)o(tially)g(sa)o +(ying)f(that)f(w)o(e)0 2092 y(can)k(compare)f(trees)g(of)g +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) +g(to)g(compare)g Fi(a)p Fp('s)g(for)g(equalit)o(y)l(.)28 b(If)18 +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 +(error)e(w)o(ould)i(result.)71 2225 y(The)h(Hask)o(ell)h(Rep)q(ort,)f(esp)q +(ecially)j(the)d(Standard)g(Prelude,)i(con)o(tains)e(a)g(w)o(ealth)g(of)f +(useful)j(examples)e(of)0 2281 y(t)o(yp)q(e)e(classes.)21 b(Indeed,)16 +b(a)f(class)g Fi(Eq)g Fp(is)h(de\014ned)h(that)d(is)i(sligh)o(tly)g(larger)f +(than)g(the)h(one)f(de\014ned)h(earlier:)71 2392 y Fi(class)47 +b(Eq)23 b(a)48 b(where)118 2448 y(\(==\),)23 b(\(/=\))286 b(::)24 +b(a)g(->)f(a)h(->)g(Bool)118 2504 y(x)g(/=)g(y)381 b(=)48 b(not)23 +b(\(x)h(==)g(y\))0 2614 y Fp(This)15 b(is)g(an)g(example)g(of)g(a)f(class)h +(with)g Fo(two)g Fp(op)q(erations,)g(one)f(for)g(equalit)o(y)l(,)i(the)e +(other)h(for)f(inequalit)o(y)l(.)21 b(It)15 b(also)p eop +%%Page: 25 25 +bop 1857 -40 a Fp(T-25)0 105 y(demonstrates)14 b(the)h(use)g(of)f(a)h +Fo(default)h(metho)n(d)p Fp(,)f(in)h(this)f(case)g(for)f(the)h(inequalit)o(y) +i(op)q(eration)e Fi(/=)o Fp(.)20 b(If)15 b(a)g(metho)q(d)0 +162 y(for)k(a)f(particular)i(op)q(eration)g(is)f(omitted)h(in)g(an)f +(instance)h(declaration,)h(then)e(the)g(default)h(one)g(de\014ned)g(in)0 +218 y(the)e(class)g(declaration,)h(if)g(it)f(exists,)g(is)h(used)f(instead.) +29 b(F)l(or)17 b(example,)i(the)f(three)g(instances)h(of)e +Fi(Eq)h Fp(de\014ned)0 274 y(earlier)d(will)g(w)o(ork)e(p)q(erfectly)i(w)o +(ell)g(with)g(the)f(ab)q(o)o(v)o(e)f(class)h(declaration,)h(yielding)h(just)e +(the)g(righ)o(t)g(de\014nition)h(of)0 331 y(inequalit)o(y)i(that)d(w)o(e)h(w) +o(an)o(t:)k(the)c(logical)i(negation)e(of)g(equalit)o(y)l(.)71 +408 y(Hask)o(ell)j(also)f(supp)q(orts)g(a)g(notion)g(of)g Fo(class)g +(inclusion)p Fp(.)24 b(F)l(or)17 b(example,)h(w)o(e)f(ma)o(y)f(wish)i(to)e +(de\014ne)j(a)e(class)0 464 y Fi(Ord)f Fp(whic)o(h)g Fo(inherits)g +Fp(all)h(of)e(the)h(op)q(erations)g(in)h(Eq,)f(but)g(in)h(addition)g(has)f(a) +f(set)h(of)g(comparison)g(op)q(erations)0 520 y(and)f(minim)o(um)i(and)e +(maxim)o(um)g(functions:)71 621 y Fi(class)47 b(\(Eq)23 b(a\))h(=>)f(Ord)h(a) +47 b(where)118 677 y(\(<\),)24 b(\(<=\),)f(\(>=\),)g(\(>\))47 +b(::)24 b(a)g(->)f(a)h(->)g(Bool)118 733 y(max,)g(min)333 b(::)24 +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 +Fi(class)g Fp(declaration.)23 b(W)l(e)16 b(sa)o(y)f(that)h +Fi(Eq)f Fp(is)i(a)f Fo(sup)n(er)n(class)e Fp(of)i Fi(Ord)f +Fp(\(con)o(v)o(ersely)l(,)h Fi(Ord)0 902 y Fp(is)h(a)f Fo(sub)n(class)f +Fp(of)g Fi(Eq)p Fp(\),)h(and)h(an)o(y)f(instance)h(of)f Fi(Ord)f +Fp(m)o(ust)h(also)g(b)q(e)h(an)g(instance)g(of)f Fi(Eq)o Fp(.)24 +b(\(In)16 b(the)h(next)f(Section)0 958 y(w)o(e)f(giv)o(e)g(a)g(fuller)i +(de\014nition)g(or)d Fi(Ord)h Fp(tak)o(en)g(from)f(the)i(Standard)f +(Prelude.\))71 1035 y(One)24 b(b)q(ene\014t)h(of)e(suc)o(h)h(class)g +(inclusions)i(is)e(shorter)f(con)o(texts:)36 b(A)24 b(t)o(yp)q(e)f +(expression)i(for)e(a)g(function)0 1091 y(that)17 b(uses)g(op)q(erations)h +(from)e(b)q(oth)h(the)h Fi(Eq)f Fp(and)g Fi(Ord)g Fp(classes)h(can)f(use)h +(the)f(con)o(text)g Fi(\(Ord)23 b(a\))p Fp(,)17 b(rather)g(than)0 +1147 y Fi(\(Eq)23 b(a,)h(Ord)f(a\))p Fp(,)18 b(since)i Fi(Ord)d +Fp(\\implies")j Fi(Eq)o Fp(.)28 b(More)18 b(imp)q(ortan)o(tly)l(,)g(metho)q +(ds)g(for)g(sub)q(class)h(op)q(erations)f(can)0 1204 y(assume)13 +b(the)h(existence)g(of)f(metho)q(ds)g(for)g(sup)q(erclass)h(op)q(erations.)20 +b(F)l(or)12 b(example,)i(the)g Fi(Ord)f Fp(declaration)h(in)g(the)0 +1260 y(Standard)h(Prelude)i(con)o(tains)e(this)g(default)h(metho)q(d)g(for)e +Fi(\(<\))p Fp(:)166 1364 y Fi(x)24 b(<)f(y)358 b(=)48 b(x)24 +b(<=)f(y)h(&&)g(x)f(/=)h(y)71 1518 y Fp(As)15 b(an)g(example)h(of)f(the)g +(use)g(of)g Fi(Ord)p Fp(,)g(the)g(principal)i(t)o(yping)f(of)f +Fi(quicksort)f Fp(de\014ned)i(in)g(Section)g(2.5.1)e(is:)71 +1629 y Fi(quicksort)356 b(::)48 b(\(Ord)23 b(a\))h(=>)f([a])h(->)f([a])0 +1738 y Fp(In)g(other)g(w)o(ords,)g Fi(quicksort)e Fp(only)j(op)q(erates)e(on) +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 +b(This)24 b(t)o(yping)f(for)0 1794 y Fi(quicksort)14 b Fp(arises)h(b)q +(ecause)h(of)f(the)h(use)f(of)g(the)g(comparison)g(op)q(erators)g +Fi(<)g Fp(and)g Fi(>=)g Fp(in)h(its)f(de\014nition.)71 1871 +y(Hask)o(ell)21 b(also)g(p)q(ermits)g Fo(multiple)h(inheritanc)n(e)p +Fp(,)f(since)h(classes)f(ma)o(y)f(ha)o(v)o(e)g(more)h(than)f(one)h(sup)q +(erclass.)0 1927 y(Name)16 b(con\015icts)g(are)g(a)o(v)o(oided)g(b)o(y)f(ha)o +(ving)h(the)g(constrain)o(t)f(that)g(a)h(particular)g(op)q(eration)g(can)g(b) +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 +(giv)o(en)i(scop)q(e.)71 2060 y(Con)o(texts)e(are)h(also)g(allo)o(w)o(ed)g +(in)h Fi(data)f Fp(declarations;)h(see)f Fn(x)p Fp(4.2.1.)0 +2198 y Fc(A)k(Di\013eren)o(t)f(P)o(ersp)q(ectiv)o(e.)44 b Fp(Before)17 +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 +(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 +(other)i(viewp)q(oin)o(ts)h(of)f(Hask)o(ell's)g(t)o(yp)q(e)g(classes.)20 +b(The)13 b(\014rst)g(is)g(b)o(y)g(analogy)g(to)f(ob)s(ject-)0 +2311 y(orien)o(ted)j(programming)f(\(OOP\).)h(In)g(the)g(follo)o(wing)g +(general)h(statemen)o(t)d(ab)q(out)i(OOP)l(,)g(simply)h(substituting)0 +2368 y Fo(typ)n(e)g(class)e Fp(for)h(class,)g(and)g Fo(typ)n(e)h +Fp(for)e(ob)s(ject,)g(yields)j(a)e(v)m(alid)i(summary)e(of)f(Hask)o(ell's)i +(t)o(yp)q(e)f(class)h(mec)o(hanism:)71 2444 y(\\)p Fo(Classes)c +Fp(capture)j(common)g(sets)f(of)h Fo(op)n(er)n(ations)p Fp(.)k(A)c +(particular)g Fo(obje)n(ct)g Fp(ma)o(y)f(b)q(e)i(an)f Fo(instanc)n(e)e +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 +Fp(corresp)q(onding)h(to)e(eac)o(h)h(op)q(eration.)25 b(Classes)17 +b(ma)o(y)f(b)q(e)h(arranged)g(hierarc)o(hically)l(,)0 2557 +y(forming)e(notions)g(of)g Fo(sup)n(er)n(classes)e Fp(and)j +Fo(sub)n(classes)p Fp(,)d(and)i(p)q(ermitting)h Fo(inheritanc)n(e)e +Fp(of)h(op)q(erations/metho)q(ds.)0 2614 y(A)g Fo(default)i(metho)n(d)f +Fp(ma)o(y)e(also)h(b)q(e)h(asso)q(ciated)g(with)f(an)g(op)q(eration.")p +eop +%%Page: 26 26 +bop 0 -40 a Fp(T-26)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g +(AND)f(\\OOP")71 105 y Fp(In)h Fo(c)n(ontr)n(ast)e Fp(to)h(OOP)l(,)h(it)g +(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) +i(in)g(particular)g(there)g(is)g(no)0 162 y(notion)f(of)g(an)f(ob)s(ject's)g +(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 +(tage)g(o)o(v)o(er)f(OOP)h(is)h(that)e(metho)q(ds)h(in)0 218 +y(Hask)o(ell)i(are)f(completely)i(t)o(yp)q(e-safe:)k(an)o(y)17 +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 +(e)f(is)h(not)f(in)0 274 y(the)f(required)h(class)f(will)h(b)q(e)f(detected)h +(at)e(compile)i(time)f(instead)g(of)f(at)g(run)o(time.)21 b(In)15 +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 +(at)g(run)o(time)h(but)f(are)g(simply)h(passed)g(as)f(higher-order)g +(functions.)71 428 y(A)d(di\013eren)o(t)g(p)q(ersp)q(ectiv)o(e)h(can)f(b)q(e) +h(gotten)e(b)o(y)h(considering)h(the)f(relationship)i(b)q(et)o(w)o(een)e +(parametric)g(and)g(ad)0 485 y(ho)q(c)k(p)q(olymorphism.)21 +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 +(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 +(univ)o(ersally)j(quan)o(tifying)e(o)o(v)o(er)f Fo(al)r(l)h +Fp(t)o(yp)q(es.)18 b(Sometimes,)13 b(ho)o(w)o(ev)o(er,)e(that)g(univ)o(ersal) +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 +(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) +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 +(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 +(as)g(pro)o(viding)h(a)e(structured)h(w)o(a)o(y)f(to)g(do)h(just)0 +710 y(this.)j(Indeed,)c(w)o(e)f(can)g(think)g(of)f(parametric)h(p)q +(olymorphism)h(as)e(a)h(kind)h(of)e(o)o(v)o(erloading)h(to)q(o!)k(It's)14 +b(just)h(that)0 767 y(the)k(o)o(v)o(erloading)g(o)q(ccurs)g(implicitly)j(o)o +(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 +(yp)q(es)h(\(i.e.)f(a)h(t)o(yp)q(e)0 823 y(class\).)71 920 +y(In)g(the)g(remainder)h(of)e(this)h(section)h(w)o(e)f(in)o(tro)q(duce)g(the) +g(sev)o(eral)g(prede\014ned)i Fo(standar)n(d)e Fp(t)o(yp)q(e)g(classes)g(in)0 +977 y(Hask)o(ell.)0 1176 y Fg(5.1)56 b(Equalit)n(y)17 b(and)i(Ordered)f +(Classes)0 1310 y Fp(Hask)o(ell's)c(standard)e(classes)i(form)e(the)h +(somewhat)f(frigh)o(tening)i(inclusion)i(structure)d(sho)o(wn)f(in)i(Figure)g +(2.)k(A)o(t)0 1367 y(the)e(top)f(of)g(the)g(\014gure,)h(w)o(e)f(see)h +Fi(Eq)f Fp(with)h(its)g(sub)q(class)g Fi(Ord)f Fp(b)q(elo)o(w)h(it.)21 +b(These)16 b(w)o(ere)f(de\014ned)i(in)g(the)e(previous)0 1423 +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 +(o)f(sub)q(classes)j(of)d Fi(Ord)p Fp(,)h Fi(Enum)f Fp(and)i +Fi(Ix)o Fp(.)0 1623 y Fg(5.2)56 b(En)n(umeration)17 b(and)i(Index)f(Classes)0 +1757 y Fi(Enum)13 b Fp(has)g(a)h(set)f(of)g(op)q(erations)h(that)f(underlie)i +(the)f(syn)o(tactic)f(sugar)g(of)h(arithmetic)g(sequences;)h(for)d(example,)0 +1813 y(the)j(arithmetic)g(sequence)h(expression)f Fi([1,3..])f +Fp(stands)h(for)f Fi(enumFromThen)22 b(1)i(3)14 b Fp(\(see)h +Fn(x)p Fp(3.9)f(for)g(the)g(formal)0 1870 y(translation\).)29 +b(Arithmetic)20 b(sequences)f(are)g(ordered,)g(so)f(naturally)l(,)h +Fi(Enum)f Fp(is)h(a)f(sub)q(class)i(of)e Fi(Ord)p Fp(.)29 b(W)l(e)19 +b(can)0 1926 y(no)o(w)d(see)h(that)f(arithmetic)i(sequence)f(expressions)h +(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 +(that)f(is)h(an)0 1983 y(instance)f(of)g Fi(Enum)o Fp(.)21 +b(This)16 b(includes)i(not)e(only)g(most)f(n)o(umeric)h(t)o(yp)q(es,)f(but)h +(also)g Fi(Char)o Fp(,)g(so)f(that,)g(for)g(instance,)0 2039 +y Fi(['a'..'z'])g Fp(denotes)h(the)g(list)h(of)f(lo)o(w)o(er-case)f(letters)i +(in)g(alphab)q(etical)h(order.)k(F)l(urthermore,)15 b(user-de\014ned)0 +2096 y(en)o(umerated)g(t)o(yp)q(es)h(lik)o(e)g Fi(Color)e Fp(can)i(easily)g +(b)q(e)g(giv)o(en)f Fi(Enum)g Fp(instance)h(declarations.)21 +b(If)15 b(so:)318 2221 y Fi([Red..Violet])72 b Fn(\))h Fi([Red,)24 +b(Green,)f(Blue,)g(Indigo,)g(Violet])0 2347 y Fp(Note)13 b(that)g(suc)o(h)h +(a)g(sequence)h(is)f Fo(arithmetic)g Fp(in)h(the)f(sense)g(that)f(the)h +(incremen)o(t)g(b)q(et)o(w)o(een)g(v)m(alues)h(is)f(constan)o(t,)0 +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 +2501 y(The)j(other)h(immediate)g(standard)f(sub)q(class)i(of)e +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 +(es)h(that)f(can)g(b)q(e)0 2557 y(used)d(as)g(arra)o(y)e(indices.)22 +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) +q(class)i(of)e Fi(Ord)p Fp(,)g(since)i(w)o(e)e(exp)q(ect)i(the)0 +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 +(order.)i(W)l(e)d(deal)g(with)f(class)h Fi(Ix)e Fp(in)j(Section)f(6.9.)p +eop +%%Page: 27 27 +bop 0 -40 a Fj(5.3)45 b(T)l(ext)15 b(and)g(Binary)h(Classes)1267 +b Fp(T-27)793 675 y Fa(#)751 708 y(#)741 717 y(#)943 525 y(#)901 +558 y(#)891 567 y(#)1074 375 y(#)1033 409 y(#)1022 417 y(#)1093 +675 y(#)1051 708 y(#)1041 717 y(#)1187 825 y(#)1145 858 y(#)1134 +867 y(#)816 534 y(S)841 567 y(S)816 234 y(S)847 275 y(S)878 +317 y(S)909 358 y(S)940 400 y(S)953 417 y(S)1022 833 y(S)1047 +867 y(S)1041 534 y(S)1066 567 y(S)1153 684 y(S)1178 717 y(S)909 +684 y(S)934 717 y(S)546 609 y(S)577 650 y(S)608 692 y(S)627 +717 y(S)631 384 y(\023)600 425 y(\023)569 467 y(\023)549 492 +y(\023)728 234 y(\023)703 267 y(\023)703 384 y(S)728 417 y(S)1022 +923 y Fi(RealFloat)591 773 y(Integral)389 b(Floating)-473 b(RealFrac)1022 +623 y(Fractional)516 548 y(Ix)816 623 y(Real)966 473 y(Num)-279 +b(Enum)628 323 y(Ord)759 173 y(Eq)1097 323 y(Text)185 b(Binary)468 +1071 y Fp(Figure)16 b(2:)j(Hask)o(ell's)d(Standard)f(T)o(yp)q(e)g(Class)h +(Hierarc)o(h)o(y)0 1254 y Fg(5.3)56 b(T)-5 b(ext)18 b(and)h(Binary)f(Classes) +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 +(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 +(v)o(erted)g(to)f(c)o(haracter)g(strings)h(\(t)o(ypically)0 +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 +(op)q(erations)g(for)f(parsing)h(c)o(haracter)f(strings)g(to)g(obtain)h(the)0 +1735 y(v)m(alues)j(they)f(ma)o(y)f(represen)o(t)h(and)g(for)f(pro)q(ducing)j +(the)e(canonical)h(textual)f(represen)o(tation)g(of)f(a)h(prin)o(table)0 +1791 y(v)m(alue.)i(As)14 b(these)g(primitiv)o(e)i(op)q(erations)e(are)g +(somewhat)g(esoteric,)g(let's)g(b)q(egin)i(with)e(one)h(of)e(the)i +(higher-lev)o(el)0 1848 y(functions)h(that)e(is)i(de\014ned)h(in)f(terms)e +(of)h(them:)71 1948 y Fi(show)476 b(::)24 b(\(Text)f(a\))h(=>)f(a)h(->)g +(String)0 2057 y Fp(Naturally)16 b(enough,)f Fi(show)f Fp(tak)o(es)h(an)o(y)f +(v)m(alue)j(of)d(an)h(appropriate)h(t)o(yp)q(e)f(and)g(returns)g(its)g +(represen)o(tation)h(as)e(a)0 2113 y(c)o(haracter)i(string)g(\(list)h(of)f(c) +o(haracters\),)f(as)h(in)h Fi(show)23 b(\(2+2\))o Fp(,)16 b(whic)o(h)i +(results)e(in)h Fi("4")p Fp(.)23 b(This)17 b(is)g(\014ne)g(as)f(far)f(as)0 +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 +(more)f(complex)h(strings)f(that)g(ma)o(y)g(ha)o(v)o(e)g(the)g(represen)o +(tations)0 2226 y(of)g(man)o(y)g(v)m(alues)h(in)g(them,)f(as)f(in)71 +2335 y Fi("The)23 b(sum)g(of)h(")g(++)f(show)h(x)f(++)h(")g(and)f(")h(++)f +(show)h(y)f(++)h(")g(is)f(")h(++)g(show)f(\(x+y\))g(++)h(".")0 +2444 y Fp(and)18 b(after)f(a)g(while,)j(all)f(that)e(concatenation)h(gets)f +(to)g(b)q(e)h(a)g(bit)g(ine\016cien)o(t.)29 b(Sp)q(eci\014call)q(y)l(,)21 +b(let's)d(consider)g(a)0 2501 y(function)h(to)f(represen)o(t)g(the)g(binary)h +(trees)f(of)g(Section)h(2.3)e(as)h(a)f(string,)i(with)f(suitable)i(markings)e +(to)g(sho)o(w)0 2557 y(the)d(nesting)h(of)e(subtrees)i(and)f(the)g +(separation)g(of)f(left)i(and)f(righ)o(t)g(branc)o(hes)g(\(pro)o(vided)h(the) +f(elemen)o(t)g(t)o(yp)q(e)g(is)0 2614 y(represen)o(table)h(as)f(a)g +(string\):)p eop +%%Page: 28 28 +bop 0 -40 a Fp(T-28)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g +(AND)f(\\OOP")71 160 y Fi(showTree)380 b(::)24 b(\(Text)f(a\))h(=>)f(Tree)h +(a)f(->)h(String)71 216 y(showTree)e(\(Leaf)i(x\))166 b(=)48 +b(show)23 b(x)71 272 y(showTree)f(\(Branch)h(l)h(r\))71 b(=)48 +b("<")23 b(++)h(showTree)f(l)g(++)h("|")f(++)h(showTree)f(r)h(++)f(">")0 +382 y Fp(Because)16 b Fi(\(++\))f Fp(has)g(time)h(complexit)o(y)g(linear)h +(in)f(the)f(length)h(of)f(its)h(left)f(argumen)o(t,)g Fi(showTree)f +Fp(is)i(quadratic)0 438 y(in)g(the)f(size)h(of)f(the)g(tree.)71 +531 y(T)l(o)f(restore)h(linear)h(complexit)o(y)l(,)g(the)g(function)g +Fi(shows)e Fp(is)i(pro)o(vided:)71 640 y Fi(shows)452 b(::)24 +b(\(Text)f(a\))h(=>)f(a)h(->)g(String)f(->)g(String)0 749 y(shows)15 +b Fp(tak)o(es)g(a)h(prin)o(table)h(v)m(alue)g(and)f(a)f(string)h(and)g +(returns)g(that)f(string)h(with)g(the)g(v)m(alue's)h(represen)o(tation)0 +805 y(concatenated)f(at)g(the)g(fron)o(t.)22 b(The)16 b(second)h(argumen)o(t) +e(serv)o(es)h(as)g(a)g(sort)f(of)h(string)g Fo(ac)n(cumulator,)h +Fp(and)g Fi(show)0 862 y Fp(can)e(no)o(w)g(b)q(e)h(de\014ned)g(as)f +Fi(shows)g Fp(with)g(the)h(n)o(ull)g(accum)o(ulator:)71 962 +y Fi(show)23 b(x)429 b(=)48 b(shows)23 b(x)h("")0 1071 y Fp(W)l(e)16 +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 +(ersion)f(of)f Fi(showTree)o Fp(,)h(whic)o(h)g(also)g(has)f(a)h(string)g +(accum)o(u-)0 1128 y(lator)f(argumen)o(t:)71 1237 y Fi(showsTree)356 +b(::)24 b(\(Text)f(a\))h(=>)f(Tree)h(a)f(->)h(String)f(->)h(String)71 +1293 y(showsTree)e(\(Leaf)h(x\))h(s)95 b(=)48 b(shows)23 b(x)h(s)71 +1349 y(showsTree)e(\(Branch)h(l)h(r\))f(s=)48 b('<')23 b(:)h(showsTree)f(l)g +(\('|')h(:)f(showsTree)g(r)h(\('>')f(:)h(s\)\))0 1461 y Fp(This)16 +b(solv)o(es)f(our)g(e\016ciency)i(problem)f(\()p Fi(showsTree)e +Fp(has)h(linear)h(complexit)o(y\),)g(but)f(the)g(presen)o(tation)h(of)f(this) +0 1518 y(function)h(\(and)f(others)g(lik)o(e)h(it\))f(can)h(b)q(e)g(impro)o +(v)o(ed.)k(First,)14 b(let's)h(create)g(a)g(t)o(yp)q(e)g(synon)o(ym:)71 +1629 y Fi(type)23 b(ShowS)333 b(=)48 b(String)23 b(->)h(String)0 +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 +(a)h(string)g(represen)o(tation)g(of)g(something)g(follo)o(w)o(ed)g(b)o(y)g +(an)0 1795 y(accum)o(ulator)15 b(string.)21 b(Second,)c(w)o(e)e(can)h(a)o(v)o +(oid)f(carrying)h(accum)o(ulators)f(around,)g(and)h(also)g(a)o(v)o(oid)f +(amassing)0 1851 y(paren)o(theses)g(at)g(the)g(righ)o(t)g(end)h(of)f(long)g +(constructions,)g(b)o(y)g(using)h(functional)h(comp)q(osition:)71 +1960 y Fi(showsTree)356 b(::)24 b(\(Text)f(a\))h(=>)f(Tree)h(a)f(->)h(ShowS) +71 2016 y(showsTree)e(\(Leaf)h(x\))143 b(=)48 b(shows)23 b(x)71 +2073 y(showsTree)f(\(Branch)h(l)h(r\))47 b(=)h(\('<':\))23 +b(.)h(showsTree)e(l)i(.)g(\('|':\))f(.)h(showsTree)e(r)i(.)g(\('>':\))0 +2182 y Fp(Something)16 b(more)g(imp)q(ortan)o(t)g(than)f(just)h(tidying)h(up) +f(the)g(co)q(de)h(has)f(come)g(ab)q(out)f(b)o(y)h(this)h(transformation:)0 +2238 y(W)l(e)f(ha)o(v)o(e)f(raised)h(the)g(presen)o(tation)g(from)e(an)i +Fo(obje)n(ct)g(level)f Fp(\(in)h(this)g(case,)g(strings\))f(to)g(a)g +Fo(function)h(level.)21 b Fp(W)l(e)0 2295 y(can)16 b(think)h(of)e(the)h(t)o +(yping)h(as)e(sa)o(ying)h(that)f Fi(showsTree)g Fp(maps)h(a)f(tree)h(in)o(to) +g(a)g Fo(showing)g(function)p Fp(.)22 b(F)l(unctions)0 2351 +y(lik)o(e)16 b Fi(\('<')23 b(:\))14 b Fp(or)g Fi(\("a)23 b(string")g(++\))14 +b Fp(are)g(primitiv)o(e)i(sho)o(wing)e(functions,)h(and)g(w)o(e)f(build)i(up) +f(more)f(complex)0 2408 y(functions)i(b)o(y)f(comp)q(osition.)71 +2501 y(No)o(w)i(that)g(w)o(e)h(can)g(turn)g(trees)g(in)o(to)g(strings,)g +(let's)g(turn)g(to)g(the)g(in)o(v)o(erse)g(problem.)30 b(The)18 +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 +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 +(and)h(returns)f(a)h(list)g(of)g Fi(\(a,)k(String\))0 2614 +y Fp(pairs[7].)c(The)d(Standard)f(Prelude)h(pro)o(vides)g(a)f(t)o(yp)q(e)g +(synon)o(ym)g(for)f(suc)o(h)i(functions:)p eop +%%Page: 29 29 +bop 0 -40 a Fj(5.3)45 b(T)l(ext)15 b(and)g(Binary)h(Classes)1267 +b Fp(T-29)71 160 y Fi(type)23 b(ReadS)g(a)286 b(=)48 b(String)23 +b(->)h([\(a,String\)])0 269 y Fp(Normally)l(,)13 b(a)f(parser)f(returns)h(a)g +(singleton)h(list,)g(con)o(taining)f(a)g(v)m(alue)h(of)f(t)o(yp)q(e)g +Fi(a)f Fp(that)h(w)o(as)f(read)h(from)f(the)h(input)0 325 y(string)g(and)g +(the)g(remaining)i(string)e(that)f(follo)o(ws)h(what)g(w)o(as)f(parsed.)19 +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 +382 y(result)k(is)h(the)f(empt)o(y)f(list,)i(and)f(if)g(there)g(is)g(more)g +(than)g(one)g(p)q(ossible)h(parse)f(\(an)f(am)o(biguit)o(y\),)h(the)g +(resulting)0 438 y(list)e(con)o(tains)g(more)f(than)g(one)h(pair.)20 +b(The)14 b(standard)f(function)h Fi(reads)f Fp(is)h(a)f(parser)g(for)g(an)o +(y)g(instance)i(of)e Fi(Text)o Fp(:)71 547 y Fi(reads)452 b(::)24 +b(\(Text)f(a\))h(=>)f(ReadS)g(a)0 656 y Fp(W)l(e)16 b(can)h(use)g(this)f +(function)i(to)d(de\014ne)j(a)e(parsing)g(function)i(for)d(the)i(string)f +(represen)o(tation)g(of)g(binary)h(trees)0 713 y(pro)q(duced)k(b)o(y)f +Fi(showsTree)n Fp(.)34 b(List)21 b(comprehensions)g(giv)o(e)f(us)g(a)f(con)o +(v)o(enien)o(t)h(idiom)h(for)f(constructing)g(suc)o(h)0 769 +y(parsers:)71 878 y Fi(readsTree)356 b(::)24 b(\(Text)f(a\))h(=>)f(ReadS)g +(\(Tree)h(a\))71 934 y(readsTree)e(\('<':s\))166 b(=)48 b([\(Branch)23 +b(l)g(r,)h(u\))g(|)f(\(l,)h('|':t\))f(<-)g(readsTree)g(s,)1168 +991 y(\(r,)h('>':u\))f(<-)g(readsTree)g(t)h(])71 1047 y(readsTree)e(s)310 +b(=)48 b([\(Leaf)23 b(x,)h(t\))119 b(|)23 b(\(x,t\))143 b(<-)23 +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 +(this)h(function)f(de\014nition)i(in)f(detail.)31 b(There)20 +b(are)e(t)o(w)o(o)g(main)h(cases)g(to)0 1213 y(consider:)i(If)15 +b(the)g(\014rst)g(c)o(haracter)f(of)h(the)g(string)g(to)f(b)q(e)i(parsed)f +(is)g Fi('<')p Fp(,)g(w)o(e)f(should)i(ha)o(v)o(e)f(the)g(represen)o(tation)0 +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 +b(In)14 b(the)f(\014rst)g(case,)g(calling)i(the)e(rest)g(of)g(the)g(input)h +(string)f(follo)o(wing)0 1326 y(the)j(op)q(ening)h(angle)f(brac)o(k)o(et)f +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 +Fi(Branch)23 b(l)h(r)15 b Fp(with)h(remaining)h(string)0 1382 +y Fi(u)p Fp(,)e(sub)s(ject)g(to)f(the)i(follo)o(wing)f(conditions:)56 +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 +(b)q(eginning)j(of)c(the)i(string)f Fi(s)p Fp(.)56 1611 y(2.)22 +b(The)14 b(string)f(remaining)i(\(follo)o(wing)f(the)g(represen)o(tation)g +(of)f Fi(l)p Fp(\))g(b)q(egins)i(with)g Fi('|')o Fp(.)k(Call)c(the)f(tail)g +(of)g(this)114 1668 y(string)h Fi(t)p Fp(.)56 1769 y(3.)22 +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) +j(of)c Fi(t)p Fp(.)56 1870 y(4.)22 b(The)15 b(string)g(remaining)h(from)f +Fo(that)h Fp(parse)f(b)q(egins)h(with)g Fi('>')o Fp(,)f(and)h +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) +o(er)f(w)o(e)g(get)g(from)g(the)g(com)o(bination)h(of)f(pattern)g(matc)o +(hing)g(with)h(list)g(comprehen-)0 2054 y(sion:)22 b(The)16 +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 +(expression)h(of)e(the)h(list)h(comprehension,)g(the)0 2110 +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 +(y)f(the)g(\014rst)f(generator)h(\(\\)p Fi(\(l,)22 b('|':t\))14 +b Fp(is)g(dra)o(wn)g(from)f(the)h(list)0 2167 y(of)h(parses)g(of)g +Fi(s)o Fp(."\),)f(and)i(the)f(remaining)h(conditions)h(are)d(expressed)i(b)o +(y)f(the)h(second)f(generator.)71 2252 y(The)e(second)g(de\014ning)h +(equation)f(ab)q(o)o(v)o(e)f(just)h(sa)o(ys)f(that)g(to)g(parse)g(the)h +(represen)o(tation)g(of)f(a)g(leaf,)i(w)o(e)e(parse)0 2308 +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 +(tree)g(and)h(apply)f(the)h(constructor)e Fi(Leaf)g Fp(to)h(the)g(v)m(alue)h +(th)o(us)0 2365 y(obtained.)71 2450 y(W)l(e'll)f(accept)h(on)e(faith)h(for)g +(the)g(momen)o(t)f(that)g(there)h(is)h(a)e Fi(Text)g Fp(instance)i(of)f +Fi(Int)f Fp(\(among)g(man)o(y)g(other)0 2506 y(t)o(yp)q(es\),)g(pro)o(viding) +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 +(ect,)f(e.g.:)115 2614 y Fi(\(reads)23 b("5)h(golden)f(rings"\))g(::)h +([\(Int,String\)])71 b Fn(\))j Fi([\(5,)23 b(")h(golden)f(rings"\)])p +eop +%%Page: 30 30 +bop 0 -40 a Fp(T-30)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g +(AND)f(\\OOP")0 105 y Fp(With)g(this)h(understanding,)g(the)f(reader)g +(should)i(v)o(erify)e(the)g(follo)o(wing)h(ev)m(aluations:)21 +194 y Fi(readsTree)22 b("<1|<2|3>>")101 b Fn(\))i Fi([\(Branch)22 +b(\(Leaf)i(1\))f(\(Branch)g(\(Leaf)g(2\))h(\(Leaf)f(3\)\),)g(""\)])21 +251 y(readsTree)f("<1|2")221 b Fn(\))103 b Fi([])71 362 y Fp(Because)19 +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 +(trees)h(is)g(unam)o(biguous,)h Fi(readsTree)d Fp(will)0 418 +y(alw)o(a)o(ys)11 b(return)g(either)h(a)f(singleton)i(list)f(or)f(an)g(empt)o +(y)g(list,)i(pro)o(vided)f(that)f(the)g(represen)o(tation)h(of)f(the)g +(elemen)o(t)0 474 y(t)o(yp)q(e)k(is)g(also)f(unam)o(biguous.)21 +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 +(hange)h(our)f(textual)h(represen)o(tation)f(of)0 531 y(trees)h(to)g(omit)g +(the)g(angle)h(brac)o(k)o(ets:)71 640 y Fi(readsTree)22 b(s)310 +b(=)48 b([\(Branch)23 b(l)g(r,)h(u\))g(|)f(\(l,)h('|':t\))f(<-)g(readsTree)g +(s,)1168 696 y(\(r,)h(u\))119 b(<-)23 b(readsTree)g(t)h(])715 +753 y(++)715 809 y([\(Leaf)f(x,)h(t\))119 b(|)23 b(\(x,t\))143 +b(<-)23 b(reads)h(s])0 921 y Fp(\(The)16 b Fi(\(++\))g Fp(here)h(can)g(b)q(e) +g(though)o(t)e(of)h(as)g(a)h(list)g(analogue)f(of)g(set)h(union;)g(that)f +(is,)h(the)g(tree)f(parses)g(of)g Fi(s)g Fp(are)0 977 y(all)g(its)g(parses)f +(as)f(a)h(branc)o(h)h(plus)g(all)g(its)f(parses)g(as)g(a)g(leaf.\))20 +b(No)o(w,)14 b(w)o(e)h(see)h(that:)51 1069 y Fi(readsTree)22 +b("1|2|3")102 b Fn(\))g Fi([\(Branch)23 b(\(Branch)g(\(Leaf)g(1\))h(\(Leaf)f +(2\)\))g(\(Leaf)g(3\),)h(""\),)730 1125 y(\(Branch)f(\(Leaf)g(1\))h(\(Branch) +f(\(Leaf)g(2\))g(\(Leaf)g(3\)\),)h(""\)])71 1236 y Fp(Returning)15 +b(to)f(our)g(unam)o(biguous)h(represen)o(tation,)f(there)h(are)f(a)g(couple)h +(of)f(shortcomings)g(to)g(deal)h(with.)0 1293 y(One)g(is)g(that)e(the)h +(parser)g(is)h(quite)g(rigid,)g(allo)o(wing)g(no)f(white)h(space)f(b)q(efore) +h(or)e(b)q(et)o(w)o(een)i(the)f(elemen)o(ts)h(of)f(the)0 1349 +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 +(e)h(parse)g(our)g(punctuation)h(sym)o(b)q(ols)g(is)g(quite)g(di\013eren)o(t) +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 +(subtrees,)g(this)g(lac)o(k)g(of)f(uniformit)o(y)h(making)g(the)g(function)g +(de\014nition)0 1462 y(harder)16 b(to)g(read.)23 b(W)l(e)17 +b(can)f(address)h(b)q(oth)f(of)g(these)h(problems)g(b)o(y)f(using)h(the)g +(lexical)h(analyzer)f(pro)o(vided)g(b)o(y)0 1519 y(the)e(Standard)g(Prelude:) +71 1619 y Fi(lex)500 b(::)24 b(ReadS)f(String)0 1728 y(lex)c +Fp(normally)i(returns)f(a)f(singleton)i(list)g(con)o(taining)g(a)e(pair)i(of) +e(strings:)30 b(the)20 b(\014rst)f(lexeme)i(in)g(the)f(input)0 +1784 y(string)d(and)g(the)g(remainder)g(of)g(the)g(input.)26 +b(The)17 b(lexical)i(rules)e(are)g(those)f(of)h(Hask)o(ell)g(programs,)f +(including)0 1841 y(commen)o(ts,)h(whic)o(h)g Fi(lex)g Fp(skips,)h(along)f +(with)g(whitespace.)26 b(If)18 b(the)f(input)h(string)f(is)g(empt)o(y)g(or)f +(con)o(tains)h(only)0 1897 y(whitespace)e(and)f(commen)o(ts,)f +Fi(lex)h Fp(returns)g Fi([\("",""\)])o Fp(;)g(if)g(the)g(input)h(is)g(not)e +(empt)o(y)h(in)h(this)f(sense,)h(but)f(also)0 1954 y(do)q(es)i(not)e(b)q +(egin)j(with)e(a)g(v)m(alid)i(lexeme)f(after)f(an)o(y)g(leading)h(whitespace) +g(and)g(commen)o(ts,)e Fi(lex)h Fp(returns)g Fi([])o Fp(.)71 +2032 y(Using)g(the)h(lexical)h(analyzer,)e(our)g(tree)g(parser)g(no)o(w)g(lo) +q(oks)g(lik)o(e)h(this:)71 2141 y Fi(readsTree)356 b(::)24 +b(\(Text)f(a\))h(=>)f(ReadS)g(\(Tree)h(a\))71 2197 y(readsTree)e(s)310 +b(=)48 b([\(Branch)23 b(l)g(r,)h(x\))g(|)f(\("<",)g(t\))h(<-)g(lex)f(s,)1168 +2254 y(\(l,)71 b(u\))24 b(<-)g(readsTree)e(t,)1168 2310 y(\("|",)h(v\))h(<-)g +(lex)f(u,)1168 2367 y(\(r,)71 b(w\))24 b(<-)g(readsTree)e(v,)1168 +2423 y(\(">",)h(x\))h(<-)g(lex)f(w)215 b(])715 2480 y(++)715 +2536 y([\(Leaf)23 b(x,)h(t\))119 b(|)23 b(\(x,)71 b(t\))24 +b(<-)g(reads)f(s)167 b(])p eop +%%Page: 31 31 +bop 0 -40 a Fj(5.4)45 b(Deriv)o(ed)15 b(Instances)1402 b Fp(T-31)71 +105 y(W)l(e)10 b(ma)o(y)g(no)o(w)h(wish)g(to)f(use)h Fi(readsTree)f +Fp(and)h Fi(showsTree)e Fp(to)h(declare)i Fi(\(Text)23 b(a\))h(=>)g(Tree)f(a) +10 b Fp(an)h(instance)0 162 y(of)18 b Fi(Text)o Fp(.)30 b(This)19 +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 +(functions)g(from)e(the)i(Prelude)g(to)f(parse)0 218 y(and)c(displa)o(y)g +(trees.)19 b(Moreo)o(v)o(er,)12 b(w)o(e)i(w)o(ould)g(automatically)f(then)h +(b)q(e)g(able)h(to)e(parse)g(and)h(displa)o(y)g(man)o(y)f(other)0 +274 y(t)o(yp)q(es)k(con)o(taining)g(trees)f(as)g(comp)q(onen)o(ts,)h(for)f +(example,)h Fi([Tree)23 b(Int])p Fp(.)h(As)16 b(it)h(turns)f(out,)g +Fi(readsTree)g Fp(and)0 331 y Fi(showsTree)c Fp(are)h(of)h(almost)f(the)g +(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 +(only)f(the)f(addition)i(of)e(an)h(extra)0 387 y(parameter)f(eac)o(h)g(that)g +(has)g(do)h(do)f(with)h(paren)o(thesization)g(of)f(forms)g(with)h(in\014x)h +(constructors.)j(W)l(e)c(refer)f(the)0 444 y(in)o(terested)j(reader)f(to)f +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 +Fi(Text)f Fp(instance)i(b)o(y)f(applying)h Fi(\(read)24 b(.)f(show\))16 +b Fp(\(whic)o(h)i(should)g(b)q(e)g(the)f(iden)o(tit)o(y\))0 +584 y(to)e(some)f(trees,)h(where)g Fi(read)g Fp(is)h(a)f(sp)q(ecialization)i +(of)e Fi(reads)p Fp(:)71 693 y Fi(read)476 b(::)24 b(\(Text)f(a\))h(=>)f +(String)g(->)h(a)0 802 y Fp(This)c(function)g(fails)h(if)f(there)f(is)h(not)f +(a)g(unique)i(parse)f(or)f(if)h(the)f(input)i(con)o(tains)e(an)o(ything)h +(more)f(than)g(a)0 858 y(represen)o(tation)c(of)g(one)g(v)m(alue)i(of)e(t)o +(yp)q(e)g Fi(a)g Fp(\(and)g(p)q(ossibly)l(,)h(commen)o(ts)f(and)g +(whitespace\).)0 1010 y Fc(5.3.2)52 b(Binary)17 b(Class)0 1123 +y Fp(The)e Fi(Binary)f Fp(class)i(is)f(similar)h(to)f Fi(Text)o +Fp(,)g(but)g(uses)g(a)g(primitiv)o(e)h(abstract)e(t)o(yp)q(e)h +Fi(Bin)g Fp(instead)g(of)g Fi(String)o Fp(,)g(the)0 1180 y(purp)q(ose)f(of)g +(whic)o(h)g(is)h(e\016cien)o(t)f(transparen)o(t)f(I/O.)h(\(See)g +Fn(x)p Fp(7.\))19 b(Generally)l(,)c(only)f(deriv)o(ed)h(instances)f(of)g +Fi(Binary)0 1236 y Fp(are)22 b(used)g(\(see)g(b)q(elo)o(w\),)h(whic)o(h)g +(generate)e(implemen)o(tation-de\014ned)k(op)q(erations)d Fi(readBin)f +Fp(and)h Fi(showBin)0 1293 y Fp(\(analogous)15 b(to)f Fi(reads)h +Fp(and)g Fi(shows)o Fp(\).)0 1446 y Fg(5.4)56 b(Deriv)n(ed)17 +b(Instances)0 1560 y Fp(Recall)12 b(the)f Fi(Eq)f Fp(instance)i(for)e(trees)g +(w)o(e)h(presen)o(ted)g(in)g(Section)h(5;)f(suc)o(h)g(a)g(declaration)g(is)g +(simple|and)i(b)q(oring|)0 1616 y(to)f(pro)q(duce:)20 b(W)l(e)12 +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 +(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 +(are)0 1673 y(equal)18 b(i\013)f(they)h(con)o(tain)f(equal)h(elemen)o(ts,)g +(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 +(righ)o(t)f(subtrees)0 1729 y(are)e(equal,)g(resp)q(ectiv)o(ely)l(.)22 +b(An)o(y)15 b(other)g(t)o(w)o(o)f(trees)h(are)g(unequal:)71 +1838 y Fi(instance)46 b(\(Eq)24 b(a\))f(=>)h(Eq)f(\(Tree)h(a\))47 +b(where)166 1895 y(\(Leaf)23 b(x\))119 b(==)24 b(\(Leaf)f(y\))191 +b(=)47 b(x)24 b(==)g(y)166 1951 y(\(Branch)f(l)h(r\))f(==)h(\(Branch)f(l')g +(r'\))48 b(=)f(l)24 b(==)g(l')f(&&)h(r)f(==)h(r')166 2008 y(_)286 +b(==)24 b(_)358 b(=)47 b(False)71 2168 y Fp(F)l(ortunately)l(,)13 +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) +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 +(e;)f(the)g Fi(Eq)f Fp(instance)i(can)f(b)q(e)g Fo(derive)n(d)h(automatic)n +(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 +(ecify:)71 2335 y Fi(data)47 b(Tree)23 b(a)286 b(=)48 b(Leaf)23 +b(a)h(|)g(Branch)f(\(Tree)g(a\))g(\(Tree)h(a\))47 b(deriving)23 +b(Eq)0 2444 y Fp(The)16 b Fi(deriving)e Fp(clause)i(implicitly)i(pro)q(duces) +e(an)g Fi(Eq)f Fp(instance)h(declaration)g(just)f(lik)o(e)h(the)g(one)f(in)h +(Section)h(5.)0 2501 y(Instances)d(of)f Fi(Ord)o Fp(,)h Fi(Enum)o +Fp(,)g Fi(Ix)o Fp(,)g Fi(Text)o Fp(,)f(and)h Fi(Binary)e Fp(can)i(also)f(b)q +(e)h(generated)g(b)o(y)f(the)h Fi(deriving)e Fp(clause.)20 +b([More)0 2557 y(than)d(one)g(class)h(name)f(can)h(b)q(e)g(sp)q(eci\014ed,)h +(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 +(thesized)h(and)0 2614 y(the)c(names,)g(separated)g(b)o(y)g(commas.])p +eop +%%Page: 32 32 +bop 0 -40 a Fp(T-32)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g +(AND)f(\\OOP")71 105 y Fp(The)g(deriv)o(ed)h Fi(Ord)f Fp(instance)h(for)f +Fi(Tree)f Fp(is)i(sligh)o(tly)g(more)f(complicated)h(than)g(the)f +Fi(Eq)g Fp(instance:)71 215 y Fi(instance)46 b(\(Ord)24 b(a\))f(=>)h(Ord)f +(\(Tree)g(a\))48 b(where)166 272 y(\(Leaf)23 b(_\))119 b(<=)24 +b(\(Branch)f(_\))143 b(=)47 b(True)166 328 y(\(Leaf)23 b(x\))119 +b(<=)24 b(\(Leaf)f(y\))191 b(=)47 b(x)24 b(<=)g(y)166 385 y(\(Branch)f(_\))71 +b(<=)24 b(\(Leaf)f(_\))191 b(=)47 b(False)166 441 y(\(Branch)23 +b(l)h(r\))f(<=)h(\(Branch)f(l')g(r'\))48 b(=)f(l)24 b(==)g(l')f(&&)h(r)f(<=)h +(r')g(||)f(l)h(<=)g(l')0 550 y Fp(This)17 b(sp)q(eci\014es)i(a)d +Fo(lexic)n(o)n(gr)n(aphic)g Fp(order:)23 b(Constructors)15 +b(are)i(ordered)g(b)o(y)f(the)h(order)f(of)h(their)g(app)q(earance)g(in)0 +607 y(the)f Fi(data)g Fp(declaration,)h(and)g(the)f(argumen)o(ts)g(of)g(a)g +(constructor)f(are)i(compared)f(from)g(left)g(to)g(righ)o(t.)23 +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 +(tically)g(equiv)m(alen)o(t)h(to)e(an)g(ordinary)h(t)o(w)o(o-constructor)d(t) +o(yp)q(e.)24 b(In)17 b(fact,)0 720 y(this)f(is)f(the)h(full)g(declaration:)71 +820 y Fi(data)23 b([a])190 b(=)24 b([])g(|)f(a)h(:)g([a])f(deriving)g(\(Eq,)g +(Ord,)h(Binary\))118 b(--)24 b(pseudocode)0 931 y Fp(\(Lists)16 +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 +(deriv)o(ed.\))21 b(The)15 b(deriv)o(ed)i Fi(Eq)e Fp(and)g +Fi(Ord)g Fp(instances)h(for)f(lists)0 988 y(are)e(the)h(usual)h(ones;)f(in)g +(particular,)h(c)o(haracter)e(strings,)h(as)f(lists)h(of)g(c)o(haracters,)f +(are)g(ordered)h(as)g(determined)0 1044 y(b)o(y)20 b(the)g(underlying)j +Fi(Char)c Fp(t)o(yp)q(e,)i(with)g(an)f(initial)i(substring)f(comparing)f +(less)h(than)f(a)g(longer)g(string;)j(for)0 1101 y(example,)16 +b Fi("cat")23 b(<)h("catalog")n Fp(.)71 1194 y(In)11 b(practice,)h +Fi(Eq)f Fp(and)g Fi(Ord)f Fp(instances)i(are)f(almost)f(alw)o(a)o(ys)g(deriv) +o(ed,)j(rather)d(than)h(user-de\014ned.)20 b(In)11 b(fact,)g(w)o(e)0 +1250 y(should)16 b(pro)o(vide)f(our)f(o)o(wn)g(de\014nitions)i(of)e(equalit)o +(y)i(and)e(ordering)h(predicates)g(only)g(with)g(some)g(trepidation,)0 +1307 y(b)q(eing)i(careful)g(to)e(main)o(tain)h(the)g(exp)q(ected)h(algebraic) +g(prop)q(erties)f(of)f(equiv)m(alence)k(relations)d(and)g(partial)g(or)0 +1363 y(total)h(orders.)28 b(An)19 b(in)o(transitiv)o(e)f Fi(\(==\))g +Fp(predicate,)h(for)e(example,)i(could)h(b)q(e)e(disastrous,)g(confusing)h +(readers)0 1420 y(of)f(the)g(program)f(and)h(confounding)h(man)o(ual)g(or)e +(automatic)h(program)f(transformations)g(that)g(rely)i(on)f(the)0 +1476 y Fi(\(==\))i Fp(predicate's)h(b)q(eing)h(an)f(appro)o(ximation)f(to)g +(de\014nitional)j(equalit)o(y)l(.)37 b(Nev)o(ertheless,)23 +b(it)e(is)g(sometimes)0 1533 y(necessary)16 b(to)f(pro)o(vide)h +Fi(Eq)f Fp(or)g Fi(Ord)h Fp(instances)g(di\013eren)o(t)g(from)f(those)g(that) +g(w)o(ould)h(b)q(e)g(deriv)o(ed;)h(probably)f(the)0 1589 y(most)h(imp)q +(ortan)o(t)h(example)h(is)f(that)g(of)f(an)h(abstract)f(data)h(t)o(yp)q(e)g +(in)h(whic)o(h)g(di\013eren)o(t)f(concrete)g(v)m(alues)i(ma)o(y)0 +1645 y(represen)o(t)15 b(the)g(same)g(abstract)g(v)m(alue.)71 +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 +Fi(Enum)e Fp(instance,)i(and)f(here)g(again,)g(the)g(ordering)g(is)g(that)f +(of)0 1795 y(the)g(constructors)g(in)h(the)f Fi(data)g Fp(declaration.)20 +b(F)l(or)15 b(example:)71 1904 y Fi(data)23 b(Day)g(=)h(Sunday)f(|)h(Monday)f +(|)h(Tuesday)f(|)g(Wednesday)285 1960 y(|)h(Thursday)f(|)h(Friday)f(|)g +(Saturday)214 b(deriving)23 b(\(Eq,)g(Ord,)g(Enum\))272 2099 +y([Wednesday..Friday])141 b Fn(\))72 b Fi([Wednesday,)22 b(Thursday,)h +(Friday])272 2156 y([Monday,)g(Wednesday)f(..])72 b Fn(\))g +Fi([Monday,)23 b(Wednesday,)f(Friday])71 2295 y Fp(An)17 b(en)o(umerated)g(t) +o(yp)q(e)h(or)e(tuple)i(\(single-constructor\))g(t)o(yp)q(e)f(all)h(of)f +(whose)g(comp)q(onen)o(t)g(t)o(yp)q(es)g(ha)o(v)o(e)g Fi(Ix)0 +2351 y Fp(instances)f(can)f(ha)o(v)o(e)g(a)g(deriv)o(ed)h Fi(Ix)f +Fp(instance.)21 b(\(See)15 b(Section)h Fn(x)q Fp(6.9.\))71 +2444 y(Deriv)o(ed)j Fi(Text)f Fp(instances)i(are)e(p)q(ossible)i(for)f(en)o +(umerated)g(t)o(yp)q(es)f(and)h(other)g(t)o(yp)q(es)f(all)i(of)e(whose)h +(com-)0 2501 y(p)q(onen)o(t)g(t)o(yp)q(es)f(also)g(ha)o(v)o(e)g +Fi(Text)g Fp(instances.)30 b(\()p Fi(Text)17 b Fp(instances)i(for)f(most)f +(of)h(the)g(standard)g(t)o(yp)q(es,)h(but)f(not)0 2557 y(functions,)d(are)f +(pro)o(vided)h(b)o(y)f(the)h(Standard)f(Prelude.\))21 b(The)14 +b(textual)h(represen)o(tation)f(de\014ned)i(b)o(y)e(a)g(deriv)o(ed)0 +2614 y Fi(Text)21 b Fp(instance)h(is)f(consisten)o(t)h(with)f(the)h(app)q +(earance)f(of)g(constan)o(t)g(Hask)o(ell)h(expressions)g(of)f(the)g(t)o(yp)q +(e)g(in)p eop +%%Page: 33 33 +bop 0 -40 a Fj(5.5)45 b(Num)o(b)q(ers)1575 b Fp(T-33)0 105 +y(question.)20 b(F)l(or)15 b(example,)h(if)f(w)o(e)g(add)h +Fi(Text)e Fp(to)h(the)g Fi(deriving)f Fp(clause)i(for)f(t)o(yp)q(e)g +Fi(Day)p Fp(,)f(ab)q(o)o(v)o(e,)h(w)o(e)g(obtain)259 209 y +Fi(show)23 b([Monday..Wednesday])71 b Fn(\))i Fi +("[Monday,Tuesday,Wednesday]")0 361 y Fg(5.5)56 b(Num)n(b)r(ers)0 +474 y Fp(Hask)o(ell)21 b(pro)o(vides)f(a)g(ric)o(h)g(collection)i(of)d(n)o +(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 +(in)h(turn)0 530 y(are)15 b(based)h(on)f(Common)g(Lisp[6)q(].)20 +b(\(Those)15 b(languages,)g(ho)o(w)o(ev)o(er,)g(are)g(dynamically)i(t)o(yp)q +(ed.\))k(The)15 b(standard)0 587 y(t)o(yp)q(es)j(include)j(\014xed-)e(and)f +(arbitrary-precision)h(in)o(tegers,)g(ratios)f(\(rational)f(n)o(um)o(b)q +(ers\))i(formed)e(from)h(eac)o(h)0 643 y(in)o(teger)c(t)o(yp)q(e,)g(and)g +(single-)h(and)f(double-precision)j(real)d(and)g(complex)h(\015oating-p)q +(oin)o(t.)20 b(W)l(e)14 b(outline)h(here)f(the)0 700 y(basic)i(c)o +(haracteristics)f(of)g(the)g(n)o(umeric)i(t)o(yp)q(e)e(class)g(structure)g +(and)h(refer)f(the)g(reader)g(to)g Fn(x)p Fp(6.8)f(for)h(details.)0 +850 y Fc(5.5.1)52 b(Numeric)17 b(Class)g(Structure)0 963 y +Fp(Returning)f(to)f(Figure)g(2,)f(w)o(e)h(notice)g(that)g(the)g(n)o(umeric)h +(t)o(yp)q(e)f(classes)g(\(class)g Fi(Num)g Fp(and)g(those)g(that)f(lie)i(b)q +(elo)o(w)0 1019 y(it\))h(accoun)o(t)f(for)g(more)g(than)h(half)g(of)f(the)h +(standard)f(classes.)24 b(W)l(e)17 b(also)g(note)f(that)g Fi(Num)g +Fp(is)h(a)g(sub)q(class)g(of)g Fi(Eq)o Fp(,)0 1076 y(but)c(not)f(of)h +Fi(Ord)o Fp(;)h(this)f(is)g(b)q(ecause)h(the)f(order)f(predicates)i(do)f(not) +f(apply)i(to)e(complex)i(n)o(um)o(b)q(ers.)19 b(The)13 b(sub)q(class)0 +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 +(class)i(of)d Fi(Ord)h Fp(as)g(w)o(ell.)71 1215 y(The)k Fi(Num)f +Fp(class)i(pro)o(vides)f(sev)o(eral)g(basic)h(op)q(erations)f(common)g(to)f +(all)i(n)o(umeric)g(t)o(yp)q(es;)h(these)e(include,)0 1271 +y(among)14 b(others,)h(addition,)h(subtraction,)f(negation,)g(m)o +(ultiplication,)i(and)e(absolute)h(v)m(alue:)71 1380 y Fi(\(+\),)23 +b(\(-\),)g(\(*\))262 b(::)24 b(\(Num)f(a\))h(=>)f(a)h(->)g(a)f(->)h(a)71 +1437 y(negate,)e(abs)310 b(::)24 b(\(Num)f(a\))h(=>)f(a)h(->)g(a)0 +1548 y Fp([)p Fi(negate)10 b Fp(is)h(the)g(function)h(applied)h(b)o(y)e(Hask) +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 +(it)f Fi(\(-\))p Fp(,)g(b)q(ecause)0 1605 y(that)j(is)h(the)g(subtraction)g +(function,)g(so)g(this)g(name)g(is)g(pro)o(vided)h(instead.)k(F)l(or)14 +b(example,)i Fi(-x*y)e Fp(is)h(equiv)m(alen)o(t)0 1661 y(to)d +Fi(negate)23 b(\(x*y\))o Fp(.)c(\(Pre\014x)12 b(min)o(us)h(has)f(the)g(same)g +(syn)o(tactic)g(precedence)i(as)e(in\014x)h(min)o(us,)g(whic)o(h,)g(of)f +(course,)0 1718 y(is)k(lo)o(w)o(er)f(than)g(that)f(of)h(m)o +(ultiplication.\)])71 1801 y(Note)d(that)h Fi(Num)g Fp(do)q(es)g +Fo(not)h Fp(pro)o(vide)f(a)g(division)j(op)q(erator;)c(t)o(w)o(o)g +(di\013eren)o(t)i(kinds)g(of)f(division)i(op)q(erators)d(are)0 +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 +(of)f Fi(Num)p Fp(:)71 1940 y(The)i(class)h Fi(Integral)e Fp(pro)o(vides)i +(whole-n)o(um)o(b)q(er)h(division)g(and)f(remainder)g(op)q(erations,)f(as)g +(w)o(ell)i(as)e(the)0 1996 y Fi(even)e Fp(and)h Fi(odd)g Fp(predicates.)23 +b(The)16 b(standard)f(instances)i(of)e Fi(Integral)g Fp(are)h +Fi(Integer)f Fp(\(un)o(b)q(ounded)i(or)e(math-)0 2053 y(ematical)20 +b(in)o(tegers,)f(also)g(kno)o(wn)g(as)g(\\bign)o(ums"\))f(and)i +Fi(Int)e Fp(\(b)q(ounded,)j(mac)o(hine)f(in)o(tegers,)f(with)h(a)e(range)0 +2109 y(equiv)m(alen)o(t)i(to)f(at)f(least)h(29-bit)f(signed)i(binary\).)31 +b(A)19 b(particular)g(Hask)o(ell)h(implemen)o(tation)g(migh)o(t)e(pro)o(vide) +0 2166 y(other)d(in)o(tegral)g(t)o(yp)q(es)g(in)g(addition)h(to)f(these.)20 +b(Note)14 b(that)g Fi(Integral)g Fp(is)h(a)g(sub)q(class)h(of)e +Fi(Real)p Fp(,)g(rather)h(than)f(of)0 2222 y Fi(Num)h Fp(directly;)h(this)g +(means)f(that)f(there)h(is)h(no)f(attempt)g(to)f(pro)o(vide)i(Gaussian)f(in)o +(tegers.)71 2305 y(All)23 b(other)e(n)o(umeric)i(t)o(yp)q(es)e(fall)i(in)g +(the)f(class)g Fi(Fractional)n Fp(,)h(whic)o(h)g(pro)o(vides)f(the)g +(ordinary)g(division)0 2361 y(op)q(erator)13 b Fi(\(/\))p Fp(.)19 +b(The)c(further)e(sub)q(class)j Fi(Floating)d Fp(con)o(tains)h +(trigonometric,)f(logarithmic,)i(and)f(exp)q(onen)o(tial)0 +2418 y(functions.)71 2501 y(The)j Fi(RealFrac)g Fp(sub)q(class)h(of)g +Fi(Fractional)e Fp(and)i Fi(Real)f Fp(pro)o(vides)h(a)f(function)h +Fi(properFraction)n Fp(,)g(whic)o(h)0 2557 y(decomp)q(oses)e(a)f(n)o(um)o(b)q +(er)h(in)o(to)f(its)h(whole)g(and)g(fractional)f(parts,)g(and)g(a)g +(collection)j(of)d(functions)h(that)f(round)0 2614 y(to)g(in)o(tegral)g(v)m +(alues)h(b)o(y)g(di\013ering)g(rules:)p eop +%%Page: 34 34 +bop 0 -40 a Fp(T-34)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g +(AND)f(\\OOP")71 160 y Fi(properFraction)236 b(::)24 b(\(Fractional)e(a,)i +(Integral)f(b\))g(=>)h(a)g(->)f(\(b,a\))71 216 y(truncate,)f(round,)71 +272 y(floor,)h(ceiling:)213 b(::)24 b(\(Fractional)e(a,)i(Integral)f(b\))g +(=>)h(a)g(->)f(b)71 453 y Fp(The)d Fi(RealFloat)f Fp(sub)q(class)j(of)e +Fi(Floating)f Fp(and)i Fi(RealFrac)e Fp(pro)o(vides)i(some)f(sp)q(ecialized)j +(functions)f(for)0 509 y(e\016cien)o(t)c(access)g(to)f(the)h(comp)q(onen)o +(ts)g(of)f(a)g(\015oating-p)q(oin)o(t)i(n)o(um)o(b)q(er,)f(the)g +Fo(exp)n(onent)f Fp(and)g Fo(signi\014c)n(and)p Fp(.)26 b(The)0 +566 y(standard)15 b(t)o(yp)q(es)g Fi(Float)f Fp(and)i Fi(Double)e +Fp(fall)i(in)g(class)g Fi(RealFloat)o Fp(.)0 782 y Fc(5.5.2)52 +b(Constructed)17 b(Num)o(b)q(ers)0 924 y Fp(Of)h(the)g(standard)f(n)o(umeric) +i(t)o(yp)q(es,)f Fi(Int)p Fp(,)g Fi(Integer)o Fp(,)g Fi(Float)o +Fp(,)g(and)g Fi(Double)f Fp(are)h(primitiv)o(e.)29 b(The)18 +b(others)f(are)0 981 y(made)e(from)g(these)g(b)o(y)g(t)o(yp)q(e)g +(constructors:)71 1083 y Fi(Complex)e Fp(is)i(a)g(t)o(yp)q(e)f(constructor)g +(that)g(mak)o(es)g(a)h(complex)g(t)o(yp)q(e)g(in)g(class)g +Fi(Floating)f Fp(from)g(a)g Fi(RealFloat)0 1140 y Fp(t)o(yp)q(e:)71 +1249 y Fi(data)23 b(\(RealFloat)f(a\))i(=>)g(Complex)e(a)i(=)g(a)g(:+)f(a)48 +b(deriving)23 b(\(Eq,)g(Binary,)g(Text\))0 1358 y Fp(Notice)14 +b(the)f(con)o(text)g Fi(\(RealFloat)23 b(a\))g(=>)p Fp(,)13 +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 +(standard)g(com-)0 1414 y(plex)18 b(t)o(yp)q(es)g(are)f Fi(Complex)23 +b(Float)17 b Fp(and)g Fi(Complex)23 b(Double)o Fp(.)k(W)l(e)17 +b(can)h(also)f(see)h(from)f(the)g Fi(data)g Fp(declaration)0 +1471 y(that)12 b(a)g(complex)i(n)o(um)o(b)q(er)e(is)h(written)g +Fo(x)18 b Fi(:+)12 b Fo(y)t Fp(;)i(the)e(argumen)o(ts)g(are)g(the)h +(cartesian)f(real)h(and)g(imaginary)g(parts,)0 1527 y(resp)q(ectiv)o(ely)l(.) +22 b(Since)16 b Fi(:+)f Fp(is)h(a)f(data)f(constructor,)g(w)o(e)h(can)h(use)f +(it)h(in)g(pattern)e(matc)o(hing:)71 1636 y Fi(conjugate)356 +b(::)24 b(\(RealFloat)e(a\))i(=>)g(Complex)e(a)i(->)g(Complex)f(a)71 +1693 y(conjugate)f(\(x:+y\))190 b(=)48 b(x)24 b(:+)f(\(-y\))71 +1873 y Fp(Similarly)l(,)15 b(the)f(t)o(yp)q(e)g(constructor)f +Fi(Ratio)f Fp(mak)o(es)h(a)h(rational)f(t)o(yp)q(e)h(in)g(class)g +Fi(RealFrac)f Fp(from)g(an)g(instance)0 1929 y(of)k Fi(Integral)o +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 +Fi(Ratio)23 b(Integer)o Fp(.\))j Fi(Ratio)o Fp(,)18 b(ho)o(w)o(ev)o(er,)f(is) +h(an)f(abstract)0 1986 y(t)o(yp)q(e)h(constructor,)g(b)q(eing)h(de\014ned)h +(in)f(the)f(Prelude)h(mo)q(dule)h Fi(PreludeRatio)n Fp(,)e(from)g(whic)o(h)h +(it)f(is)h(exp)q(orted)0 2042 y(without)d(its)g(data)f(constructor;)g(th)o +(us,)h(ratios)f(cannot)h(b)q(e)g(pattern-matc)o(hed.)22 b(Instead,)16 +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 +(tegers)h(is)h(pro)o(vided,)g(as)e(w)o(ell)j(as)d(comp)q(onen)o(t)i +(extraction)f(functions:)71 2208 y Fi(\(\045\))500 b(::)24 +b(\(Integral)f(a\))g(=>)h(a)f(->)h(a)g(->)f(Ratio)h(a)71 2264 +y(numerator,)e(denominator)46 b(::)24 b(\(Integral)f(a\))g(=>)h(Ratio)f(a)h +(->)f(a)71 2444 y Fp(Wh)o(y)17 b(the)g(di\013erence?)29 b(Complex)19 +b(n)o(um)o(b)q(ers)e(in)i(cartesian)e(form)g(are)h(unique|there)h(are)e(no)h +(non)o(trivial)0 2501 y(iden)o(tities)g(in)o(v)o(olving)g Fi(:+)p +Fp(.)23 b(On)17 b(the)f(other)h(hand,)f(ratios)g(are)g(not)g(unique,)i(but)f +(ha)o(v)o(e)f(a)g(canonical)h(\(reduced\))0 2557 y(form)h(that)f(the)i +(implemen)o(tation)h(of)e(the)g(abstract)g(data)g(t)o(yp)q(e)g(m)o(ust)g +(main)o(tain;)i(it)f(is)g(not)f(necessarily)i(the)0 2614 y(case,)14 +b(for)h(instance,)g(that)f Fi(numerator)23 b(\(x\045y\))14 +b Fp(is)h(equal)g(to)f Fi(x)p Fp(,)h(although)g(the)g(real)g(part)f(of)g +Fi(x:+y)g Fp(is)i(alw)o(a)o(ys)e Fi(x)o Fp(.)p eop +%%Page: 35 35 +bop 0 -40 a Fj(5.5)45 b(Num)o(b)q(ers)1575 b Fp(T-35)0 105 +y Fc(5.5.3)52 b(Numeric)17 b(Co)q(ercions)h(and)g(Ov)o(erloaded)f(Literals)0 +269 y Fp(The)e(Standard)h(Prelude)g(pro)o(vides)g(sev)o(eral)f(o)o(v)o +(erloaded)g(functions)h(that)f(serv)o(e)g(as)f(explicit)k(co)q(ercions:)71 +378 y Fi(fromInteger)308 b(::)24 b(\(Num)f(a\))h(=>)f(Integer)g(->)h(a)71 +435 y(fromRational)284 b(::)24 b(\(Fractional)e(a\))i(=>)f(Rational)g(->)h(a) +71 491 y(toInteger)356 b(::)24 b(\(Integral)f(a\))g(=>)h(a)f(->)h(Integer)71 +548 y(toRational)332 b(::)24 b(\(RealFrac)f(a\))g(=>)h(a)f(->)h(Rational)71 +604 y(fromIntegral)284 b(::)24 b(\(Integral)f(a,)g(Num)h(b\))f(=>)h(a)f(->)h +(b)71 661 y(fromRealFrac)284 b(::)24 b(\(RealFrac)f(a,)g(Fractional)g(b\))g +(=>)h(a)g(->)f(b)71 740 y(fromIntegral)284 b(=)48 b(fromInteger)22 +b(.)i(toInteger)71 797 y(fromRealFrac)284 b(=)48 b(fromRational)22 +b(.)i(toRational)71 992 y Fp(Tw)o(o)18 b(of)h(these)g(are)g(implicitly)k +(used)c(to)g(pro)o(vide)h(o)o(v)o(erloaded)f(n)o(umeric)h(literals:)29 +b(An)20 b(in)o(teger)g(n)o(umeral)0 1049 y(\(without)c(a)g(decimal)i(p)q(oin) +o(t\))e(is)h(actually)g(equiv)m(alen)o(t)h(to)e(an)g(application)i(of)e +Fi(fromInteger)f Fp(to)g(the)i(v)m(alue)g(of)0 1105 y(the)i(n)o(umeral)g(as)f +(an)h Fi(Integer)o Fp(.)31 b(Similarly)l(,)21 b(a)e(\015oating)g(n)o(umeral)g +(\(with)g(a)f(decimal)i(p)q(oin)o(t\))f(is)h(regarded)e(as)0 +1162 y(an)e(application)h(of)e Fi(fromRational)g Fp(to)g(the)h(v)m(alue)h(of) +e(the)h(n)o(umeral)g(as)f(a)h Fi(Rational)o Fp(.)21 b(Th)o(us,)16 +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 +Fp(,)18 b(and)f Fi(7.3)g Fp(has)g(the)h(t)o(yp)q(e)f Fi(Fractional)23 +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 +(umeric)0 1274 y(literals)e(in)g(generic)h(n)o(umeric)f(functions,)f(for)g +(example:)71 1383 y Fi(halve)452 b(::)24 b(\(Fractional)e(a\))i(=>)f(a)h(->)g +(a)71 1440 y(halve)f(x)405 b(=)48 b(x)24 b(*)f(0.5)0 1549 y +Fp(This)16 b(rather)e(indirect)i(w)o(a)o(y)e(of)h(o)o(v)o(erloading)g(n)o +(umerals)g(has)g(the)g(additional)i(adv)m(an)o(tage)d(that)g(the)h(metho)q(d) +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 +(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 +Fi(Integral)e Fp(or)h Fi(Fractional)0 1662 y Fp(instance)j(declaration)g +(\(since)g Fi(fromInteger)d Fp(and)i Fi(fromRational)f Fp(are)g(op)q(erators) +g(of)h(those)g(classes,)g(resp)q(ec-)0 1718 y(tiv)o(ely\).)20 +b(F)l(or)15 b(example,)h(the)f Fi(Num)g Fp(instance)h(of)e +Fi(\(RealFloat)23 b(a\))g(=>)h(Complex)f(a)15 b Fp(con)o(tains)g(this)h +(metho)q(d:)71 1830 y Fi(fromInteger)22 b(x)262 b(=)48 b(fromInteger)22 +b(x)i(:+)g(0)0 1939 y Fp(This)15 b(sa)o(ys)f(that)g(a)h Fi(Complex)f +Fp(instance)h(of)g Fi(fromInteger)e Fp(is)i(de\014ned)h(to)e(pro)q(duce)i(a)e +(complex)i(n)o(um)o(b)q(er)f(whose)0 1995 y(real)h(part)e(is)i(supplied)i(b)o +(y)d(an)g(appropriate)g Fi(RealFloat)f Fp(instance)j(of)d Fi(fromInteger)o +Fp(.)20 b(In)c(this)g(manner,)f(ev)o(en)0 2052 y(user-de\014ned)i(n)o(umeric) +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 +(v)o(erloaded)g(n)o(umerals.)71 2170 y(As)g(another)g(example,)g(recall)i +(our)d(\014rst)h(de\014nition)i(of)e Fi(succ)g Fp(from)f(Section)i(2:)71 +2279 y Fi(succ)23 b(::)g(Int)h(->)g(Int)71 2335 y(succ)f(n)h(=)f(n+1)0 +2444 y Fp(Ignoring)15 b(the)g(t)o(yp)q(e)f(signature,)g(the)h(most)f(general) +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 +Fp(.)c(The)14 b(explicit)j(t)o(yp)q(e)0 2501 y(signature)h(is)g(legal,)h(ho)o +(w)o(ev)o(er,)e(since)i(it)f(is)g Fo(mor)n(e)g(sp)n(e)n(ci\014c)e +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 +2557 y(signature)e(w)o(ould)g(cause)g(a)f(static)g(error\).)20 +b(The)c(t)o(yp)q(e)g(signature)g(has)f(the)h(e\013ect)f(of)h(restricting)g +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 +(cause)f(something)h(lik)o(e)g Fi(succ)23 b(\(1::Float\))14 +b Fp(to)h(b)q(e)h(ill-t)o(yp)q(ed.)p eop +%%Page: 36 36 +bop 0 -40 a Fp(T-36)771 b Fj(5)45 b(TYPE)15 b(CLASSES,)h(O)o(VERLO)o(ADING,)g +(AND)f(\\OOP")0 105 y Fc(5.5.4)52 b(Default)18 b(Numeric)g(T)o(yp)q(es)0 +216 y Fp(Consider)e(the)f(follo)o(wing)h(function)g(de\014nition:)71 +325 y Fi(rms)500 b(::)24 b(\(Floating)f(a\))g(=>)h(a)f(->)h(a)g(->)f(a)71 +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 +493 y Fp(The)c(exp)q(onen)o(tiation)g(function)g Fi(\(^\))f +Fp(\(one)g(of)g(three)g(di\013eren)o(t)h(standard)f(exp)q(onen)o(tiation)h +(op)q(erators)f(with)0 549 y(di\013eren)o(t)13 b(t)o(ypings,)g(see)g +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 +(b\))i(=>)g(a)f(->)h(b)g(->)f(a)p Fp(,)13 b(and)g(since)h Fi(2)e +Fp(has)0 606 y(the)k(t)o(yp)q(e)f Fi(\(Num)24 b(a\))f(=>)h(a)p +Fp(,)15 b(the)h(t)o(yp)q(e)g(of)f Fi(x^2)g Fp(is)h Fi(\(Num)23 +b(a,)h(Integral)f(b\))g(=>)h(a)p Fp(.)d(This)16 b(is)g(a)g(problem;)g(there)0 +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) +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 +(is)h(in)f(the)g(con)o(text,)0 719 y(but)j(has)f(otherwise)h(v)m(anished)i +(from)d(the)g(t)o(yp)q(e)h(expression.)31 b(Essen)o(tially)l(,)21 +b(the)e(programmer)e(has)i(sp)q(eci\014ed)0 775 y(that)e Fi(x)h +Fp(should)g(b)q(e)h(squared,)f(but)f(has)h(not)f(sp)q(eci\014ed)j(whether)e +(it)g(should)h(b)q(e)f(squared)g(with)g(an)g Fi(Int)f Fp(or)g(an)0 +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 +(can)g(\014x)h(this:)71 942 y Fi(rms)23 b(x)h(y)405 b(=)48 +b(sqrt)23 b(\(\(x)h(^)f(\(2::Int\))g(+)h(y)g(^)f(\(2::Int\)\))g(*)h(0.5\))0 +1051 y Fp(It's)15 b(ob)o(vious)g(that)g(this)g(sort)g(of)f(thing)i(will)h(so) +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 +(kind)i(of)d(o)o(v)o(erloading)i(am)o(biguit)o(y)f(is)h(not)f(restricted)g +(to)g(n)o(um)o(b)q(ers:)71 1241 y Fi(show)23 b(\(read)g("xyz"\))0 +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 +(e)h(read?)35 b(This)20 b(is)g(more)f(serious)h(than)g(the)g(exp)q(onen)o +(tiation)0 1407 y(am)o(biguit)o(y)l(,)14 b(b)q(ecause)h(there,)f(an)o(y)f +Fi(Integral)g Fp(instance)i(will)g(do,)f(whereas)g(here,)g(v)o(ery)f +(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 +(ending)i(on)d(what)f(instance)i(of)f Fi(Text)g Fp(is)h(used)f(to)g(resolv)o +(e)g(the)h(am)o(biguit)o(y)l(.)71 1545 y(Because)h(of)f(the)g(di\013erence)i +(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 +(v)o(erloading)h(am)o(biguit)o(y)0 1601 y(problem,)24 b(Hask)o(ell)e(pro)o +(vides)g(a)g(solution)g(that)f(is)h(restricted)g(to)f(n)o(um)o(b)q(ers:)33 +b(Eac)o(h)22 b(mo)q(dule)h(ma)o(y)e(con)o(tain)0 1658 y(a)h +Fo(default)h(de)n(clar)n(ation,)g Fp(consisting)g(of)f(the)g(k)o(eyw)o(ord)g +Fi(default)f Fp(follo)o(w)o(ed)i(b)o(y)f(a)g(paren)o(thesized,)i(comma-)0 +1714 y(separated)17 b(list)h(of)f(n)o(umeric)h(monot)o(yp)q(es)f(\(t)o(yp)q +(es)h(with)f(no)h(v)m(ariables\).)27 b(When)18 b(an)f(am)o(bigous)g(t)o(yp)q +(e)h(v)m(ariable)0 1770 y(is)h(disco)o(v)o(ered)f(\(suc)o(h)h(as)e +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) +f(is)h(n)o(umeric)g(and)f(all)h(of)f(its)h(classes)f(are)0 +1827 y(standard,)d(the)g(default)h(list)h(is)f(consulted,)g(and)f(the)h +(\014rst)f(t)o(yp)q(e)g(from)g(the)h(list)g(that)f(will)i(satisfy)e(the)h +(con)o(text)0 1883 y(of)g(the)h(t)o(yp)q(e)g(v)m(ariable)h(is)f(used.)25 +b(F)l(or)16 b(example,)h(if)h(the)e(default)i(declaration)f +Fi(default)23 b(\(Int,)g(Float\))16 b Fp(is)h(in)0 1940 y(e\013ect,)e(the)g +(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) +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 +(details.\))71 2021 y(The)f(\\default)h(default")g(is)g Fi(\(Int,)23 +b(Double\))o Fp(,)15 b(but)f Fi(\(Integer,)23 b(Rational,)g(Double\))13 +b Fp(ma)o(y)h(also)h(b)q(e)g(ap-)0 2078 y(propriate.)20 b(V)l(ery)15 +b(cautious)h(programmers)e(ma)o(y)g(prefer)i Fi(default)22 +b(\(\))p Fp(,)15 b(whic)o(h)h(pro)o(vides)g(no)f(defaults.)p +eop +%%Page: 37 37 +bop 1857 -40 a Fp(T-37)0 105 y Fq(6)69 b(Mo)r(dules)0 237 y +Fp(A)o(t)14 b(the)h(top)f(lev)o(el,)i(a)f(Hask)o(ell)g(program)f(consists)h +(of)f(a)h(collection)h(of)f Fo(mo)n(dules)p Fp(.)k(A)c(mo)q(dule)h(in)g(Hask) +o(ell)f(serv)o(es)0 294 y(the)g(dual)h(purp)q(ose)g(of)f(con)o(trolling)h +(name-spaces)g(and)f(creating)g(abstract)g(data)f(t)o(yp)q(es.)71 +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 +(of)h(the)g(v)m(arious)g(declarations)h(w)o(e)e(ha)o(v)o(e)h(discussed:)29 +b(\014xit)o(y)0 435 y(declarations,)15 b(data)f(and)h(t)o(yp)q(e)g +(declarations,)g(class)g(and)f(instance)i(declarations,)f(t)o(yp)q(e)g +(signatures,)f(function)0 492 y(de\014nitions,)k(and)e(pattern)f(bindings.)25 +b(Except)16 b(for)f(the)h(fact)g(that)f(\014xit)o(y)h(declarations)h(and)f +(imp)q(ort)g(declara-)0 548 y(tions)i(\(to)f(b)q(e)i(describ)q(ed)h +(shortly\))e(m)o(ust)f(app)q(ear)h(\014rst,)g(the)h(declarations)f(ma)o(y)g +(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 +(is)g(m)o(utually)g(recursiv)o(e\).)71 690 y(Hask)o(ell's)d(mo)q(dule)g +(design)h(is)f(relativ)o(ely)g(conserv)m(ativ)o(e:)19 b(The)13 +b(namespace)g(of)f(mo)q(dules)i(is)f(completely)h(\015at,)0 +746 y(and)h(mo)q(dules)i(are)d(in)j(no)e(w)o(a)o(y)f(\\\014rst-class.")19 +b(Mo)q(dule)d(names)g(are)e(alphan)o(umeric)j(and)e(m)o(ust)g(b)q(egin)i +(with)e(an)0 803 y(upp)q(ercase)g(letter.)20 b(There)14 b(is)h(no)f(formal)f +(connection)i(b)q(et)o(w)o(een)g(a)e(Hask)o(ell)i(mo)q(dule)h(and)e(the)g +(\014le)h(system)f(that)0 859 y(w)o(ould)i(\(t)o(ypically\))h(supp)q(ort)f +(it.)22 b(In)17 b(particular,)f(there)g(is)h(no)f(connection)h(b)q(et)o(w)o +(een)f(mo)q(dule)h(names)f(and)g(\014le)0 916 y(names,)g(and)g(more)g(than)g +(one)g(mo)q(dule)h(could)g(conceiv)m(ably)i(reside)e(in)g(a)f(single)h +(\014le)g(\(one)f(mo)q(dule)h(ma)o(y)f(ev)o(en)0 972 y(span)g(sev)o(eral)f +(\014les\).)22 b(Of)15 b(course,)h(a)f(particular)h(implemen)o(tation)h(will) +g(most)e(lik)o(ely)i(adopt)e(con)o(v)o(en)o(tions)h(that)0 +1029 y(mak)o(e)f(the)g(connection)h(b)q(et)o(w)o(een)g(mo)q(dules)g(and)f +(\014les)i(more)d(stringen)o(t.)71 1114 y(T)l(ec)o(hnically)h(sp)q(eaking,)f +(a)f(mo)q(dule)h(is)g(really)g(just)f(one)g(big)h(declaration)g(whic)o(h)g(b) +q(egins)g(with)g(the)f(k)o(eyw)o(ord)0 1170 y Fi(module)o Fp(;)i(here's)g(an) +g(example)h(for)f(a)g(mo)q(dule)h(whose)f(name)g(is)h Fi(Tree)p +Fp(:)71 1279 y Fi(module)23 b(Tree)g(\()h(Tree\(Leaf,Branch\),)d(fringe)i(\)) +h(where)71 1359 y(data)f(Tree)g(a)382 b(=)24 b(Leaf)f(a)h(|)f(Branch)g +(\(Tree)h(a\))f(\(Tree)g(a\))71 1439 y(fringe)g(::)g(Tree)h(a)f(->)h([a])71 +1495 y(fringe)f(\(Leaf)g(x\))286 b(=)24 b([x])71 1551 y(fringe)f(\(Branch)g +(left)g(right\))g(=)h(fringe)f(left)g(++)h(fringe)f(right)0 +1661 y Fp(The)14 b(t)o(yp)q(e)g Fi(Tree)f Fp(and)h(the)g(function)h +Fi(fringe)e Fp(should)i(b)q(e)g(familiar;)f(they)g(w)o(ere)g(giv)o(en)g(as)g +(examples)g(in)h(Section)0 1717 y(2.3.)29 b([Because)19 b(of)f(the)h +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 +(top)f(lev)o(el)i(of)e(a)h(mo)q(dule,)h(and)e(th)o(us)h(the)0 +1773 y(declarations)f(m)o(ust)e(all)i(line)g(up)f(in)h(the)f(same)f(column)i +(\(t)o(ypically)g(the)f(\014rst\).)24 b(Also)17 b(note)g(that)f(the)h(mo)q +(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 +(this)h(is)g(allo)o(w)o(ed.])71 1915 y(This)e(mo)q(dule)h(explicitly)i +Fo(exp)n(orts)d Fi(Tree)o Fp(,)g Fi(Leaf)o Fp(,)g Fi(Branch)o +Fp(,)g(and)g Fi(fringe)o Fp(.)20 b(If)14 b(the)g(exp)q(ort)g(list)g(follo)o +(wing)h(the)0 1972 y Fi(module)10 b Fp(k)o(eyw)o(ord)g(is)h(omitted,)g +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 +(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 +(o)o(v)o(e)e(example)i(ev)o(erything)g(is)f(explicitly)j(exp)q(orted,)e(so)e +(the)i(e\013ect)e(w)o(ould)i(b)q(e)g(the)f(same.\))18 b(Note)12 +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 +(m)o(ust)g(b)q(e)h(group)q(ed)g(together,)f(as)g(in)h Fi(Tree\(Leaf,Branch\)) +n Fp(.)21 b(As)0 2141 y(short-hand,)15 b(w)o(e)g(could)h(also)f(write)g +Fi(Tree\(..\))f Fp(\(exp)q(orting)i(a)f(subset)g(of)g(the)g(constructors)f +(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) +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 +(dule:)71 2335 y Fi(module)23 b(Main)g(\(main\))g(where)71 +2392 y(import)g(Tree)g(\()h(Tree\(Leaf,Branch\),)d(fringe)i(\))71 +2448 y(main)g(::)g(Dialogue)71 2504 y(main)g(=)h(print)f(\(fringe)g(\(Branch) +g(\(Leaf)g(1\))g(\(Leaf)h(2\)\)\))0 2614 y Fp(The)16 b(v)m(arious)g(items)g +(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 +(dule)i(are)e(called)i Fo(entities)p Fp(.)j(Note)15 b(the)p +eop +%%Page: 38 38 +bop 0 -40 a Fp(T-38)1557 b Fj(6)46 b(MODULES)0 105 y Fp(explicit)21 +b(imp)q(ort)d(list)h(in)h(the)e(imp)q(ort)h(declaration;)h(omitting)f(it)g(w) +o(ould)g(cause)f(all)i(en)o(tities)f(exp)q(orted)g(from)0 162 +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 +Fi(main)e Fp(\(and)i(its)f(t)o(yping\))h(and)f(the)h(mo)q(dule)g(name)g +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 +(ecial)0 300 y(signi\014cance,)17 b(as)e(sp)q(eci\014ed)i(in)f(the)f(Rep)q +(ort:)71 383 y(\\A)d(Hask)o(ell)i Fo(pr)n(o)n(gr)n(am)g Fp(is)f(a)g +(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) +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 +(ort)g(the)h(v)m(alue)h Fi(main)o Fp(.)27 b(The)18 b Fo(value)g +Fp(of)f(the)h(program)e(is)i(the)g(v)m(alue)h(of)e(the)h(iden)o(ti\014er)h +Fi(main)e Fp(in)0 496 y(mo)q(dule)f Fi(Main)p Fp(,)f(and)g +Fi(main)g Fp(m)o(ust)f(ha)o(v)o(e)h(t)o(yp)q(e)g Fi(Dialogue)o +Fp(.")71 578 y(\(The)e(t)o(yp)q(e)g Fi(Dialogue)f Fp(relates)h(to)g(I/O,)g +(and)h(is)f(discussed)i(in)f(Section)g(8.\))19 b(Th)o(us)13 +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 +(constitute)i(a)f(v)m(alid)i(Hask)o(ell)f(program.)0 784 y +Fg(6.1)56 b(Original)17 b(Names)h(and)h(Renaming)0 896 y Fp(Abstractly)d +(asso)q(ciated)h(with)g(ev)o(ery)f(en)o(tit)o(y)g(is)h(its)g +Fo(original)g(name)p Fp(|a)f(pair)h(consisting)g(of)f(the)g(name)h(of)f(the)0 +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) +f(it)f(w)o(as)g(originally)i(de\014ned.)20 b(This)14 b(concept)g(is)g(useful) +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 +(name)h(to)f(b)q(e)h(imp)q(orted)g(from)f(a)g(v)m(ariet)o(y)h(of)f +(di\013eren)o(t)h(mo)q(dules,)h(without)0 1066 y(con\015ict,)h(as)f(long)g +(as)g(the)g(original)h(name)g(is)f(the)h(same.)71 1148 y(En)o(tities)f(b)q +(eing)i(imp)q(orted)f(can)f(also)g(b)q(e)h Fo(r)n(ename)n(d)p +Fp(;)e(for)h(example:)71 1257 y Fi(import)23 b(Tree)g(\()h +(Tree\(Leaf,Branch\),)d(fringe)i(\))238 1313 y(renaming)f(\(Leaf)i(to)f +(Root,)g(Branch)g(to)h(Twig\))0 1541 y Fg(6.2)56 b(In)n(terfaces)18 +b(and)h(Impleme)o(n)n(tations)0 1653 y Fp(The)d(mo)q(dules)h +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 +(actualit)o(y)f(mo)q(dule)g Fo(implementations)p Fp(|they)g(con)o(tain)0 +1709 y(all)j(of)e(the)h(Hask)o(ell)g(co)q(de)g(to)g(completely)h(de\014ne)f +(a)g(mo)q(dule.)28 b(The)18 b(information)g(passed)g(b)q(et)o(w)o(een)g(mo)q +(dules)0 1766 y(during)f(exp)q(ort)e(and)h(imp)q(ort,)g(ho)o(w)o(ev)o(er,)f +(is)h(more)f(abstract,)g(and)h(is)g(captured)g(formally)g(in)h(a)e(mo)q(dule) +i Fo(inter-)0 1822 y(fac)n(e)p Fp(.)i(The)c(in)o(terface)g(for)f(a)g(mo)q +(dule)i Fi(M)e Fp(con)o(tains)h(all)g(of)f(the)h(information)f(ab)q(out)h +(the)f(en)o(tities)i(exp)q(orted)f(from)0 1879 y Fi(M)h Fp(that)f(is)i +(needed)h(to)d(ensure)i(prop)q(er)f(t)o(yping)h(of)e(some)h(other)g(mo)q +(dule)h Fi(N)f Fp(that)g(ma)o(y)f(imp)q(ort)i Fi(M)p Fp(.)22 +b(The)17 b(prop)q(er)0 1935 y(in)o(terfaces)e(for)g(the)g(mo)q(dules)i +Fi(Tree)d Fp(and)i Fi(Main)e Fp(are:)71 2035 y Fi(interface)22 +b(Tree)i(\()f(Tree\(Leaf,Branch\),)f(fringe)h(\))g(where)71 +2092 y(data)g(Tree)g(a)h(=)g(Leaf)f(a)h(|)f(Branch)g(\(Tree)h(a\))f(\(Tree)g +(a\))71 2148 y(fringe)g(::)g(Tree)h(a)f(->)h([a])71 2228 y(interface)e(Main)i +(\(main\))f(where)71 2284 y(import)g(Tree)g(\()h(Tree\(Leaf,Branch\),)d +(fringe)i(\))71 2341 y(main)g(::)g(Dialogue)71 2501 y Fp(Normally)12 +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 +(terfaces,)g(since)h(they)f(are)f(usually)i(deriv)o(ed)0 2557 +y(automatically)k(from)f(the)h(mo)q(dule)h(implemen)o(tation.)27 +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) +g(to)0 2614 y(statically)f(debug)h(a)e(mo)q(dule)i(implemen)o(tation)g(that)e +(imp)q(orts)h(some)f(other)g(mo)q(dule)i(whose)f(implemen)o(tation)p +eop +%%Page: 39 39 +bop 0 -40 a Fj(6.3)45 b(Abstract)14 b(Data)g(T)o(yp)q(es)1332 +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 +(explicitly)k(write)d(the)g(in)o(terface)g(for)g(this)g(imp)q(orted)g(mo)q +(dule)i(w)o(ould)0 162 y(p)q(ermit)f(this.)41 b(Indeed,)24 +b(in)o(terfaces)e(supp)q(ort)g(top-do)o(wn,)h(successiv)o(e)g(re\014nemen)o +(t,)g(soft)o(w)o(are)d(dev)o(elopmen)o(t)0 218 y(metho)q(dologies,)c(in)g +(whic)o(h)g Fo(al)r(l)f Fp(in)o(terfaces)g(are)g(ideally)i(written)e +Fo(\014rst)p Fp(.)0 493 y Fg(6.3)56 b(Abstract)19 b(Data)f(T)n(yp)r(es)0 +661 y Fp(Aside)j(from)f(con)o(trolling)h(namespaces,)g(mo)q(dules)g(pro)o +(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 +717 y(\(ADTs\))c(in)i(Hask)o(ell.)27 b(F)l(or)17 b(example,)h(the)g(c)o +(haracteristic)f(feature)g(of)g(an)g(ADT)g(is)h(that)f(the)g +Fo(r)n(epr)n(esentation)0 774 y(typ)n(e)i Fp(is)h Fo(hidden)p +Fp(;)h(all)f(op)q(erations)f(on)g(the)g(ADT)g(are)g(done)h(at)e(an)h +(abstract)f(lev)o(el)j(whic)o(h)f(do)q(es)g(not)e(dep)q(end)0 +830 y(on)f(the)h(represen)o(tation.)26 b(F)l(or)16 b(example,)j(although)e +(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 +(t)g(not)0 886 y(normally)e(mak)o(e)g(it)g(abstract,)e(a)h(suitable)i(ADT)f +(for)f(it)h(migh)o(t)g(include)i(the)e(follo)o(wing)g(op)q(erations,)g(whic)o +(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 +1052 y Fi(interface)22 b(TreeADT)h(\(Tree,)g(leaf,)g(branch,)g(cell,)524 +1108 y(left,)g(right,)g(isLeaf,)g(isBranch\))g(where)71 1165 +y(data)g(Tree)g(a)71 1221 y(leaf)476 b(::)24 b(a)g(->)f(Tree)h(a)71 +1278 y(branch)428 b(::)24 b(Tree)f(a)h(->)g(Tree)f(a)h(->)f(Tree)g(a)71 +1334 y(cell)476 b(::)24 b(Tree)f(a)h(->)g(a)71 1391 y(left,)f(right)309 +b(::)24 b(Tree)f(a)h(->)g(Tree)f(a)71 1447 y(isLeaf)428 b(::)24 +b(Tree)f(a)h(->)g(Bool)0 1556 y Fp(A)15 b(mo)q(dule)i(implemen)o(tation)f +(supp)q(orting)g(this)g(is:)71 1665 y Fi(module)23 b(TreeADT)g(\(Tree,)g +(leaf,)g(branch,)g(cell,)452 1722 y(left,)h(right,)f(isLeaf\))g(where)71 +1801 y(data)g(Tree)g(a)310 b(=)24 b(Leaf)f(a)h(|)g(Branch)f(\(Tree)g(a\))h +(\(Tree)f(a\))71 1881 y(leaf)476 b(=)24 b(Leaf)71 1937 y(branch)428 +b(=)24 b(Branch)71 1994 y(cell)47 b(\(Leaf)23 b(a\))238 b(=)24 +b(a)71 2050 y(left)47 b(\(Branch)23 b(l)g(r\))143 b(=)24 b(l)71 +2107 y(right)f(\(Branch)g(l)g(r\))143 b(=)24 b(r)71 2163 y(isLeaf)70 +b(\(Leaf)24 b(_\))166 b(=)24 b(True)71 2220 y(isLeaf)70 b(_)334 +b(=)24 b(False)0 2331 y Fp(Note)d(in)h(the)g(exp)q(ort)f(list)i(that)d(the)i +(t)o(yp)q(e)f(name)h Fi(Tree)f Fp(app)q(ears)g(alone)h(\(i.e.)f(without)h +(its)g(constructors\);)0 2388 y(similarly)l(,)e(in)f(the)e(in)o(terface)h +(the)g Fi(data)f Fp(declaration)i(for)e Fi(Tree)g Fp(do)q(es)h(not)f(include) +k(the)c(constructors.)27 b(Th)o(us)0 2444 y Fi(Leaf)17 b Fp(and)h +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 +(build)j(or)e(tak)o(e)f(apart)g(trees)g(outside)i(of)e(the)0 +2501 y(mo)q(dule)f(is)f(b)o(y)g(using)h(the)f(v)m(arious)g(\(abstract\))e(op) +q(erations.)20 b(Of)15 b(course,)g(the)g(adv)m(an)o(tage)f(of)h(this)g +(information)0 2557 y(hiding)20 b(is)e(that)f(at)h(a)g(later)g(time)g(w)o(e)g +(could)h Fo(change)e Fp(the)h(represen)o(tation)g(t)o(yp)q(e)g(without)g +(a\013ecting)g(users)g(of)0 2614 y(the)d(t)o(yp)q(e.)p eop +%%Page: 40 40 +bop 0 -40 a Fp(T-40)1368 b Fj(7)45 b(TYPING)15 b(PITF)-5 b(ALLS)0 +105 y Fg(6.4)56 b(Rules,)17 b(Rules,)g(and)j(More)e(Rules)0 +227 y Fp(Although)f(Hask)o(ell's)h(mo)q(dule)g(system)e(is)i(relativ)o(ely)g +(conserv)m(ativ)o(e,)f(there)g(are)g(man)o(y)f(rules)i(concerning)g(the)0 +283 y(imp)q(ort)g(and)g(exp)q(ort)g(of)g(v)m(alues.)29 b(Most)17 +b(of)g(these)h(are)g(ob)o(vious|for)g(instance,)h(it)f(is)h(illegal)h(to)d +(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 +(the)f(same)h(name)f(in)o(to)h(the)g(same)f(scop)q(e.)25 b(Other)17 +b(rules)h(are)e(not)h(so)f(ob)o(vious|for)0 396 y(example,)f(an)e +Fi(instance)g Fp(declaration)i(can)f(only)g(app)q(ear)g(in)h(the)f(mo)q(dule) +g(in)h(whic)o(h)g(the)f(corresp)q(onding)h Fi(data)0 453 y +Fp(or)g Fi(class)f Fp(declaration)i(app)q(ears.)k(The)c(reader)f(should)h +(read)f(the)g(Rep)q(ort)h(for)e(details)j(\()p Fn(x)o Fp(5\).)0 +646 y Fq(7)69 b(T)n(yping)23 b(Pitfalls)0 783 y Fp(This)c(short)e(section)i +(giv)o(e)f(an)g(in)o(tuitiv)o(e)i(description)f(of)f(a)g(few)g(common)g +(problems)g(that)g(no)o(vices)h(run)f(in)o(to)0 840 y(using)e(Hask)o(ell's)g +(t)o(yp)q(e)f(system.)0 1011 y Fg(7.1)56 b(Let-Bound)17 b(P)n(olymorphism)0 +1133 y Fp(An)o(y)i(language)h(using)g(the)f(Hindley-Milne)q(r)j(t)o(yp)q(e)d +(system)g(has)g(what)f(is)i(called)h Fo(let-b)n(ound)f(p)n(olymorphism)p +Fp(,)0 1189 y(b)q(ecause)g(iden)o(ti\014ers)g(not)e(b)q(ound)i(using)g(a)e +Fi(let)g Fp(or)h Fi(where)f Fp(clause)h(\(or)f(at)g(the)h(top)g(lev)o(el)h +(of)e(a)h(mo)q(dule\))g(are)0 1246 y(limited)14 b(with)e(resp)q(ect)h(to)e +(their)h(p)q(olymorphism.)20 b(In)13 b(particular,)g(a)f Fo(lamb)n(da-b)n +(ound)g Fp(function)h(\(i.e.,)f(one)g(passed)0 1302 y(as)k(argumen)o(t)g(to)f +(another)h(function\))h(cannot)f(b)q(e)h(instan)o(tiated)g(in)g(t)o(w)o(o)e +(di\013eren)o(t)i(w)o(a)o(ys.)22 b(F)l(or)15 b(example,)j(this)0 +1359 y(program)c(is)i(illegal:)71 1468 y Fi(let)23 b(f)h(g)47 +b(=)h(\(g)24 b([],)f(g)h('a'\))548 b(--)24 b(ill-typed)e(expression)71 +1524 y(in)h(f)h(\(\\x->x\))0 1633 y Fp(b)q(ecause)19 b Fi(g)p +Fp(,)f(b)q(ound)h(to)e(a)h(lam)o(b)q(da)g(abstraction)g(whose)g(principal)i +(t)o(yp)q(e)e(is)h Fi(a->a)o Fp(,)f(is)h(used)f(within)i Fi(f)d +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 +(yp)q(e)h Fi([a]->[a])n Fp(,)f(and)h(once)f(with)h(t)o(yp)q(e)f +Fi(Char->Char)o Fp(.)0 1861 y Fg(7.2)56 b(Numeric)16 b(Ov)n(erloading)0 +1983 y Fp(It)f(is)g(easy)g(to)f(forget)g(at)g(times)h(that)g(n)o(umerals)g +(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 +(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 +(in)j(man)o(y)d(other)h(languages.)26 b(More)17 b(general)h(n)o(umeric)g +(expressions)g(sometimes)f(cannot)0 2096 y(b)q(e)f(quite)g(so)f(generic.)20 +b(A)c(common)e(n)o(umeric)j(t)o(yping)e(error)f(is)i(something)g(lik)o(e)g +(the)f(follo)o(wing:)71 2205 y Fi(average)22 b(xs)334 b(=)48 +b(sum)23 b(xs)h(/)g(length)f(xs)262 b(--)24 b(Wrong!)0 2314 +y(\(/\))c Fp(requires)h(fractional)f(argumen)o(ts,)g(but)h +Fi(length)o Fp('s)f(result)g(is)h(an)f Fi(Int)p Fp(.)35 b(The)20 +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 +(explicit)i(co)q(ercion:)71 2480 y Fi(average)404 b(::)24 b(\(Fractional)e +(a\))i(=>)f([a])h(->)f(a)71 2536 y(average)f(xs)334 b(=)48 +b(sum)23 b(xs)h(/)g(fromIntegral)e(\(length)h(xs\))p eop +%%Page: 41 41 +bop 0 -40 a Fj(7.3)45 b(The)15 b(Monomorphism)g(Restriction)1118 +b Fp(T-41)0 105 y Fg(7.3)56 b(The)18 b(Monomorphism)e(Restriction)0 +213 y Fp(The)e(Hask)o(ell)h(t)o(yp)q(e)g(system)e(con)o(tains)i(a)f +(restriction)g(related)h(to)e(t)o(yp)q(e)i(classes)f(that)g(is)h(not)e(found) +i(in)g(ordinary)0 269 y(Hindley-Milne)q(r)23 b(t)o(yp)q(e)d(systems:)29 +b(the)20 b Fo(monomorphism)i(r)n(estriction)p Fp(.)34 b(The)21 +b(reason)f(for)f(this)i(restriction)f(is)0 326 y(related)c(to)e(a)h(subtle)h +(t)o(yp)q(e)f(am)o(biguit)o(y)g(and)h(is)f(explained)j(in)d(full)i(detail)f +(in)g(the)f(Rep)q(ort)h(\()p Fn(x)p Fp(4.5.4\).)i(A)d(simpler)0 +382 y(explanation)h(follo)o(ws:)71 461 y(The)g(monomorphism)f(restriction)i +(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 +(binding)j(\(whic)o(h)e(in-)0 517 y(cludes)e(bindings)g(to)e(a)g(single)i +(iden)o(ti\014er\),)g(and)e(ha)o(ving)h(no)f(explicit)j(t)o(yp)q(e)e +(signature,)f(m)o(ust)g(b)q(e)h Fo(monomorphic)p Fp(.)0 574 +y(An)h(iden)o(ti\014er)h(is)f(monomorphic)g(if)f(is)h(either)h(not)e(o)o(v)o +(erloaded,)g(or)g(is)h(o)o(v)o(erloaded)f(but)h(is)g(used)g(in)g(at)f(most)g +(one)0 630 y(sp)q(eci\014c)k(o)o(v)o(erloading)e(and)h(is)f(not)g(exp)q +(orted.)71 709 y(Violations)e(of)e(this)i(restriction)g(result)f(in)h(a)f +(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 +(v)o(oid)h(the)g(problem)0 765 y(is)18 b(to)g(pro)o(vide)g(an)g(explicit)i(t) +o(yp)q(e)e(signature.)28 b(Note)17 b(that)g Fo(any)h Fp(t)o(yp)q(e)g +(signature)g(will)h(do)f(\(as)f(long)h(it)h(is)f(t)o(yp)q(e)0 +822 y(correct\).)71 900 y(A)12 b(common)h(violation)g(of)g(the)f(restriction) +i(happ)q(ens)f(with)g(functions)h(de\014ned)g(in)f(a)g(higher-order)g +(manner,)0 957 y(as)i(in)h(this)f(de\014nition)i(of)e Fi(sum)g +Fp(from)f(the)i(Standard)f(Prelude:)71 1057 y Fi(sum)500 b(=)48 +b(foldl)23 b(\(+\))h(0)0 1166 y Fp(As)15 b(is,)h(this)f(w)o(ould)h(cause)f(a) +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) +f(adding)h(the)f(t)o(yp)q(e)g(signature:)71 1275 y Fi(sum)500 +b(::)24 b(\(Num)f(a\))h(=>)f([a])h(->)f(a)0 1384 y Fp(Also)16 +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 +(w)o(e)f(had)g(written:)71 1493 y Fi(sum)23 b(xs)429 b(=)48 +b(foldl)23 b(\(+\))h(0)f(xs)0 1602 y Fp(b)q(ecause)16 b(the)f(restriction)h +(only)g(applies)h(to)d(pattern)h(bindings.)0 1766 y Fq(8)69 +b(Input/Output)0 1890 y Fp(The)17 b(I/O)h(system)e(in)i(Hask)o(ell)g(is)g +(purely)g(functional,)g(y)o(et)f(has)g(all)h(the)f(expressiv)o(e)h(p)q(o)o(w) +o(er)f(of)f(that)h(found)g(in)0 1946 y(con)o(v)o(en)o(tional)h(programming)f +(languages.)27 b(T)l(o)18 b(ac)o(hiev)o(e)g(this,)g(Hask)o(ell)g(relies)h +(critically)h(on)e(lazy)g(ev)m(aluation)0 2002 y(and)d(higher-order)h +(functions,)g(the)f(k)o(ey)g(building)j(blo)q(c)o(ks)e(of)f(an)o(y)g +(functional)h(program.)j(\()p Fn(x)p Fp(7\))71 2081 y(The)13 +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 +(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 +Fp(approac)o(h)i(and)0 2137 y(the)f Fo(c)n(ontinuation-b)n(ase)n(d)e +Fp(approac)o(h.)19 b(The)13 b(former)f(is)h(probably)g(easier)g(to)f(explain) +j(conceptually)l(,)f(and)f(indeed)0 2194 y(the)19 b(latter)f(is)h(de\014ned)h +(in)f(terms)f(of)g(the)h(former)f(in)h(the)g(Rep)q(ort.)30 +b(Ho)o(w)o(ev)o(er,)18 b(for)g(practical)h(programming,)0 2250 +y(the)g(latter)f(\(con)o(tin)o(uation-based\))h(approac)o(h)g(is)g(the)g +(preferred)g(metho)q(dology)l(,)g(and)g(that)f(is)i(what)e(w)o(e)g(will)0 +2307 y(concen)o(trate)d(on)g(in)h(this)g(section.)k(\()p Fn(x)p +Fp(7.5\))0 2449 y Fg(8.1)56 b(In)n(tro)r(duction)18 b(to)g(Con)n(tin)n +(uations)0 2557 y Fp(T)l(o)13 b(understand)g(this)h(metho)q(dology)l(,)f(it)g +(is)g(helpful)i(to)e(ha)o(v)o(e)f(some)h(understanding)h(of)e(the)h(notion)h +(of)e(a)h Fo(c)n(ontin-)0 2614 y(uation)p Fp(.)20 b(A)13 b(con)o(tin)o +(uation)h(is)f(basically)i(a)e(\(p)q(ossibly)i(n)o(ullary\))f +Fo(function)e Fp(that)h(maps)g(an)g(\\in)o(termediate)h(v)m(alue")p +eop +%%Page: 42 42 +bop 0 -40 a Fp(T-42)1417 b Fj(8)45 b(INPUT/OUTPUT)0 105 y Fp(\(p)q(ossibly)20 +b(empt)o(y\))e(to)g(\\the)g(rest)g(of)h(the)f(program.")29 +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 +(explicitly)0 162 y(manage)d(\\\015o)o(w)h(of)f(con)o(trol,")h(and)g(th)o(us) +g(w)o(e)f(tend)i(to)e(de\014ne)i(functions)g(that,)e(instead)i(of)e +(returning)i(with)f(an)0 218 y(answ)o(er,)g(will)j(apply)e(a)f(con)o(tin)o +(uation)i(\(passed)e(in)i(as)e(an)h(argumen)o(t\))e(to)h(the)h(answ)o(er.)24 +b(Because)17 b(of)g(this,)g(the)0 274 y(resulting)f(programming)f(st)o(yle)g +(is)h(often)f(called)i Fo(c)n(ontinuation)e(p)n(assing)g(style)p +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 +(this)i(idea)f(without)g(reference)g(to)f(I/O,)h(let's)g(consider)g(the)g +(use)g(of)g(con)o(tin)o(uations)0 416 y(to)i(manage)g(errors|i.e.,)g(to)f +(create)i(the)f(e\013ect)g(of)g(a)g(non-lo)q(cal)i(exit,)f(or)f(call)h(to)f +(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 +(of)h(handling)i(error)d(v)m(alues)i(in)g(Hask)o(ell)g(migh)o(t)g(b)q(e)f +(the)h(follo)o(wing:)71 581 y Fi(data)23 b(Maybe)g(a)286 b(=)24 +b(Ok)g(a)f(|)h(Oops)f(String)71 638 y(f)548 b(::)24 b(Int)f(->)h(Maybe)f(Int) +71 694 y(f)g(x)501 b(=)24 b(let)f(y)h(=)g(...)691 751 y(in)47 +b(if)24 b(y==0)47 b(then)g(Oops)24 b("divide)f(by)g(zero")786 +807 y(else)48 b(Ok)23 b(\(x/y\))0 916 y Fp(Here)c(the)g Fi(Maybe)f +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 +(error)g(in)o(v)o(olving)i(a)f(particular)g(t)o(yp)q(e.)31 +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 +(somewhere;)i(for)f(example,)h(supp)q(ose)g(when)f(the)h(divide-b)o(y-zero)h +(error)e(o)q(ccurs)0 1029 y(there)i(is)h(some)f(default)h(v)m(alue)g +Fi(d)f Fp(that)g(is)g(appropriate)g(to)g(use)h(instead:)118 +1138 y Fi(case)24 b(f)f(z)h(of)166 1195 y(Ok)g(x)71 b(->)24 +b(x)166 1251 y(Oops)f(s)h(->)g(d)71 1414 y Fp(In)16 b(con)o(trast)f(to)h +(this,)h(an)f(approac)o(h)g(to)f(handling)j(errors)e(based)g(on)h(explicit)h +(con)o(tin)o(uations)f(migh)o(t)f(lo)q(ok)0 1470 y(something)f(lik)o(e)i +(this:)71 1579 y Fi(f)548 b(::)24 b(Int)f(->)h(\(String)f(->)g(Int\))h(->)f +(Int)71 1635 y(f)g(x)h(c)453 b(=)24 b(let)f(y)h(=)g(...)691 +1692 y(in)47 b(if)24 b(x==0)47 b(then)g(c)24 b("divide)f(by)h(zero")786 +1748 y(else)48 b(x/y)0 1864 y Fp(Note)17 b(that)f(an)h(error)f(con)o(tin)o +(uation)i Fi(c)f Fp(is)g(explicitly)j(supplied)g(to)c Fi(f)h +Fp(as)f(an)h(argumen)o(t.)1546 1847 y Fm(14)1608 1864 y Fp(No)o(w,)g(to)f +(sim)o(ulate)0 1920 y(the)f(ab)q(o)o(v)o(e)g Fo(use)g Fp(of)g +Fi(f)p Fp(,)g(w)o(e)f(w)o(ould)i(simply)g(write:)118 2029 y +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 +(w)o(een)h(con)o(v)o(en)o(tional)h(and)f(con)o(tin)o(uation-based)h(approac)o +(hes)f(to)f(handling)j(suc)o(h)f(things)0 2248 y(as)i(errors)f(are)h(sub)s +(jectiv)o(e.)20 b(The)c(passing)f(of)g(con)o(tin)o(uations)g(can)h(b)q(e)f +(cum)o(b)q(ersome,)h(but)f(on)g(the)g(other)g(hand,)p 0 2295 +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 +(out)g(that)g(an)f(ev)o(en)h(b)q(etter)g(solution)h(w)o(ould)g(exist)f(if)f +(the)h(primitiv)o(e)h(arithmetic)g(functions)g(to)q(ok)0 2383 +y(con)o(tin)o(uation)e(argumen)o(ts)e(to)q(o!)j(If)12 b Ff(divide)f +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 +(simply)h(write:)71 2472 y Ff(f)k(x)g(c)372 b(=)20 b(let)e(y)h(=)g(...)581 +2518 y(in)38 b(divide)17 b(x)j(y)f(c)p eop +%%Page: 43 43 +bop 0 -40 a Fj(8.2)45 b(Con)o(tin)o(uation)15 b(Based)g(I/O)1271 +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 +(t)o(yp)q(es)e(is)h(also)g(cum)o(b)q(ersome.)18 b(The)12 b(programmer)e(m)o +(ust)h(mak)o(e)g(a)g(judicious)0 162 y(c)o(hoice)16 b(based)g(on)f(her)g +(particular)h(circumstances.)71 259 y(Before)e(mo)o(ving)g(on)g(to)f(I/O,)h +(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 +(tage)f(of)f(con)o(tin)o(uations)i(b)o(y)f(noting)0 316 y(that)g(if)h +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 +(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 +(e)i(propagated)0 372 y(bac)o(k)c(through)f(ev)o(ery)h(lev)o(el)i(of)d +(recursion,)i(whereas)f(in)h(the)f(con)o(tin)o(uation-based)h(approac)o(h,)e +(the)i(con)o(tin)o(uation)0 429 y(is)f(called)h(directly)l(,)g(m)o(uc)o(h)f +(lik)o(e)h(a)e(non-lo)q(cal)i(exit)f(to)e(an)i(error)f(handler!)19 +b(This)12 b(ma)o(y)f(ha)o(v)o(e)g(an)h(imp)q(ortan)o(t)f(impact)0 +485 y(on)k(e\016ciency)l(.)0 688 y Fg(8.2)56 b(Con)n(tin)n(uation)19 +b(Based)g(I/O)0 823 y Fp(Giv)o(en)12 b(this)f(bac)o(kground,)h(understanding) +g(con)o(tin)o(uation-based)g(I/O)g(in)g(Hask)o(ell)g(should)g(b)q(e)f +(straigh)o(tforw)o(ard;)0 879 y(there)k(are)g(only)h(t)o(w)o(o)e(small)i(t)o +(wists.)71 977 y(First,)11 b(a)h(program)f(engaged)h(in)h(I/O)f(\\comm)o +(unicates")g(to)f(the)h(outside)h(w)o(orld)f(\(nominally)l(,)i(the)e(op)q +(erating)0 1033 y(system\))19 b(using)h(con)o(tin)o(uations.)32 +b(A)20 b(Hask)o(ell)g(program)e(engaged)i(in)g(I/O)g(is)g(required)g(to)f(ha) +o(v)o(e)g(a)g(top-lev)o(el)0 1090 y(iden)o(ti\014er)j Fi(main)d +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 +(e)g(of)g(the)g(con)o(tin)o(uation)g(that)g(the)g(op)q(erating)0 +1146 y(system)15 b(is)g(exp)q(ecting.)71 1244 y(The)j(other)g(t)o(wist)f(is)i +(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) +o(uation,)h(but)g(so)e(is)i Fo(suc)n(c)n(ess)p Fp(,)e(since)0 +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 +(ects)e(of)h(I/O.)g(Th)o(us)f(the)h(I/O)g(\\commands")f(in)i(Hask)o +(ell|functions)0 1357 y(called)h Fo(tr)n(ansactions)p Fp(|tak)o(e)d +Fo(two)h Fp(con)o(tin)o(uation)h(argumen)o(ts,)e(one)h(for)g(success)h(and)f +(the)g(other)g(for)g(failure.)71 1455 y(The)d(simplest)h(thing)g(a)f(program) +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 +(the)g(sp)q(ecial)i Fi(done)e Fp(con)o(tin)o(uation,)0 1512 +y(whose)j(t)o(yp)q(e)g(is)h Fi(Dialogue)o Fp(:)71 1622 y Fi(main)476 +b(=)48 b(done)71 1797 y Fp(F)l(or)18 b(a)g(little)i(more)f(sophistication,)h +(supp)q(ose)f(w)o(e)g(wish)g(to)f(write)h(a)g(string)f Fi(s)h +Fp(to)f(a)g(\014le)i(whose)f(name)f(is)0 1854 y Fi("ReadMe")o +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 +Fi(writeFile)e Fp(transaction:)71 1963 y Fi(main)476 b(=)24 +b(writeFile)f("ReadMe")f(s)i(failCont)f(succCont)0 2072 y Fp(where)12 +b Fi(failCont)f Fp(and)h Fi(succCont)f Fp(are)h(failure)h(and)f(success)g +(con)o(tin)o(uations,)h(resp)q(ectiv)o(ely)l(,)h(that)d(will)j(b)q(e)e(giv)o +(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 +Fi(writeFile)f Fp(is:)71 2237 y Fi(writeFile)356 b(::)24 b(Name)f(->)h +(String)f(->)g(FailCont)g(->)h(SuccCont)f(->)g(Dialogue)71 +2294 y(type)g(Name)357 b(=)24 b(String)0 2403 y Fp(So)15 b(w)o(e)g(see)h +(that)e(the)h(result)h(of)f(the)g(application)i(of)e Fi(writeFile)f +Fp(has)h(the)g(appropriate)g(t)o(yp)q(e:)20 b Fi(Dialogue)o +Fp(.)71 2501 y(But)g(what)f(exactly)h(are)g Fi(FailCont)e Fp(and)j +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 +(understand)i(what)0 2557 y(kinds)16 b(of)e(\\in)o(termediate)h(v)m(alues")h +(are)e(generated)h(b)o(y)f(the)h(v)m(arious)g(transactions.)k(F)l(or)14 +b(example,)i Fo(failur)n(e)e Fp(of)g(a)0 2614 y(transaction)h(ma)o(y)f +(generate)h(an)o(y)g(of)g(the)g(follo)o(wing)h(kinds)g(of)f(errors:)p +eop +%%Page: 44 44 +bop 0 -40 a Fp(T-44)1417 b Fj(8)45 b(INPUT/OUTPUT)71 160 y +Fi(data)23 b(IOError)285 b(=)24 b(WriteError)46 b(String)643 +216 y(|)24 b(ReadError)70 b(String)643 272 y(|)24 b(SearchError)e(String)643 +329 y(|)i(FormatError)e(String)643 385 y(|)i(OtherError)46 +b(String)0 494 y Fp(and)15 b(th)o(us)g Fi(FailCont)f Fp(is)i(de\014ned)h(as:) +71 595 y Fi(type)23 b(FailCont)261 b(=)24 b(IOError)f(->)h(Dialogue)0 +704 y Fp(In)16 b(con)o(trast)e(to)g(failure,)i Fo(suc)n(c)n(ess)e +Fp(of)g Fi(writeFile)g Fp(do)q(esn't)h(really)h(return)g Fo(anything)p +Fp(,)e(so)h Fi(SuccCont)f Fp(is)i(simply:)71 813 y Fi(type)23 +b(SuccCont)261 b(=)24 b(Dialogue)0 922 y Fp(A)19 b(simple)h(failure)f(con)o +(tin)o(uation)g(that)f(is)h(prede\014ned)h(in)f(Hask)o(ell)h(is)f(one)f(that) +g(ignores)h(the)g(error)e(message)0 978 y(and)e(halts:)71 1078 +y Fi(abort)452 b(::)24 b(FailCont)71 1135 y(abort)f(err)357 +b(=)24 b(done)0 1244 y Fp(A)15 b(b)q(etter)g(one,)g(also)h(prede\014ned,)g +(prin)o(ts)f(the)h(error)e(message)h(to)g Fi(stderror)f Fp(b)q(efore)h +(halting:)71 1353 y Fi(exit)476 b(::)48 b(FailCont)71 1409 +y(exit)23 b(err)381 b(=)48 b(appendChan)22 b(stderr)h(msg)h(abort)f(done)715 +1466 y(where)g(msg)h(=)f(case)h(err)f(of)h(ReadError)70 b(s)24 +b(->)f(s)1288 1522 y(WriteError)46 b(s)24 b(->)f(s)1288 1579 +y(SearchError)f(s)i(->)f(s)1288 1635 y(FormatError)f(s)i(->)f(s)1288 +1692 y(OtherError)46 b(s)24 b(->)f(s)71 1850 y Fp(Returning)18 +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) +g(is)i(simply)g(to)e(halt)g(after)g(writing)i(to)0 1906 y(the)c(\014le,)h +(and)g(prin)o(t)f(an)o(y)g(error)f(message)h(that)g(migh)o(t)g(arise,)g(w)o +(e)g(w)o(ould)g(write:)71 2015 y Fi(main)476 b(=)24 b(writeFile)f("ReadMe")f +(s)i(exit)f(done)71 2173 y Fp(The)15 b(transaction)g Fi(readFile)f +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 +(t)o(yp)q(e)g(is)h(giv)o(en)g(b)o(y:)71 2282 y Fi(readFile)380 +b(::)24 b(Name)f(->)h(FailCont)f(->)g(StrCont)g(->)h(Dialogue)71 +2339 y(type)f(StrCont)285 b(=)24 b(String)f(->)h(Dialogue)0 +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 +(\014le)i(previously)f(written:)71 2557 y Fi(main)476 b(=)24 +b(readFile)f("ReadMe")g(exit)g(\(\\s->...\))p eop +%%Page: 45 45 +bop 0 -40 a Fj(8.2)45 b(Con)o(tin)o(uation)15 b(Based)g(I/O)1271 +b Fp(T-45)0 105 y(where)15 b(the)h Fi(...)e Fp(re\015ects)i(whatev)o(er)e(it) +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 +183 y(Pragmatically)l(,)f(it)h(ma)o(y)e(seem)i(that)e Fi(readFile)g +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 +(space)h(and)0 240 y(time)k(p)q(erformance)g(under)h(certain)g +(circumstances.)32 b(Ho)o(w)o(ev)o(er,)18 b(this)i(is)f(not)g(the)g(case.)31 +b(The)19 b(k)o(ey)g(p)q(oin)o(t)g(is)0 296 y(that)c Fi(readFile)g +Fp(returns)h(a)g(\\lazy")g(\(i.e.)23 b(non-strict\))16 b(list)h(of)f(c)o +(haracters)f(\(recall)i(that)f(strings)g(are)f(just)h(lists)0 +353 y(of)e(c)o(haracters)g(in)i(Hask)o(ell\),)f(whose)g(elemen)o(ts)g(are)f +(read)h(\\b)o(y)g(demand")g(just)f(lik)o(e)i(an)o(y)e(other)h(list.)20 +b(An)15 b(imple-)0 409 y(men)o(tation)f(can)g(b)q(e)h(exp)q(ected)h(to)e +(implemen)o(t)h(this)g(demand-driv)o(en)h(b)q(eha)o(vior)f(b)o(y)f(reading)h +(one)f(c)o(haracter)g(at)0 465 y(a)h(time)g(from)g(the)g(\014le.)71 +543 y(There)k(are)g(lots)h(of)f(other)g(transactions)g(a)o(v)m(ailable)i(in)f +(the)g(Hask)o(ell)g(I/O)g(design,)h(whic)o(h)f(primarily)h(re-)0 +600 y(\015ects)d(the)g(desire)h(for)e(compatibilit)o(y)j(with)e(con)o(v)o(en) +o(tional)g(op)q(erating)g(systems.)27 b(F)l(or)18 b(example,)h(there)f(is)g +(an)0 656 y Fi(appendFile)e Fp(transaction)g(whic)o(h)i(writes)f(a)f(string)h +(to)g(the)g(end)g(of)g(a)f(\014le.)26 b(There)18 b(are)e(also)h +Fo(binary)g Fp(v)o(ersions)0 713 y(of)e Fi(readFile)o Fp(,)f +Fi(writeFile)o Fp(,)h(and)g Fi(appendFile)f Fp(\()p Fn(x)p +Fp(7\).)71 791 y(Also)h(included)j(among)c(the)h(standard)f(op)q(erations)i +(are)e(those)h(whic)o(h)h(in)o(teract)f(with)g Fo(channels)p +Fp(,)e(whic)o(h)j(in)0 847 y(Unix-land)k(includes)g(things)e(lik)o(e)h +(standard-input,)g(standard-output,)f(etc.)27 b(The)19 b(t)o(w)o(o)d(most)h +(imp)q(ortan)o(t)g(of)0 904 y(these)e(are:)71 1004 y Fi(readChan)380 +b(::)24 b(Name)f(->)262 b(FailCont)23 b(->)h(StrCont)47 b(->)23 +b(Dialogue)71 1060 y(appendChan)332 b(::)24 b(Name)f(->)h(String)f(->)g +(FailCont)g(->)h(SuccCont)f(->)g(Dialogue)0 1169 y Fp(There)12 +b(is)g(no)g Fi(writeChan)f Fp(transaction,)h(since)h(the)f(output)f(is)i(alw) +o(a)o(ys)e(app)q(ended)i(to)e(whatev)o(er)h(w)o(as)f(previously)0 +1226 y(written)k(\(th)o(us)g Fi(appendChan)f Fp(is)h(akin)h(to)f +Fi(appendFile)n Fp(\).)71 1304 y(Note)g(that)h(c)o(hannel)h(names)f(are)g +(just)f(strings)h(\(lik)o(e)h(\014le)g(names\).)23 b(There)16 +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 +(orted)i(b)o(y)f(a)g(prop)q(er)h(implemen)o(tation,)g(and)f(are)g(b)q(ound)h +(to)f(the)g(follo)o(wing)h(iden)o(ti\014ers:)71 1469 y Fi(stdin)452 +b(=)48 b("stdin")71 1526 y(stdout)428 b(=)48 b("stdout")71 +1582 y(stderr)428 b(=)48 b("stderr")71 1639 y(stdecho)404 b(=)48 +b("stdecho")0 1750 y Fp(On)12 b(most)f(systems,)g Fi(stdout)p +Fp(,)g Fi(stderr)p Fp(,)h(and)f Fi(stdecho)g Fp(all)h(represen)o(t)g(the)g +(same)f(ph)o(ysical)i(c)o(hannel)g(\(nominally)l(,)0 1807 y(the)i(user's)g +(terminal)h(displa)o(y\).)71 1885 y(Let's)k(no)o(w)g(consider)h(a)f(sligh)o +(tly)i(bigger)f(program|one)f(that)f(writes)i(to)f(a)g(\014le,)i(reads)e(the) +h(\014le)g(bac)o(k,)0 1941 y(compares)15 b(the)h(con)o(ten)o(ts)e(for)h +(equalit)o(y)h(with)g(what)f(w)o(as)f(previously)j(written,)e(prin)o(ts)h(a)f +(suitable)i(message)e(to)0 1998 y(standard)g(output,)f(and)i(halts:)71 +2107 y Fi(main)94 b(=)24 b(writeFile)f("ReadMe")g(s1)g(exit)h(\()309 +2163 y(readFile)47 b("ReadMe")94 b(exit)24 b(\(\\s2->)309 2220 +y(appendChan)f(stdout)g(\(if)g(s1==s2)g(then)h("contents)e(match")1001 +2276 y(else)i("something)e(intervened!"\))g(exit)309 2333 y(done\)\))0 +2444 y Fp(This)f(program)e(demonstrates)g(an)h(imp)q(ortan)o(t)f(asp)q(ect)i +(of)e(Hask)o(ell)i(I/O|it)g(p)q(ermits)g Fo(nondeterminism)e +Fp(in)0 2501 y(the)e(op)q(erating)g(system)f(\(if)h(it)g(didn't,)g(it)g(w)o +(ould)g(hardly)h(b)q(e)f(practical!\),)g(y)o(et)f(in)o(ternally)j(programs)c +(are)i(still)0 2557 y(referen)o(tially)d(transparen)o(t.)k(In)13 +b(this)g(example)h(there)f(is)g(the)f(p)q(ossibilit)o(y)j(\(alb)q(eit)f +(small\))f(that)f(the)h(test)f Fi(s1==s2)0 2614 y Fp(will)17 +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 +(\014le)h(b)q(et)o(w)o(een)f(the)g(times)g(it)g(w)o(as)f(written)h(and)g +(read.)p eop +%%Page: 46 46 +bop 0 -40 a Fp(T-46)1417 b Fj(8)45 b(INPUT/OUTPUT)71 105 y +Fp(Also)16 b(note)g(ho)o(w)g(this)g(program)f(is)i(formatted,)e(giving)i(it)f +(an)g(\\imp)q(erativ)o(e)h(feel.")24 b(W)l(e)16 b(can)g(enhance)i(this)0 +162 y(st)o(yle)d(b)o(y)g(using)h(an)g(in\014x)g(apply)g(op)q(erator:)71 +271 y Fi(infixr)23 b(0)g($)71 327 y(f)g($)h(a)71 b(=)24 b(f)g(a)71 +407 y(main)94 b(=)24 b(writeFile)47 b("ReadMe")22 b(s1)i(exit)f($)309 +463 y(readFile)71 b("ReadMe")94 b(exit)23 b($)h(\\s2->)309 +520 y(appendChan)f(stdout)g(\(if)g(s1==s2)g(then)h("contents)e(match")1001 +576 y(else)i("somebody)e(intervened!"\))g(exit)i($)309 632 +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 +(not)h(requiring)h(the)f(nesting)g(of)g(paren)o(theses,)g(whic)o(h)h(in)f +(larger)g(programs)0 798 y(can)j(b)q(ecome)h(quite)g(anno)o(ying.)0 +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 +(tion)d(should)i(b)q(e)f(made)g(of)f(reading)h(from)f(standard)g(input,)h(in) +g(that)f(what)g(is)h(returned)g(is)g(a)f(lazy)0 1264 y(string,)f(just)g(as)g +(for)g(a)g(\014le.)20 b(The)13 b(\014rst)g(issue)h(that)f(arises)g(is)h +(whether)f(the)h(input)g(is)g(\\ec)o(ho)q(ed")f(on)g(the)h(terminal,)0 +1320 y(or)e(whether)h(the)g(user)f(is)h(required)h(to)e(do)h(so)f(explicitly) +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 +(hoice!)20 b(The)12 b(default)0 1377 y(is)k(that)f(ec)o(hoing)i(is)f(\\on,")f +(but)g(it)h(can)g(b)q(e)g(turned)h(o\013)d(\(or)h(on\))h(using)g(the)g +Fi(echo)f Fp(transaction,)g(whic)o(h)h(tak)o(es)f(a)0 1433 +y(b)q(o)q(olean)h(argumen)o(t)f(along)g(with)g(the)h(\(ubiquitous\))g +(failure)g(and)f(success)h(con)o(tin)o(uations:)71 1545 y Fi(echo)476 +b(::)24 b(Bool)f(->)h(FailCont)f(->)g(SuccCont)g(->)h(Dialogue)0 +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 +(if,)f(for)f(example,)h(w)o(e)g(w)o(an)o(ted)f(to)g(write)g(a)h(screen-orien) +o(ted)g(text)0 1710 y(editor.)71 1823 y(Since)13 b(the)f(result)g(of)f +(reading)i(from)e Fi(stdin)g Fp(is)h(a)g(lazy)g(string,)g(that)f(means)h(it)g +(only)g(has)g(to)f(b)q(e)h(done)h Fo(onc)n(e)e Fp(for)0 1880 +y(a)k(giv)o(en)h(program|indeed,)g(a)f(run-time)i(error)e(will)i(result)f(if) +f(it)h(is)g(done)g(more)f(than)g(once.)21 b(But)16 b(this)g(raises)0 +1936 y(the)f(follo)o(wing)g(question:)20 b(if)c(ec)o(hoing)f(is)g(enabled,)h +(the)f(input)h(stream)d(will)k(app)q(ear)e(on)f(the)h Fi(stdecho)f +Fp(c)o(hannel)0 1993 y(\(whic)o(h)k(on)g(most)f(systems)h(is)g(synon)o(ymous) +g(with)g Fi(stdout)o Fp(\);)h(but)f(then)g(ho)o(w)f(is)i(this)f(output)g +(\\in)o(terlea)o(v)o(ed")0 2049 y(with)e(explicit)h(output)e(to)f(the)i(same) +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) +g(question)h(requires)f(de\014ning)i(precisely)g(the)e(b)q(eha)o(vior)g(of)g +(the)g(op)q(erating)0 2218 y(system;)j(that's)g(wh)o(y)g(in)i(the)e(App)q +(endix)j(of)d(the)h(Rep)q(ort)g(a)g(sp)q(eci\014cation)h(of)e(the)h(op)q +(erating)g(system)f(is)h(giv)o(en)0 2275 y(in)g(Hask)o(ell)g(co)q(de.)21 +b(Here,)15 b(w)o(e)g(simply)h(giv)o(e)f(an)h(op)q(erational)f(description)i +(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) +g(consider)h(whether)f(ec)o(hoing)h(is)g(enabled)g(or)f(disabled.)25 +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 +(editing)f(functions)g(lik)o(e)g(\\rub)q(out")f(to)g(b)q(e)g(handled)i +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 +2501 y(result,)i(and)f(indeed)i(that's)d(what)g(happ)q(ens)i(in)g(Hask)o +(ell.)29 b(This)19 b(means)f(that)f(the)h(user)g(input)h(is)g(e\013ectiv)o +(ely)0 2557 y(seen)e(\\line-at-a-time,")h(since)f(a)f(series)h(of)f(rub)q +(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 +b(Consider,)17 b(for)0 2614 y(example,)f(this)f(program:)p +eop +%%Page: 47 47 +bop 0 -40 a Fj(8.4)45 b(Finer)15 b(Lev)o(el)i(of)d(Con)o(trol)1311 +b Fp(T-47)71 160 y Fi(main)285 b(=)24 b(echo)f(flag)h(exit)262 +b($)500 216 y(readChan)23 b(stdin)g(exit)143 b($)23 b(\\s->)500 +272 y(appendChan)g(stdout)g(s)g(exit)h($)500 329 y(done)0 438 +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 +(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 +(en)o(tire)h(line,)h(with)f(correc-)0 494 y(tions)k(b)q(eing)h(dutifully)h +(pro)q(cessed.)25 b(When)17 b(a)f(new-line)j(c)o(haracter)d(is)h(t)o(yp)q +(ed,)g(the)g Fi(appendChan)e Fp(transaction)0 551 y(will)20 +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 +(displa)o(y)h(the)g(line)h(just)e(t)o(yp)q(ed,)h(with)g(corrections.)0 +607 y(This)d(pro)q(cess)f(will)i(then)f(rep)q(eat)f(for)g(subsequen)o(t)h +(lines;)g(in)g(other)f(w)o(ords,)f(the)h(ec)o(hoing)h(and)g(explicit)h +(output)0 664 y(are)f(in)o(terlea)o(v)o(ed)h(line-at-a-time.)26 +b(Note)16 b(that)g(this)h(program)e(is)i(essen)o(tially)h(in)f(an)g +(in\014nite)h(lo)q(op,)f(unless)h(the)0 720 y(user)h(terminates)h(the)f +(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 +(vironmen)o(t\),)g(in)g(whic)o(h)g(case)0 777 y Fi(appendChan)14 +b Fp(can)h(\014nish)i(its)e(task.)71 858 y(On)j(the)h(other)f(hand,)h(if)f +Fi(flag)g Fp(is)h Fi(False)o Fp(,)g(ec)o(hoing)g(is)f(disabled,)j(and)d +Fi(appendChan)f Fp(will)j(see)f(the)f(input)0 915 y(c)o(haracter-b)o(y-c)o +(haracter.)g(Th)o(us)12 b(the)g(e\013ect)f(of)h Fi(appendChan)e +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 +996 y(The)17 b(other)f(factor)g(in)i(determining)g(the)g(in)o(terlea)o(ving)g +(b)q(eha)o(vior)f(is)h(the)f(degree)g(to)f(whic)o(h)i(the)f(program)0 +1052 y Fo(dep)n(ends)j Fp(on)h(the)g(input)h(stream.)36 b(F)l(or)20 +b(example,)j(a)e(program)f(that)g(prin)o(ts)h(one)g Fi("X")g +Fp(for)f(ev)o(ery)h(10)f(input)0 1109 y(c)o(haracters)14 b(will)j(b)q(eha)o +(v)o(e)f(as)f(exp)q(ected;)h(here)f(is)h(suc)o(h)f(a)g(program:)71 +1218 y Fi(main)94 b(=)24 b(readChan)f(stdin)g(exit)g($)h(\\s->)309 +1274 y(let)g(loop)f(n)48 b([])310 b(=)23 b(done)405 1331 y(loop)g(n)h +(\(x:xs\))f(|)g(n==10)48 b(=)23 b(appendChan)g(stdout)g("X")g(exit)h($)1001 +1387 y(loop)95 b(1)48 b(xs)739 1444 y(|)23 b(True)72 b(=)23 +b(loop)h(\(n+1\))f(xs)309 1500 y(in)h(loop)f(1)h(s)0 1612 y +Fp(This)19 b(program)e(also)h(demonstrates)g(ho)o(w)f(to)h(write)g(a)g(lo)q +(op)h(\(i.e.)f(a)g(recursion\))g(using)h(con)o(tin)o(uations.)30 +b(\(See)0 1668 y Fn(x)p Fp(7.7)14 b(for)h(another)g(example)h(of)f(sync)o +(hronizing)h(input)h(with)e(output.\))71 1750 y(There)g(are)g(sev)o(eral)g(v) +o(ery)g(useful)h(prede\014ned)h(functions)f(in)g(Hask)o(ell)g(that)f(mak)o(e) +f(in)o(teractions)i(with)f(stan-)0 1806 y(dard)20 b(input)h(and)f(output)g +(relativ)o(ely)h(painless.)36 b(These)21 b(are)e Fi(print)p +Fp(,)h Fi(prints)p Fp(,)g(and)h Fi(interact)o Fp(,)f(whic)o(h)h(are)0 +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 +2009 y Fg(8.4)56 b(Finer)18 b(Lev)n(el)f(of)i(Con)n(trol)0 +2120 y Fp(Sometimes)c(\(although)f(rarely\))g(the)h(user)f(will)i(need)g(a)e +(\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) +o(vided)0 2176 y(b)o(y)g(the)f(standard)h(set)f(of)g(I/O)h(transactions)f +(pro)o(vided)i(in)f(Hask)o(ell)h(\(for)e(example,)h(sometimes)g(it)g(is)g +(necessary)0 2233 y(to)f(explicitly)k(op)q(en)e(and)f(close)h(\014les\).)20 +b(This)15 b(fact)e(is)i(recognized)g(in)g(App)q(endix)h Fn(x)p +Fp(C,)e(where)g(an)g(alternativ)o(e)g(set)0 2289 y(of)h(I/O)g(op)q(erations)h +(is)f(suggested)h(and)f(that)f(some)h(implemen)o(tations)i(ma)o(y)d(supp)q +(ort.)p eop +%%Page: 48 48 +bop 0 -40 a Fp(T-48)1597 b Fj(9)45 b(ARRA)l(YS)0 105 y Fq(9)69 +b(Arra)n(ys)0 236 y Fp(Ideally)l(,)13 b(arra)o(ys)d(in)i(a)f(functional)h +(language)f(w)o(ould)g(b)q(e)h(regarded)f(simply)h(as)f(functions)h(from)e +(indices)j(to)d(v)m(alues,)0 292 y(but)16 b(pragmatically)l(,)g(in)h(order)e +(to)g(assure)h(e\016cien)o(t)g(access)g(to)f(arra)o(y)g(elemen)o(ts,)h(w)o(e) +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 +(of)h(the)g(sp)q(ecial)h(prop)q(erties)g(of)e(the)h(domains)g(of)g(these)g +(functions,)h(whic)o(h)f(are)g(isomorphic)0 405 y(to)h(\014nite)i(con)o +(tiguous)f(subsets)g(of)f(the)h(in)o(tegers.)34 b(Hask)o(ell,)21 +b(therefore,)f(do)q(es)g(not)g(treat)f(arra)o(ys)f(as)h(general)0 +462 y(functions)d(with)f(an)h(application)g(op)q(eration,)g(but)f(as)g +(abstract)f(data)g(t)o(yp)q(es)i(with)f(a)g(subscript)h(op)q(eration.)71 +546 y(Tw)o(o)11 b(main)h(approac)o(hes)g(to)f(functional)j(arra)o(ys)c(ma)o +(y)i(b)q(e)g(discerned:)20 b Fo(incr)n(emental)11 b Fp(and)h +Fo(monolithic)g Fp(de\014ni-)0 603 y(tion.)20 b(In)15 b(the)f(incremen)o(tal) +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) +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) +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 +(a)f(new)g(arra)o(y)f(that)g(di\013ers)h(from)f(the)h(old)0 +716 y(one)i(only)g(at)f(the)h(giv)o(en)h(index.)23 b(Ob)o(viously)l(,)17 +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 +(tics)h(w)o(ould)0 772 y(b)q(e)h(in)o(tolerably)g(ine\016cien)o(t,)g +(requiring)g(a)e(new)h(cop)o(y)g(of)g(an)f(arra)o(y)g(for)g(eac)o(h)h +(incremen)o(tal)h(rede\014nition;)h(th)o(us,)0 829 y(serious)13 +b(attempts)e(at)g(using)i(this)f(approac)o(h)g(emplo)o(y)h(sophisticated)g +(static)f(analysis)g(and)h(clev)o(er)g(run-time)f(de-)0 885 +y(vices)j(to)f(a)o(v)o(oid)h(excessiv)o(e)g(cop)o(ying.)20 +b(The)15 b(monolithic)h(approac)o(h,)e(on)g(the)h(other)f(hand,)h(constructs) +f(an)g(arra)o(y)0 941 y(all)k(at)f(once,)g(without)g(reference)h(to)f(in)o +(termediate)g(arra)o(y)f(v)m(alues.)27 b(Although)18 b(Hask)o(ell)g(has)f(an) +g(incremen)o(tal)0 998 y(arra)o(y)d(up)q(date)i(op)q(erator,)e(the)h(main)h +(thrust)e(of)h(the)g(arra)o(y)f(facilit)o(y)j(is)e(monolithic.)0 +1155 y Fg(9.1)56 b(Index)18 b(t)n(yp)r(es)0 1270 y Fp(The)d(Standard)h +(Prelude)g(de\014nes)g(a)f(t)o(yp)q(e)g(class)h(of)f(arra)o(y)f(indices:)71 +1379 y Fi(class)47 b(\(Ord)23 b(a\))h(=>)f(Ix)h(a)47 b(where)166 +1436 y(range)166 b(::)24 b(\(a,a\))f(->)h([a])166 1492 y(index)166 +b(::)24 b(\(a,a\))f(a)h(->)f(Int)166 1549 y(inRange)118 b(::)24 +b(\(a,a\))f(->)h(a)f(->)h(Bool)0 1658 y Fp(Instance)12 b(declarations)g(are)e +(pro)o(vided)i(for)f Fi(Int)o Fp(,)h Fi(Integer)o Fp(,)f Fi(Char)p +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 +(addition,)0 1714 y(instances)17 b(ma)o(y)e(b)q(e)i(automatically)f(deriv)o +(ed)h(for)f(en)o(umerated)g(and)g(tuple)h(t)o(yp)q(es.)23 b(W)l(e)16 +b(regard)f(the)i(primitiv)o(e)0 1771 y(t)o(yp)q(es)j(as)f(v)o(ector)g +(indices)i(and)f(tuples)h(as)e(indices)i(of)f(m)o(ultidimensional)i +(rectangular)e(arra)o(ys.)31 b(Note)20 b(that)0 1827 y(the)c(\014rst)g +(argumen)o(t)f(of)h(eac)o(h)g(of)f(the)h(op)q(erations)h(of)e(class)h +Fi(Ix)g Fp(is)h(a)e(pair)i(of)e(indices;)j(these)f(are)e(t)o(ypically)j(the)0 +1883 y Fo(b)n(ounds)g Fp(\(\014rst)f(and)h(last)g(indices\))i(of)e(an)g(arra) +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 +(t,)i(zero-origin)0 1940 y(v)o(ector)13 b(with)h Fi(Int)f Fp(indices)j(w)o +(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) +h(matrix)f(migh)o(t)h(ha)o(v)o(e)f(the)h(b)q(ounds)0 1996 y +Fi(\(\(1,1\),\(100,100\)\))n Fp(.)38 b(\(In)22 b(man)o(y)e(other)h +(languages,)i(suc)o(h)f(b)q(ounds)g(w)o(ould)g(b)q(e)g(written)f(in)h(a)f +(form)g(lik)o(e)0 2053 y Fi(1:100,)i(1:100)o Fp(,)17 b(but)g(the)g(presen)o +(t)f(form)g(\014ts)h(the)g(t)o(yp)q(e)g(system)f(b)q(etter,)h(since)g(eac)o +(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 +(index.\))71 2194 y(The)g Fi(range)g Fp(op)q(eration)g(tak)o(es)g(a)f(b)q +(ounds)j(pair)e(and)h(pro)q(duces)g(the)f(list)h(of)f(indices)i(lying)g(b)q +(et)o(w)o(een)e(those)0 2250 y(b)q(ounds,)g(in)g(index)g(order.)k(F)l(or)14 +b(example,)617 2357 y Fi(range)23 b(\(0,4\))72 b Fn(\))i Fi([0,1,2,3,4])151 +2468 y(range)23 b(\(\(0,0\),\(1,2\)\))72 b Fn(\))i Fi([\(0,0\),)22 +b(\(0,1\),)h(\(0,2\),)h(\(1,0\),)f(\(1,1\),)g(\(1,2\)])0 2557 +y Fp(The)17 b Fi(inRange)g Fp(predicate)h(determines)g(whether)f(an)g(index)i +(lies)f(b)q(et)o(w)o(een)g(a)e(giv)o(en)i(pair)g(of)e(b)q(ounds.)27 +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 +(erformed)g(comp)q(onen)o(t)o(wise.\))19 b(Finally)l(,)14 b(the)e +Fi(index)f Fp(op)q(eration)h(is)g(what)f(is)i(needed)g(to)p +eop +%%Page: 49 49 +bop 0 -40 a Fj(9.2)45 b(Arra)o(y)14 b(Creation)1451 b Fp(T-49)0 +105 y(address)13 b(a)g(particular)h(elemen)o(t)g(of)f(an)g(arra)o(y:)k(Giv)o +(en)d(a)f(b)q(ounds)h(pair)g(and)f(an)g(in-range)h(index,)g(the)g(op)q +(eration)0 162 y(yields)j(the)e(zero-origin)h(ordinal)g(of)f(the)g(index)i +(within)f(the)f(range;)g(for)g(example:)712 259 y Fi(index)23 +b(\(1,9\))g(2)73 b Fn(\))h Fi(1)569 357 y(index)23 b(\(\(0,0\),\(1,2\)\))f +(\(1,1\))73 b Fn(\))g Fi(5)0 501 y Fg(9.2)56 b(Arra)n(y)19 +b(Creation)0 610 y Fp(Hask)o(ell's)h(monolithic)h(arra)o(y)d(creation)i +(function)h(forms)d(an)i(arra)o(y)e(from)h(a)g(pair)h(of)f(b)q(ounds)i(and)f +(a)f(list)h(of)0 666 y(index-v)m(alue)e(pairs)d(\(an)g Fo(asso)n(ciation)h +(list)p Fp(\):)71 778 y Fi(array)452 b(::)24 b(\(Ix)f(a\))h(=>)g(\(a,a\))f +(->)g([Assoc)g(a)h(b])g(->)f(Array)g(a)h(b)0 887 y Fp(Notice)15 +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) +o(y)g(of)f(arra)o(y)f(expressions,)i(the)f(pairs)h(in)g(the)g(asso)q(ciation) +0 944 y(list)h(are)f(not)g(of)f(the)i(ordinary)f(sort,)f(but)h(of)g(another)g +(tuple)h(t)o(yp)q(e)f(with)h(the)f(data)g(constructor)f Fi(\(:=\))p +Fp(:)71 1053 y Fi(data)47 b(Assoc)23 b(a)h(b)214 b(=)48 b(a)24 +b(:=)f(b)0 1162 y Fp(Here,)15 b(for)g(example,)g(is)h(a)f(de\014nition)i(of)e +(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 +(100:)71 1271 y Fi(squares)404 b(=)48 b(array)23 b(\(1,100\))g([i)h(:=)f(i)h +(*)g(i)f(|)h(i)g(<-)f([1..100]])0 1380 y Fp(This)17 b(arra)o(y)e(expression)j +(is)f(t)o(ypical)g(in)h(using)f(a)f(list)h(comprehension)h(for)e(the)h(asso)q +(ciation)g(list;)g(in)h(fact,)e(this)0 1436 y(usage)e(results)h(in)g(arra)o +(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 +(ehensions)e Fp(of)h(the)g(language)h(Id[4].)k(Arra)o(y)0 1493 +y(subscripting)f(is)f(p)q(erformed)g(with)g(the)g(in\014x)g(op)q(erator)f +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 +(extracted)0 1549 y(with)f(the)f(function)h Fi(bounds)o Fp(:)748 +1606 y Fi(squares!7)72 b Fn(\))h Fi(49)628 1687 y(bounds)24 +b(squares)72 b Fn(\))h Fi(\(1,100\))0 1768 y Fp(W)l(e)15 b(migh)o(t)f +(generalize)j(this)e(example)g(b)o(y)g(parameterizing)h(the)e(b)q(ounds)i +(and)f(the)g(function)g(to)g(b)q(e)g(applied)i(to)0 1824 y(eac)o(h)e(index:) +71 1924 y Fi(mkArray)404 b(::)24 b(\(Ix)f(a\))h(=>)g(\(a)f(->)h(b\))f(->)h +(\(a,a\))f(->)h(Array)f(a)h(b)71 1981 y(mkArray)e(f)i(bnds)238 +b(=)48 b(array)23 b(bnds)g([i)h(:=)g(f)f(i)h(|)g(i)f(<-)h(range)f(bnds])0 +2090 y Fp(Th)o(us,)15 b(w)o(e)g(could)h(de\014ne)g Fi(squares)e +Fp(as)h Fi(mkArray)23 b(\(\\i)h(->)f(i)h(*)g(i\))f(\(1,100\))o +Fp(.)71 2170 y(Man)o(y)12 b(arra)o(ys)g(are)h(de\014ned)i(recursiv)o(ely;)g +(that)e(is,)g(with)h(the)g(v)m(alues)g(of)f(some)g(elemen)o(ts)h(dep)q +(ending)i(on)d(the)0 2226 y(v)m(alues)j(of)f(others.)20 b(Here,)15 +b(for)f(example,)i(w)o(e)f(ha)o(v)o(e)g(a)f(function)i(returning)g(an)f(arra) +o(y)f(of)h(Fib)q(onacci)i(n)o(um)o(b)q(ers:)71 2335 y Fi(fibs)94 +b(::)24 b(Int)g(->)f(Array)g(Int)h(Int)71 2392 y(fibs)f(n)47 +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 +(++)954 2448 y([i)g(:=)h(a!\(i-2\))f(+)g(a!\(i-1\))g(|)h(i)g(<-)f([2..n]]\))0 +2557 y Fp(Another)18 b(example)i(of)e(suc)o(h)h(a)f(recurrence)h(is)g(the)g +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 +(ts)f(of)f(the)0 2614 y(\014rst)f(ro)o(w)e(and)j(\014rst)e(column)i(all)g(ha) +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 +(sums)h(of)g(their)g(neigh)o(b)q(ors)h(to)p eop +%%Page: 50 50 +bop 0 -40 a Fp(T-50)1597 b Fj(9)45 b(ARRA)l(YS)0 105 y Fp(the)15 +b(w)o(est,)f(north)o(w)o(est,)g(and)h(north:)71 214 y Fi(wavefront)165 +b(::)24 b(Int)f(->)h(Array)f(\(Int,Int\))g(Int)71 271 y(wavefront)f(n)119 +b(=)48 b(a)g(where)524 327 y(a)24 b(=)f(array)h(\(\(1,1\),\(n,n\)\))643 +383 y(\([\(1,j\))f(:=)h(1)g(|)f(j)h(<-)g([1..n]])e(++)667 440 +y([\(i,1\))h(:=)h(1)g(|)f(i)h(<-)g([2..n]])e(++)667 496 y([\(i,j\))h(:=)h +(a!\(i,j-1\))e(+)i(a!\(i-1,j-1\))f(+)g(a!\(i-1,j\))954 553 +y(|)g(i)h(<-)g([2..n],)e(j)i(<-)g([2..n]]\))0 662 y Fp(The)13 +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 +(parallel)i(implemen)o(tation,)g(the)f(recurrence)g(dictates)g(that)0 +718 y(the)f(computation)h(can)f(b)q(egin)h(with)g(the)f(\014rst)g(ro)o(w)f +(and)i(column)g(in)g(parallel)h(and)e(pro)q(ceed)h(as)f(a)g(w)o(edge-shap)q +(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 +(to)g(southeast.)28 b(It)18 b(is)g(imp)q(ortan)o(t)g(to)f(note,)h(ho)o(w)o +(ev)o(er,)g(that)f(no)h(order)f(of)0 831 y(computation)e(is)h(sp)q(eci\014ed) +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 +(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 +(ciation)g(for)e(eac)o(h)i(index)g(of)f(the)g(arra)o(y)0 1015 +y(and)j(only)f(for)g(the)h(indices)h(within)g(the)e(b)q(ounds)h(of)f(the)h +(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 +1072 y(for)14 b(an)h(arra)o(y)f(b)q(e)i(fully)h(de\014ned.)k(An)15 +b(asso)q(ciation)h(with)f(an)g(out-of-b)q(ounds)h(index)g(results)f(in)h(an)f +(error;)f(if)i(an)0 1128 y(index)g(is)e(missing)i(or)d(app)q(ears)i(more)f +(than)g(once,)g(ho)o(w)o(ev)o(er,)g(there)g(is)h(no)f(immediate)i(error,)d +(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 +(then)f(unde\014ned,)i(so)d(that)h(subscripting)h(the)f(arra)o(y)f(with)h +(suc)o(h)g(an)g(index)h(yields)0 1241 y(an)f(error.)0 1542 +y Fg(9.3)56 b(Accum)n(ulation)0 1721 y Fp(W)l(e)14 b(can)g(relax)g(the)g +(restriction)g(that)f(an)h(index)h(app)q(ear)f(at)g(most)f(once)h(in)g(the)g +(asso)q(ciation)h(list)f(b)o(y)g(sp)q(ecifying)0 1777 y(ho)o(w)h(to)g(com)o +(bine)h(m)o(ultiple)i(v)m(alues)f(asso)q(ciated)e(with)h(a)g(single)g(index;) +h(the)f(result)g(is)g(called)h(an)f Fo(ac)n(cumulate)n(d)0 +1834 y(arr)n(ay)p Fp(:)71 1943 y Fi(accumArray)22 b(::)i(\(Ix)f(a\))h(->)f +(\(b)h(->)f(c)h(->)g(b\))f(->)h(b)g(->)f(\(a,a\))g(->)h([Assoc)f(a)h(c])f(->) +h(Array)f(a)h(b)0 2054 y Fp(The)15 b(\014rst)g(argumen)o(t)g(of)g +Fi(accumArray)e Fp(is)j(the)g Fo(ac)n(cumulating)g(function)p +Fp(,)e(the)i(second)f(is)h(an)f(initial)j(v)m(alue)e(\(the)0 +2111 y(same)g(for)f(eac)o(h)i(elemen)o(t)g(of)e(the)i(arra)o(y\),)d(and)i +(the)h(remaining)g(argumen)o(ts)e(are)h(b)q(ounds)h(and)f(an)h(asso)q +(ciation)0 2167 y(list,)e(as)f(with)h(the)g Fi(array)e Fp(function.)21 +b(T)o(ypically)l(,)16 b(the)f(accum)o(ulating)g(function)g(is)g +Fi(\(+\))p Fp(,)f(and)h(the)f(initial)j(v)m(alue,)0 2224 y(zero;)f(for)g +(example,)h(this)f(function)h(tak)o(es)f(a)f(pair)i(of)f(b)q(ounds)h(and)f(a) +g(list)h(of)f(v)m(alues)h(\(of)e(an)h(index)i(t)o(yp)q(e\))e(and)0 +2280 y(yields)h(a)e(histogram;)f(that)g(is,)i(a)e(table)i(of)f(the)g(n)o(um)o +(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 +(ounds:)71 2389 y Fi(hist)285 b(::)24 b(\(Ix)f(a,)h(Integral)f(b\))g(=>)h +(\(a,a\))f(->)h([a])f(->)h(Array)f(a)h(b)71 2446 y(hist)f(bnds)g(is)95 +b(=)48 b(accumArray)22 b(\(+\))i(0)g(bnds)f([i)h(:=)f(1)h(|)g(i)f(<-)h(is,)f +(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 +(collection)j(of)d(measuremen)o(ts)h(on)g(the)f(in)o(terv)m(al)i([)p +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) +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 +(n)o(um)o(b)q(er)h(of)e(measuremen)o(ts)h(within)i(eac)o(h:)p +eop +%%Page: 51 51 +bop 0 -40 a Fj(9.4)45 b(Incremen)o(tal)16 b(up)q(dates)1348 +b Fp(T-51)71 160 y Fi(decades)213 b(::)24 b(\(RealFrac)f(a\))g(=>)h(a)g(->)f +(a)h(->)f([a])h(->)f(Array)h(Int)f(Int)71 216 y(decades)f(a)i(b)119 +b(=)48 b(hist)23 b(\(0,9\))g(.)h(map)g(decade)524 272 y(where)f(decade)g(x)h +(=)g(floor)f(\(\(x)g(-)h(a\))g(*)f(s\))667 329 y(s)191 b(=)24 +b(10)f(/)h(\(b)g(-)f(a\))0 572 y Fg(9.4)56 b(Incremen)n(tal)16 +b(up)r(dates)0 691 y Fp(In)d(addition)g(to)e(the)i(monolithic)g(arra)o(y)e +(creation)h(functions,)h(Hask)o(ell)g(also)f(has)g(an)g(incremen)o(tal)i +(arra)o(y)c(up)q(date)0 747 y(function,)15 b(written)g(as)f(the)h(in\014x)g +(op)q(erator)f Fi(//)p Fp(;)g(the)h(simplest)h(case,)e(an)h(arra)o(y)e +Fi(a)h Fp(with)h(elemen)o(t)h Fi(i)e Fp(up)q(dated)i(to)0 804 +y Fi(v)p Fp(,)e(is)i(written)e Fi(a)24 b(//)g([i)f(:=)h(v])p +Fp(.)19 b(The)c(reason)g(for)f(the)g(square)h(brac)o(k)o(ets)f(is)h(that)f +(the)h(left)g(argumen)o(t)f(of)h Fi(\(//\))0 860 y Fp(is)h(an)f(asso)q +(ciation)g(list,)h(usually)h(con)o(taining)f(a)e(prop)q(er)i(subset)f(of)g +(the)g(indices)j(of)c(the)i(arra)o(y:)71 969 y Fi(\(//\))285 +b(::)24 b(\(Ix)f(a\))h(=>)g(Array)f(a)h(b)f(->)h([Assoc)f(a)h(b])f(->)h +(Array)f(a)h(b)0 1078 y Fp(As)15 b(with)h(the)f Fi(array)g +Fp(function,)h(the)f(indices)i(in)f(the)g(asso)q(ciation)g(list)g(m)o(ust)e +(b)q(e)i(unique)h(for)e(the)g(v)m(alues)i(to)d(b)q(e)0 1135 +y(de\014ned.)21 b(F)l(or)15 b(example,)g(here)h(is)g(a)f(function)h(to)e(in)o +(terc)o(hange)i(t)o(w)o(o)e(ro)o(ws)g(of)h(a)f(matrix:)71 1243 +y Fi(swapRows)22 b(::)i(\(Ix)f(a,)h(Ix)g(b,)f(Enum)g(b\))h(=>)g(a)f(->)h(a)g +(->)f(Array)g(\(a,b\))h(c)f(->)h(Array)f(\(a,b\))g(c)71 1300 +y(swapRows)f(i)i(i')g(a)f(=)48 b(a)24 b(//)f(\([\(i,j\))47 +b(:=)24 b(a!\(i',j\))e(|)i(j)g(<-)f([jLo..jHi]])g(++)667 1356 +y([\(i',j\))g(:=)h(a!\(i,)f(j\))g(|)h(j)g(<-)f([jLo..jHi]]\))524 +1413 y(where)g(\(\(iLo,jLo\),\(iHi,jHi\)\))e(=)j(bounds)f(a)0 +1522 y Fp(The)15 b(concatenation)f(here)h(of)g(t)o(w)o(o)e(separate)h(list)h +(comprehensions)h(o)o(v)o(er)d(the)i(same)f(list)i(of)e Fi(j)g +Fp(indices)j(is,)d(ho)o(w-)0 1578 y(ev)o(er,)i(a)h(sligh)o(t)g +(ine\016ciency;)i(it's)d(lik)o(e)i(writing)f(t)o(w)o(o)e(lo)q(ops)i(where)g +(one)f(will)i(do)f(in)g(an)g(imp)q(erativ)o(e)g(language.)0 +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 +(of)e(a)g(lo)q(op)g(fusion)h(optimization)g(in)g(Hask)o(ell:)71 +1744 y Fi(swapRows)22 b(i)i(i')g(a)f(=)48 b(a)24 b(//)f([assoc)g(|)h(j)g(<-)f +([jLo..jHi],)858 1800 y(assoc)g(<-)h([\(i,)f(j\))h(:=)f(a!\(i',j\),)1097 +1857 y(\(i',j\))g(:=)g(a!\(i,)h(j\)])f(])524 1913 y(where)g +(\(\(iLo,jLo\),\(iHi,jHi\)\))e(=)j(bounds)f(a)0 2156 y Fg(9.5)56 +b(An)19 b(example:)j(Matrix)c(Multiplication)0 2275 y Fp(W)l(e)13 +b(complete)h(our)f(in)o(tro)q(duction)h(to)e(Hask)o(ell)i(arra)o(ys)e(with)h +(the)g(familiar)h(example)g(of)e(matrix)h(m)o(ultiplication,)0 +2331 y(taking)k(adv)m(an)o(tage)f(of)g(o)o(v)o(erloading)h(to)f(de\014ne)i(a) +e(fairly)i(general)f(function.)25 b(Since)18 b(only)g(m)o(ultiplication)h +(and)0 2388 y(addition)c(on)f(the)f(elemen)o(t)i(t)o(yp)q(e)f(of)f(the)h +(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 +(ultiplies)j(matrices)0 2444 y(of)h(an)o(y)g(n)o(umeric)h(t)o(yp)q(e)g +(unless)h(w)o(e)e(try)g(hard)g(not)g(to.)26 b(Additionally)l(,)20 +b(if)e(w)o(e)f(are)g(careful)h(to)f(apply)h(only)g Fi(\(!\))0 +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 +(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 +(the)g(four)g(ro)o(w)0 2557 y(and)e(column)h(index)f(t)o(yp)q(es)g(need)h +(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 +(ev)o(er,)d(w)o(e)g(require)i(that)e(the)h(left)0 2614 y(column)g(indices)g +(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 +(and)g(moreo)o(v)o(er,)e(that)h(the)h(b)q(ounds)g(b)q(e)h(equal:)p +eop +%%Page: 52 52 +bop 0 -40 a Fp(T-52)1597 b Fj(9)45 b(ARRA)l(YS)71 160 y Fi(matMult)213 +b(::)24 b(\(Ix)f(a,)h(Ix)g(b,)f(Ix)h(c,)f(Num)h(d\))f(=>)524 +216 y(Array)g(\(a,b\))g(d)h(->)g(Array)f(\(b,c\))g(d)h(->)f(Array)h(\(a,c\))f +(d)71 272 y(matMult)f(x)i(y)119 b(=)48 b(array)23 b(resultBounds)667 +329 y([\(i,j\))g(:=)h(sum)f([x!\(i,k\))g(*)h(y!\(k,j\))f(|)g(k)h(<-)g(range)f +(\(lj,uj\)])1025 385 y(|)h(i)g(<-)f(range)g(\(li,ui\),)1073 +442 y(j)h(<-)f(range)g(\(lj',uj'\))g(])261 498 y(where)h +(\(\(li,lj\),\(ui,uj\)\))212 b(=)48 b(bounds)23 b(x)405 555 +y(\(\(li',lj'\),\(ui',uj'\)\))116 b(=)48 b(bounds)23 b(y)405 +611 y(resultBounds)452 668 y(|)h(\(lj,uj\)==\(li',ui'\))93 +b(=)48 b(\(\(li,lj'\),\(ui,uj'\)\))452 724 y(|)24 b(otherwise)309 +b(=)24 b(error)f("matMult:)g(incompatible)f(bounds")0 833 y +Fp(As)16 b(an)h(aside,)g(w)o(e)f(can)g(also)h(de\014ne)g Fi(matMult)f +Fp(using)h Fi(accumArray)n Fp(,)g(resulting)g(in)g(a)f(presen)o(tation)h +(that)e(more)0 890 y(closely)h(resem)o(bles)g(the)g(usual)g(form)o(ulation)f +(in)h(an)f(imp)q(erativ)o(e)h(language:)71 999 y Fi(matMult)22 +b(x)i(y)119 b(=)48 b(accumArray)22 b(\(+\))i(0)g(resultBounds)786 +1055 y([\(i,j\))g(:=)f(x!\(i,k\))g(*)h(y!\(k,j\))977 1112 y(|)g(i)g(<-)f +(range)h(\(li,ui\),)1025 1168 y(j)g(<-)f(range)h(\(lj',uj'\))1025 +1224 y(k)g(<-)f(range)h(\(lj,uj\))46 b(])261 1281 y(where)24 +b(\(\(li,lj\),\(ui,uj\)\))212 b(=)48 b(bounds)23 b(x)405 1337 +y(\(\(li',lj'\),\(ui',uj'\)\))116 b(=)48 b(bounds)23 b(y)405 +1394 y(resultBounds)452 1450 y(|)h(\(lj,uj\)==\(li',ui'\))93 +b(=)48 b(\(\(li,lj'\),\(ui,uj'\)\))452 1507 y(|)24 b(otherwise)309 +b(=)24 b(error)f("matMult:)g(incompatible)f(bounds")71 1718 +y Fp(W)l(e)16 b(can)h(generalize)h(further)e(b)o(y)h(making)g(the)f(function) +i(higher-order,)f(simply)h(replacing)g Fi(sum)e Fp(and)g Fi(\(*\))0 +1775 y Fp(b)o(y)f(functional)i(parameters:)71 1883 y Fi(genMatMult)141 +b(::)24 b(\(Ix)f(a,)h(Ix)g(b,)f(Ix)h(c\))f(=>)524 1940 y(\([f])g(->)h(g\))f +(->)h(\(d)g(->)f(e)h(->)g(f\))f(->)524 1996 y(Array)g(\(a,b\))g(d)h(->)g +(Array)f(\(b,c\))g(e)h(->)f(Array)h(\(a,c\))f(g)71 2053 y(genMatMult)f(f)i(g) +g(x)f(y)48 b(=)f(array)24 b(resultBounds)643 2109 y([\(i,j\))f(:=)h(f)g +([x!\(i,k\))e(`g`)i(y!\(k,j\))f(|)h(k)f(<-)h(range)f(\(lj,uj\)])858 +2166 y(|)h(i)g(<-)f(range)g(\(li,ui\),)906 2222 y(j)h(<-)f(range)g +(\(lj',uj'\))g(])261 2279 y(where)h(\(\(li,lj\),\(ui,uj\)\))212 +b(=)48 b(bounds)23 b(x)405 2335 y(\(\(li',lj'\),\(ui',uj'\)\))116 +b(=)48 b(bounds)23 b(y)405 2392 y(resultBounds)452 2448 y(|)h +(\(lj,uj\)==\(li',ui'\))93 b(=)48 b(\(\(li,lj'\),\(ui,uj'\)\))452 +2504 y(|)24 b(otherwise)309 b(=)24 b(error)f("matMult:)g(incompatible)f +(bounds")0 2614 y Fp(APL)16 b(fans)f(will)h(recognize)g(the)g(usefulness)g +(of)f(functions)h(lik)o(e)g(the)g(follo)o(wing:)p eop +%%Page: 53 53 +bop 1857 -40 a Fp(T-53)71 160 y Fi(genMatMult)22 b(maximum)h(\(-\))71 +216 y(genMatMult)f(and)i(\(==\))0 328 y Fp(With)15 b(the)g(\014rst)f(of)g +(these,)h(the)g(argumen)o(ts)f(are)g(n)o(umeric)i(matrices,)e(and)h(the)g(\() +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 +384 y(is)g(the)g(maxim)o(um)f(di\013erence)i(b)q(et)o(w)o(een)f(corresp)q +(onding)h(elemen)o(ts)f(of)f(the)h Fo(i)5 b Fp(-th)14 b(ro)o(w)g(and)h +Fo(j)6 b Fp(-th)15 b(column)h(of)e(the)0 441 y(inputs.)30 b(In)18 +b(the)h(second)f(case,)h(the)f(argumen)o(ts)f(are)h(matrices)g(of)g(an)o(y)g +(equalit)o(y)h(t)o(yp)q(e,)f(and)h(the)f(result)h(is)f(a)0 +497 y(Bo)q(olean)d(matrix)f(in)h(whic)o(h)g(elemen)o(t)g(\()p +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 +Fo(i)5 b Fp(-th)14 b(ro)o(w)g(of)f(the)i(\014rst)e(argumen)o(t)h(and)0 +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) +o(ectors.)71 629 y(Notice)k(that)f(the)h(elemen)o(t)g(t)o(yp)q(es)g(of)g +Fi(genMatMult)e Fp(need)j(not)e(b)q(e)i(the)e(same,)i(but)e(merely)i +(appropriate)0 685 y(for)c(the)i(function)f(parameter)g Fi(g)p +Fp(.)25 b(W)l(e)17 b(could)h(generalize)h(still)f(further)f(b)o(y)g(dropping) +h(the)f(requiremen)o(t)h(that)0 742 y(the)i(\014rst)f(column)i(index)f(and)g +(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 +(t)o(w)o(o)c(matrices)i(could)g(b)q(e)0 798 y(considered)14 +b(conformable)g(as)e(long)i(as)e(the)i(lengths)f(of)g(the)g(columns)h(of)e +(the)i(\014rst)e(and)i(the)f(ro)o(ws)f(of)g(the)h(second)0 +855 y(are)k(equal.)28 b(The)18 b(reader)g(ma)o(y)f(wish)h(to)f(deriv)o(e)h +(this)h(still)g(more)e(general)h(v)o(ersion.)27 b(\()p Fc(Hin)o(t:)e +Fp(Use)18 b(the)g Fi(index)0 911 y Fp(op)q(eration)d(to)g(determine)h(the)f +(lengths.\))0 1070 y Fq(10)69 b(Ac)n(kno)n(wledgemen)n(ts)0 +1190 y Fp(Thanks)20 b(to)g(P)o(atricia)h(F)l(asel)f(and)h(Mark)f(Mundt)g(at)g +(Los)g(Alamos,)i(and)e(Nic)o(k)h(Carriero,)g(Charles)g(Consel,)0 +1247 y(Amir)f(Kishon,)h(Sandra)e(Lo)q(osemore,)h(Martin)f(Odersky)l(,)h(John) +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 +1303 y(Univ)o(ersit)o(y)i(for)f(their)g(quic)o(k)i(readings)e(of)g(earlier)h +(drafts)f(of)g(this)h(man)o(uscript.)35 b(Sp)q(ecial)23 b(thanks)d(to)f(John) +0 1360 y(P)o(eterson)c(for)f(getting)h(the)h(bugs)f(out)g(of)f(our)h(Hask)o +(ell)h(co)q(de.)0 1519 y Fq(References)0 1636 y Fp([1])22 b(R.)d(Bird)h(and)f +(P)l(.)g(W)l(adler.)32 b Fo(Intr)n(o)n(duction)19 b(to)h(F)m(unctional)f(Pr)n +(o)n(gr)n(amming)p Fp(.)31 b(Pren)o(tice)20 b(Hall,)g(New)g(Y)l(ork,)71 +1692 y(1988.)0 1780 y([2])i(P)l(.)14 b(Hudak.)20 b(Conception,)c(ev)o +(olution,)f(and)g(application)i(of)e(functional)h(programming)e(languages.)20 +b Fo(A)o(CM)71 1836 y(Computing)c(Surveys)p Fp(,)e(21\(3\):359{411,)d(1989.)0 +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 +(adler)g(\(editors\).)29 b(Rep)q(ort)18 b(on)g(the)h(Programming)e(Language) +71 1981 y(Hask)o(ell,)23 b(A)e(Non-strict)g(Purely)h(Functional)g(Language)f +(\(Version)g(1.2\).)36 b Fo(A)o(CM)20 b(SIGPLAN)g(Notic)n(es)p +Fp(,)71 2037 y(27\(5\),)13 b(Ma)o(y)h(1992.)0 2125 y([4])22 +b(R.S.)c(Nikhil.)30 b(Id)18 b(\(v)o(ersion)g(90.0\))f(reference)h(man)o(ual.) +29 b(T)l(ec)o(hnical)19 b(rep)q(ort,)f(Massac)o(h)o(usetts)f(Institute)h(of) +71 2181 y(T)l(ec)o(hnology)l(,)d(Lab)q(oratory)f(for)h(Computer)g(Science,)i +(Septem)o(b)q(er)e(1990.)0 2269 y([5])22 b(J.)15 b(Rees)h(and)g(W.)f(Clinger) +h(\(eds.\).)k(The)c(revised)928 2252 y Fm(3)964 2269 y Fp(rep)q(ort)f(on)h +(the)f(algorithmic)h(language)g(Sc)o(heme.)21 b Fo(SIG-)71 +2325 y(PLAN)15 b(Notic)n(es)p Fp(,)f(21\(12\):37{79)o(,)e(Decem)o(b)q(er)k +(1986.)0 2413 y([6])22 b(G.L.)14 b(Steele)j(Jr.)i Fo(Common)e(Lisp:)j(The)c +(L)n(anguage)p Fp(.)j(Digital)d(Press,)e(Burlington,)i(Mass.,)e(1984.)0 +2501 y([7])22 b(P)l(.)f(W)l(adler.)39 b(Ho)o(w)21 b(to)g(replace)i(failure)g +(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 +(dings)e(of)i(Confer)n(enc)n(e)e(on)71 2557 y(F)m(unctional)e(Pr)n(o)n(gr)n +(amming)h(L)n(anguages)g(and)h(Computer)h(A)o(r)n(chite)n(ctur)n(e,)f(LNCS)e +(V)m(ol.)h(201)p Fp(,)h(pages)f(113{)71 2614 y(128.)14 b(Springer)i(V)l +(erlag,)f(1985.)p eop +%%Trailer +end +userdict /end-hook known{end-hook}if +%%EOF diff --git a/doc/xinterface/xman.dvi b/doc/xinterface/xman.dvi Binary files differnew file mode 100644 index 0000000..0306db9 --- /dev/null +++ b/doc/xinterface/xman.dvi diff --git a/emacs-tools/README b/emacs-tools/README new file mode 100644 index 0000000..bb22105 --- /dev/null +++ b/emacs-tools/README @@ -0,0 +1,5 @@ +This directory contains GNU Emacs support for editing Haskell files. +We don't yet have a fancy editing mode, but haskell.el contains stuff +for running Haskell as an inferior process from Emacs with key bindings +for evaluating code from buffers, etc. Look at the comments in haskell.el +for more information. diff --git a/emacs-tools/comint.el b/emacs-tools/comint.el new file mode 100644 index 0000000..e690005 --- /dev/null +++ b/emacs-tools/comint.el @@ -0,0 +1,1524 @@ +;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff +;;; Copyright Olin Shivers (1988). +;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright +;;; notice appearing here to the effect that you may use this code any +;;; way you like, as long as you don't charge money for it, remove this +;;; notice, or hold me liable for its results. + +;;; The changelog is at the end of this file. + +;;; Please send me bug reports, bug fixes, and extensions, so that I can +;;; merge them into the master source. +;;; - Olin Shivers (shivers@cs.cmu.edu) + +;;; This hopefully generalises shell mode, lisp mode, tea mode, soar mode,... +;;; This file defines a general command-interpreter-in-a-buffer package +;;; (comint mode). The idea is that you can build specific process-in-a-buffer +;;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, .... +;;; This way, all these specific packages share a common base functionality, +;;; and a common set of bindings, which makes them easier to use (and +;;; saves code, implementation time, etc., etc.). + +;;; Several packages are already defined using comint mode: +;;; - cmushell.el defines a shell-in-a-buffer mode. +;;; - cmulisp.el defines a simple lisp-in-a-buffer mode. +;;; Cmushell and cmulisp mode are similar to, and intended to replace, +;;; their counterparts in the standard gnu emacs release (in shell.el). +;;; These replacements are more featureful, robust, and uniform than the +;;; released versions. The key bindings in lisp mode are also more compatible +;;; with the bindings of Hemlock and Zwei (the Lisp Machine emacs). +;;; +;;; - The file cmuscheme.el defines a scheme-in-a-buffer mode. +;;; - The file tea.el tunes scheme and inferior-scheme modes for T. +;;; - The file soar.el tunes lisp and inferior-lisp modes for Soar. +;;; - cmutex.el defines tex and latex modes that invoke tex, latex, bibtex, +;;; previewers, and printers from within emacs. +;;; - background.el allows csh-like job control inside emacs. +;;; It is pretty easy to make new derived modes for other processes. + +;;; For documentation on the functionality provided by comint mode, and +;;; the hooks available for customising it, see the comments below. +;;; For further information on the standard derived modes (shell, +;;; inferior-lisp, inferior-scheme, ...), see the relevant source files. + +;;; For hints on converting existing process modes (e.g., tex-mode, +;;; background, dbx, gdb, kermit, prolog, telnet) to use comint-mode +;;; instead of shell-mode, see the notes at the end of this file. + +(provide 'comint) +(defconst comint-version "2.01") + + + + + + + + + + + + + + + + + + + + + +;;; Brief Command Documentation: +;;;============================================================================ +;;; Comint Mode Commands: (common to all derived modes, like cmushell & cmulisp +;;; mode) +;;; +;;; m-p comint-previous-input Cycle backwards in input history +;;; m-n comint-next-input Cycle forwards +;;; m-s comint-previous-similar-input Previous similar input +;;; c-c r comint-previous-input-matching Search backwards in input history +;;; return comint-send-input +;;; c-a comint-bol Beginning of line; skip prompt. +;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff. +;;; c-c c-u comint-kill-input ^u +;;; c-c c-w backward-kill-word ^w +;;; c-c c-c comint-interrupt-subjob ^c +;;; c-c c-z comint-stop-subjob ^z +;;; c-c c-\ comint-quit-subjob ^\ +;;; c-c c-o comint-kill-output Delete last batch of process output +;;; c-c c-r comint-show-output Show last batch of process output +;;; +;;; Not bound by default in comint-mode +;;; send-invisible Read a line w/o echo, and send to proc +;;; (These are bound in shell-mode) +;;; comint-dynamic-complete Complete filename at point. +;;; comint-dynamic-list-completions List completions in help buffer. +;;; comint-replace-by-expanded-filename Expand and complete filename at point; +;;; replace with expanded/completed name. +;;; comint-kill-subjob No mercy. +;;; comint-continue-subjob Send CONT signal to buffer's process +;;; group. Useful if you accidentally +;;; suspend your process (with C-c C-z). +;;; +;;; Bound for RMS -- I prefer the input history stuff, but you might like 'em. +;;; m-P comint-msearch-input Search backwards for prompt +;;; m-N comint-psearch-input Search forwards for prompt +;;; C-cR comint-msearch-input-matching Search backwards for prompt & string + +;;; comint-mode-hook is the comint mode hook. Basically for your keybindings. +;;; comint-load-hook is run after loading in this package. + + + + + +;;; Buffer Local Variables: +;;;============================================================================ +;;; Comint mode buffer local variables: +;;; comint-prompt-regexp - string comint-bol uses to match prompt. +;;; comint-last-input-end - marker For comint-kill-output command +;;; input-ring-size - integer For the input history +;;; input-ring - ring mechanism +;;; input-ring-index - marker ... +;;; comint-last-input-match - string ... +;;; comint-get-old-input - function Hooks for specific +;;; comint-input-sentinel - function process-in-a-buffer +;;; comint-input-filter - function modes. +;;; comint-input-send - function +;;; comint-eol-on-send - boolean + +(defvar comint-prompt-regexp "^" + "Regexp to recognise prompts in the inferior process. +Defaults to \"^\", the null string at BOL. + +Good choices: + Canonical Lisp: \"^[^> ]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp) + Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\" + franz: \"^\\(->\\|<[0-9]*>:\\) *\" + kcl: \"^>+ *\" + shell: \"^[^#$%>]*[#$%>] *\" + T: \"^>+ *\" + +This is a good thing to set in mode hooks.") + +(defvar input-ring-size 30 + "Size of input history ring.") + +;;; Here are the per-interpreter hooks. +(defvar comint-get-old-input (function comint-get-old-input-default) + "Function that submits old text in comint mode. +This function is called when return is typed while the point is in old text. +It returns the text to be submitted as process input. The default is +comint-get-old-input-default, which grabs the current line, and strips off +leading text matching comint-prompt-regexp") + +(defvar comint-input-sentinel (function ignore) + "Called on each input submitted to comint mode process by comint-send-input. +Thus it can, for instance, track cd/pushd/popd commands issued to the csh.") + +(defvar comint-input-filter + (function (lambda (str) (not (string-match "\\`\\s *\\'" str)))) + "Predicate for filtering additions to input history. +Only inputs answering true to this function are saved on the input +history list. Default is to save anything that isn't all whitespace") + +(defvar comint-input-sender (function comint-simple-send) + "Function to actually send to PROCESS the STRING submitted by user. +Usually this is just 'comint-simple-send, but if your mode needs to +massage the input string, this is your hook. This is called from +the user command comint-send-input. comint-simple-send just sends +the string plus a newline.") + +(defvar comint-eol-on-send 'T + "If non-nil, then jump to the end of the line before sending input to process. +See COMINT-SEND-INPUT") + +(defvar comint-mode-hook '() + "Called upon entry into comint-mode") + +(defvar comint-mode-map nil) + +(defun comint-mode () + "Major mode for interacting with an inferior interpreter. +Interpreter name is same as buffer name, sans the asterisks. +Return at end of buffer sends line as input. +Return not at end copies rest of line to end and sends it. +Setting mode variable comint-eol-on-send means jump to the end of the line +before submitting new input. + +This mode is typically customised to create inferior-lisp-mode, +shell-mode, etc.. This can be done by setting the hooks +comint-input-sentinel, comint-input-filter, comint-input-sender and +comint-get-old-input to appropriate functions, and the variable +comint-prompt-regexp to the appropriate regular expression. + +An input history is maintained of size input-ring-size, and +can be accessed with the commands comint-next-input [\\[comint-next-input]] and +comint-previous-input [\\[comint-previous-input]]. Commands not keybound by +default are send-invisible, comint-dynamic-complete, and +comint-list-dynamic-completions. + +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it. + +\\{comint-mode-map} + +Entry to this mode runs the hooks on comint-mode-hook" + (interactive) + (let ((old-ring (and (assq 'input-ring (buffer-local-variables)) + (boundp 'input-ring) + input-ring)) + (old-ptyp comint-ptyp)) ; preserve across local var kill. gross. + (kill-all-local-variables) + (setq major-mode 'comint-mode) + (setq mode-name "Comint") + (setq mode-line-process '(": %s")) + (use-local-map comint-mode-map) + (make-local-variable 'comint-last-input-end) + (setq comint-last-input-end (make-marker)) + (make-local-variable 'comint-last-input-match) + (setq comint-last-input-match "") + (make-local-variable 'comint-prompt-regexp) ; Don't set; default + (make-local-variable 'input-ring-size) ; ...to global val. + (make-local-variable 'input-ring) + (make-local-variable 'input-ring-index) + (setq input-ring-index 0) + (make-local-variable 'comint-get-old-input) + (make-local-variable 'comint-input-sentinel) + (make-local-variable 'comint-input-filter) + (make-local-variable 'comint-input-sender) + (make-local-variable 'comint-eol-on-send) + (make-local-variable 'comint-ptyp) + (setq comint-ptyp old-ptyp) + (run-hooks 'comint-mode-hook) + ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook. + ;The test is so we don't lose history if we run comint-mode twice in + ;a buffer. + (setq input-ring (if (ring-p old-ring) old-ring + (make-ring input-ring-size))))) + +;;; The old-ptyp stuff above is because we have to preserve the value of +;;; comint-ptyp across calls to comint-mode, in spite of the +;;; kill-all-local-variables that it does. Blech. Hopefully, this will all +;;; go away when a later release fixes the signalling bug. + +(if comint-mode-map + nil + (setq comint-mode-map (make-sparse-keymap)) + (define-key comint-mode-map "\ep" 'comint-previous-input) + (define-key comint-mode-map "\en" 'comint-next-input) + (define-key comint-mode-map "\es" 'comint-previous-similar-input) + (define-key comint-mode-map "\C-m" 'comint-send-input) + (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof) + (define-key comint-mode-map "\C-a" 'comint-bol) + (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input) + (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word) + (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob) + (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob) + (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob) + (define-key comint-mode-map "\C-c\C-o" 'comint-kill-output) + (define-key comint-mode-map "\C-cr" 'comint-previous-input-matching) + (define-key comint-mode-map "\C-c\C-r" 'comint-show-output) + ;;; Here's the prompt-search stuff I installed for RMS to try... + (define-key comint-mode-map "\eP" 'comint-msearch-input) + (define-key comint-mode-map "\eN" 'comint-psearch-input) + (define-key comint-mode-map "\C-cR" 'comint-msearch-input-matching)) + + +;;; This function is used to make a full copy of the comint mode map, +;;; so that client modes won't interfere with each other. This function +;;; isn't necessary in emacs 18.5x, but we keep it around for 18.4x versions. +(defun full-copy-sparse-keymap (km) + "Recursively copy the sparse keymap KM" + (cond ((consp km) + (cons (full-copy-sparse-keymap (car km)) + (full-copy-sparse-keymap (cdr km)))) + (t km))) + +(defun comint-check-proc (buffer-name) + "True if there is a process associated w/buffer BUFFER-NAME, and +it is alive (status RUN or STOP)." + (let ((proc (get-buffer-process buffer-name))) + (and proc (memq (process-status proc) '(run stop))))) + +;;; Note that this guy, unlike shell.el's make-shell, barfs if you pass it () +;;; for the second argument (program). +(defun make-comint (name program &optional startfile &rest switches) + (let* ((buffer (get-buffer-create (concat "*" name "*"))) + (proc (get-buffer-process buffer))) + ;; If no process, or nuked process, crank up a new one and put buffer in + ;; comint mode. Otherwise, leave buffer and existing process alone. + (cond ((or (not proc) (not (memq (process-status proc) '(run stop)))) + (save-excursion + (set-buffer buffer) + (comint-mode)) ; Install local vars, mode, keymap, ... + (comint-exec buffer name program startfile switches))) + buffer)) + +(defvar comint-ptyp t + "True if communications via pty; false if by pipe. Buffer local. +This is to work around a bug in emacs process signalling.") + +(defun comint-exec (buffer name command startfile switches) + "Fires up a process in buffer for comint modes. +Blasts any old process running in the buffer. Doesn't set the buffer mode. +You can use this to cheaply run a series of processes in the same comint +buffer." + (save-excursion + (set-buffer buffer) + (let ((proc (get-buffer-process buffer))) ; Blast any old process. + (if proc (delete-process proc))) + ;; Crank up a new process + (let ((proc (comint-exec-1 name buffer command switches))) + (make-local-variable 'comint-ptyp) + (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe. + ;; Jump to the end, and set the process mark. + (goto-char (point-max)) + (set-marker (process-mark proc) (point))) + ;; Feed it the startfile. + (cond (startfile + ;;This is guaranteed to wait long enough + ;;but has bad results if the comint does not prompt at all + ;; (while (= size (buffer-size)) + ;; (sleep-for 1)) + ;;I hope 1 second is enough! + (sleep-for 1) + (goto-char (point-max)) + (insert-file-contents startfile) + (setq startfile (buffer-substring (point) (point-max))) + (delete-region (point) (point-max)) + (comint-send-string proc startfile))) + buffer)) + +;;; This auxiliary function cranks up the process for comint-exec in +;;; the appropriate environment. It is twice as long as it should be +;;; because emacs has two distinct mechanisms for manipulating the +;;; process environment, selected at compile time with the +;;; MAINTAIN-ENVIRONMENT #define. In one case, process-environment +;;; is bound; in the other it isn't. + +(defun comint-exec-1 (name buffer command switches) + (if (boundp 'process-environment) ; Not a completely reliable test. + (let ((process-environment + (comint-update-env process-environment + (list (format "TERMCAP=emacs:co#%d:tc=unknown" + (screen-width)) + "TERM=emacs" + "EMACS=t")))) + (apply 'start-process name buffer command switches)) + + (let ((tcapv (getenv "TERMCAP")) + (termv (getenv "TERM")) + (emv (getenv "EMACS"))) + (unwind-protect + (progn (setenv "TERMCAP" (format "emacs:co#%d:tc=unknown" + (screen-width))) + (setenv "TERM" "emacs") + (setenv "EMACS" "t") + (apply 'start-process name buffer command switches)) + (setenv "TERMCAP" tcapv) + (setenv "TERM" termv) + (setenv "EMACS" emv))))) + + + +;; This is just (append new old-env) that compresses out shadowed entries. +;; It's also pretty ugly, mostly due to elisp's horrible iteration structures. +(defun comint-update-env (old-env new) + (let ((ans (reverse new)) + (vars (mapcar (function (lambda (vv) + (and (string-match "^[^=]*=" vv) + (substring vv 0 (match-end 0))))) + new))) + (while old-env + (let* ((vv (car old-env)) ; vv is var=value + (var (and (string-match "^[^=]*=" vv) + (substring vv 0 (match-end 0))))) + (setq old-env (cdr old-env)) + (cond ((not (and var (comint-mem var vars))) + (if var (setq var (cons var vars))) + (setq ans (cons vv ans)))))) + (nreverse ans))) + +;;; This should be in emacs, but it isn't. +(defun comint-mem (item list &optional elt=) + "Test to see if ITEM is equal to an item in LIST. +Option comparison function ELT= defaults to equal." + (let ((elt= (or elt= (function equal))) + (done nil)) + (while (and list (not done)) + (if (funcall elt= item (car list)) + (setq done list) + (setq list (cdr list)))) + done)) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +;;; Ring Code +;;;============================================================================ +;;; This code defines a ring data structure. A ring is a +;;; (hd-index tl-index . vector) +;;; list. You can insert to, remove from, and rotate a ring. When the ring +;;; fills up, insertions cause the oldest elts to be quietly dropped. +;;; +;;; HEAD = index of the newest item on the ring. +;;; TAIL = index of the oldest item on the ring. +;;; +;;; These functions are used by the input history mechanism, but they can +;;; be used for other purposes as well. + +(defun ring-p (x) + "T if X is a ring; NIL otherwise." + (and (consp x) (integerp (car x)) + (consp (cdr x)) (integerp (car (cdr x))) + (vectorp (cdr (cdr x))))) + +(defun make-ring (size) + "Make a ring that can contain SIZE elts" + (cons 1 (cons 0 (make-vector (+ size 1) nil)))) + +(defun ring-plus1 (index veclen) + "INDEX+1, with wraparound" + (let ((new-index (+ index 1))) + (if (= new-index veclen) 0 new-index))) + +(defun ring-minus1 (index veclen) + "INDEX-1, with wraparound" + (- (if (= 0 index) veclen index) 1)) + +(defun ring-length (ring) + "Number of elts in the ring." + (let ((hd (car ring)) (tl (car (cdr ring))) (siz (length (cdr (cdr ring))))) + (let ((len (if (<= hd tl) (+ 1 (- tl hd)) (+ 1 tl (- siz hd))))) + (if (= len siz) 0 len)))) + +(defun ring-empty-p (ring) + (= 0 (ring-length ring))) + +(defun ring-insert (ring item) + "Insert a new item onto the ring. If the ring is full, dump the oldest +item to make room." + (let* ((vec (cdr (cdr ring))) (len (length vec)) + (new-hd (ring-minus1 (car ring) len))) + (setcar ring new-hd) + (aset vec new-hd item) + (if (ring-empty-p ring) ;overflow -- dump one off the tail. + (setcar (cdr ring) (ring-minus1 (car (cdr ring)) len))))) + +(defun ring-remove (ring) + "Remove the oldest item retained on the ring." + (if (ring-empty-p ring) (error "Ring empty") + (let ((tl (car (cdr ring))) (vec (cdr (cdr ring)))) + (set-car (cdr ring) (ring-minus1 tl (length vec))) + (aref vec tl)))) + +;;; This isn't actually used in this package. I just threw it in in case +;;; someone else wanted it. If you want rotating-ring behavior on your history +;;; retrieval (analagous to kill ring behavior), this function is what you +;;; need. I should write the yank-input and yank-pop-input-or-kill to go with +;;; this, and not bind it to a key by default, so it would be available to +;;; people who want to bind it to a key. But who would want it? Blech. +(defun ring-rotate (ring n) + (if (not (= n 0)) + (if (ring-empty-p ring) ;Is this the right error check? + (error "ring empty") + (let ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring)))) + (let ((len (length vec))) + (while (> n 0) + (setq tl (ring-plus1 tl len)) + (aset ring tl (aref ring hd)) + (setq hd (ring-plus1 hd len)) + (setq n (- n 1))) + (while (< n 0) + (setq hd (ring-minus1 hd len)) + (aset vec hd (aref vec tl)) + (setq tl (ring-minus1 tl len)) + (setq n (- n 1)))) + (set-car ring hd) + (set-car (cdr ring) tl))))) + +(defun comint-mod (n m) + "Returns N mod M. M is positive. Answer is guaranteed to be non-negative, +and less than m." + (let ((n (% n m))) + (if (>= n 0) n + (+ n + (if (>= m 0) m (- m)))))) ; (abs m) + +(defun ring-ref (ring index) + (let ((numelts (ring-length ring))) + (if (= numelts 0) (error "indexed empty ring") + (let* ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring))) + (index (comint-mod index numelts)) + (vec-index (comint-mod (+ index hd) + (length vec)))) + (aref vec vec-index))))) + + +;;; Input history retrieval commands +;;; M-p -- previous input M-n -- next input +;;; C-c r -- previous input matching +;;; =========================================================================== + +(defun comint-previous-input (arg) + "Cycle backwards through input history." + (interactive "*p") + (let ((len (ring-length input-ring))) + (cond ((<= len 0) + (message "Empty input ring") + (ding)) + ((not (comint-after-pmark-p)) + (message "Not after process mark") + (ding)) + (t + (cond ((eq last-command 'comint-previous-input) + (delete-region (mark) (point))) + ((eq last-command 'comint-previous-similar-input) + (delete-region + (process-mark (get-buffer-process (current-buffer))) + (point))) + (t + (setq input-ring-index + (if (> arg 0) -1 + (if (< arg 0) 1 0))) + (push-mark (point)))) + (setq input-ring-index (comint-mod (+ input-ring-index arg) len)) + (message "%d" (1+ input-ring-index)) + (insert (ring-ref input-ring input-ring-index)) + (setq this-command 'comint-previous-input))))) + +(defun comint-next-input (arg) + "Cycle forwards through input history." + (interactive "*p") + (comint-previous-input (- arg))) + +(defvar comint-last-input-match "" + "Last string searched for by comint input history search, for defaulting. +Buffer local variable.") + +(defun comint-previous-input-matching (str) + "Searches backwards through input history for substring match." + (interactive (let* ((last-command last-command) ; preserve around r-f-m + (s (read-from-minibuffer + (format "Command substring (default %s): " + comint-last-input-match)))) + (list (if (string= s "") comint-last-input-match s)))) +; (interactive "sCommand substring: ") + (setq comint-last-input-match str) ; update default + (if (not (eq last-command 'comint-previous-input)) + (setq input-ring-index -1)) + (let ((str (regexp-quote str)) + (len (ring-length input-ring)) + (n (+ input-ring-index 1))) + (while (and (< n len) (not (string-match str (ring-ref input-ring n)))) + (setq n (+ n 1))) + (cond ((< n len) + (comint-previous-input (- n input-ring-index))) + (t (if (eq last-command 'comint-previous-input) + (setq this-command 'comint-previous-input)) + (message "Not found.") + (ding))))) + + +;;; These next three commands are alternatives to the input history commands -- +;;; comint-next-input, comint-previous-input and +;;; comint-previous-input-matching. They search through the process buffer +;;; text looking for occurrences of the prompt. RMS likes them better; +;;; I don't. Bound to M-P, M-N, and C-c R (uppercase P, N, and R) for +;;; now. Try'em out. Go with what you like... + +;;; comint-msearch-input-matching prompts for a string, not a regexp. +;;; This could be considered to be the wrong thing. I decided to keep it +;;; simple, and not make the user worry about regexps. This, of course, +;;; limits functionality. + +(defun comint-psearch-input () + "Search forwards for next occurrence of prompt and skip to end of line. +\(prompt is anything matching regexp comint-prompt-regexp)" + (interactive) + (if (re-search-forward comint-prompt-regexp (point-max) t) + (end-of-line) + (error "No occurrence of prompt found"))) + +(defun comint-msearch-input () + "Search backwards for previous occurrence of prompt and skip to end of line. +Search starts from beginning of current line." + (interactive) + (let ((p (save-excursion + (beginning-of-line) + (cond ((re-search-backward comint-prompt-regexp (point-min) t) + (end-of-line) + (point)) + (t nil))))) + (if p (goto-char p) + (error "No occurrence of prompt found")))) + +(defun comint-msearch-input-matching (str) + "Search backwards for occurrence of prompt followed by STRING. +STRING is prompted for, and is NOT a regular expression." + (interactive (let ((s (read-from-minibuffer + (format "Command (default %s): " + comint-last-input-match)))) + (list (if (string= s "") comint-last-input-match s)))) +; (interactive "sCommand: ") + (setq comint-last-input-match str) ; update default + (let* ((r (concat comint-prompt-regexp (regexp-quote str))) + (p (save-excursion + (beginning-of-line) + (cond ((re-search-backward r (point-min) t) + (end-of-line) + (point)) + (t nil))))) + (if p (goto-char p) + (error "No match")))) + +;;; +;;; Similar input -- contributed by ccm and highly winning. +;;; +;;; Reenter input, removing back to the last insert point if it exists. +;;; +(defvar comint-last-similar-string "" + "The string last used in a similar string search.") +(defun comint-previous-similar-input (arg) + "Reenters the last input that matches the string typed so far. If repeated +successively older inputs are reentered. If arg is 1, it will go back +in the history, if -1 it will go forward." + (interactive "p") + (if (not (comint-after-pmark-p)) + (error "Not after process mark")) + (if (not (eq last-command 'comint-previous-similar-input)) + (setq input-ring-index -1 + comint-last-similar-string + (buffer-substring + (process-mark (get-buffer-process (current-buffer))) + (point)))) + (let* ((size (length comint-last-similar-string)) + (len (ring-length input-ring)) + (n (+ input-ring-index arg)) + entry) + (while (and (< n len) + (or (< (length (setq entry (ring-ref input-ring n))) size) + (not (equal comint-last-similar-string + (substring entry 0 size))))) + (setq n (+ n arg))) + (cond ((< n len) + (setq input-ring-index n) + (if (eq last-command 'comint-previous-similar-input) + (delete-region (mark) (point)) ; repeat + (push-mark (point))) ; 1st time + (insert (substring entry size))) + (t (message "Not found.") (ding) (sit-for 1))) + (message "%d" (1+ input-ring-index)))) + + + + + + + + + +(defun comint-send-input () + "Send input to process. After the process output mark, sends all text +from the process mark to point as input to the process. Before the +process output mark, calls value of variable comint-get-old-input to retrieve +old input, copies it to the end of the buffer, and sends it. A terminal +newline is also inserted into the buffer and sent to the process. In either +case, value of variable comint-input-sentinel is called on the input before +sending it. The input is entered into the input history ring, if value of +variable comint-input-filter returns non-nil when called on the input. + +If variable comint-eol-on-send is non-nil, then point is moved to the end of +line before sending the input. + +comint-get-old-input, comint-input-sentinel, and comint-input-filter are chosen +according to the command interpreter running in the buffer. E.g., +If the interpreter is the csh, + comint-get-old-input is the default: take the current line, discard any + initial string matching regexp comint-prompt-regexp. + comint-input-sentinel monitors input for \"cd\", \"pushd\", and \"popd\" + commands. When it sees one, it cd's the buffer. + comint-input-filter is the default: returns T if the input isn't all white + space. + +If the comint is Lucid Common Lisp, + comint-get-old-input snarfs the sexp ending at point. + comint-input-sentinel does nothing. + comint-input-filter returns NIL if the input matches input-filter-regexp, + which matches (1) all whitespace (2) :a, :c, etc. + +Similarly for Soar, Scheme, etc.." + (interactive) + ;; Note that the input string does not include its terminal newline. + (let ((proc (get-buffer-process (current-buffer)))) + (if (not proc) (error "Current buffer has no process") + (let* ((pmark (process-mark proc)) + (pmark-val (marker-position pmark)) + (input (if (>= (point) pmark-val) + (progn (if comint-eol-on-send (end-of-line)) + (buffer-substring pmark (point))) + (let ((copy (funcall comint-get-old-input))) + (goto-char pmark) + (insert copy) + copy)))) + (insert ?\n) + (if (funcall comint-input-filter input) (ring-insert input-ring input)) + (funcall comint-input-sentinel input) + (funcall comint-input-sender proc input) + (set-marker (process-mark proc) (point)) + (set-marker comint-last-input-end (point)))))) + +(defun comint-get-old-input-default () + "Default for comint-get-old-input: take the current line, and discard +any initial text matching comint-prompt-regexp." + (save-excursion + (beginning-of-line) + (comint-skip-prompt) + (let ((beg (point))) + (end-of-line) + (buffer-substring beg (point))))) + +(defun comint-skip-prompt () + "Skip past the text matching regexp comint-prompt-regexp. +If this takes us past the end of the current line, don't skip at all." + (let ((eol (save-excursion (end-of-line) (point)))) + (if (and (looking-at comint-prompt-regexp) + (<= (match-end 0) eol)) + (goto-char (match-end 0))))) + + +(defun comint-after-pmark-p () + "Is point after the process output marker?" + ;; Since output could come into the buffer after we looked at the point + ;; but before we looked at the process marker's value, we explicitly + ;; serialise. This is just because I don't know whether or not emacs + ;; services input during execution of lisp commands. + (let ((proc-pos (marker-position + (process-mark (get-buffer-process (current-buffer)))))) + (<= proc-pos (point)))) + +(defun comint-simple-send (proc string) + "Default function for sending to PROC input STRING. +This just sends STRING plus a newline. To override this, +set the hook COMINT-INPUT-SENDER." + (comint-send-string proc string) + (comint-send-string proc "\n")) + +(defun comint-bol (arg) + "Goes to the beginning of line, then skips past the prompt, if any. +If a prefix argument is given (\\[universal-argument]), then no prompt skip +-- go straight to column 0. + +The prompt skip is done by skipping text matching the regular expression +comint-prompt-regexp, a buffer local variable. + +If you don't like this command, reset c-a to beginning-of-line +in your hook, comint-mode-hook." + (interactive "P") + (beginning-of-line) + (if (null arg) (comint-skip-prompt))) + +;;; These two functions are for entering text you don't want echoed or +;;; saved -- typically passwords to ftp, telnet, or somesuch. +;;; Just enter m-x send-invisible and type in your line. + +(defun comint-read-noecho (prompt) + "Prompt the user with argument PROMPT. Read a single line of text +without echoing, and return it. Note that the keystrokes comprising +the text can still be recovered (temporarily) with \\[view-lossage]. This +may be a security bug for some applications." + (let ((echo-keystrokes 0) + (answ "") + tem) + (if (and (stringp prompt) (not (string= (message prompt) ""))) + (message prompt)) + (while (not(or (= (setq tem (read-char)) ?\^m) + (= tem ?\n))) + (setq answ (concat answ (char-to-string tem)))) + (message "") + answ)) + +(defun send-invisible (str) + "Read a string without echoing, and send it to the process running +in the current buffer. A new-line is additionally sent. String is not +saved on comint input history list. +Security bug: your string can still be temporarily recovered with +\\[view-lossage]." +; (interactive (list (comint-read-noecho "Enter non-echoed text"))) + (interactive "P") ; Defeat snooping via C-x esc + (let ((proc (get-buffer-process (current-buffer)))) + (if (not proc) (error "Current buffer has no process") + (comint-send-string proc + (if (stringp str) str + (comint-read-noecho "Enter non-echoed text"))) + (comint-send-string proc "\n")))) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +;;; Low-level process communication + +(defvar comint-input-chunk-size 512 + "*Long inputs send to comint processes are broken up into chunks of this size. +If your process is choking on big inputs, try lowering the value.") + +(defun comint-send-string (proc str) + "Send PROCESS the contents of STRING as input. +This is equivalent to process-send-string, except that long input strings +are broken up into chunks of size comint-input-chunk-size. Processes +are given a chance to output between chunks. This can help prevent processes +from hanging when you send them long inputs on some OS's." + (let* ((len (length str)) + (i (min len comint-input-chunk-size))) + (process-send-string proc (substring str 0 i)) + (while (< i len) + (let ((next-i (+ i comint-input-chunk-size))) + (accept-process-output) + (process-send-string proc (substring str i (min len next-i))) + (setq i next-i))))) + +(defun comint-send-region (proc start end) + "Sends to PROC the region delimited by START and END. +This is a replacement for process-send-region that tries to keep +your process from hanging on long inputs. See comint-send-string." + (comint-send-string proc (buffer-substring start end))) + + + + + + + + + + + + + + + + + + +;;; Random input hackage + +(defun comint-kill-output () + "Kill all output from interpreter since last input." + (interactive) + (let ((pmark (process-mark (get-buffer-process (current-buffer))))) + (kill-region comint-last-input-end pmark) + (goto-char pmark) + (insert "*** output flushed ***\n") + (set-marker pmark (point)))) + +(defun comint-show-output () + "Display start of this batch of interpreter output at top of window. +Also put cursor there." + (interactive) + (goto-char comint-last-input-end) + (backward-char) + (beginning-of-line) + (set-window-start (selected-window) (point)) + (end-of-line)) + +(defun comint-interrupt-subjob () + "Interrupt the current subjob." + (interactive) + (interrupt-process nil comint-ptyp)) + +(defun comint-kill-subjob () + "Send kill signal to the current subjob." + (interactive) + (kill-process nil comint-ptyp)) + +(defun comint-quit-subjob () + "Send quit signal to the current subjob." + (interactive) + (quit-process nil comint-ptyp)) + +(defun comint-stop-subjob () + "Stop the current subjob. +WARNING: if there is no current subjob, you can end up suspending +the top-level process running in the buffer. If you accidentally do +this, use \\[comint-continue-subjob] to resume the process. (This +is not a problem with most shells, since they ignore this signal.)" + (interactive) + (stop-process nil comint-ptyp)) + +(defun comint-continue-subjob () + "Send CONT signal to process buffer's process group. +Useful if you accidentally suspend the top-level process." + (interactive) + (continue-process nil comint-ptyp)) + +(defun comint-kill-input () + "Kill all text from last stuff output by interpreter to point." + (interactive) + (let* ((pmark (process-mark (get-buffer-process (current-buffer)))) + (p-pos (marker-position pmark))) + (if (> (point) p-pos) + (kill-region pmark (point))))) + +(defun comint-delchar-or-maybe-eof (arg) + "Delete ARG characters forward, or send an EOF to process if at end of buffer." + (interactive "p") + (if (eobp) + (process-send-eof) + (delete-char arg))) + + + + + + + + + + + + + + + + + + + + + + + +;;; Support for source-file processing commands. +;;;============================================================================ +;;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have +;;; commands that process files of source text (e.g. loading or compiling +;;; files). So the corresponding process-in-a-buffer modes have commands +;;; for doing this (e.g., lisp-load-file). The functions below are useful +;;; for defining these commands. +;;; +;;; Alas, these guys don't do exactly the right thing for Lisp, Scheme +;;; and Soar, in that they don't know anything about file extensions. +;;; So the compile/load interface gets the wrong default occasionally. +;;; The load-file/compile-file default mechanism could be smarter -- it +;;; doesn't know about the relationship between filename extensions and +;;; whether the file is source or executable. If you compile foo.lisp +;;; with compile-file, then the next load-file should use foo.bin for +;;; the default, not foo.lisp. This is tricky to do right, particularly +;;; because the extension for executable files varies so much (.o, .bin, +;;; .lbin, .mo, .vo, .ao, ...). + + +;;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing +;;; commands. +;;; +;;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you +;;; want to save the buffer before issuing any process requests to the command +;;; interpreter. +;;; +;;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt +;;; for the file to process. + +;;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes) +;;;============================================================================ +;;; This function computes the defaults for the load-file and compile-file +;;; commands for tea, soar, cmulisp, and cmuscheme modes. +;;; +;;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last +;;; source-file processing command. NIL if there hasn't been one yet. +;;; - SOURCE-MODES is a list used to determine what buffers contain source +;;; files: if the major mode of the buffer is in SOURCE-MODES, it's source. +;;; Typically, (lisp-mode) or (scheme-mode). +;;; +;;; If the command is given while the cursor is inside a string, *and* +;;; the string is an existing filename, *and* the filename is not a directory, +;;; then the string is taken as default. This allows you to just position +;;; your cursor over a string that's a filename and have it taken as default. +;;; +;;; If the command is given in a file buffer whose major mode is in +;;; SOURCE-MODES, then the the filename is the default file, and the +;;; file's directory is the default directory. +;;; +;;; If the buffer isn't a source file buffer (e.g., it's the process buffer), +;;; then the default directory & file are what was used in the last source-file +;;; processing command (i.e., PREVIOUS-DIR/FILE). If this is the first time +;;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory +;;; is the cwd, with no default file. (\"no default file\" = nil) +;;; +;;; SOURCE-REGEXP is typically going to be something like (tea-mode) +;;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode) +;;; for Soar programs, etc. +;;; +;;; The function returns a pair: (default-directory . default-file). + +(defun comint-source-default (previous-dir/file source-modes) + (cond ((and buffer-file-name (memq major-mode source-modes)) + (cons (file-name-directory buffer-file-name) + (file-name-nondirectory buffer-file-name))) + (previous-dir/file) + (t + (cons default-directory nil)))) + + +;;; (COMINT-CHECK-SOURCE fname) +;;;============================================================================ +;;; Prior to loading or compiling (or otherwise processing) a file (in the CMU +;;; process-in-a-buffer modes), this function can be called on the filename. +;;; If the file is loaded into a buffer, and the buffer is modified, the user +;;; is queried to see if he wants to save the buffer before proceeding with +;;; the load or compile. + +(defun comint-check-source (fname) + (let ((buff (get-file-buffer fname))) + (if (and buff + (buffer-modified-p buff) + (y-or-n-p (format "Save buffer %s first? " + (buffer-name buff)))) + ;; save BUFF. + (let ((old-buffer (current-buffer))) + (set-buffer buff) + (save-buffer) + (set-buffer old-buffer))))) + + +;;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p) +;;;============================================================================ +;;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter +;;; commands that process source files (like loading or compiling a file). +;;; It prompts for the filename, provides a default, if there is one, +;;; and returns the result filename. +;;; +;;; See COMINT-SOURCE-DEFAULT for more on determining defaults. +;;; +;;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair +;;; from the last source processing command. SOURCE-MODES is a list of major +;;; modes used to determine what file buffers contain source files. (These +;;; two arguments are used for determining defaults). If MUSTMATCH-P is true, +;;; then the filename reader will only accept a file that exists. +;;; +;;; A typical use: +;;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file +;;; '(lisp-mode) t)) + +;;; This is pretty stupid about strings. It decides we're in a string +;;; if there's a quote on both sides of point on the current line. +(defun comint-extract-string () + "Returns string around point that starts the current line or nil." + (save-excursion + (let* ((point (point)) + (bol (progn (beginning-of-line) (point))) + (eol (progn (end-of-line) (point))) + (start (progn (goto-char point) + (and (search-backward "\"" bol t) + (1+ (point))))) + (end (progn (goto-char point) + (and (search-forward "\"" eol t) + (1- (point)))))) + (and start end + (buffer-substring start end))))) + +(defun comint-get-source (prompt prev-dir/file source-modes mustmatch-p) + (let* ((def (comint-source-default prev-dir/file source-modes)) + (stringfile (comint-extract-string)) + (sfile-p (and stringfile + (file-exists-p stringfile) + (not (file-directory-p stringfile)))) + (defdir (if sfile-p (file-name-directory stringfile) + (car def))) + (deffile (if sfile-p (file-name-nondirectory stringfile) + (cdr def))) + (ans (read-file-name (if deffile (format "%s(default %s) " + prompt deffile) + prompt) + defdir + (concat defdir deffile) + mustmatch-p))) + (list (expand-file-name (substitute-in-file-name ans))))) + +;;; I am somewhat divided on this string-default feature. It seems +;;; to violate the principle-of-least-astonishment, in that it makes +;;; the default harder to predict, so you actually have to look and see +;;; what the default really is before choosing it. This can trip you up. +;;; On the other hand, it can be useful, I guess. I would appreciate feedback +;;; on this. +;;; -Olin + + + + + + + + + + + + + + + + + + + + + + + +;;; Simple process query facility. +;;; =========================================================================== +;;; This function is for commands that want to send a query to the process +;;; and show the response to the user. For example, a command to get the +;;; arglist for a Common Lisp function might send a "(arglist 'foo)" query +;;; to an inferior Common Lisp process. +;;; +;;; This simple facility just sends strings to the inferior process and pops +;;; up a window for the process buffer so you can see what the process +;;; responds with. We don't do anything fancy like try to intercept what the +;;; process responds with and put it in a pop-up window or on the message +;;; line. We just display the buffer. Low tech. Simple. Works good. + +;;; Send to the inferior process PROC the string STR. Pop-up but do not select +;;; a window for the inferior process so that its response can be seen. +(defun comint-proc-query (proc str) + (let* ((proc-buf (process-buffer proc)) + (proc-mark (process-mark proc))) + (display-buffer proc-buf) + (set-buffer proc-buf) ; but it's not the selected *window* + (let ((proc-win (get-buffer-window proc-buf)) + (proc-pt (marker-position proc-mark))) + (comint-send-string proc str) ; send the query + (accept-process-output proc) ; wait for some output + ;; Try to position the proc window so you can see the answer. + ;; This is bogus code. If you delete the (sit-for 0), it breaks. + ;; I don't know why. Wizards invited to improve it. + (if (not (pos-visible-in-window-p proc-pt proc-win)) + (let ((opoint (window-point proc-win))) + (set-window-point proc-win proc-mark) (sit-for 0) + (if (not (pos-visible-in-window-p opoint proc-win)) + (push-mark opoint) + (set-window-point proc-win opoint))))))) + + + + + + + + + + + +;;; Filename completion in a buffer +;;; =========================================================================== +;;; Useful completion functions, courtesy of the Ergo group. +;;; M-<Tab> will complete the filename at the cursor as much as possible +;;; M-? will display a list of completions in the help buffer. + +;;; Three commands: +;;; comint-dynamic-complete Complete filename at point. +;;; comint-dynamic-list-completions List completions in help buffer. +;;; comint-replace-by-expanded-filename Expand and complete filename at point; +;;; replace with expanded/completed name. + +;;; These are not installed in the comint-mode keymap. But they are +;;; available for people who want them. Shell-mode installs them: +;;; (define-key cmushell-mode-map "\M-\t" 'comint-dynamic-complete) +;;; (define-key cmushell-mode-map "\M-?" 'comint-dynamic-list-completions))) +;;; +;;; Commands like this are fine things to put in load hooks if you +;;; want them present in specific modes. Example: +;;; (setq cmushell-load-hook +;;; '((lambda () (define-key lisp-mode-map "\M-\t" +;;; 'comint-replace-by-expanded-filename)))) +;;; + + +(defun comint-match-partial-pathname () + "Returns the string of an existing filename or causes an error." + (if (save-excursion (backward-char 1) (looking-at "\\s ")) "" + (save-excursion + (re-search-backward "[^~/A-Za-z0-9---_.$#,]+") + (re-search-forward "[~/A-Za-z0-9---_.$#,]+") + (substitute-in-file-name + (buffer-substring (match-beginning 0) (match-end 0)))))) + + +(defun comint-replace-by-expanded-filename () +"Replace the filename at point with an expanded, canonicalised, and +completed replacement. +\"Expanded\" means environment variables (e.g., $HOME) and ~'s are +replaced with the corresponding directories. \"Canonicalised\" means .. +and \. are removed, and the filename is made absolute instead of relative. +See functions expand-file-name and substitute-in-file-name. See also +comint-dynamic-complete." + (interactive) + (let* ((pathname (comint-match-partial-pathname)) + (pathdir (file-name-directory pathname)) + (pathnondir (file-name-nondirectory pathname)) + (completion (file-name-completion pathnondir + (or pathdir default-directory)))) + (cond ((null completion) + (message "No completions of %s." pathname) + (ding)) + ((eql completion t) + (message "Unique completion.")) + (t ; this means a string was returned. + (delete-region (match-beginning 0) (match-end 0)) + (insert (expand-file-name (concat pathdir completion))))))) + + +(defun comint-dynamic-complete () + "Dynamically complete the filename at point. +This function is similar to comint-replace-by-expanded-filename, except +that it won't change parts of the filename already entered in the buffer; +it just adds completion characters to the end of the filename." + (interactive) + (let* ((pathname (comint-match-partial-pathname)) + (pathdir (file-name-directory pathname)) + (pathnondir (file-name-nondirectory pathname)) + (completion (file-name-completion pathnondir + (or pathdir default-directory)))) + (cond ((null completion) + (message "No completions of %s." pathname) + (ding)) + ((eql completion t) + (message "Unique completion.")) + (t ; this means a string was returned. + (goto-char (match-end 0)) + (insert (substring completion (length pathnondir))))))) + +(defun comint-dynamic-list-completions () + "List in help buffer all possible completions of the filename at point." + (interactive) + (let* ((pathname (comint-match-partial-pathname)) + (pathdir (file-name-directory pathname)) + (pathnondir (file-name-nondirectory pathname)) + (completions + (file-name-all-completions pathnondir + (or pathdir default-directory)))) + (cond ((null completions) + (message "No completions of %s." pathname) + (ding)) + (t + (let ((conf (current-window-configuration))) + (with-output-to-temp-buffer "*Help*" + (display-completion-list completions)) + (sit-for 0) + (message "Hit space to flush.") + (let ((ch (read-char))) + (if (= ch ?\ ) + (set-window-configuration conf) + (setq unread-command-char ch)))))))) + +; Ergo bindings +; (global-set-key "\M-\t" 'comint-replace-by-expanded-filename) +; (global-set-key "\M-?" 'comint-dynamic-list-completions) +; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete) + + + + + + + + + + + + + + + + + + + + + + + + + + +;;; Converting process modes to use comint mode +;;; =========================================================================== +;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog, +;;; telnet are some) use the shell package as clients. Most of them would +;;; be better off using the comint package, but they predate it. +;;; +;;; Altering these packages to use comint mode should greatly +;;; improve their functionality, and is fairly easy. +;;; +;;; Renaming variables +;;; Most of the work is renaming variables and functions. These are the common +;;; ones: +;;; Local variables: +;;; last-input-end comint-last-input-end +;;; last-input-start <unnecessary> +;;; shell-prompt-pattern comint-prompt-regexp +;;; shell-set-directory-error-hook <no equivalent> +;;; Miscellaneous: +;;; shell-set-directory <unnecessary> +;;; shell-mode-map comint-mode-map +;;; Commands: +;;; shell-send-input comint-send-input +;;; shell-send-eof comint-delchar-or-maybe-eof +;;; kill-shell-input comint-kill-input +;;; interrupt-shell-subjob comint-interrupt-subjob +;;; stop-shell-subjob comint-stop-subjob +;;; quit-shell-subjob comint-quit-subjob +;;; kill-shell-subjob comint-kill-subjob +;;; kill-output-from-shell comint-kill-output +;;; show-output-from-shell comint-show-output +;;; copy-last-shell-input Use comint-previous-input/comint-next-input +;;; +;;; LAST-INPUT-START is no longer necessary because inputs are stored on the +;;; input history ring. SHELL-SET-DIRECTORY is gone, its functionality taken +;;; over by SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-sentinel. +;;; Comint mode does not provide functionality equivalent to +;;; shell-set-directory-error-hook; it is gone. +;;; +;;; If you are implementing some process-in-a-buffer mode, called foo-mode, do +;;; *not* create the comint-mode local variables in your foo-mode function. +;;; This is not modular. Instead, call comint-mode, and let *it* create the +;;; necessary comint-specific local variables. Then create the +;;; foo-mode-specific local variables in foo-mode. Set the buffer's keymap to +;;; be foo-mode-map, and its mode to be foo-mode. Set the comint-mode hooks +;;; (comint-prompt-regexp, comint-input-filter, comint-input-sentinel, +;;; comint-get-old-input) that need to be different from the defaults. Call +;;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself; +;;; comint-mode will take care of it. The following example, from cmushell.el, +;;; is typical: +;;; +;;; (defun shell-mode () +;;; (interactive) +;;; (comint-mode) +;;; (setq comint-prompt-regexp shell-prompt-pattern) +;;; (setq major-mode 'shell-mode) +;;; (setq mode-name "Shell") +;;; (cond ((not shell-mode-map) +;;; (setq shell-mode-map (full-copy-sparse-keymap comint-mode-map)) +;;; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete) +;;; (define-key shell-mode-map "\M-?" +;;; 'comint-dynamic-list-completions))) +;;; (use-local-map shell-mode-map) +;;; (make-local-variable 'shell-directory-stack) +;;; (setq shell-directory-stack nil) +;;; (setq comint-input-sentinel 'shell-directory-tracker) +;;; (run-hooks 'shell-mode-hook)) +;;; +;;; +;;; Note that make-comint is different from make-shell in that it +;;; doesn't have a default program argument. If you give make-shell +;;; a program name of NIL, it cleverly chooses one of explicit-shell-name, +;;; $ESHELL, $SHELL, or /bin/sh. If you give make-comint a program argument +;;; of NIL, it barfs. Adjust your code accordingly... +;;; + + + + + + + + + + + + + + +;;; Do the user's customisation... + +(defvar comint-load-hook nil + "This hook is run when comint is loaded in. +This is a good place to put keybindings.") + +(run-hooks 'comint-load-hook) + +;;; Change log: +;;; 9/12/89 +;;; - Souped up the filename expansion procedures. +;;; Doc strings are much clearer and more detailed. +;;; Fixed a bug where doing a filename completion when the point +;;; was in the middle of the filename instead of at the end would lose. +;;; +;;; 2/17/90 +;;; - Souped up the command history stuff so that text inserted +;;; by comint-previous-input-matching is removed by following +;;; command history recalls. comint-next/previous-input-matching +;;; is now much more smoothly integrated w/the command history stuff. +;;; - Added comint-eol-on-send flag and comint-input-sender hook. +;;; Comint-input-sender based on code contributed by Jeff Peck +;;; (peck@sun.com). +;;; +;;; 3/13/90 ccm@cmu.cs.edu +;;; - Added comint-previous-similar-input for looking up similar inputs. +;;; - Added comint-send-and-get-output to allow snarfing input from +;;; buffer. +;;; - Added the ability to pick up a source file by positioning over +;;; a string in comint-get-source. +;;; - Added add-hook to make it a little easier for the user to use +;;; multiple hooks. +;;; +;;; 5/22/90 shivers +;;; - Moved Chris' multiplexed ipc stuff to comint-ipc.el. +;;; - Altered Chris' comint-get-source string feature. The string +;;; is only offered as a default if it names an existing file. +;;; - Changed comint-exec to directly crank up the process, instead +;;; of calling the env program. This made background.el happy. +;;; - Added new buffer-local var comint-ptyp. The problem is that +;;; the signalling functions don't work as advertised. If you are +;;; communicating via pipes, the CURRENT-GROUP arg is supposed to +;;; be ignored, but, unfortunately it seems to be the case that you +;;; must pass a NIL for this arg in the pipe case. COMINT-PTYP +;;; is a flag that tells whether the process is communicating +;;; via pipes or a pty. The comint signalling functions use it +;;; to determine the necessary CURRENT-GROUP arg value. The bug +;;; has been reported to the Gnu folks. +;;; - comint-dynamic-complete flushes the help window if you hit space +;;; after you execute it. +;;; - Added functions comint-send-string, comint-send-region and var +;;; comint-input-chunk-size. comint-send-string tries to prevent processes +;;; from hanging when you send them long strings by breaking them into +;;; chunks and allowing process output between chunks. I got the idea from +;;; Eero Simoncelli's Common Lisp package. Note that using +;;; comint-send-string means that the process buffer's contents can change +;;; during a call! If you depend on process output only happening between +;;; toplevel commands, this could be a problem. In such a case, use +;;; process-send-string instead. If this is a problem for people, I'd like +;;; to hear about it. +;;; - Added comint-proc-query as a simple mechanism for commands that +;;; want to query an inferior process and display its response. For a +;;; typical use, see lisp-show-arglist in cmulisp.el. +;;; - Added constant comint-version, which is now "2.01". +;;; +;;; 6/14/90 shivers +;;; - Had comint-update-env defined twice. Removed extra copy. Also +;;; renamed mem to be comint-mem, for modularity. The duplication +;;; was reported by Michael Meissner. +;;; 6/16/90 shivers +;;; - Emacs has two different mechanisms for maintaining the process +;;; environment, determined at compile time by the MAINTAIN-ENVIRONMENT +;;; #define. One uses the process-environment global variable, and +;;; one uses a getenv/setenv interface. comint-exec assumed the +;;; process-environment interface; it has been generalised (with +;;; comint-exec-1) to handle both cases. Pretty bogus. We could, +;;; of course, skip all this and just use the etc/env program to +;;; handle the environment tweaking, but that obscures process +;;; queries that other modules (like background.el) depend on. etc/env +;;; is also fairly bogus. This bug, and some of the fix code was +;;; reported by Dan Pierson. +;;; +;;; 9/5/90 shivers +;;; - Changed make-variable-buffer-local's to make-local-variable's. +;;; This leaves non-comint-mode buffers alone. Stephane Payrard +;;; reported the sloppy useage. +;;; - You can now go from comint-previous-similar-input to +;;; comint-previous-input with no problem. + + diff --git a/emacs-tools/comint.elc b/emacs-tools/comint.elc Binary files differnew file mode 100644 index 0000000..0b9bf63 --- /dev/null +++ b/emacs-tools/comint.elc diff --git a/emacs-tools/haskell.el b/emacs-tools/haskell.el new file mode 100644 index 0000000..4130aea --- /dev/null +++ b/emacs-tools/haskell.el @@ -0,0 +1,2198 @@ +;;; ================================================================== +;;; File: haskell.el ;;; +;;; ;;; +;;; Author: A. Satish Pai ;;; +;;; Maria M. Gutierrez ;;; +;;; Dan Rabin (Jul-1991) ;;; +;;; ================================================================== + +;;; Description: Haskell mode for GNU Emacs. + +;;; Related files: comint.el + +;;; Contents: + +;;; Update Log + +;;; Known bugs / problems +;;; - the haskell editing mode (indentation, etc) is still missing. +;;; - the handling for errors from haskell needs to be rethought. +;;; - general cleanup of code. + + +;;; Errors generated + +;;; ================================================================== +;;; Haskell mode for editing files, and an Inferior Haskell mode to +;;; run a Haskell process. This file contains stuff snarfed and +;;; modified from tea.el, scheme.el, etc. This file may be freely +;;; modified; however, if you have any bug-corrections or useful +;;; improvements, I'd appreciate it if you sent me the mods so that +;;; I can merge them into the version I maintain. +;;; +;;; The inferior Haskell mode requires comint.el. +;;; +;;; You might want to add this to your .emacs to go automagically +;;; into Haskell mode while finding .hs files. +;;; +;;; (setq auto-mode-alist +;;; (cons '("\\.hs$" . haskell-mode) +;;; auto-mode-alist)_) +;;; +;;; To use this file, set up your .emacs to autoload this file for +;;; haskell-mode. For example: +;;; +;;; (autoload 'haskell-mode "$HASKELL/emacs-tools/haskell.elc" +;;; "Load Haskell mode" t) +;;; +;;; (autoload 'run-mode "$HASKELL/emacs-tools/haskell.elc" +;;; "Load Haskell mode" t) +;;; +;;; [Note: The path name given above is Yale specific!! Modify as +;;; required.] +;;; ================================================================ + +;;; Announce your existence to the world at large. + +(provide 'haskell) + + +;;; Load these other files. + +(require 'comint) ; Olin Shivers' comint mode is the substratum + + + + +;;; ================================================================ +;;; Declare a bunch of variables. +;;; ================================================================ + + +;;; User settable (via M-x set-variable and M-x edit-options) + +(defvar haskell-program-name (getenv "HASKELLPROG") + "*Program invoked by the haskell command") + +(defvar *haskell-buffer* "*haskell*" + "*Name of the haskell process buffer") + +(defvar *haskell-show-error* 1 + "*If not nil move to the buffer where the error was found") + + +(defvar haskell-auto-create-process t + "*If not nil, create a Haskell process automatically when required to evaluate or compile Haskell code") + +(defvar *haskell-debug-in-lisp* nil + "*If not nil, enter Lisp debugger on error; otherwise, automagically return +to Haskell top-level.") + + +;;; Command interface related variables + +(defvar *emacs* nil + "When not nil means haskell is in emacs mode") + + +;;; Pad/buffer Initialization variables + +(defvar haskell-main-pad "\*Main-pad\*" + "Scratch pad associated with module Main") + +(defvar haskell-main-file "Main") + +(defvar haskell-main-module "Main") + + +(defvar *last-loaded* haskell-main-file + "Last file loaded with a :load command - Defaults to Main") + +(defvar *last-loaded-modtime* nil + "Modification time of last file loaded, used to determine whether it +needs to be reloaded.") + +(defvar *last-module* haskell-main-module + "Last module set with a :module command - Defaults to Main") + +(defvar *last-pad* haskell-main-pad + "Last pad saved with a :save command - Defaults to Main") + + +;;; These are used for haskell-tutorial mode. + +(defvar *ht-source-file* "$HASKELL/progs/tutorial/tutorial.hs") +(defvar *ht-temp-buffer* nil) +(defvar *ht-file-buffer* "Haskell-Tutorial-Master") + + + +;;; ================================================================ +;;; Haskell editing mode stuff +;;; ================================================================ + +;;; Leave this place alone... +;;; The definitions below have been pared down to the bare +;;; minimum; they will be restored later. +;;; +;;; -Satish 2/5. + +;;; Keymap for Haskell mode +(defvar haskell-mode-map nil + "Keymap used for haskell-mode") + +(defun haskell-establish-key-bindings (keymap) + (define-key keymap "\C-ce" 'haskell-eval) + (define-key keymap "\C-cr" 'haskell-run) + (define-key keymap "\C-cm" 'haskell-run-main) + (define-key keymap "\C-c\C-r" 'haskell-run-file) + (define-key keymap "\C-cp" 'haskell-get-pad) + (define-key keymap "\C-c\C-o" 'haskell-optimizers) + (define-key keymap "\C-c\C-p" 'haskell-printers) + (define-key keymap "\C-cc" 'haskell-compile) + (define-key keymap "\C-cl" 'haskell-load) + (define-key keymap "\C-ch" 'haskell-switch) + (define-key keymap "\C-c:" 'haskell-command) + (define-key keymap "\C-cq" 'haskell-exit) + (define-key keymap "\C-ci" 'haskell-interrupt) + (define-key keymap "\C-cu" 'haskell-edit-unit) + (define-key keymap "\C-cd" 'haskell-please-recover) + (define-key keymap "\C-c(" 'haskell-ensure-lisp-mode) + (define-key keymap "\C-c)" 'haskell-resume-command-loop)) + + +(if haskell-mode-map + nil + (progn + (setq haskell-mode-map (make-sparse-keymap)) + ;; Compiler commands + (haskell-establish-key-bindings haskell-mode-map) + )) + +(defvar haskell-mode-syntax-table nil + "Syntax table used for haskell-mode") + +(if haskell-mode-syntax-table + nil + (setq haskell-mode-syntax-table (standard-syntax-table))) + +;;; Command for invoking the Haskell mode +(defun haskell-mode nil + "Major mode for editing Haskell code to run in Emacs +The following commands are available: +\\{haskell-mode-map} + +A Haskell process can be fired up with \"M-x haskell\". + +Customization: Entry to this mode runs the hooks that are the value of variable +haskell-mode-hook. + +Windows: + +There are 3 types of windows associated with Haskell mode. They are: + *haskell*: which is the process window. + Pad: which are buffers available for each module. It is here + where you want to test things before preserving them in a + file. Pads are always associated with a module. + When issuing a command: + The pad and its associated module are sent to the Haskell + process prior to the execution of the command. + .hs: These are the files where Haskell programs live. They + have .hs as extension. + When issuing a command: + The file is sent to the Haskell process prior to the + execution of the command. + +Commands: + +Each command behaves differently according to the type of the window in which +the cursor is positioned when the command is issued . + +haskell-eval: \\[haskell-eval] + Always promts user for a Haskell expression to be evaluated. If in a + .hs file buffer, then the cursor tells which module is the current + module and the pad for that module (if any) gets loaded as well. + +haskell-run: \\[haskell-run] + Always queries for a variable of type Dialogue to be evaluated. + +haskell-run-main: \\[haskell-run-main] + Run Dialogue named main. + +haskell-run-file: \\[haskell-run-file] + Runs a file. Ideally the file has a set of variable of type Dialogue + that get evaluated. + +haskell-mode: \\[haskell-mode] + Puts the current buffer in haskell mode. + +haskell-compile: \\[haskell-compile] + Compiles file in current buffer. + +haskell-load: \\[haskell-load] + Loads file in current buffer. + +haskell-pad: \\[haskell-pad] + Creates a scratch pad for the current module. + +haskell-optimizers: \\[haskell-optimizers] + Shows the list of available optimizers. Commands for turning them on/off. + +haskell-printers: \\[haskell-printers] + Shows the list of available printers. Commands for turning them on/off. + +haskell-command: \\[haskell-command] + Prompts for a command to be sent to the command interface. You don't + need to put the : before the command. + +haskell-quit: \\[haskell-quit] + Terminates the haskell process. + +switch-to-haskell: \\[switch-to-haskell] + Switchs to the inferior Haskell buffer (*haskell*) and positions the + cursor at the end of the buffer. + +haskell-interrupt: \\[haskell-interrupt] + Interrupts haskell process and resets it. + +haskell-edit-unit: \\[haskell-edit-unit] + Edit the .hu file for the unit containing this file. +" + (interactive) + (kill-all-local-variables) + (use-local-map haskell-mode-map) + (setq major-mode 'haskell-mode) + (setq mode-name "Haskell") + (make-local-variable 'indent-line-function) + (setq indent-line-function 'indent-relative-maybe) + ;(setq local-abbrev-table haskell-mode-abbrev-table) + (set-syntax-table haskell-mode-syntax-table) + ;(setq tab-stop-list haskell-tab-stop-list) ;; save old list?? + (run-hooks 'haskell-mode-hook)) + + + +;;;================================================================ +;;; Inferior Haskell stuff +;;;================================================================ + + +(defvar inferior-haskell-mode-map nil) + +(if inferior-haskell-mode-map + nil + (setq inferior-haskell-mode-map + (full-copy-sparse-keymap comint-mode-map)) + ;;; Haskell commands + (haskell-establish-key-bindings inferior-haskell-mode-map) + (define-key inferior-haskell-mode-map "\C-m" 'haskell-send-input)) + +(defvar haskell-source-modes '(haskell-mode) + "*Used to determine if a buffer contains Haskell source code. +If it's loaded into a buffer that is in one of these major modes, +it's considered a Haskell source file.") + +(defvar haskell-prev-l/c-dir/file nil + "Caches the (directory . file) pair used in the last invocation of +haskell-run-file.") + +(defvar haskell-prompt-pattern "^[A-Z]\\([A-Z]\\|[a-z]\\|[0-9]\\)*>\\s-*" + "Regular expression capturing the Haskell system prompt.") + +(defvar haskell-prompt-ring () + "Keeps track of input to haskell process from the minibuffer") + +(defvar tea-prompt-pattern "^>+\\s-*" + "Regular expression capturing the T system prompt.") + +(defvar haskell-version "Yale University Haskell Version 0.8, 1991" + "Current Haskell system version") + +(defun inferior-haskell-mode-variables () + nil) + + +;;; INFERIOR-HASKELL-MODE (adapted from comint.el) + +(defun inferior-haskell-mode () + "Major mode for interacting with an inferior Haskell process. + +The following commands are available: +\\{inferior-haskell-mode-map} + +A Haskell process can be fired up with \"M-x haskell\". + +Customization: Entry to this mode runs the hooks on comint-mode-hook and +inferior-haskell-mode-hook (in that order). + +You can send text to the inferior Haskell process from other buffers containing +Haskell source. + + +Windows: + +There are 3 types of windows in the inferior-haskell-mode. They are: + *haskell*: which is the process window. + Pad: which are buffers available for each module. It is here + where you want to test things before preserving them in a + file. Pads are always associated with a module. + When issuing a command: + The pad and its associated module are sent to the Haskell + process prior to the execution of the command. + .hs: These are the files where Haskell programs live. They + have .hs as extension. + When issuing a command: + The file is sent to the Haskell process prior to the + execution of the command. + +Commands: + +Each command behaves differently according to the type of the window in which +the cursor is positioned when the command is issued. + +haskell-eval: \\[haskell-eval] + Always promts user for a Haskell expression to be evaluated. If in a + .hs file, then the cursor tells which module is the current module and + the pad for that module (if any) gets loaded as well. + +haskell-run: \\[haskell-run] + Always queries for a variable of type Dialogue to be evaluated. + +haskell-run-main: \\[haskell-run-main] + Run Dialogue named main. + +haskell-run-file: \\[haskell-run-file] + Runs a file. Ideally the file has a set of variable of type Dialogue + that get evaluated. + +haskell-mode: \\[haskell-mode] + Puts the current buffer in haskell mode. + +haskell-compile: \\[haskell-compile] + Compiles file in current buffer. + +haskell-load: \\[haskell-load] + Loads file in current buffer. + +haskell-pad: \\[haskell-pad] + Creates a scratch pad for the current module. + +haskell-optimizers: \\[haskell-optimizers] + Shows the list of available optimizers. Commands for turning them on/off. + +haskell-printers: \\[haskell-printers] + Shows the list of available printers. Commands for turning them on/off. + +haskell-command: \\[haskell-command] + Prompts for a command to be sent to the command interface. You don't + need to put the : before the command. + +haskell-quit: \\[haskell-quit] + Terminates the haskell process. + +switch-to-haskell: \\[switch-to-haskell] + Switchs to the inferior Haskell buffer (*haskell*) and positions the + cursor at the end of the buffer. + +haskell-interrupt: \\[haskell-interrupt] + Interrupts haskell process and resets it. + +haskell-edit-unit: \\[haskell-edit-unit] + Edit the .hu file for the unit containing this file. + +The usual comint functions are also available. In particular, the +following are all available: + +comint-bol: Beginning of line, but skip prompt. Bound to C-a by default. +comint-delchar-or-maybe-eof: Delete char, unless at end of buffer, in + which case send EOF to process. Bound to C-d by default. + +Note however, that the default keymap bindings provided shadow some of +the default comint mode bindings, so that you may want to bind them +to your choice of keys. + +Comint mode's dynamic completion of filenames in the buffer is available. +(Q.v. comint-dynamic-complete, comint-dynamic-list-completions.) + +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it." + + (interactive) + (comint-mode) + (setq comint-prompt-regexp haskell-prompt-pattern) + ;; Customise in inferior-haskell-mode-hook + (inferior-haskell-mode-variables) + (setq major-mode 'inferior-haskell-mode) + (setq mode-name "Inferior Haskell") + (setq mode-line-process '(": %s : busy")) + (use-local-map inferior-haskell-mode-map) + (setq comint-input-filter 'haskell-input-filter) + (setq comint-input-sentinel 'ignore) + (setq comint-get-old-input 'haskell-get-old-input) + (run-hooks 'inferior-haskell-mode-hook) + ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook. + ;The test is so we don't lose history if we run comint-mode twice in + ;a buffer. + (setq haskell-prompt-ring (make-ring input-ring-size))) + + +;;; Install the process communication commands in the +;;; inferior-haskell-mode keymap. + +(defvar inferior-haskell-mode-hook 'haskell-fresh-start + "*Hook for customizing inferior-Haskell mode") + +(defun haskell-input-filter (str) + "Don't save whitespace." + (not (string-match "\\s *" str))) + + + +;;; ================================================================== +;;; Handle output from Haskell process +;;; ================================================================== + + +;;; This keeps track of the status of the haskell process. +;;; Values are: +;;; busy -- The process is busy. +;;; ready -- The process is ready for a command. +;;; input -- The process is waiting for input. +;;; dead -- The process is dead (exited or not started yet). + + +(defvar *haskell-status* 'dead + "Status of the haskell process") + +(defun set-haskell-status (value) + (setq *haskell-status* value) + (update-mode-line)) + +(defun get-haskell-status () + *haskell-status*) + +(defun update-mode-line () + (save-excursion + (set-buffer *haskell-buffer*) + (cond ((eq *haskell-status* 'ready) + (setq mode-line-process '(": %s: ready"))) + ((eq *haskell-status* 'input) + (setq mode-line-process '(": %s: input"))) + ((eq *haskell-status* 'busy) + (setq mode-line-process '(": %s: busy"))) + ((eq *haskell-status* 'dead) + (setq mode-line-process '(": %s: dead"))) + (t + (haskell-mode-error "Confused about status of haskell process!"))) + ;; Yes, this is the officially sanctioned technique for forcing + ;; a redisplay of the mode line. + (set-buffer-modified-p (buffer-modified-p)))) + + +;;; Filter +;;; The haskell process produces output with embedded control codes. +;;; These control codes are used to keep track of what kind of input +;;; the haskell process is expecting. Ordinary output is just displayed. +;;; +;;; This is kind of complicated because control sequences can be broken +;;; across multiple batches of text received from the haskell process. +;;; If the string ends in the middle of a control sequence, save it up +;;; for the next call. + +(defvar *haskell-saved-output* nil) + +(defun process-haskell-output (process str) + "Filter for output from Yale Haskell command interface" + (let ((idx 0) + (lastidx 0) + (data (match-data))) + (unwind-protect + (progn + ;; If there was saved output from last time, glue it in front of the + ;; newly received input. + (if *haskell-saved-output* + (progn + (setq str (concat *haskell-saved-output* str)) + (setq *haskell-saved-output* nil))) + ;; Loop, looking for complete command sequences. + ;; Set idx to point to the first one. + ;; lastidx points to next character to be processed. + (while (setq idx (ci-response-start str lastidx)) + ;; Display any intervening ordinary text. + (if (not (eq idx lastidx)) + (haskell-display-output (substring str lastidx idx))) + ;; Now dispatch on the particular command sequence found. + ;; Handler functions are called with the string and start index + ;; as arguments, and should return the index of the "next" + ;; character -- usually (match-end 0). + (setq lastidx (funcall (ci-response-handler str idx) str idx))) + ;; Look to see whether the string ends with an incomplete + ;; command sequence. + ;; If so, save the tail of the string for next time. + (if (setq idx (ci-prefix-start str lastidx)) + (setq *haskell-saved-output* (substring str idx)) + (setq idx (length str))) + ;; Display any leftover ordinary text. + (if (not (eq idx lastidx)) + (haskell-display-output (substring str lastidx idx)))) + (store-match-data data)))) + + + +;;; Here is code for matching command sequences from haskell. + +;;; The first entry of each item is the full regexp; the second is a prefix +;;; regexp; the third is a handler function to call. + +(defvar *ci-responses* + '(("\C-Ar" "\C-A" haskell-got-ready) + ("\C-Ai" "\C-A" haskell-got-input-request) + ("\C-Ae" "\C-A" haskell-got-error) + ("\C-Ap.*\n" "\C-A\\(p.*\\)?" haskell-got-printers) + ("\C-Ao.*\n" "\C-A\\(o.*\\)?" haskell-got-optimizers) + ("\C-As.*\n" "\C-A\\(s.*\\)?" haskell-got-message) + ;; This is the error string for T +; ("^\\*\\* Error" +; "^\\*\\(\\*\\( \\(E\\(r\\(r\\(or?\\)?\\)?\\)?\\)?\\)?\\)?" +; haskell-got-lisp-error) + ;; This is the prompt for Lucid's break loop + ("\n-> " "\n\\(-\\(> ?\\)?\\)?" haskell-got-lisp-error) + ;; This is the prompt for CMU CL's break loop + ("0\\] " "0\\(\\] ?\\)?" haskell-got-lisp-error) + ;; This is the prompt for AKCL's break loop + ("USER>>" "U\\(S\\(E\\(R\\(>>?\\)?\\)?\\)?\\)?" haskell-got-lisp-error) + ;; This is the prompt for Allegro CL + ("USER(.*):" "U\\(S\\(E\\(R\\((.*)?\\)?\\)?\\)?\\)?" haskell-got-lisp-error) + ;; This is the prompt for Harlequin Lispworks + ("USER .* : .* >" "U\\(S\\(E\\(R\\( .*\\( \\(:\\( .*\\( >?\\)?\\)?\\)?\\)?\\)?\\)?\\)?\\)?" haskell-got-lisp-error) + )) + +(defun command-match-regexp (x) (car x)) +(defun command-prefix-regexp (x) (car (cdr x))) +(defun command-handler (x) (car (cdr (cdr x)))) + +(defun glue-together (extractor) + (let ((result (concat "\\(" (funcall extractor (car *ci-responses*)) "\\)")) + (stuff (cdr *ci-responses*))) + (while stuff + (setq result + (concat result "\\|\\(" (funcall extractor (car stuff)) "\\)")) + (setq stuff (cdr stuff))) + result)) + +(defvar *ci-response-regexp* (glue-together 'command-match-regexp)) + +(defvar *ci-prefix-regexp* + (concat "\\(" (glue-together 'command-prefix-regexp) "\\)\\'")) + +(defun ci-response-start (str idx) + (string-match *ci-response-regexp* str idx)) + +(defun ci-prefix-start (str idx) + (string-match *ci-prefix-regexp* str idx)) + +(defun ci-response-handler (str idx) + (let ((list *ci-responses*) + (result nil)) + (while (and list (null result)) + (if (eq (string-match (command-match-regexp (car list)) str idx) idx) + (setq result (command-handler (car list))) + (setq list (cdr list)))) + (if (null result) + (haskell-mode-error "Failed to find command handler!!!")) + result)) + + +;;; Here are the low-level handler functions. Basically, these +;;; guys just parse the input for the command sequence and then call some +;;; other function to do the real work. + +(defun haskell-got-ready (str idx) + (let ((result (match-end 0))) + (haskell-reset) + result)) + +(defun haskell-got-input-request (str idx) + (let ((result (match-end 0))) + (get-user-input) + result)) + +(defun haskell-got-error (str idx) + (let ((result (match-end 0))) + (haskell-error-handler) + result)) + +(defun haskell-got-printers (str idx) + (let ((result (match-end 0))) + (update-printers-list (substring str (+ idx 2) (- result 1))) + result)) + +(defun haskell-got-optimizers (str idx) + (let ((result (match-end 0))) + (update-optimizers-list (substring str (+ idx 2) (- result 1))) + result)) + +(defun haskell-got-message (str idx) + (let ((result (match-end 0))) + (message (substring str (+ idx 2) (- result 1))) + result)) + +(defun haskell-got-lisp-error (str idx) + (haskell-handle-lisp-error idx str) + (length str)) + + +;;; Something really bad happened and we got a Lisp error. +;;; Either let the user mess around in the Lisp debugger, or else +;;; just get out of it and go back into the Haskell command loop. + +(defun haskell-handle-lisp-error (location str) + (haskell-display-output (substring str location)) + (if *emacs* + ;; Don't ding if we were already in the break loop when the + ;; error happened. + (progn + (ding) + (if *haskell-debug-in-lisp* + (haskell-talk-to-lisp) + (haskell-flush-commands-and-reset))))) + +(defun loaded-tutorial-p () + (and *ht-temp-buffer* + (get-buffer *ht-temp-buffer*) + (equal *last-loaded* (buffer-file-name (get-buffer *ht-temp-buffer*))))) + +(defun haskell-flush-commands-and-reset () + (haskell-flush-command-queue) + (save-excursion + (switch-to-buffer *haskell-buffer*) + (haskell-ensure-lisp-mode) + (haskell-resume-command-loop))) + +(defun haskell-talk-to-lisp () + (pop-to-buffer *haskell-buffer*) + (goto-char (point-max)) + (haskell-ensure-lisp-mode)) + + +(defun haskell-resume-command-loop () + "Resumes Haskell command processing after debugging in Lisp. \\[haskell-resume-command-loop]" + (interactive) + (if (not *emacs*) + (progn + (process-send-string "haskell" "(mumble-user::restart-haskell)\n") + (haskell-ensure-emacs-mode)))) + + + +;;; Displays output at end of given buffer. +;;; This function only ensures that the output is visible, without +;;; selecting the buffer in which it is displayed. +;;; Note that just using display-buffer instead of all this rigamarole +;;; won't work; you need to temporarily select the window containing +;;; the *haskell-buffer*, or else the display won't be scrolled to show +;;; the new output. +;;; *** This should really position the window in the buffer so that +;;; *** the point is on the last line of the window. + +(defun haskell-display-output (str) + (if (eq (get-haskell-status) 'dead) + (save-excursion + (set-buffer *haskell-buffer*) + (haskell-display-output-aux str)) + (let ((window (selected-window))) + (unwind-protect + (progn + (pop-to-buffer *haskell-buffer*) + (haskell-display-output-aux str)) + (select-window window))))) + +(defun haskell-display-output-aux (str) + (haskell-move-marker) + (insert str) + (haskell-move-marker)) + + + +;;; The haskell process says it's expecting the user to type in some input. +;;; Switch to the *haskell-buffer* so the user can type things. +;;; Once we have received an input message, stay in input mode until +;;; we get a ready message back from haskell. This permits multiple +;;; data messages to be sent to haskell from a single input request. +;;; +;;; This user interface isn't really ideal. You can be typing +;;; away in some other buffer and all of a sudden have Haskell decide +;;; it wants some input, and bingo! You're switched into the Haskell +;;; buffer behind your back. There's also the problem that you're +;;; left in the Haskell buffer afterwards, instead of getting swapped +;;; back into the buffer that was current when the input request was +;;; received. +;;; Not sure how to fix this -- seems like a totally synchronous interface +;;; would be worse.... + +(defun get-user-input () + (message "Haskell is waiting for input...") + (pop-to-buffer *haskell-buffer*) + (goto-char (point-max)) + (set-haskell-status 'input) + (haskell-pop-data-queue)) + + +;;; The haskell process says it encountered an error. +;;; Remember to flush the command queue before continuing. + +(defun haskell-error-handler () + (ding) + (haskell-flush-command-queue) + ;; *** See comments below for why this is disabled. +; (if *haskell-show-error* +; (haskell-show-error)) + (set-haskell-status 'ready) + (haskell-end-interaction nil)) + + +;;; Pop up a buffer containing the file with the error, and put the +;;; point on the line where the error was reported. +;;; *** This code does the wrong thing in some situations. For example, +;;; *** if you type in garbage to C-c e, it thinks that it should +;;; *** show you the last pad sent to the haskell process, which is +;;; *** clearly bogus. +;;; *** I also think it would be better interaction style to have to +;;; *** request to be shown the error explicitly, instead of unexpectedly +;;; *** being thrown into some other buffer. + +;;; Error handling Variables + +(defvar *yh-error-def* "Error occured in definition of\\s *") +(defvar *yh-error-line* "at line\\s *") +(defvar *yh-error-file* "of file\\s *") +(defvar *haskell-line* "\\([0-9]\\)*") + +(defun haskell-show-error () + "Point out error to user if possible" + (set-buffer *haskell-buffer*) + (save-excursion + (let ((function-name nil) + (line-number nil) + (filename nil)) + (if (and (setq function-name (get-function-name)) + (setq line-number (get-line-number)) + (setq filename (get-filename))) + (point-error-to-user function-name line-number filename))))) + +(defvar *haskell-function-name* + "\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\|\-\\)*") + +(defun get-function-name () + (if (and (re-search-backward *yh-error-def* (point-min) t) + (re-search-forward *yh-error-def* (point-max) t)) + (let ((beg (point))) + (if (re-search-forward *haskell-function-name* (point-max) t) + (buffer-substring beg (point)) + nil)) + nil)) + +(defun get-line-number () + (if (re-search-forward *yh-error-line* (point-max) t) + (let ((beg (point))) + (if (re-search-forward *haskell-line* (point-max) t) + (string-to-int (buffer-substring beg (point))) + nil)) + nil)) + + +(defun get-filename () + (if (re-search-forward *yh-error-file* (point-max) t) + (let ((beg (point))) + (if (re-search-forward "\\($\\| \\|\t\\)" (point-max) t) + (buffer-substring beg (point)) + nil)) + nil)) + +(defun point-error-to-user (function-name line-number filename) + (if (equal filename "Interactive") + (pop-to-buffer *last-pad*) + (let ((fname (strip-fext filename))) + (if (get-buffer fname) + (pop-to-buffer fname) + (find-file-other-window filename)))) + (goto-line line-number)) + + +;;; The haskell process says it is ready to execute another command. +;;; Tell the user the last command has finished and execute the next +;;; command from the queue, if there is one. + +(defun haskell-reset () + (set-haskell-status 'ready) + (haskell-pop-command-queue)) + + + + +;;; ================================================================== +;;; Command queue utilities +;;; ================================================================== + +;;; Here's the stuff for managing the command queue. +;;; There are three kinds of things that show up in the queue: +;;; * Strings to be sent as commands to the haskell process. These +;;; are queued with haskell-send-command. +;;; * Other stuff to be sent to the haskell process (e.g., text to +;;; be read as dialogue input). These are queued with +;;; haskell-send-data. +;;; * Messages indicating start of an interaction sequence. These +;;; are just shown to the user. These are added to the queue with +;;; haskell-begin-interaction. +;;; * Messages indicating end of an interaction sequence. These are +;;; queued with haskell-end-interaction. +;;; +;;; Representationally, the queue is just a list of conses. The car of each +;;; entry is a symbol that identifies the kind of queue entry, and the cdr +;;; is associated data. Only the functions in this section need to know +;;; about the internal format of the queue. + + +(defvar *command-interface-queue* nil + "Contains the commands to be sent to the Haskell command interface") + + +;;; Here's a helper function. + +(defun haskell-queue-or-execute (fn request data) + (cond (*command-interface-queue* + (setq *command-interface-queue* + (nconc *command-interface-queue* (list (cons request data))))) + ((eq (get-haskell-status) 'ready) + (funcall fn data)) + (t + (setq *command-interface-queue* (list (cons request data)))))) + + +;;; Queue a command. + +(defun haskell-send-command (str) + "Queues STRING for transmission to haskell process." + (haskell-queue-or-execute 'haskell-send-command-aux 'command str)) + +(defun haskell-send-command-aux (str) + (process-send-string "haskell" str) + (process-send-string "haskell" "\n") + (if (not (eq (get-haskell-status) 'input)) + (set-haskell-status 'busy))) + + +;;; Queue a begin-interaction message. + +(defvar *begin-interaction-delimiter* nil ;; "-------------\n" + "*Delimiter showing an interaction has begun") + +(defun haskell-begin-interaction (msg) + (haskell-queue-or-execute 'haskell-begin-interaction-aux 'begin msg)) + +(defun haskell-begin-interaction-aux (msg) + (if *begin-interaction-delimiter* + (haskell-display-output *begin-interaction-delimiter*)) + (if msg + (haskell-display-output (concat "\n" msg "\n")))) + + +;;; Queue an end-interaction message. + +(defvar *end-interaction-delimiter* nil ;; "\n--- ready ---\n\n" + "*Delimiter showing an interaction has ended") + +(defun haskell-end-interaction (msg) + (haskell-queue-or-execute 'haskell-end-interaction-aux 'end msg)) + +(defun haskell-end-interaction-aux (msg) + (if *end-interaction-delimiter* + (haskell-display-output *end-interaction-delimiter*)) + (if msg + (message "%s" msg))) + + +;;; Queue data. This is treated a little differently because we want +;;; text typed in as input to the program to be sent down the pipe to +;;; the process before processing end-interaction messages and additional +;;; commands in the queue. + +(defun haskell-send-data (str) + (cond ((assoc 'data *command-interface-queue*) + (setq *command-interface-queue* + (merge-data-into-queue + (list (cons 'data str)) + *command-interface-queue* + *command-interface-queue* + nil))) + ((or (eq (get-haskell-status) 'ready) (eq (get-haskell-status) 'input)) + (haskell-send-command-aux str)) + (t + (setq *command-interface-queue* (list (cons 'data str)))))) + +(defun merge-data-into-queue (new head tail lasttail) + (cond ((null tail) + (rplacd lasttail new) + head) + ((eq (car (car tail)) 'data) + (merge-data-into-queue new head (cdr tail) tail)) + (lasttail + (rplacd lasttail new) + (rplacd new tail) + head) + (t + (rplacd new tail) + new))) + + +;;; This function is called when the haskell process reports that it +;;; has finished processing a command. It sends the next queued +;;; command (if there is one) down the pipe. + +(defun haskell-pop-command-queue () + (if *command-interface-queue* + (let ((entry (car *command-interface-queue*))) + (setq *command-interface-queue* (cdr *command-interface-queue*)) + (cond ((eq (car entry) 'command) + (haskell-send-command-aux (cdr entry))) + ((eq (car entry) 'begin) + (haskell-begin-interaction-aux (cdr entry)) + (haskell-pop-command-queue)) + ((eq (car entry) 'end) + (haskell-end-interaction-aux (cdr entry)) + (haskell-pop-command-queue)) + ((eq (car entry) 'data) + (haskell-send-command-aux (cdr entry))) + (t + (haskell-mode-error "Invalid command in queue!!!")) + )))) + + +;;; This function is called when the haskell process reports that it +;;; wants to read some input. If there's queued data, send it; but +;;; don't do commands or messages on the queue. +;;; Remember, we can send multiple pieces of input data for one input +;;; request from haskell. + +(defun haskell-pop-data-queue () + (if *command-interface-queue* + (let ((entry (car *command-interface-queue*))) + (if (eq (car entry) 'data) + (progn + (setq *command-interface-queue* (cdr *command-interface-queue*)) + (haskell-send-command-aux (cdr entry)) + (haskell-pop-data-queue)))))) + + +;;; This is called when there is an error. + +(defun haskell-flush-command-queue () + (setq *command-interface-queue* nil)) + + + +;;; ================================================================== +;;; Interactive commands +;;; ================================================================== + + +;;; HASKELL and RUN HASKELL +;;; ------------------------------------------------------------------ + +;;; These are the two functions that start a Haskell process. +;;; Rewritten to avoid doing anything if a Haskell process +;;; already exists. 1991-Sep-09 Dan Rabin. + +;;; *** Dan says: +;;; *** If the *haskell* buffer still exists, and the process has status +;;; *** `dead', the usual evaluation commands don't create a new one, so no +;;; *** evaluation happens. + + +(defun haskell () + "Run an inferior Haskell process with input and output via buffer *haskell*. +Takes the program name from the variable haskell-program-name. +Runs the hooks from inferior-haskell-mode-hook +(after the comint-mode-hook is run). +\(Type \\[describe-mode] in the process buffer for a list of commands.)" + (interactive) + (let ((haskell-buffer (get-buffer *haskell-buffer*))) + (if (not (and haskell-buffer (comint-check-proc haskell-buffer))) + (progn + (setq haskell-buffer + (apply 'make-comint + "haskell" + haskell-program-name + nil + nil)) + (save-excursion + (set-buffer haskell-buffer) + (inferior-haskell-mode)) + (display-buffer haskell-buffer))))) + + +;;; Fresh start + +(defun haskell-fresh-start () + (set-haskell-status 'busy) + (setq *command-interface-queue* nil) + (setq *last-loaded* haskell-main-file) + (setq *last-pad* haskell-main-pad) + (setq *emacs* nil) + (setq *haskell-saved-output* nil) + (haskell-ensure-emacs-mode)) + + +;;; Called from evaluation and compilation commands to start up a Haskell +;;; process if none is already in progress. + +(defun haskell-maybe-create-process () + (if haskell-auto-create-process + (haskell))) + + +;;; This is called from HASKELL-FRESH-START to ensure that +;;; there is a pad when starting up a Haskell interaction. + +(defun haskell-ensure-emacs-mode () + (create-main-pad) + (setq *emacs* t) + (ci-emacs)) + + +;;; This is called when a Lisp error has been detected. + +(defun haskell-ensure-lisp-mode () + "Switch to talking to Lisp. \\[haskell-ensure-lisp-mode]" + (interactive) + (setq *emacs* nil)) + + +;;; HASKELL-GET-PAD +;;; ------------------------------------------------------------------ + +;;; This always puts the pad buffer in the "other" window. +;;; Having it wipe out the .hs file window is clearly the wrong +;;; behavior. + +(defun haskell-get-pad () + "Creates a new scratch pad for the current module. +Signals an error if the current buffer is not a .hs file." + (interactive) + (let ((fname (buffer-file-name))) + (if fname + (do-get-pad fname (current-buffer)) + (haskell-mode-error "Not in a .hs buffer")))) + + +(defun do-get-pad (fname buff) + (let* ((mname (or (get-modname buff) + (read-no-blanks-input "Scratch pad for module? " nil))) + (pname (lookup-pad mname fname)) + (pbuff nil)) + ;; Generate the base name of the pad buffer, then create the + ;; buffer. The actual name of the pad buffer may be something + ;; else because of name collisions. + (if (or (not pname) (not (setq pbuff (get-buffer pname)))) + (progn + (setq pname (get-padname mname)) + (setq pbuff (generate-new-buffer pname)) + (setq pname (buffer-name pbuff)) + (record-pad-mapping pname mname fname) + )) + ;; Make sure the pad buffer is in haskell mode. + (pop-to-buffer pbuff) + (haskell-mode))) + + +;;; HASKELL-SWITCH +;;; ------------------------------------------------------------------ + +(defun haskell-switch () + "Switches to \*haskell\* buffer" + (interactive) + (haskell-maybe-create-process) + (switch-to-haskell t)) + + +(defun switch-to-haskell (eob-p) + "Really switch to the \*haskell\* buffer. +With argument, positions cursor at end of buffer." + (interactive "P") + (pop-to-buffer *haskell-buffer*) + (cond (eob-p + (push-mark) + (goto-char (point-max))))) + + +;;; HASKELL-COMMAND +;;; ------------------------------------------------------------------ + +(defun haskell-command (str) + "Format STRING as a haskell command and send it to haskell process. \\[haskell-command]" + (interactive "sHaskell command: ") + (if (eq ?Q (capitalize (aref str 0))) + (ci-quit) + (progn + (haskell-begin-interaction + (concat "Executing command: :" str)) + (haskell-send-command (concat ":" str)) + (haskell-end-interaction + (concat "Executing command: :" str " ...done."))))) + + +;;; HASKELL-EVAL and HASKELL-RUN +;;; ------------------------------------------------------------------ + +(defun haskell-eval () + "Evaluate expression in current module. \\[haskell-eval]" + (interactive) + (haskell-maybe-create-process) + (haskell-eval-aux (get-haskell-expression "Haskell expression: ") + nil + "Evaluating")) + +(defun haskell-run () + "Run Haskell Dialogue in current module" + (interactive) + (haskell-maybe-create-process) + (haskell-eval-aux (get-haskell-expression "Haskell dialogue: ") + t + "Running")) + +(defun haskell-run-main () + "Run Dialogue named main in current module" + (interactive) + (haskell-maybe-create-process) + (haskell-eval-aux "main" t "Running")) + +(defun haskell-eval-aux (exp dialogue-p what) + (cond ((equal *haskell-buffer* (buffer-name)) + (let* ((pname *last-pad*) + (mname *last-module*) + (fname *last-loaded*) + (msg (format "%s: %s" what exp))) + (haskell-eval-aux-aux exp pname mname fname msg dialogue-p))) + ((equal *ht-temp-buffer* (buffer-name)) + (let* ((fname (buffer-file-name)) + (mname (get-modname (current-buffer))) + (pname (lookup-pad mname fname)) + (msg (format "%s (in tutorial): %s" what exp))) + (haskell-eval-aux-aux exp pname mname fname msg dialogue-p))) + ((buffer-file-name) + (let* ((fname (buffer-file-name)) + (mname (get-modname (current-buffer))) + (pname (lookup-pad mname fname)) + (msg (format "%s (in file %s): %s" + what (file-name-nondirectory fname) exp))) + (haskell-eval-aux-aux exp pname mname fname msg dialogue-p))) + (t + (let* ((pname (buffer-name (current-buffer))) + (mname (get-module-from-pad pname)) + (fname (get-file-from-pad pname)) + (msg (format "%s (in pad %s): %s" what pname exp))) + (haskell-eval-aux-aux exp pname mname fname msg dialogue-p))) + )) + +(defun haskell-eval-aux-aux (exp pname mname fname msg dialogue-p) + (haskell-begin-interaction msg) + (ci-kill) + (haskell-load-file-if-modified fname) + (ci-module mname) + (if pname (haskell-save-pad-if-modified pname)) + (if dialogue-p + (ci-send-name exp) + (ci-print-exp exp)) + (ci-eval) + (haskell-end-interaction (concat msg " ...done."))) + + +;;; Save pad only if modified. Keep track of *last-pad* sent to process. + +(defun haskell-save-pad-if-modified (pad) + (save-excursion + (set-buffer pad) + (if (or (equal pad haskell-main-pad) (buffer-modified-p)) + (progn + (setq *last-pad* pad) + (ci-clear) + (ci-set-file pad) + (ci-send-buffer pad) +; (set-buffer-modified-p t) ;***??? + (ci-save))))) + + + +;;; HASKELL-RUN-FILE +;;; ------------------------------------------------------------------ + +(defun haskell-run-file () + "Run all Dialogues in current file" + (interactive) + (haskell-maybe-create-process) + (cond ((equal *haskell-buffer* (buffer-name)) + ;; When called from the haskell process buffer, prompt for + ;; a file to run. + (call-interactively 'haskell-run-file/process)) + ((buffer-file-name) + ;; When called from a .hs file buffer, run that file. + (haskell-run-file-aux (buffer-file-name))) + (t + ;; When called from a pad, run the file that the module the + ;; pad belongs to lives in. + (haskell-run-file-aux + (get-file-from-pad (buffer-name (current-buffer))))) + )) + +(defun haskell-run-file/process (filename) + (interactive (comint-get-source "Haskell file to run: " + haskell-prev-l/c-dir/file + haskell-source-modes t)) + (comint-check-source filename) + (setq haskell-prev-l/c-dir/file + (cons (file-name-directory filename) + (file-name-nondirectory filename))) + (haskell-run-file-aux filename)) + +(defun haskell-run-file-aux (fname) + (let ((msg (concat "Running file: " fname))) + (haskell-begin-interaction msg) + (ci-kill) + (save-modified-source-files buffer-file-name) + (ci-run (strip-fext fname)) + (haskell-end-interaction (concat msg " ...done.")))) + + +;;; HASKELL-LOAD +;;; ------------------------------------------------------------------ + +(defun haskell-load () + "Load current file" + (interactive) + (haskell-maybe-create-process) + (let* ((fname (buffer-file-name)) + (msg (concat "Loading file: " fname))) + (cond (fname + (haskell-begin-interaction msg) + (haskell-load-file-if-modified fname) + (haskell-end-interaction (concat msg " ...done."))) + (t + (haskell-mode-error "Must be in a file to load"))))) + + +;;; Load file only if modified or not *last-loaded*. +;;; For now, this just loads the file unconditionally. + +(defun haskell-load-file-if-modified (filename) + (save-modified-source-files buffer-file-name) + (cond ((string= filename haskell-main-file) + (setq *last-loaded* haskell-main-file) + (ci-load-main)) + (t + (setq *last-loaded* filename) + (ci-load (strip-fext filename))))) + + +;;; ***This isn't used any more. +;(defun file-modification-time (file) +; "Get modification time for FILE from filesystem information." +; (car (cdr (car (nthcdr 5 (file-attributes file)))))) + + +;;; HASKELL-COMPILE +;;; ------------------------------------------------------------------ + +(defun haskell-compile () + "Compile current file" + (interactive) + (haskell-maybe-create-process) + (let ((fname (buffer-file-name))) + (cond (fname + (haskell-begin-interaction (concat "Compiling: " fname)) + (haskell-compile-file-if-modified fname) + (haskell-end-interaction + (concat "Compiling: " fname " ...done."))) + (t + (haskell-mode-error "Must be in a file to compile"))))) + +(defun haskell-compile-file-if-modified (fname) + ;; *** For now it unconditionally compiles the file. + (save-modified-source-files buffer-file-name) + (ci-compile (strip-fext fname))) + + +;;; HASKELL-EXIT +;;; ------------------------------------------------------------------ + +(defun haskell-exit () + "Quit the haskell process" + (interactive) + (ci-quit) + ;; If we were running the tutorial, mark the temp buffer as unmodified + ;; so we don't get asked about saving it later. + (if (and *ht-temp-buffer* + (get-buffer *ht-temp-buffer*)) + (save-excursion + (set-buffer *ht-temp-buffer*) + (set-buffer-modified-p nil))) + ;; Try to remove the haskell output buffer from the screen. + (bury-buffer *haskell-buffer*) + (replace-buffer-in-windows *haskell-buffer*)) + + +;;; HASKELL-INTERRUPT +;;; ------------------------------------------------------------------ + +(defun haskell-interrupt () + "Interrupt the haskell process" + (interactive) + ;; Do not queue the interrupt character; send it immediately. + (haskell-send-command-aux "\C-c") ; interrupt Haskell + (haskell-end-interaction "done.") ; send a reset to Lisp + ) + + +;;; HASKELL-EDIT-UNIT +;;; ------------------------------------------------------------------ + +(defun haskell-edit-unit () + "Edit the .hu file." + (interactive) + (let ((fname (buffer-file-name))) + (if fname + (let ((find-file-not-found-hooks (list 'haskell-new-unit)) + (file-not-found nil) + (units-fname (haskell-get-unit-file))) + (find-file-other-window units-fname) + (if file-not-found + ;; *** this is broken. + (units-add-source-file + (if (string= (file-name-directory fname) + (file-name-directory units-fname)) + (file-name-nondirectory fname) + fname)))) + (haskell-mode-error "Not in a .hs buffer")))) + +(defun haskell-new-unit () + (setq file-not-found t)) + +(defun units-add-source-file (file) + (save-excursion + (insert (strip-fext file) "\n"))) + + +;;; Look for a comment like "-- unit:" at top of file. +;;; If not found, assume unit file has same name as the buffer but +;;; a .hu extension. + +(defun haskell-get-unit-file () + (let ((name nil)) + (save-excursion + (beginning-of-buffer) + (if (re-search-forward "-- unit:[ \t]*" (point-max) t) + (let ((beg (match-end 0))) + (end-of-line) + (setq name (buffer-substring beg (point)))) + (setq name (concat (strip-fext (buffer-file-name)) ".hu")))) + name)) + + +;;; HASKELL-PLEASE-RECOVER +;;; ------------------------------------------------------------------ + +(defun haskell-please-recover () + (interactive) + (haskell-flush-commands-and-reset) + (haskell-end-interaction "done.")) + + + +;;; ================================================================== +;;; Support for printers/optimizers menus +;;; ================================================================== + +;;; This code was adapted from the standard buff-menu.el code. + +(defvar haskell-menu-mode-map nil "") + +(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" 'haskell-menu-mark) + (define-key haskell-menu-mode-map "u" 'haskell-menu-unmark) + (define-key haskell-menu-mode-map "x" 'haskell-menu-exit) + (define-key haskell-menu-mode-map "q" 'haskell-menu-exit) + (define-key haskell-menu-mode-map " " 'next-line) + (define-key haskell-menu-mode-map "\177" 'haskell-menu-backup-unmark) + (define-key haskell-menu-mode-map "?" 'describe-mode))) + +;; Printers Menu mode is suitable only for specially formatted data. + +(put 'haskell-menu-mode 'mode-class 'special) + +(defun haskell-menu-mode () + "Major mode for editing Haskell flags. +Each line describes a flag. +Letters do not insert themselves; instead, they are commands. +m -- mark flag (turn it on) +u -- unmark flag (turn it off) +x -- exit; tell the Haskell process to update the flags, then leave menu. +q -- exit; same as x. +Precisely,\\{haskell-menu-mode-map}" + (kill-all-local-variables) + (use-local-map haskell-menu-mode-map) + (setq truncate-lines t) + (setq buffer-read-only t) + (setq major-mode 'haskell-menu-mode) + (setq mode-name "Haskell Flags Menu") + ;; These are all initialized elsewhere + (make-local-variable 'haskell-menu-current-flags) + (make-local-variable 'haskell-menu-request-fn) + (make-local-variable 'haskell-menu-update-fn) + (run-hooks 'haskell-menu-mode-hook)) + + +(defun haskell-menu (help-file buffer request-fn update-fn) + (haskell-maybe-create-process) + (if (get-buffer buffer) + (progn + (pop-to-buffer buffer) + (goto-char (point-min))) + (progn + (pop-to-buffer buffer) + (insert-file-contents help-file) + (haskell-menu-mode) + (setq haskell-menu-request-fn request-fn) + (setq haskell-menu-update-fn update-fn) + )) + (haskell-menu-mark-current) + (message "m = mark; u = unmark; x = execute; q = quit; ? = more help.")) + + + +;;; A line that starts with *haskell-menu-marked* is a menu item turned on. +;;; A line that starts with *haskell-menu-unmarked* is turned off. +;;; A line that starts with anything else is just random text and is +;;; ignored by commands that deal with menu items. + +(defvar *haskell-menu-marked* " on") +(defvar *haskell-menu-unmarked* " ") +(defvar *haskell-menu-marked-regexp* " on \\w") +(defvar *haskell-menu-unmarked-regexp* " \\w") + +(defun haskell-menu-mark () + "Mark flag to be turned on." + (interactive) + (beginning-of-line) + (cond ((looking-at *haskell-menu-marked-regexp*) + (forward-line 1)) + ((looking-at *haskell-menu-unmarked-regexp*) + (let ((buffer-read-only nil)) + (delete-char (length *haskell-menu-unmarked*)) + (insert *haskell-menu-marked*) + (forward-line 1))) + (t + (forward-line 1)))) + +(defun haskell-menu-unmark () + "Unmark flag." + (interactive) + (beginning-of-line) + (cond ((looking-at *haskell-menu-unmarked-regexp*) + (forward-line 1)) + ((looking-at *haskell-menu-marked-regexp*) + (let ((buffer-read-only nil)) + (delete-char (length *haskell-menu-marked*)) + (insert *haskell-menu-unmarked*) + (forward-line 1))) + (t + (forward-line 1)))) + +(defun haskell-menu-backup-unmark () + "Move up and unmark." + (interactive) + (forward-line -1) + (haskell-menu-unmark) + (forward-line -1)) + + +;;; Actually make the changes. + +(defun haskell-menu-exit () + "Update flags, then leave menu." + (interactive) + (haskell-menu-execute) + (haskell-menu-quit)) + +(defun haskell-menu-execute () + "Tell haskell process to tweak flags." + (interactive) + (start-setting-flags) + (save-excursion + (goto-char (point-min)) + (while (not (eq (point) (point-max))) + (cond ((looking-at *haskell-menu-unmarked-regexp*) + (funcall haskell-menu-update-fn (haskell-menu-flag) nil)) + ((looking-at *haskell-menu-marked-regexp*) + (funcall haskell-menu-update-fn (haskell-menu-flag) t)) + (t + nil)) + (forward-line 1))) + (finish-setting-flags)) + +(defun haskell-menu-quit () + (interactive) + "Make the menu go away." + (bury-buffer (current-buffer)) + (replace-buffer-in-windows (current-buffer))) + + +(defun haskell-menu-flag () + (save-excursion + (beginning-of-line) + (forward-char 6) + (let ((beg (point))) + ;; End of flag name marked by tab or two spaces. + (re-search-forward "\t\\| ") + (buffer-substring beg (match-beginning 0))))) + + +(defun start-setting-flags () + nil) + +(defun finish-setting-flags () + (haskell-end-interaction "Setting flags....done.")) + + +;;; Update the menu to mark only those items currently turned on. + +(defun haskell-menu-mark-current () + (funcall haskell-menu-request-fn) + (save-excursion + (goto-char (point-min)) + (while (not (eq (point) (point-max))) + (cond ((and (looking-at *haskell-menu-unmarked-regexp*) + (menu-item-currently-on-p (haskell-menu-flag))) + (haskell-menu-mark)) + ((and (looking-at *haskell-menu-marked-regexp*) + (not (menu-item-currently-on-p (haskell-menu-flag)))) + (haskell-menu-unmark)) + (t + (forward-line 1)))))) + + +;;; See if a menu item is turned on. + +(defun menu-item-currently-on-p (item) + (member-string= item haskell-menu-current-flags)) + +(defun member-string= (item list) + (cond ((null list) + nil) + ((string= item (car list)) + list) + (t + (member-string= item (cdr list))))) + + + +;;; Make the menu for printers. + +(defvar *haskell-printers-help* + (concat (getenv "HASKELL") "/emacs-tools/printer-help.txt") + "Help file for printers.") + +(defvar *haskell-printers-buffer* "*Haskell printers*") + +(defun haskell-printers () + "Set printers interactively." + (interactive) + (haskell-menu + *haskell-printers-help* + *haskell-printers-buffer* + 'get-current-printers + 'set-current-printers)) + +(defun get-current-printers () + (setq haskell-menu-current-flags t) + (haskell-send-command ":p?") + (while (eq haskell-menu-current-flags t) + (sleep-for 1))) + +(defun update-printers-list (data) + (setq haskell-menu-current-flags (read data))) + +(defun set-current-printers (flag on) + (let ((was-on (menu-item-currently-on-p flag))) + (cond ((and on (not was-on)) + (haskell-send-command (format ":p+ %s" flag))) + ((and (not on) was-on) + (haskell-send-command (format ":p- %s" flag))) + (t + nil)))) + + +;;; Equivalent stuff for the optimizers menu + +(defvar *haskell-optimizers-help* + (concat (getenv "HASKELL") "/emacs-tools/optimizer-help.txt") + "Help file for optimizers.") + +(defvar *haskell-optimizers-buffer* "*Haskell optimizers*") + +(defun haskell-optimizers () + "Set optimizers interactively." + (interactive) + (haskell-menu + *haskell-optimizers-help* + *haskell-optimizers-buffer* + 'get-current-optimizers + 'set-current-optimizers)) + +(defun get-current-optimizers () + (setq haskell-menu-current-flags t) + (haskell-send-command ":o?") + (while (eq haskell-menu-current-flags t) + (sleep-for 1))) + +(defun update-optimizers-list (data) + (setq haskell-menu-current-flags (read data))) + +(defun set-current-optimizers (flag on) + (let ((was-on (menu-item-currently-on-p flag))) + (cond ((and on (not was-on)) + (haskell-send-command (format ":o+ %s" flag))) + ((and (not on) was-on) + (haskell-send-command (format ":o- %s" flag))) + (t + nil)))) + + + + +;;; ================================================================== +;;; Random utilities +;;; ================================================================== + + +;;; Keep track of the association between pads, modules, and files. +;;; The global variable is a list of (pad-buffer-name module-name file-name) +;;; lists. + +(defvar *pad-mappings* () + "Associates pads with their corresponding module and file.") + +(defun record-pad-mapping (pname mname fname) + (setq *pad-mappings* + (cons (list pname mname fname) *pad-mappings*))) + +(defun get-module-from-pad (pname) + (car (cdr (assoc pname *pad-mappings*)))) + +(defun get-file-from-pad (pname) + (car (cdr (cdr (assoc pname *pad-mappings*))))) + +(defun lookup-pad (mname fname) + (lookup-pad-aux mname fname *pad-mappings*)) + +(defun lookup-pad-aux (mname fname list) + (cond ((null list) + nil) + ((and (equal mname (car (cdr (car list)))) + (equal fname (car (cdr (cdr (car list)))))) + (car (car list))) + (t + (lookup-pad-aux mname fname (cdr list))))) + + + +;;; Save any modified .hs and .hu files. +;;; Yes, the two set-buffer calls really seem to be necessary. It seems +;;; that y-or-n-p makes emacs forget we had temporarily selected some +;;; other buffer, and if you just do save-buffer directly it will end +;;; up trying to save the current buffer instead. The built-in +;;; save-some-buffers function has this problem.... + +(defvar *ask-before-saving* t) + +(defun save-modified-source-files (filename) + (let ((buffers (buffer-list)) + (found-any nil)) + (while buffers + (let ((buffer (car buffers))) + (if (and (buffer-modified-p buffer) + (save-excursion + (set-buffer buffer) + (and buffer-file-name + (source-file-p buffer-file-name) + (setq found-any t) + (or (null *ask-before-saving*) + (string= buffer-file-name filename) + (y-or-n-p + (format "Save file %s? " buffer-file-name)))))) + (save-excursion + (set-buffer buffer) + (save-buffer)))) + (setq buffers (cdr buffers))) + (if found-any + (message "") + (message "(No files need saving)")))) + +(defun source-file-p (filename) + (or (string-match "\\.hs$" filename) + (string-match "\\.lhs$" filename) + (string-match "\\.hu$" filename) + (string-match "\\.shu$" filename) + (string-match "\\.hsp$" filename) + (string-match "\\.prim$" filename))) + + +;;; Buffer utilities + +(defun haskell-move-marker () + "Moves the marker and point to the end of buffer" + (set-marker comint-last-input-end (point-max)) + (set-marker (process-mark (get-process "haskell")) (point-max)) + (goto-char (point-max))) + + +;;; Pad utils + +(defun create-main-pad () + (let ((buffer (get-buffer-create haskell-main-pad))) + (save-excursion + (set-buffer buffer) + (haskell-mode)) + (record-pad-mapping haskell-main-pad haskell-main-module haskell-main-file) + buffer)) + + +;;; Extract the name of the module the point is in, from the given buffer. + +(defvar *re-module* "^module\\s *\\|^>\\s *module\\s *") +(defvar *re-modname* "[A-Z]\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\)*") + +(defun get-modname (buff) + "Get module name in BUFFER that point is in." + (save-excursion + (set-buffer buff) + (if (or (looking-at *re-module*) + (re-search-backward *re-module* (point-min) t) + (re-search-forward *re-module* (point-max) t)) + (progn + (goto-char (match-end 0)) + (if (looking-at *re-modname*) + (buffer-substring (match-beginning 0) (match-end 0)) + (haskell-mode-error "Module name not found!!"))) + "Main"))) + + +;;; Build the base name for a pad buffer. + +(defun get-padname (m) + "Build padname from module name" + (concat "*" m "-pad*")) + + +;;; Strip file extensions. +;;; Only strip off extensions we know about; e.g. +;;; "foo.hs" -> "foo" but "foo.bar" -> "foo.bar". + +(defvar *haskell-filename-regexp* "\\(.*\\)\\.\\(hs\\|lhs\\)$") + +(defun strip-fext (filename) + "Strip off the extension from a filename." + (if (string-match *haskell-filename-regexp* filename) + (substring filename (match-beginning 1) (match-end 1)) + filename)) + + +;;; Haskell mode error + +(defun haskell-mode-error (msg) + "Show MSG in message line as an error from the haskell mode" + (error (concat "Haskell mode: " msg))) + + + + +;;; ================================================================== +;;; Command generators +;;; ================================================================== + +;;; Generate Haskell command interface commands. These are very simple +;;; routines building the string commands to be sent to the haskell +;;; process. + +(defun ci-send-buffer (buff) + "Send BUFFER to haskell process." + (let ((str (buffer-string))) + (if (not (string-match "\\`\\s *\\'" str)) ; ignore if all whitespace + (save-excursion + (set-buffer buff) + (haskell-send-command str))))) + +(defun ci-kill () + (haskell-send-command ":kill")) + +(defun ci-clear () + (haskell-send-command ":clear")) + +(defun ci-set-file (file-name) + (haskell-send-command (concat ":file " file-name))) + +(defun ci-module (modname) + (setq *last-module* modname) + (haskell-send-command (concat ":module " modname))) + + +;;; Keeps track of the last file loaded. +;;; Change to do a :compile (temporary until new csys) +;;; 2-Aug-91 Dan Rabin. + +(defun ci-load (filename) + (haskell-send-command (concat ":load " filename))) + +(defun ci-load-main () + (haskell-send-command ":Main")) + +(defun ci-save () + (haskell-send-command ":save")) + +(defun ci-compile (filename) + (haskell-send-command (concat ":compile " filename))) + +(defun ci-run (filename) + (haskell-send-command (concat ":run " filename))) + +(defun ci-print-exp (exp) + (ci-set-file "interactive-expression-buffer") + (haskell-send-command (concat "= " exp))) + +(defun ci-send-name (name) + (let ((temp (make-temp-name "etemp"))) + (ci-set-file "interactive-expression-buffer") + (haskell-send-command (concat temp " = " name)))) + +(defun ci-eval () + (haskell-send-command ":eval")) + +(defun ci-quit () + (cond ((not (get-buffer-process *haskell-buffer*)) + (message "No process currently running.")) + ((y-or-n-p "Do you really want to quit Haskell? ") + (process-send-string "haskell" ":quit\n") + (set-haskell-status 'dead)) + (t + nil))) + + +;;; When setting emacs mode (on/off) +;;; (a) Set process-filter +;;; (b) Send :Emacs command to Haskell process + +(defun ci-emacs () + (haskell-reset) + (set-process-filter (get-process "haskell") 'process-haskell-output) + (haskell-send-command ":Emacs on")) + + + + + + +;;; ================================================================== +;;; Handle input in haskell process buffer; history commands. +;;; ================================================================== + +(defun haskell-get-old-input () + "Get old input text from Haskell process buffer." + (save-excursion + (if (re-search-forward haskell-prompt-pattern (point-max) 'move) + (goto-char (match-beginning 0))) + (cond ((re-search-backward haskell-prompt-pattern (point-min) t) + (comint-skip-prompt) + (let ((temp (point))) + (end-of-line) + (buffer-substring temp (point))))))) + + +;;; Modified for Haskell (taken from comint-send-input) + +(defun haskell-send-input () + "Send input to Haskell while in the process buffer" + (interactive) + (if *emacs* + (haskell-send-input-aux) + (comint-send-input))) + +(defun haskell-send-input-aux () + ;; Note that the input string does not include its terminal newline. + (let ((proc (get-buffer-process (current-buffer)))) + (if (not proc) + (haskell-mode-error "Current buffer has no process") + (let* ((pmark (process-mark proc)) + (pmark-val (marker-position pmark)) + (input (if (>= (point) pmark-val) + (buffer-substring pmark (point)) + (let ((copy (funcall comint-get-old-input))) + (goto-char pmark) + (insert copy) + copy)))) + (insert ?\n) + (if (funcall comint-input-filter input) + (ring-insert input-ring input)) + (funcall comint-input-sentinel input) + (set-marker (process-mark proc) (point)) + (set-marker comint-last-input-end (point)) + (haskell-send-data input))))) + + + +;;; ================================================================== +;;; Minibuffer input stuff +;;; ================================================================== + +;;; Haskell input history retrieval commands (taken from comint.el) +;;; M-p -- previous input M-n -- next input + +(defvar haskell-minibuffer-local-map nil + "Local map for minibuffer when in Haskell") + +(if haskell-minibuffer-local-map + nil + (progn + (setq haskell-minibuffer-local-map + (full-copy-sparse-keymap minibuffer-local-map)) + ;; Haskell commands + (define-key haskell-minibuffer-local-map "\ep" 'haskell-previous-input) + (define-key haskell-minibuffer-local-map "\en" 'haskell-next-input) + )) + +(defun haskell-previous-input (arg) + "Cycle backwards through input history." + (interactive "*p") + (let ((len (ring-length haskell-prompt-ring))) + (cond ((<= len 0) + (message "Empty input ring") + (ding)) + (t + (cond ((eq last-command 'haskell-previous-input) + (delete-region (mark) (point)) + (set-mark (point))) + (t + (setq input-ring-index + (if (> arg 0) -1 + (if (< arg 0) 1 0))) + (push-mark (point)))) + (setq input-ring-index (comint-mod (+ input-ring-index arg) len)) + (insert (ring-ref haskell-prompt-ring input-ring-index)) + (setq this-command 'haskell-previous-input)) + (t (ding))))) + +(defun haskell-next-input (arg) + "Cycle forwards through input history." + (interactive "*p") + (haskell-previous-input (- arg))) + +(defvar haskell-last-input-match "" + "Last string searched for by Haskell input history search, for defaulting. +Buffer local variable.") + +(defun haskell-previous-input-matching (str) + "Searches backwards through input history for substring match" + (interactive (let ((s (read-from-minibuffer + (format "Command substring (default %s): " + haskell-last-input-match)))) + (list (if (string= s "") haskell-last-input-match s)))) + (setq haskell-last-input-match str) ; update default + (let ((str (regexp-quote str)) + (len (ring-length haskell-prompt-ring)) + (n 0)) + (while (and (<= n len) + (not (string-match str (ring-ref haskell-prompt-ring n)))) + (setq n (+ n 1))) + (cond ((<= n len) (haskell-previous-input (+ n 1))) + (t (haskell-mode-error "Not found."))))) + + +;;; Actually read an expression from the minibuffer using the new keymap. + +(defun get-haskell-expression (prompt) + (let ((exp (read-from-minibuffer prompt nil haskell-minibuffer-local-map))) + (ring-insert haskell-prompt-ring exp) + exp)) + + + + +;;; ================================================================== +;;; User customization +;;; ================================================================== + +(defvar haskell-load-hook nil + "This hook is run when haskell is loaded in. +This is a good place to put key bindings." + ) + +(run-hooks 'haskell-load-hook) + + + + +;;;====================================================================== +;;; Tutorial mode setup +;;;====================================================================== + +;;; Set up additional key bindings for tutorial mode. + +(defvar ht-mode-map nil) + +(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 "\C-c\C-f" 'ht-next-page) + (define-key ht-mode-map "\C-c\C-b" 'ht-prev-page) + (define-key ht-mode-map "\C-c\C-l" 'ht-restore-page) + (define-key ht-mode-map "\C-c?" 'describe-mode))) + +(defun haskell-tutorial-mode () + "Major mode for running the Haskell tutorial. +You can use these commands: +\\{ht-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map ht-mode-map) + (setq major-mode 'haskell-tutorial-mode) + (setq mode-name "Haskell Tutorial") + (set-syntax-table haskell-mode-syntax-table) + (run-hooks 'haskell-mode-hook)) + + +(defun haskell-tutorial () + "Run the haskell tutorial." + (interactive) + (ht-load-tutorial) + (ht-make-buffer) + (ht-display-page)) + + +;;; Load the tutorial file into a read-only buffer. Do not display this +;;; buffer. + +(defun ht-load-tutorial () + (let ((buffer (get-buffer *ht-file-buffer*))) + (if buffer + (save-excursion + (set-buffer buffer) + (beginning-of-buffer)) + (save-excursion + (set-buffer (setq buffer (get-buffer-create *ht-file-buffer*))) + (let ((fname (substitute-in-file-name *ht-source-file*))) + (if (file-readable-p fname) + (ht-load-tutorial-aux fname) + (call-interactively 'ht-load-tutorial-aux))))))) + +(defun ht-load-tutorial-aux (filename) + (interactive "fTutorial file: ") + (insert-file filename) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (beginning-of-buffer)) + + +;;; Create a buffer to use for messing about with each page of the tutorial. +;;; Put the buffer into haskell-tutorial-mode. + +(defun ht-make-buffer () + (find-file (concat "/tmp/" (make-temp-name "ht") ".hs")) + (setq *ht-temp-buffer* (buffer-name)) + (haskell-tutorial-mode)) + + +;;; Commands for loading text into the tutorial pad buffer + +(defun ht-next-page () + "Go to the next tutorial page." + (interactive) + (if (ht-goto-next-page) + (ht-display-page) + (beep))) + +(defun ht-goto-next-page () + (let ((buff (current-buffer))) + (unwind-protect + (progn + (set-buffer *ht-file-buffer*) + (search-forward "\C-l" nil t)) + (set-buffer buff)))) + +(defun ht-prev-page () + "Go to the previous tutorial page." + (interactive) + (if (ht-goto-prev-page) + (ht-display-page) + (beep))) + +(defun ht-goto-prev-page () + (let ((buff (current-buffer))) + (unwind-protect + (progn + (set-buffer *ht-file-buffer*) + (search-backward "\C-l" nil t)) + (set-buffer buff)))) + +(defun ht-goto-page (arg) + "Go to the tutorial page specified as the argument." + (interactive "sGo to page: ") + (if (ht-searchfor-page (format "-- Page %s " arg)) + (ht-display-page) + (beep))) + +(defun ht-goto-section (arg) + "Go to the tutorial section specified as the argument." + (interactive "sGo to section: ") + (if (ht-searchfor-page (format "-- Section %s " arg)) + (ht-display-page) + (beep))) + +(defun ht-searchfor-page (search-string) + (let ((buff (current-buffer))) + (unwind-protect + (progn + (set-buffer *ht-file-buffer*) + (let ((point (point))) + (beginning-of-buffer) + (if (search-forward search-string nil t) + t + (progn + (goto-char point) + nil)))) + (set-buffer buff)))) + +(defun ht-restore-page () + (interactive) + (let ((old-point (point))) + (ht-display-page) + (goto-char old-point))) + +(defun ht-display-page () + (set-buffer *ht-file-buffer*) + (let* ((beg (progn + (if (search-backward "\C-l" nil t) + (forward-line 1) + (beginning-of-buffer)) + (point))) + (end (progn + (if (search-forward "\C-l" nil t) + (beginning-of-line) + (end-of-buffer)) + (point))) + (text (buffer-substring beg end))) + (set-buffer *ht-temp-buffer*) + (erase-buffer) + (insert text) + (beginning-of-buffer))) diff --git a/emacs-tools/haskell.elc b/emacs-tools/haskell.elc new file mode 100644 index 0000000..165e126 --- /dev/null +++ b/emacs-tools/haskell.elc @@ -0,0 +1,788 @@ + +(provide (quote haskell)) + +(require (quote comint)) + +(defvar haskell-program-name (getenv "HASKELLPROG") "\ +*Program invoked by the haskell command") + +(defvar *haskell-buffer* "*haskell*" "\ +*Name of the haskell process buffer") + +(defvar *haskell-show-error* 1 "\ +*If not nil move to the buffer where the error was found") + +(defvar haskell-auto-create-process t "\ +*If not nil, create a Haskell process automatically when required to evaluate or compile Haskell code") + +(defvar *haskell-debug-in-lisp* nil "\ +*If not nil, enter Lisp debugger on error; otherwise, automagically return +to Haskell top-level.") + +(defvar *emacs* nil "\ +When not nil means haskell is in emacs mode") + +(defvar haskell-main-pad "*Main-pad*" "\ +Scratch pad associated with module Main") + +(defvar haskell-main-file "Main") + +(defvar haskell-main-module "Main") + +(defvar *last-loaded* haskell-main-file "\ +Last file loaded with a :load command - Defaults to Main") + +(defvar *last-loaded-modtime* nil "\ +Modification time of last file loaded, used to determine whether it +needs to be reloaded.") + +(defvar *last-module* haskell-main-module "\ +Last module set with a :module command - Defaults to Main") + +(defvar *last-pad* haskell-main-pad "\ +Last pad saved with a :save command - Defaults to Main") + +(defvar *ht-source-file* "$HASKELL/progs/tutorial/tutorial.hs") + +(defvar *ht-temp-buffer* nil) + +(defvar *ht-file-buffer* "Haskell-Tutorial-Master") + +(defvar haskell-mode-map nil "\ +Keymap used for haskell-mode") + +(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)) + +(if haskell-mode-map nil (progn (setq haskell-mode-map (make-sparse-keymap)) (haskell-establish-key-bindings haskell-mode-map))) + +(defvar haskell-mode-syntax-table nil "\ +Syntax table used for haskell-mode") + +(if haskell-mode-syntax-table nil (setq haskell-mode-syntax-table (standard-syntax-table))) + +(defun haskell-mode nil "\ +Major mode for editing Haskell code to run in Emacs +The following commands are available: +\\{haskell-mode-map} + +A Haskell process can be fired up with \"M-x haskell\". + +Customization: Entry to this mode runs the hooks that are the value of variable +haskell-mode-hook. + +Windows: + +There are 3 types of windows associated with Haskell mode. They are: + *haskell*: which is the process window. + Pad: which are buffers available for each module. It is here + where you want to test things before preserving them in a + file. Pads are always associated with a module. + When issuing a command: + The pad and its associated module are sent to the Haskell + process prior to the execution of the command. + .hs: These are the files where Haskell programs live. They + have .hs as extension. + When issuing a command: + The file is sent to the Haskell process prior to the + execution of the command. + +Commands: + +Each command behaves differently according to the type of the window in which +the cursor is positioned when the command is issued . + +haskell-eval: \\[haskell-eval] + Always promts user for a Haskell expression to be evaluated. If in a + .hs file buffer, then the cursor tells which module is the current + module and the pad for that module (if any) gets loaded as well. + +haskell-run: \\[haskell-run] + Always queries for a variable of type Dialogue to be evaluated. + +haskell-run-main: \\[haskell-run-main] + Run Dialogue named main. + +haskell-run-file: \\[haskell-run-file] + Runs a file. Ideally the file has a set of variable of type Dialogue + that get evaluated. + +haskell-mode: \\[haskell-mode] + Puts the current buffer in haskell mode. + +haskell-compile: \\[haskell-compile] + Compiles file in current buffer. + +haskell-load: \\[haskell-load] + Loads file in current buffer. + +haskell-pad: \\[haskell-pad] + Creates a scratch pad for the current module. + +haskell-optimizers: \\[haskell-optimizers] + Shows the list of available optimizers. Commands for turning them on/off. + +haskell-printers: \\[haskell-printers] + Shows the list of available printers. Commands for turning them on/off. + +haskell-command: \\[haskell-command] + Prompts for a command to be sent to the command interface. You don't + need to put the : before the command. + +haskell-quit: \\[haskell-quit] + Terminates the haskell process. + +switch-to-haskell: \\[switch-to-haskell] + Switchs to the inferior Haskell buffer (*haskell*) and positions the + cursor at the end of the buffer. + +haskell-interrupt: \\[haskell-interrupt] + Interrupts haskell process and resets it. + +haskell-edit-unit: \\[haskell-edit-unit] + Edit the .hu file for the unit containing this file. +" (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)) + +(defvar inferior-haskell-mode-map nil) + +(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))) + +(defvar haskell-source-modes (quote (haskell-mode)) "\ +*Used to determine if a buffer contains Haskell source code. +If it's loaded into a buffer that is in one of these major modes, +it's considered a Haskell source file.") + +(defvar haskell-prev-l/c-dir/file nil "\ +Caches the (directory . file) pair used in the last invocation of +haskell-run-file.") + +(defvar haskell-prompt-pattern "^[A-Z]\\([A-Z]\\|[a-z]\\|[0-9]\\)*>\\s-*" "\ +Regular expression capturing the Haskell system prompt.") + +(defvar haskell-prompt-ring nil "\ +Keeps track of input to haskell process from the minibuffer") + +(defvar tea-prompt-pattern "^>+\\s-*" "\ +Regular expression capturing the T system prompt.") + +(defvar haskell-version "Yale University Haskell Version 0.8, 1991" "\ +Current Haskell system version") + +(defun inferior-haskell-mode-variables nil (byte-code "À‡" [nil] 1)) + +(defun inferior-haskell-mode nil "\ +Major mode for interacting with an inferior Haskell process. + +The following commands are available: +\\{inferior-haskell-mode-map} + +A Haskell process can be fired up with \"M-x haskell\". + +Customization: Entry to this mode runs the hooks on comint-mode-hook and +inferior-haskell-mode-hook (in that order). + +You can send text to the inferior Haskell process from other buffers containing +Haskell source. + + +Windows: + +There are 3 types of windows in the inferior-haskell-mode. They are: + *haskell*: which is the process window. + Pad: which are buffers available for each module. It is here + where you want to test things before preserving them in a + file. Pads are always associated with a module. + When issuing a command: + The pad and its associated module are sent to the Haskell + process prior to the execution of the command. + .hs: These are the files where Haskell programs live. They + have .hs as extension. + When issuing a command: + The file is sent to the Haskell process prior to the + execution of the command. + +Commands: + +Each command behaves differently according to the type of the window in which +the cursor is positioned when the command is issued. + +haskell-eval: \\[haskell-eval] + Always promts user for a Haskell expression to be evaluated. If in a + .hs file, then the cursor tells which module is the current module and + the pad for that module (if any) gets loaded as well. + +haskell-run: \\[haskell-run] + Always queries for a variable of type Dialogue to be evaluated. + +haskell-run-main: \\[haskell-run-main] + Run Dialogue named main. + +haskell-run-file: \\[haskell-run-file] + Runs a file. Ideally the file has a set of variable of type Dialogue + that get evaluated. + +haskell-mode: \\[haskell-mode] + Puts the current buffer in haskell mode. + +haskell-compile: \\[haskell-compile] + Compiles file in current buffer. + +haskell-load: \\[haskell-load] + Loads file in current buffer. + +haskell-pad: \\[haskell-pad] + Creates a scratch pad for the current module. + +haskell-optimizers: \\[haskell-optimizers] + Shows the list of available optimizers. Commands for turning them on/off. + +haskell-printers: \\[haskell-printers] + Shows the list of available printers. Commands for turning them on/off. + +haskell-command: \\[haskell-command] + Prompts for a command to be sent to the command interface. You don't + need to put the : before the command. + +haskell-quit: \\[haskell-quit] + Terminates the haskell process. + +switch-to-haskell: \\[switch-to-haskell] + Switchs to the inferior Haskell buffer (*haskell*) and positions the + cursor at the end of the buffer. + +haskell-interrupt: \\[haskell-interrupt] + Interrupts haskell process and resets it. + +haskell-edit-unit: \\[haskell-edit-unit] + Edit the .hu file for the unit containing this file. + +The usual comint functions are also available. In particular, the +following are all available: + +comint-bol: Beginning of line, but skip prompt. Bound to C-a by default. +comint-delchar-or-maybe-eof: Delete char, unless at end of buffer, in + which case send EOF to process. Bound to C-d by default. + +Note however, that the default keymap bindings provided shadow some of +the default comint mode bindings, so that you may want to bind them +to your choice of keys. + +Comint mode's dynamic completion of filenames in the buffer is available. +(Q.v. comint-dynamic-complete, comint-dynamic-list-completions.) + +If you accidentally suspend your process, use \\[comint-continue-subjob] +to continue it." (interactive) (byte-code "ËˆÌ ˆ ‰ˆÍ ˆÎ‰ˆÏ‰ˆÐ‰ˆÑ
!ˆÒ‰ˆÓ‰ˆÔ‰ˆÕÖ!ˆ× +!‰ ‡" [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)) + +(defvar inferior-haskell-mode-hook (quote haskell-fresh-start) "\ +*Hook for customizing inferior-Haskell mode") + +(defun haskell-input-filter (str) "\ +Don't save whitespace." (byte-code "ÁÂ\"?‡" [str string-match "\\s *"] 3)) + +(defvar *haskell-status* (quote dead) "\ +Status of the haskell process") + +(defun set-haskell-status (value) (byte-code " ‰ˆÂ ‡" [*haskell-status* value update-mode-line] 2)) + +(defun get-haskell-status nil (byte-code "‡" [*haskell-status*] 1)) + +(defun update-mode-line nil (byte-code "Šqˆ Ä=ƒ + +(defvar *haskell-saved-output* nil) + +(defun process-haskell-output (process str) "\ +Filter for output from Yale Haskell command interface" (byte-code "ÆÆÇ ÈŽ … + +(defvar *ci-responses* (quote (("r" "" haskell-got-ready) ("i" "" haskell-got-input-request) ("e" "" haskell-got-error) ("p.* +" "\\(p.*\\)?" haskell-got-printers) ("o.* +" "\\(o.*\\)?" haskell-got-optimizers) ("s.* +" "\\(s.*\\)?" haskell-got-message) (" +-> " " +\\(-\\(> ?\\)?\\)?" 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)))) + +(defun command-match-regexp (x) (byte-code "@‡" [x] 1)) + +(defun command-prefix-regexp (x) (byte-code "A@‡" [x] 1)) + +(defun command-handler (x) (byte-code "AA@‡" [x] 1)) + +(defun glue-together (extractor) (byte-code "ÄÅ +@\"ÆQ +A …$ + +(defvar *ci-response-regexp* (glue-together (quote command-match-regexp))) + +(defvar *ci-prefix-regexp* (concat "\\(" (glue-together (quote command-prefix-regexp)) "\\)\\'")) + +(defun ci-response-start (str idx) (byte-code "à +#‡" [*ci-response-regexp* str idx string-match] 4)) + +(defun ci-prefix-start (str idx) (byte-code "à +#‡" [*ci-prefix-regexp* str idx string-match] 4)) + +(defun ci-response-handler (str idx) (byte-code " Ã… + +?…+ +?…4 +*‡" [list *ci-responses* result nil str idx string-match command-match-regexp command-handler haskell-mode-error "Failed to find command handler!!!"] 6)) + +(defun haskell-got-ready (str idx) (byte-code "ÁÂ!à ˆ)‡" [result match-end 0 haskell-reset] 3)) + +(defun haskell-got-input-request (str idx) (byte-code "ÁÂ!à ˆ)‡" [result match-end 0 get-user-input] 3)) + +(defun haskell-got-error (str idx) (byte-code "ÁÂ!à ˆ)‡" [result match-end 0 haskell-error-handler] 3)) + +(defun haskell-got-printers (str idx) (byte-code "ÃÄ!Å +Æ\\ÇZO!ˆ)‡" [result str idx match-end 0 update-printers-list 2 1] 6)) + +(defun haskell-got-optimizers (str idx) (byte-code "ÃÄ!Å +Æ\\ÇZO!ˆ)‡" [result str idx match-end 0 update-optimizers-list 2 1] 6)) + +(defun haskell-got-message (str idx) (byte-code "ÃÄ!Å +Æ\\ÇZO!ˆ)‡" [result str idx match-end 0 message 2 1] 6)) + +(defun haskell-got-lisp-error (str idx) (byte-code " \"ˆ G‡" [idx str haskell-handle-lisp-error] 3)) + +(defun haskell-handle-lisp-error (location str) (byte-code "Ä ÅO!ˆ +… + +(defun loaded-tutorial-p nil (byte-code "… + +(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)) + +(defun haskell-talk-to-lisp nil (byte-code "Á!ˆdbˆÂ ‡" [*haskell-buffer* pop-to-buffer haskell-ensure-lisp-mode] 3)) + +(defun haskell-resume-command-loop nil "\ +Resumes Haskell command processing after debugging in Lisp. \\[haskell-resume-command-loop]" (interactive) (byte-code "Áˆ?… +" haskell-ensure-emacs-mode] 3)) + +(defun haskell-display-output (str) (byte-code "à Ä=ƒ + +(defun haskell-display-output-aux (str) (byte-code "Á ˆcˆÁ ‡" [str haskell-move-marker] 3)) + +(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)) + +(defun haskell-error-handler nil (byte-code "Á ˆÂ ˆÃÄ!ˆÅÀ!‡" [nil ding haskell-flush-command-queue set-haskell-status ready haskell-end-interaction] 5)) + +(defvar *yh-error-def* "Error occured in definition of\\s *") + +(defvar *yh-error-line* "at line\\s *") + +(defvar *yh-error-file* "of file\\s *") + +(defvar *haskell-line* "\\([0-9]\\)*") + +(defun haskell-show-error nil "\ +Point out error to user if possible" (byte-code "qˆŠÂ Š‰… + +(defvar *haskell-function-name* "\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\|-\\)*") + +(defun get-function-name nil (byte-code "ÅeÁ#…
+`\"‚\" + +(defun get-line-number nil (byte-code "ÅdÁ#ƒ +`\"!‚ + +(defun get-filename nil (byte-code "ÄdÁ#ƒ +`\"‚ + +(defun point-error-to-user (function-name line-number filename) (byte-code "ÄÅ\"ƒ
+!ƒ +!‚ + +(defun haskell-reset nil (byte-code "ÀÁ!ˆÂ ‡" [set-haskell-status ready haskell-pop-command-queue] 3)) + +(defvar *command-interface-queue* nil "\ +Contains the commands to be sent to the Haskell command interface") + +(defun haskell-queue-or-execute (fn request data) (byte-code "ƒ +BC\"‰‚$ +\"‚$ +BC‰‡" [*command-interface-queue* request data fn t nconc get-haskell-status ready funcall] 5)) + +(defun haskell-send-command (str) "\ +Queues STRING for transmission to haskell process." (byte-code "ÁÂÃ#‡" [str haskell-queue-or-execute haskell-send-command-aux command] 4)) + +(defun haskell-send-command-aux (str) (byte-code "ÁÂ\"ˆÁÂÃ\"ˆÄ Å=?… +" get-haskell-status input set-haskell-status busy] 5)) + +(defvar *begin-interaction-delimiter* nil "\ +*Delimiter showing an interaction has begun") + +(defun haskell-begin-interaction (msg) (byte-code "ÁÂÃ#‡" [msg haskell-queue-or-execute haskell-begin-interaction-aux begin] 4)) + +(defun haskell-begin-interaction-aux (msg) (byte-code "… +"] 5)) + +(defvar *end-interaction-delimiter* nil "\ +*Delimiter showing an interaction has ended") + +(defun haskell-end-interaction (msg) (byte-code "ÁÂÃ#‡" [msg haskell-queue-or-execute haskell-end-interaction-aux end] 4)) + +(defun haskell-end-interaction-aux (msg) (byte-code "… + +(defun haskell-send-data (str) (byte-code "ÄÅ\"ƒ + +(defun merge-data-into-queue (new head tail lasttail) (byte-code "?ƒ +\"ˆ ‚8 + A$‚8 +\"ˆÅ +\"ˆ ‚8 +\"ˆ +‡" [tail lasttail new head t rplacd data merge-data-into-queue] 7)) + +(defun haskell-pop-command-queue nil (byte-code "…N + +(defun haskell-pop-data-queue nil (byte-code "… + +(defun haskell-flush-command-queue nil (byte-code "Á‰‡" [*command-interface-queue* nil] 2)) + +(defun haskell nil "\ +Run an inferior Haskell process with input and output via buffer *haskell*. +Takes the program name from the variable haskell-program-name. +Runs the hooks from inferior-haskell-mode-hook +(after the comint-mode-hook is run). +(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive) (byte-code "ÃˆÄ !…
+ÃÃ%‰ˆŠqˆÉ )ˆÊ!)‡" [haskell-buffer *haskell-buffer* haskell-program-name nil get-buffer comint-check-proc apply make-comint "haskell" inferior-haskell-mode display-buffer] 8)) + +(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)) + +(defun haskell-maybe-create-process nil (byte-code "… + +(defun haskell-ensure-emacs-mode nil (byte-code " ˆÁ‰ˆÃ ‡" [*emacs* t create-main-pad ci-emacs] 3)) + +(defun haskell-ensure-lisp-mode nil "\ +Switch to talking to Lisp. \\[haskell-ensure-lisp-mode]" (interactive) (byte-code "ÁˆÁ‰‡" [*emacs* nil] 2)) + +(defun haskell-get-pad nil "\ +Creates a new scratch pad for the current module. +Signals an error if the current buffer is not a .hs file." (interactive) (byte-code "ÁˆÂ ƒ + +(defun do-get-pad (fname buff) (byte-code "Æ !† + + +(defun haskell-switch nil "\ +Switches to *haskell* buffer" (interactive) (byte-code "ÁˆÂ ˆÃÀ!‡" [t nil haskell-maybe-create-process switch-to-haskell] 3)) + +(defun switch-to-haskell (eob-p) "\ +Really switch to the *haskell* buffer. +With argument, positions cursor at end of buffer." (interactive "P") (byte-code "ˆÃ!ˆ … + +(defun haskell-command (str) "\ +Format STRING as a haskell command and send it to haskell process. \\[haskell-command]" (interactive "sHaskell command: ") (byte-code "ÁˆÂÃÄH!=ƒ + +(defun haskell-eval nil "\ +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)) + +(defun haskell-run nil "\ +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)) + +(defun haskell-run-main nil "\ +Run Dialogue named main in current module" (interactive) (byte-code "ÁˆÂ ˆÃÄÀÅ#‡" [t nil haskell-maybe-create-process haskell-eval-aux "main" "Running"] 5)) + +(defun haskell-eval-aux (exp dialogue-p what) (byte-code "ÍÎ \"ƒ( + ÏÐ # Ñ
+&,‚¦ +&,‚¦ +&,‚¦ +&,‡" [*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)) + +(defun haskell-eval-aux-aux (exp pname mname fname msg dialogue-p) (byte-code "Æ!ˆÇ ˆÈ !ˆÉ +!ˆ … + +(defun haskell-save-pad-if-modified (pad) (byte-code "ŠqˆÃ \"†
+ +(defun haskell-run-file nil "\ +Run all Dialogues in current file" (interactive) (byte-code "ˆà ˆÄÅ \"ƒ + +(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)) + +(defun haskell-run-file-aux (fname) (byte-code "à PÄ!ˆÅ ˆÆ +!ˆÇÈ !!ˆÉÊ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)) + +(defun haskell-load nil "\ +Load current file" (interactive) (byte-code "ÃˆÄ ˆÅ ÆPƒ + +(defun haskell-load-file-if-modified (filename) (byte-code "Å!ˆÆ +\"ƒ +‰ˆÇ ‚ + +(defun haskell-compile nil "\ +Compile current file" (interactive) (byte-code "ˆà ˆÄ ƒ + +(defun haskell-compile-file-if-modified (fname) (byte-code "Â!ˆÃÄ !!‡" [buffer-file-name fname save-modified-source-files ci-compile strip-fext] 4)) + +(defun haskell-exit nil "\ +Quit the haskell process" (interactive) (byte-code "ÁˆÃ ˆ… +!ˆÇ +!‡" [*ht-temp-buffer* nil *haskell-buffer* ci-quit get-buffer set-buffer-modified-p bury-buffer replace-buffer-in-windows] 6)) + +(defun haskell-interrupt nil "\ +Interrupt the haskell process" (interactive) (byte-code "ÀˆÁÂ!ˆÃÄ!‡" [nil haskell-send-command-aux "" haskell-end-interaction "done."] 3)) + +(defun haskell-edit-unit nil "\ +Edit the .hu file." (interactive) (byte-code "ÈŠƒ1 +…- + +(defun haskell-new-unit nil (byte-code "Á‰‡" [file-not-found t] 2)) + +(defun units-add-source-file (file) (byte-code "ŠÁÂ!Ã\")‡" [file insert strip-fext " +"] 4)) + +(defun haskell-get-unit-file nil (byte-code "ÁŠÄ ˆÅÆdÂ#ƒ + +(defun haskell-please-recover nil (interactive) (byte-code "ÀˆÁ ˆÂÃ!‡" [nil haskell-flush-commands-and-reset haskell-end-interaction "done."] 3)) + +(defvar haskell-menu-mode-map nil "\ +") + +(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)))) + +(put (quote haskell-menu-mode) (quote mode-class) (quote special)) + +(defun haskell-menu-mode nil "\ +Major mode for editing Haskell flags. +Each line describes a flag. +Letters do not insert themselves; instead, they are commands. +m -- mark flag (turn it on) +u -- unmark flag (turn it off) +x -- exit; tell the Haskell process to update the flags, then leave menu. +q -- exit; same as x. +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)) + +(defun haskell-menu (help-file buffer request-fn update-fn) (byte-code "Æ ˆÇ!ƒ + +(defvar *haskell-menu-marked* " on") + +(defvar *haskell-menu-unmarked* " ") + +(defvar *haskell-menu-marked-regexp* " on \\w") + +(defvar *haskell-menu-unmarked-regexp* " \\w") + +(defun haskell-menu-mark nil "\ +Mark flag to be turned on." (interactive) (byte-code "ÃˆÇ ˆÈ!ƒ + +(defun haskell-menu-unmark nil "\ +Unmark flag." (interactive) (byte-code "ÃˆÇ ˆÈ!ƒ + +(defun haskell-menu-backup-unmark nil "\ +Move up and unmark." (interactive) (byte-code "ÀˆÁÂ!ˆÃ ˆÁÂ!‡" [nil forward-line -1 haskell-menu-unmark] 4)) + +(defun haskell-menu-exit nil "\ +Update flags, then leave menu." (interactive) (byte-code "ÀˆÁ ˆÂ ‡" [nil haskell-menu-execute haskell-menu-quit] 3)) + +(defun haskell-menu-execute nil "\ +Tell haskell process to tweak flags." (interactive) (byte-code "ˆŠˆŠebˆ`d=?…7 + +(defun haskell-menu-quit nil (interactive) (byte-code "ÀˆÁˆÂp!ˆÃp!‡" [nil "Make the menu go away." bury-buffer replace-buffer-in-windows] 3)) + +(defun haskell-menu-flag nil (byte-code "ŠÁ ˆÂÃ!ˆ`ÄÅ!ˆÆÇÈ!\"))‡" [beg beginning-of-line forward-char 6 re-search-forward " \\| " buffer-substring match-beginning 0] 7)) + +(defun start-setting-flags nil (byte-code "À‡" [nil] 1)) + +(defun finish-setting-flags nil (byte-code "ÀÁ!‡" [haskell-end-interaction "Setting flags....done."] 2)) + +(defun haskell-menu-mark-current nil (byte-code "Ä!ˆŠebˆ`d=?…; +!…, + +(defun menu-item-currently-on-p (item) (byte-code " \"‡" [item haskell-menu-current-flags member-string=] 3)) + +(defun member-string= (item list) (byte-code "?ƒ +@\"ƒ +A\"‡" [list nil item t string= member-string=] 4)) + +(defvar *haskell-printers-help* (concat (getenv "HASKELL") "/emacs-tools/printer-help.txt") "\ +Help file for printers.") + +(defvar *haskell-printers-buffer* "*Haskell printers*") + +(defun haskell-printers nil "\ +Set printers interactively." (interactive) (byte-code "ˆà ÄÅ$‡" [*haskell-printers-help* *haskell-printers-buffer* nil haskell-menu get-current-printers set-current-printers] 5)) + +(defun get-current-printers nil (byte-code "Á‰ˆÂÃ!ˆÁ=… + +(defun update-printers-list (data) (byte-code " !‰‡" [haskell-menu-current-flags data read] 3)) + +(defun set-current-printers (flag on) (byte-code "Å ! +… + +?… + +(defvar *haskell-optimizers-help* (concat (getenv "HASKELL") "/emacs-tools/optimizer-help.txt") "\ +Help file for optimizers.") + +(defvar *haskell-optimizers-buffer* "*Haskell optimizers*") + +(defun haskell-optimizers nil "\ +Set optimizers interactively." (interactive) (byte-code "ˆà ÄÅ$‡" [*haskell-optimizers-help* *haskell-optimizers-buffer* nil haskell-menu get-current-optimizers set-current-optimizers] 5)) + +(defun get-current-optimizers nil (byte-code "Á‰ˆÂÃ!ˆÁ=… + +(defun update-optimizers-list (data) (byte-code " !‰‡" [haskell-menu-current-flags data read] 3)) + +(defun set-current-optimizers (flag on) (byte-code "Å ! +… + +?… + +(defvar *pad-mappings* nil "\ +Associates pads with their corresponding module and file.") + +(defun record-pad-mapping (pname mname fname) (byte-code " + EB‰‡" [*pad-mappings* pname mname fname] 3)) + +(defun get-module-from-pad (pname) (byte-code " \"A@‡" [pname *pad-mappings* assoc] 3)) + +(defun get-file-from-pad (pname) (byte-code " \"AA@‡" [pname *pad-mappings* assoc] 3)) + +(defun lookup-pad (mname fname) (byte-code "à +#‡" [mname fname *pad-mappings* lookup-pad-aux] 4)) + +(defun lookup-pad-aux (mname fname list) (byte-code "?ƒ +@A@\"… + A#‡" [list nil mname fname t equal lookup-pad-aux] 6)) + +(defvar *ask-before-saving* t) + +(defun save-modified-source-files (filename) (byte-code "È Â…O + +(defun source-file-p (filename) (byte-code "ÁÂ\"†' + +(defun haskell-move-marker nil "\ +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)) + +(defun create-main-pad nil (byte-code "Ä !ŠqˆÅ )ˆÆ + #ˆ)‡" [buffer haskell-main-pad haskell-main-module haskell-main-file get-buffer-create haskell-mode record-pad-mapping] 6)) + +(defvar *re-module* "^module\\s *\\|^>\\s *module\\s *") + +(defvar *re-modname* "[A-Z]\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\)*") + +(defun get-modname (buff) "\ +Get module name in BUFFER that point is in." (byte-code "ŠqˆÄ !† + +(defun get-padname (m) "\ +Build padname from module name" (byte-code "ÁÂQ‡" [m "*" "-pad*"] 3)) + +(defvar *haskell-filename-regexp* "\\(.*\\)\\.\\(hs\\|lhs\\)$") + +(defun strip-fext (filename) "\ +Strip off the extension from a filename." (byte-code " \"ƒ + +(defun haskell-mode-error (msg) "\ +Show MSG in message line as an error from the haskell mode" (byte-code "ÁÂP!‡" [msg error "Haskell mode: "] 3)) + +(defun ci-send-buffer (buff) "\ +Send BUFFER to haskell process." (byte-code " ÃÄ\"?… + +(defun ci-kill nil (byte-code "ÀÁ!‡" [haskell-send-command ":kill"] 2)) + +(defun ci-clear nil (byte-code "ÀÁ!‡" [haskell-send-command ":clear"] 2)) + +(defun ci-set-file (file-name) (byte-code "ÁÂP!‡" [file-name haskell-send-command ":file "] 3)) + +(defun ci-module (modname) (byte-code " ‰ˆÂà P!‡" [*last-module* modname haskell-send-command ":module "] 3)) + +(defun ci-load (filename) (byte-code "ÁÂP!‡" [filename haskell-send-command ":load "] 3)) + +(defun ci-load-main nil (byte-code "ÀÁ!‡" [haskell-send-command ":Main"] 2)) + +(defun ci-save nil (byte-code "ÀÁ!‡" [haskell-send-command ":save"] 2)) + +(defun ci-compile (filename) (byte-code "ÁÂP!‡" [filename haskell-send-command ":compile "] 3)) + +(defun ci-run (filename) (byte-code "ÁÂP!‡" [filename haskell-send-command ":run "] 3)) + +(defun ci-print-exp (exp) (byte-code "ÁÂ!ˆÃÄP!‡" [exp ci-set-file "interactive-expression-buffer" haskell-send-command "= "] 4)) + +(defun ci-send-name (name) (byte-code "ÂÃ!ÄÅ!ˆÆÇ Q!)‡" [temp name make-temp-name "etemp" ci-set-file "interactive-expression-buffer" haskell-send-command " = "] 6)) + +(defun ci-eval nil (byte-code "ÀÁ!‡" [haskell-send-command ":eval"] 2)) + +(defun ci-quit nil (byte-code "Ã!?ƒ
+" set-haskell-status dead] 6)) + +(defun ci-emacs nil (byte-code "À ˆÁÂÃ!Ä\"ˆÅÆ!‡" [haskell-reset set-process-filter get-process "haskell" process-haskell-output haskell-send-command ":Emacs on"] 5)) + +(defun haskell-get-old-input nil "\ +Get old input text from Haskell process buffer." (byte-code "ŠÃdÄ#…
+`\"))‡" [haskell-prompt-pattern t temp re-search-forward move match-beginning 0 re-search-backward comint-skip-prompt end-of-line buffer-substring] 8)) + +(defun haskell-send-input nil "\ +Send input to Haskell while in the process buffer" (interactive) (byte-code "Áˆƒ + +(defun haskell-send-input-aux nil (byte-code "Êp!?ƒ +Yƒ$ + +(defvar haskell-minibuffer-local-map nil "\ +Local map for minibuffer when in Haskell") + +(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)))) + +(defun haskell-previous-input (arg) "\ +Cycle backwards through input history." (interactive "*p") (byte-code "ÇˆÈ !ÉXƒ + +(defun haskell-next-input (arg) "\ +Cycle forwards through input history." (interactive "*p") (byte-code "ÁˆÂ[!‡" [arg nil haskell-previous-input] 2)) + +(defvar haskell-last-input-match "" "\ +Last string searched for by Haskell input history search, for defaulting. +Buffer local variable.") + +(defun haskell-previous-input-matching (str) "\ +Searches backwards through input history for substring match" (interactive (byte-code "ÂÃÄ \"!ÅÆ\"ƒ +‰ˆÈ +!É !Ê
X… +Ì
\"\"?…* + +(defun get-haskell-expression (prompt) (byte-code "Å Â #Æ \"ˆ)‡" [exp prompt nil haskell-minibuffer-local-map haskell-prompt-ring read-from-minibuffer ring-insert] 4)) + +(defvar haskell-load-hook nil "\ +This hook is run when haskell is loaded in. +This is a good place to put key bindings.") + +(run-hooks (quote haskell-load-hook)) + +(defvar ht-mode-map nil) + +(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)))) + +(defun haskell-tutorial-mode nil "\ +Major mode for running the Haskell tutorial. +You can use these commands: +\\{ht-mode-map}" (interactive) (byte-code "ĈŠˆÆ!ˆÇ‰ˆÈ‰ˆÉ !ˆÊË!‡" [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)) + +(defun haskell-tutorial nil "\ +Run the haskell tutorial." (interactive) (byte-code "ÀˆÁ ˆÂ ˆÃ ‡" [nil ht-load-tutorial ht-make-buffer ht-display-page] 4)) + +(defun ht-load-tutorial nil (byte-code "Ä !ƒ +!ƒ* +!‚- + +(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)) + +(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)) + +(defun ht-next-page nil "\ +Go to the next tutorial page." (interactive) (byte-code "ÀˆÁ ƒ + +(defun ht-goto-next-page nil (byte-code "pÄŽ qˆÅÆÂÃ#))‡" [buff *ht-file-buffer* nil t ((byte-code "q‡" [buff] 1)) search-forward " "] 4)) + +(defun ht-prev-page nil "\ +Go to the previous tutorial page." (interactive) (byte-code "ÀˆÁ ƒ + +(defun ht-goto-prev-page nil (byte-code "pÄŽ qˆÅÆÂÃ#))‡" [buff *ht-file-buffer* nil t ((byte-code "q‡" [buff] 1)) search-backward " "] 4)) + +(defun ht-goto-page (arg) "\ +Go to the tutorial page specified as the argument." (interactive "sGo to page: ") (byte-code "ÁˆÂÃÄ\"!ƒ + +(defun ht-goto-section (arg) "\ +Go to the tutorial section specified as the argument." (interactive "sGo to section: ") (byte-code "ÁˆÂÃÄ\"!ƒ + +(defun ht-searchfor-page (search-string) (byte-code "pÆŽ qˆ`Ç ˆÈ ÄÅ#ƒ +bˆÄ)))‡" [buff *ht-file-buffer* point search-string nil t ((byte-code "q‡" [buff] 1)) beginning-of-buffer search-forward] 5)) + +(defun ht-restore-page nil (interactive) (byte-code "Áˆ` ˆb)‡" [old-point nil ht-display-page] 2)) + +(defun ht-display-page nil (byte-code "qˆÇÈÂÃ#ƒ diff --git a/emacs-tools/optimizer-help.txt b/emacs-tools/optimizer-help.txt new file mode 100644 index 0000000..3ed2ae2 --- /dev/null +++ b/emacs-tools/optimizer-help.txt @@ -0,0 +1,5 @@ +Optimizer switches + inline Aggressively inline functions + constant Hoist constant expressions to top-level + foldr Perform foldr/build deforestation + lisp Tell the Lisp compiler to work hard to produce best code diff --git a/emacs-tools/printer-help.txt b/emacs-tools/printer-help.txt new file mode 100644 index 0000000..a525ad1 --- /dev/null +++ b/emacs-tools/printer-help.txt @@ -0,0 +1,24 @@ +General messages + compiling Printed when the compilation system starts a compilation + loading Printed when a previously compiled unit is loaded + reading Prints the name of the file being parsed + extension Enables printing withinn extensions +Timings + time Prints the time that it takes to execute a computation + phase-time Prints the time of each phase of compilation +Compiler passes + parse Prints the program recreated from ast + import Lists all symbols imported and exported for each module + scope Print the program after scoping and precedence parsing + depend Prints entire program in nested let's + type Prints signatures during inference + cfn Prints entire program after context free normalization + depend2 Like depend + flic Prints entire program as flic code + optimize Prints entire program as optimized flic code + optimize-extra Prints extra verbose information during optimization + strictness Print strictness of all functions and variables + codegen Prints generated Lisp code + codegen-flic Prints generated Lisp code and associated flic code + dumper Prints the code in the interface + dump-stat Prints statistics for the interface file diff --git a/flic/README b/flic/README new file mode 100644 index 0000000..51af8a5 --- /dev/null +++ b/flic/README @@ -0,0 +1,2 @@ +This directory contains code to define FLIC structures and associated +pretty-printers, and the traversal to convert AST to FLIC structures. diff --git a/flic/ast-to-flic.scm b/flic/ast-to-flic.scm new file mode 100644 index 0000000..d756723 --- /dev/null +++ b/flic/ast-to-flic.scm @@ -0,0 +1,277 @@ +;;; ast-to-flic.scm -- convert AST to flic structures. +;;; +;;; author : Sandra Loosemore +;;; date : 3 Apr 1992 +;;; +;;; + + +;;; ==================================================================== +;;; Support +;;; ==================================================================== + + +(define-walker ast-to-flic ast-td-ast-to-flic-walker) + +(define-local-syntax (define-ast-to-flic ast-type lambda-list . body) + `(define-walker-method ast-to-flic ,ast-type ,lambda-list ,@body)) + +(define (ast-to-flic big-let) + (ast-to-flic-let-aux (let-decls big-let) (make-flic-void) '#t)) + +(define (ast-to-flic-1 ast-node) + (call-walker ast-to-flic ast-node)) + +(define (ast-to-flic/list l) + (map (function ast-to-flic-1) l)) + +(define (init-flic-var var value toplevel?) + (setf (var-value var) value) + (setf (var-toplevel? var) toplevel?) + (setf (var-simple? var) + (and value + (or (is-type? 'flic-const value) + (is-type? 'flic-pack value)))) + (setf (var-strict? var) '#f) + ;; Remember the strictness annotation. + (let ((strictness-ann (lookup-annotation var '|Strictness|))) + (setf (var-strictness var) + (if strictness-ann + (adjust-annotated-strictness var + (parse-strictness (car (annotation-value-args strictness-ann)))) + '#f))) + ;; If the variable has an inline annotation, rewrite its value + ;; from var = value + ;; to var = let temp = value in temp + ;; (Necessary for inlining recursive definitions.) + (let ((inline-ann (lookup-annotation var '|Inline|))) + (when inline-ann + (setf (var-force-inline? var) '#t) + (setf (var-value var) (wrap-with-let var value)))) + var) + +(define (wrap-with-let var value) + (let ((temp (copy-temp-var (def-name var)))) + (init-flic-var temp (copy-flic value (list (cons var temp))) '#f) + (make-flic-let (list temp) (make-flic-ref temp) '#t))) + + +;;; ==================================================================== +;;; ast expression structs +;;; ==================================================================== + + +(define-ast-to-flic lambda (object) + (make-flic-lambda + (map (lambda (pat) + (init-flic-var + (cond ((var-pat? pat) + (var-ref-var (var-pat-var pat))) + (else + (error "Bad lambda pattern: ~s." pat))) + '#f + '#f)) + (lambda-pats object)) + (ast-to-flic-1 (lambda-body object)))) + + +;;; For LET, the CFN has turned all of the definitions into +;;; simple assignments to a variable. The dependency analyzer +;;; adds recursive-decl-groups for things which need to be bound +;;; with LETREC. + +(define-ast-to-flic let (object) + (ast-to-flic-let-aux + (let-decls object) + (ast-to-flic-1 (let-body object)) + '#f)) + +(define (ast-to-flic-let-aux decls body toplevel?) + (multiple-value-bind (bindings newbody) + (ast-to-flic-bindings decls body toplevel?) + (if (null? bindings) + newbody + (make-flic-let bindings newbody toplevel?)))) + +(define (ast-to-flic-bindings decls body toplevel?) + (if (null? decls) + (values '() body) + (multiple-value-bind (bindings newbody) + (ast-to-flic-bindings (cdr decls) body toplevel?) + (cond ((is-type? 'valdef (car decls)) + ;; Continue collecting bindings. + (let* ((decl (car decls)) + (pat (valdef-lhs decl)) + (exp (single-definition-rhs decl))) + (values + (cond ((var-pat? pat) + (cons + (init-flic-var + (var-ref-var (var-pat-var pat)) + (ast-to-flic-1 exp) + toplevel?) + bindings)) + (else + (error "Definition has invalid pattern: ~s." decl))) + newbody))) + ((not (is-type? 'recursive-decl-group (car decls))) + (error "Decl has weird value: ~s." (car decls))) + (toplevel? + ;; We don't do any of this mess with top level bindings. + ;; Turn it into one big letrec. + (multiple-value-bind (more-bindings newerbody) + (ast-to-flic-bindings + (recursive-decl-group-decls (car decls)) + newbody + toplevel?) + (values (nconc more-bindings bindings) + newerbody))) + (else + ;; Otherwise, turn remaining bindings into a nested + ;; let or letrec, and put that in the body of a new + ;; letrec. + (multiple-value-bind (more-bindings newerbody) + (ast-to-flic-bindings + (recursive-decl-group-decls (car decls)) + (if (null? bindings) + newbody + (make-flic-let bindings newbody '#f)) + toplevel?) + (values + '() + (if (null? more-bindings) + newerbody + (make-flic-let more-bindings newerbody '#t))))) + )))) + + +(define (single-definition-rhs decl) + (let* ((def-list (valdef-definitions decl)) + (def (car def-list)) + (rhs-list (single-fun-def-rhs-list def)) + (rhs (car rhs-list))) + ;; All of this error checking could be omitted for efficiency, since + ;; none of these conditions are supposed to happen anyway. + (cond ((not (null? (cdr def-list))) + (error "Decl has multiple definitions: ~s." decl)) + ((not (null? (single-fun-def-where-decls def))) + (error "Definition has non-null where-decls list: ~s." decl)) + ((not (null? (cdr rhs-list))) + (error "Definition has multiple right-hand-sides: ~s." decl)) + ((not (is-type? 'omitted-guard (guarded-rhs-guard rhs))) + (error "Definition has a guard: ~s." decl))) + (guarded-rhs-rhs rhs))) + + + +;;; These are all straightforward translations. + +(define-ast-to-flic if (object) + (make-flic-if + (ast-to-flic-1 (if-test-exp object)) + (ast-to-flic-1 (if-then-exp object)) + (ast-to-flic-1 (if-else-exp object)))) + +(define-ast-to-flic case-block (object) + (make-flic-case-block + (case-block-block-name object) + (ast-to-flic/list (case-block-exps object)))) + +(define-ast-to-flic return-from (object) + (make-flic-return-from + (return-from-block-name object) + (ast-to-flic-1 (return-from-exp object)))) + +(define-ast-to-flic and-exp (object) + (make-flic-and (ast-to-flic/list (and-exp-exps object)))) + + +;;; Applications. Uncurry here. It's more convenient to do the +;;; optimizer on fully uncurried applications. After the optimizer +;;; has run, all applications are adjusted based on observed arity +;;; of the functions and the saturated? flag is set correctly. + +(define-ast-to-flic app (object) + (ast-to-flic-app-aux object '())) + +(define (ast-to-flic-app-aux object args) + (if (is-type? 'app object) + (ast-to-flic-app-aux + (app-fn object) + (cons (ast-to-flic-1 (app-arg object)) args)) + (make-flic-app (ast-to-flic-1 object) args '#f))) + + +;;; References + +(define-ast-to-flic var-ref (object) + (make-flic-ref (var-ref-var object))) + +(define-ast-to-flic con-ref (object) + (make-flic-pack (con-ref-con object))) + + +;;; Constants + +(define-ast-to-flic integer-const (object) + (make-flic-const (integer-const-value object))) + + +;;; We should probably add a type field to flic-const but at the moment +;;; I'll force the value to be a list of numerator, denominator. + +(define-ast-to-flic float-const (object) + (let ((e (float-const-exponent object)) + (n (float-const-numerator object)) + (d (float-const-denominator object))) + (make-flic-const + (if (> e 0) + (list (* n (expt 10 e)) d) + (list n (* d (expt 10 (- e)))))))) + +(define-ast-to-flic char-const (object) + (make-flic-const (char-const-value object))) + + +(define-ast-to-flic string-const (object) + (let ((value (string-const-value object))) + (if (equal? value "") + (make-flic-pack (core-symbol "Nil")) + (make-flic-const value)))) + + + +;;; Random stuff + +(define-ast-to-flic con-number (object) + (make-flic-con-number + (con-number-type object) + (ast-to-flic-1 (con-number-value object)))) + +(define-ast-to-flic sel (object) + (make-flic-sel + (sel-constructor object) + (sel-slot object) + (ast-to-flic-1 (sel-value object)))) + +(define-ast-to-flic is-constructor (object) + (make-flic-is-constructor + (is-constructor-constructor object) + (ast-to-flic-1 (is-constructor-value object)))) + +(define-ast-to-flic void (object) + (declare (ignore object)) + (make-flic-void)) + + +;;; This hack make strictness annotations work. It adds #t's which correspond +;;; to the strictness of the dict params. + +(define (adjust-annotated-strictness v s) + (let* ((ty (var-type v)) + (c (gtype-context ty))) + (dolist (c1 c) + (dolist (c2 c1) + (declare (ignorable c2)) + (push '#t s))) + s)) diff --git a/flic/copy-flic.scm b/flic/copy-flic.scm new file mode 100644 index 0000000..373fbd4 --- /dev/null +++ b/flic/copy-flic.scm @@ -0,0 +1,146 @@ +;;; copy-flic.scm -- general copy functions for flic structures +;;; +;;; author : Sandra Loosemore +;;; date : 23 Feb 1993 +;;; +;;; + + +;;; The var-renamings argument is an a-list. It's used to map local vars +;;; in the input expression to new, gensymed vars. + +(define-flic-walker copy-flic (object var-renamings)) + +(define (copy-flic-list objects var-renamings) + (let ((result '())) + (dolist (o objects) + (push (copy-flic o var-renamings) result)) + (nreverse result))) + + +(define (copy-flic-top object) + (copy-flic object '())) + + +(define-copy-flic flic-lambda (object var-renamings) + (let ((new-vars (map (lambda (v) + (let ((new (copy-temp-var (def-name v)))) + (push (cons v new) var-renamings) + (when (var-force-strict? v) + (setf (var-force-strict? new) '#t)) + (init-flic-var new '#f '#f))) + (flic-lambda-vars object)))) + (make-flic-lambda + new-vars + (copy-flic (flic-lambda-body object) var-renamings)))) + + +;;; Hack to avoid concatenating multiple gensym suffixes. + +(define (copy-temp-var sym) + (if (gensym? sym) + (let* ((string (symbol->string sym)) + (n (string-length string)) + (root (find-string-prefix string 0 n))) + (create-temp-var root)) + (create-temp-var sym))) + +(define (find-string-prefix string i n) + (declare (type string string) (type fixnum i n)) + (cond ((eqv? i n) + string) + ((char-numeric? (string-ref string i)) + (substring string 0 i)) + (else + (find-string-prefix string (+ i 1) n)))) + + +(define-copy-flic flic-let (object var-renamings) + (let ((new-vars (map (lambda (v) + (let ((new (copy-temp-var (def-name v)))) + (when (var-force-inline? v) + (setf (var-force-inline? new) '#t)) + (push (cons v new) var-renamings) + new)) + (flic-let-bindings object)))) + (for-each + (lambda (new old) + (init-flic-var new (copy-flic (var-value old) var-renamings) '#f)) + new-vars + (flic-let-bindings object)) + (make-flic-let + new-vars + (copy-flic (flic-let-body object) var-renamings) + (flic-let-recursive? object)))) + +(define-copy-flic flic-app (object var-renamings) + (make-flic-app + (copy-flic (flic-app-fn object) var-renamings) + (copy-flic-list (flic-app-args object) var-renamings) + (flic-app-saturated? object))) + +(define-copy-flic flic-ref (object var-renamings) + (let* ((var (flic-ref-var object)) + (entry (assq var var-renamings))) + (if entry + (make-flic-ref (cdr entry)) + (make-flic-ref var)))) ; don't share structure + + +(define-copy-flic flic-const (object var-renamings) + (declare (ignore var-renamings)) + (make-flic-const (flic-const-value object))) ; don't share structure + +(define-copy-flic flic-pack (object var-renamings) + (declare (ignore var-renamings)) + (make-flic-pack (flic-pack-con object))) ; don't share structure + + +;;; Don't have to gensym new block names; these constructs always +;;; happen in pairs. + +(define-copy-flic flic-case-block (object var-renamings) + (make-flic-case-block + (flic-case-block-block-name object) + (copy-flic-list (flic-case-block-exps object) var-renamings))) + +(define-copy-flic flic-return-from (object var-renamings) + (make-flic-return-from + (flic-return-from-block-name object) + (copy-flic (flic-return-from-exp object) var-renamings))) + +(define-copy-flic flic-and (object var-renamings) + (make-flic-and + (copy-flic-list (flic-and-exps object) var-renamings))) + +(define-copy-flic flic-if (object var-renamings) + (make-flic-if + (copy-flic (flic-if-test-exp object) var-renamings) + (copy-flic (flic-if-then-exp object) var-renamings) + (copy-flic (flic-if-else-exp object) var-renamings))) + +(define-copy-flic flic-sel (object var-renamings) + (make-flic-sel + (flic-sel-con object) + (flic-sel-i object) + (copy-flic (flic-sel-exp object) var-renamings))) + +(define-copy-flic flic-is-constructor (object var-renamings) + (make-flic-is-constructor + (flic-is-constructor-con object) + (copy-flic (flic-is-constructor-exp object) var-renamings))) + +(define-copy-flic flic-con-number (object var-renamings) + (make-flic-con-number + (flic-con-number-type object) + (copy-flic (flic-con-number-exp object) var-renamings))) + +(define-copy-flic flic-void (object var-renamings) + (declare (ignore object var-renamings)) + (make-flic-void)) ; don't share structure + + + + + + diff --git a/flic/flic-structs.scm b/flic/flic-structs.scm new file mode 100644 index 0000000..2aab75c --- /dev/null +++ b/flic/flic-structs.scm @@ -0,0 +1,89 @@ +;;; flic-structs.scm -- structures to define FLIC intermediate language +;;; +;;; author : Sandra Loosemore +;;; date : 24 Mar 1992 + + + +(define-struct flic-exp + (type-template flic-td) + (slots + (unboxed? (type bool) (default '#f) (bit #t)) + (cheap? (type bool) (default '#f) (bit #t)))) + + +;;; Use a macro to define each subtype and a BOA constructor. +;;; Maybe eventually the constructors will need to do additional +;;; initialization and have to be defined by hand. + +(define-local-syntax (define-flic name . slots) + (let* ((maker (symbol-append 'make- name)) + (pred (symbol-append name '?)) + (args (map (function car) slots)) + (inits (map (lambda (x) (list x x)) args))) + `(begin + (define-struct ,name + (include flic-exp) + (predicate ,pred) + (slots ,@slots)) + (define (,maker ,@args) (make ,name ,@inits)) + ',name))) + +(define-flic flic-lambda + (vars (type (list var))) + (body (type flic-exp))) + +(define-flic flic-let + ;; value exp is stored in var-value slot + (bindings (type (list var))) + (body (type flic-exp)) + (recursive? (type bool) (bit #t))) + +(define-flic flic-app + (fn (type flic-exp)) + (args (type (list flic-exp))) + ;; true if number of args exactly matches arity of fn + (saturated? (type bool) (bit #t))) + +(define-flic flic-ref + (var (type var))) + +(define-flic flic-const + (value (type t))) + +(define-flic flic-pack + (con (type con))) + +(define-flic flic-case-block + (block-name (type symbol)) + (exps (type (list flic-exp)))) + +(define-flic flic-return-from + (block-name (type symbol)) + (exp (type flic-exp))) + +(define-flic flic-and + (exps (type (list flic-exp)))) + +(define-flic flic-if + (test-exp (type flic-exp)) + (then-exp (type flic-exp)) + (else-exp (type flic-exp))) + +(define-flic flic-sel + (con (type con)) + (i (type int)) + (exp (type flic-exp))) + +(define-flic flic-is-constructor + (con (type con)) + (exp (type flic-exp))) + +(define-flic flic-con-number + (type (type algdata)) + (exp (type flic-exp))) + +(define-flic flic-void + ) + + diff --git a/flic/flic-td.scm b/flic/flic-td.scm new file mode 100644 index 0000000..01253b0 --- /dev/null +++ b/flic/flic-td.scm @@ -0,0 +1,21 @@ +;;; flic-td.scm -- define type descriptor for flic structs +;;; +;;; author : Sandra Loosemore +;;; date : 6 Oct 1992 +;;; + +(define-struct flic-td + (include type-descriptor) + (slots + (codegen-walker (type (maybe procedure)) (default '#f)) + (optimize-walker (type (maybe procedure)) (default '#f)) + (postoptimize-walker (type (maybe procedure)) (default '#f)) + (fun-strictness-walk-walker (type (maybe procedure)) (default '#f)) + (var-strictness-walk-walker (type (maybe procedure)) (default '#f)) + (compute-strictness-walk-walker (type (maybe procedure)) (default '#f)) + (print-strictness-walker (type (maybe procedure)) (default '#f)) + (box-analysis-walker (type (maybe procedure)) (default '#f)) + (copy-flic-walker (type (maybe procedure)) (default '#f)) + (dump-flic-walker (type (maybe procedure)) (default '#f)) + (flic-invariant?-walker (type (maybe procedure)) (default '#f)) + )) diff --git a/flic/flic-walker.scm b/flic/flic-walker.scm new file mode 100644 index 0000000..846d89f --- /dev/null +++ b/flic/flic-walker.scm @@ -0,0 +1,21 @@ +;;; flic-walker.scm -- macros for defining code walkers for flic +;;; +;;; author : Sandra Loosemore +;;; date : 7 May 1992 +;;; + + +;;; (define-flic-walker foo (object)) +;;; creates a macro (define-foo type (object) . body) +;;; and a function (foo object) that dispatches on the type of object. + +(define-syntax (define-flic-walker name args) + (let ((accessor-name (symbol-append 'flic-td- name '-walker)) + (definer-name (symbol-append 'define- name))) + `(begin + (define-walker ,name ,accessor-name) + (define-local-syntax (,definer-name type args . body) + `(define-walker-method ,',name ,type ,args ,@body)) + (define (,name ,@args) + (call-walker ,name ,@args))))) + diff --git a/flic/flic.scm b/flic/flic.scm new file mode 100644 index 0000000..8aa389a --- /dev/null +++ b/flic/flic.scm @@ -0,0 +1,29 @@ +;;; flic.scm -- compilation unit for flic stuff +;;; +;;; author : Sandra Loosemore +;;; date : 7 Apr 1992 +;;; + + +(define-compilation-unit flic + (source-filename "$Y2/flic/") + (unit flic-td + (source-filename "flic-td.scm")) + (unit flic-structs + (source-filename "flic-structs.scm") + (require flic-td)) + (unit print-flic + (source-filename "print-flic.scm") + (require flic-structs printer-support)) + (unit ast-to-flic + (source-filename "ast-to-flic.scm") + (require flic-structs ast haskell-utils)) + (unit flic-walker + (source-filename "flic-walker.scm")) + (unit copy-flic + (source-filename "copy-flic.scm") + (require flic-walker flic-structs)) + (unit invariant + (source-filename "invariant.scm") + (require flic-walker flic-structs)) + ) diff --git a/flic/invariant.scm b/flic/invariant.scm new file mode 100644 index 0000000..c6c0486 --- /dev/null +++ b/flic/invariant.scm @@ -0,0 +1,88 @@ +;;; invariant.scm -- look for invariant expressions +;;; +;;; author : Sandra Loosemore +;;; date : 12 Mar 1993 +;;; +;;; +;;; The function flic-invariant? returns true if the expression is +;;; invariant with respect to a set of local variable bindings. + +(define-flic-walker flic-invariant? (object local-bindings)) + +(define (flic-invariant-list? objects local-bindings) + (if (null objects) + '#t + (and (flic-invariant? (car objects) local-bindings) + (flic-invariant-list? (cdr objects) local-bindings)))) + +(define-flic-invariant? flic-lambda (object local-bindings) + (flic-invariant? (flic-lambda-body object) + (cons (flic-lambda-vars object) local-bindings))) + +(define-flic-invariant? flic-let (object local-bindings) + (let* ((bindings (flic-let-bindings object)) + (body (flic-let-body object)) + (recursive? (flic-let-recursive? object)) + (inner-stuff (cons bindings local-bindings))) + (and (flic-invariant-list? (map (function var-value) bindings) + (if recursive? inner-stuff local-bindings)) + (flic-invariant? body inner-stuff)))) + +(define-flic-invariant? flic-app (object local-bindings) + (and (flic-invariant? (flic-app-fn object) local-bindings) + (flic-invariant-list? (flic-app-args object) local-bindings))) + +(define-flic-invariant? flic-ref (object local-bindings) + (let ((var (flic-ref-var object))) + (or (var-toplevel? var) + (flic-local-var? var local-bindings)))) + +(define (flic-local-var? var local-bindings) + (cond ((null? local-bindings) + '#f) + ((memq var (car local-bindings)) + '#t) + (else + (flic-local-var? var (cdr local-bindings))))) + +(define-flic-invariant? flic-const (object local-bindings) + (declare (ignore object local-bindings)) + '#t) + +(define-flic-invariant? flic-pack (object local-bindings) + (declare (ignore object local-bindings)) + '#t) + +(define-flic-invariant? flic-case-block (object local-bindings) + (flic-invariant-list? (flic-case-block-exps object) local-bindings)) + +(define-flic-invariant? flic-return-from (object local-bindings) + (flic-invariant? (flic-return-from-exp object) local-bindings)) + +(define-flic-invariant? flic-and (object local-bindings) + (flic-invariant-list? (flic-and-exps object) local-bindings)) + +(define-flic-invariant? flic-if (object local-bindings) + (and (flic-invariant? (flic-if-test-exp object) local-bindings) + (flic-invariant? (flic-if-then-exp object) local-bindings) + (flic-invariant? (flic-if-else-exp object) local-bindings))) + +(define-flic-invariant? flic-sel (object local-bindings) + (flic-invariant? (flic-sel-exp object) local-bindings)) + +(define-flic-invariant? flic-is-constructor (object local-bindings) + (flic-invariant? (flic-is-constructor-exp object) local-bindings)) + +(define-flic-invariant? flic-con-number (object local-bindings) + (flic-invariant? (flic-con-number-exp object) local-bindings)) + +(define-flic-invariant? flic-void (object local-bindings) + (declare (ignore object local-bindings)) + '#t) + + + + + + + diff --git a/flic/print-flic.scm b/flic/print-flic.scm new file mode 100644 index 0000000..6077f57 --- /dev/null +++ b/flic/print-flic.scm @@ -0,0 +1,130 @@ +;;; print-flic.scm -- printers for FLIC structures +;;; +;;; author : Sandra Loosemore +;;; date : 30 Mar 1992 +;;; +;;; + + +;;; For now, printing of FLIC structures is controlled by the same +;;; *print-ast-syntax* variable as for AST structures. +;;; Maybe eventually this should use its own variable. + +(define-syntax (define-flic-printer type lambda-list . body) + `(define-ast-printer ,type ,lambda-list ,@body)) + +(define-flic-printer flic-lambda (object xp) + (with-ast-block (xp) + (write-string "\\ " xp) + (write-ordinary-list (flic-lambda-vars object) xp) + (write-string " ->" xp) + (write-whitespace xp) + (write (flic-lambda-body object) xp))) + +(define-flic-printer flic-let (object xp) + (pprint-logical-block (xp '() "" "") ; no extra indentation + (write-string "let " xp) + (write-layout-rule (flic-let-bindings object) xp + (lambda (v xp) + (with-ast-block (xp) + (write v xp) + (write-string " =" xp) + (write-whitespace xp) + (write (var-value v) xp)))) + (write-whitespace xp) + (write-string "in " xp) + (write (flic-let-body object) xp))) + +(define-flic-printer flic-app (object xp) + (with-ast-block (xp) + (maybe-paren-flic-object (flic-app-fn object) xp) + (write-whitespace xp) + (write-flic-list (flic-app-args object) xp))) + +(define (maybe-paren-flic-object object xp) + (cond ((or (flic-ref? object) + (flic-const? object) + (flic-pack? object)) + (write object xp)) + (else + (write-char #\( xp) + (write object xp) + (write-char #\) xp)))) + +(define (write-flic-list objects xp) + (write-delimited-list objects xp (function maybe-paren-flic-object) "" "" "")) + +(define-flic-printer flic-ref (object xp) + (write (flic-ref-var object) xp)) + +(define-flic-printer flic-const (object xp) + (write (flic-const-value object) xp)) + +(define-flic-printer flic-pack (object xp) + (write-string "pack/" xp) + (write (flic-pack-con object) xp)) + +(define-flic-printer flic-case-block (object xp) + (with-ast-block (xp) + (write-string "case-block " xp) + (write (flic-case-block-block-name object) xp) + (write-whitespace xp) + (write-layout-rule (flic-case-block-exps object) xp (function write)))) + +(define-flic-printer flic-return-from (object xp) + (with-ast-block (xp) + (write-string "return-from " xp) + (write (flic-return-from-block-name object) xp) + (write-whitespace xp) + (write (flic-return-from-exp object) xp))) + +(define-flic-printer flic-and (object xp) + (with-ast-block (xp) + (write-string "and " xp) + (write-layout-rule (flic-and-exps object) xp (function write)))) + +(define-flic-printer flic-if (object xp) + (with-ast-block (xp) + (write-string "if " xp) + (write (flic-if-test-exp object) xp) + (write-whitespace xp) + (with-ast-block (xp) + (write-string "then" xp) + (write-whitespace xp) + (write (flic-if-then-exp object) xp)) + (write-whitespace xp) + (with-ast-block (xp) + (write-string "else" xp) + (write-whitespace xp) + (write (flic-if-else-exp object) xp)) + )) + + +(define-flic-printer flic-sel (object xp) + (with-ast-block (xp) + (write-string "sel/" xp) + (write (flic-sel-con object) xp) + (write-char #\/ xp) + (write (flic-sel-i object) xp) + (write-whitespace xp) + (write (flic-sel-exp object) xp))) + +(define-flic-printer flic-is-constructor (object xp) + (with-ast-block (xp) + (write-string "is-constructor/" xp) + (write (flic-is-constructor-con object) xp) + (write-whitespace xp) + (write (flic-is-constructor-exp object) xp))) + +(define-flic-printer flic-con-number (object xp) + (with-ast-block (xp) + (write-string "con/" xp) + (write (flic-con-number-type object) xp) + (write-whitespace xp) + (write (flic-con-number-exp object) xp))) + +(define-flic-printer flic-void (object xp) + (declare (ignore object)) + (write-string "Void" xp)) + +
\ No newline at end of file diff --git a/haskell-development b/haskell-development new file mode 100755 index 0000000..bf318af --- /dev/null +++ b/haskell-development @@ -0,0 +1,69 @@ +#!/bin/csh +# +# Set up for Yale Haskell 2.x development +# + +source $HASKELL/haskell-setup + + +# You need to set this environment variable to point to the root +# directory where you have installed the Yale Haskell sources. + +setenv Y2 $HASKELL + + +# Define some aliases for getting the right RCS options. +# These aliases are only for use at Yale. + +alias rco 'co -l' +alias rci 'ci -u' + + +# Find the "right" lisp executable. +# You really only need to set up for the particular lisp implementation(s) +# you are going to build the system under (you can comment out the rest). + +# The Lucid CL executable we've been using is the one without fancy +# stuff like CLOS loaded. + +setenv LUCID /cs/licensed/sclisp-4.0/lisp-4-0-base + + +# Setup for CMUCL. We have this aliased to a script that will select +# the right core file for the machine you are running on. + +setenv CMUCL $Y2/bin/run-cmucl +setenv CMUCLBIN $Y2/bin/cmucl +setenv CMUCLLIB $Y2/bin + + +# This is AKCL, not ordinary KCL (which is too brain-damaged). + +setenv AKCL /net/nebula/homes/systems/hcompile/akcl/xbin/kcl + + +# Set up for Franz Allegro. +# This is a hack; we run Allegro on both sparc and next boxes, and +# we need to be able to tell which kind of machine we're running on so +# the binaries don't get jumbled up together. + +if (-e /vmunix) then + setenv ALLEGRODIR allegro + setenv ALLEGRO /usr/licensed/allegro/cl +else if (-e /mach) then + setenv ALLEGRODIR allegro-next + setenv ALLEGRO /usr/local/bin/lisp +else + echo "Can't figure out what kind of machine you're on!" +endif + + +# Set up for Harlequin Lispworks. + +setenv LISPWORKS /usr/licensed/bin/lispworks + + +# Set up for WCL +# This is not supported! +# setenv WCL /net/nebula/homes/systems/hcompile/wcl-2.14/bin/wcl +# setenv LD_LIBRARY_PATH /net/nebula/homes/systems/hcompile/wcl-2.14/lib diff --git a/haskell-setup b/haskell-setup new file mode 100755 index 0000000..16d6dcd --- /dev/null +++ b/haskell-setup @@ -0,0 +1,27 @@ +#!/bin/csh +# +# Set up for Yale Haskell 2.x users. +# + +setenv PRELUDE $HASKELL/progs/prelude +setenv HASKELL_LIBRARY $HASKELL/progs/lib + +# You may need to change this to point at the appropriate subdirectory, +# depending on which Lisp is being used. +setenv PRELUDEBIN $PRELUDE/lucid +#setenv PRELUDEBIN $PRELUDE/cmu + +# You may need to change this to point at the appropriate subdirectory, +# depending on which Lisp is being used. +setenv LIBRARYBIN $HASKELL_LIBRARY/bin/lucid +#setenv LIBRARYBIN $HASKELL_LIBRARY/bin/cmu + +# You may need to change this to point at the appropriate executable, +# depending on which Lisp is being used. +setenv HASKELLPROG $HASKELL/bin/haskell +#setenv HASKELLPROG $HASKELL/bin/cmu-haskell + +# You only need this next definition if you are using the CMU CL version +# of haskell and you have /tmp mounted on a tmpfs file system (it won't +# be able to initialize itself otherwise). +setenv CMUCL_EMPTYFILE /var/tmp/empty diff --git a/import-export/README b/import-export/README new file mode 100644 index 0000000..4bd3bc4 --- /dev/null +++ b/import-export/README @@ -0,0 +1,15 @@ +This is the import / export phase. This process is accomplished as follows: + +a) Local definitions are created in each module. These are entered into the + local symbol table. +b) Imports to non-local modules are completely resolved. +c) Local import/export is performed via a fixpoint: + 1) Export: definitions added in the previous round are filtered by the + export list and placed in a fresh export list. + 2) Each module imports from the fresh export list of the other modules. + Any import not already present is placed on a new fresh export list. + When no fresh exports are generated, the iteration is complete. +d) Missing exports and imports are checked for. + + + diff --git a/import-export/ie-errors.scm b/import-export/ie-errors.scm new file mode 100644 index 0000000..16180f5 --- /dev/null +++ b/import-export/ie-errors.scm @@ -0,0 +1,154 @@ +;;; Error checks & calls for the import-export code + +;;; this is called at the end of import-export to look for +;;; a) exported entities that were never found +;;; b) imported entities that were never found +;;; c) renamed entities that were never found +;;; d) hidden entities that were never found + +(define (check-missing-names) + (dolist (export (module-exports *module*)) + (remember-context export + (signal-missing-export export))) + (dolist (import-decl (module-imports *module*)) + (remember-context import-decl + (with-slots import-decl (mode specs renamings) import-decl + ;; *** I'm confused. Aren't these errors already detected + ;; *** by import-all-entities and import-named-entities? + ;; jcp: no - a final check is needed after all symbols have moved. + (cond ((eq? mode 'all) + (dolist (entity specs) + (signal-unused-hiding + (entity-name entity) + (import-decl-module-name import-decl)))) + (else + (dolist (entity specs) + (signal-entity-not-found + (entity-name entity) + (import-decl-module-name import-decl))))) + (find-unused-renamings renamings import-decl))))) + +(define (find-unused-renamings renamings import-decl) + (dolist (r renamings) + (when (not (renaming-referenced? r)) + (remember-context r + (signal-unused-renaming (renaming-from r) + (import-decl-module-name import-decl)))))) + +(define (check-duplicates l entity) + (when (not (null? (find-duplicates l))) + (signal-duplicate-names-in-entity entity))) + +;;; There are a ton of possible errors in import-export. All error +;;; calls are found here: + +(define (signal-missing-export export) + (recoverable-error 'missing-export + "Module ~A exports ~A, but provides no definition for it." + *module-name* export)) + +(define (signal-unused-renaming name module-name) + (recoverable-error 'unused-renaming + "The name ~a is included in the renaming list of an import declaration,~%~ + but is not among the entities being imported from module ~a." + name module-name)) + +(define (signal-unused-hiding name module-name) + (recoverable-error 'unused-hiding + "The name ~a is included in the hiding list of an import declaration,~%~ + but is not among the entities exported from module ~a." + name module-name)) + +(define (signal-multiple-name-conflict name old-local-name def) + (recoverable-error 'multiple-name-conflict + "In module ~A, the symbol ~A from module ~A is known as both ~A and ~A." + *module-name* (def-name def) (def-module def) name old-local-name)) + + +(define (signal-undefined-module-import name) + (fatal-error 'undefined-module-import + "Cannot find module ~A, imported by module ~A." + name *module-name*)) + + +(define (signal-undefined-module-export name) + (fatal-error 'undefined-module-export + "Cannot find module ~A, exported by module ~A." + name *module-name*)) + + +(define (signal-self-import name) + (fatal-error 'self-import + "Module ~A cannot import itself." + name)) + +(define (signal-missing-prelude) + (fatal-error 'missing-prelude "Can't find module Prelude.")) + +(define (signal-missing-prelude-core) + (fatal-error 'missing-prelude "Can't find module PreludeCore.")) + +(define (signal-export-not-imported name) + (recoverable-error 'export-not-imported + "Module ~A is exported from ~A,~%~ + but is not also imported into that module." + name *module-name*)) + +(define (signal-entity-not-found name module-name) + (fatal-error 'entity-not-found + "The entity ~a is not exported from module ~a." name module-name)) + +(define (signal-synonym-needs-dots name module-name) + (declare (ignore module-name)) + (fatal-error 'synonym-needs-dots + "The entity ~a is a type synonym; to name it in an import or export~%~ + list, you must use `~a(..)' as the entity." + name name)) + +(define (signal-wrong-definition expected name module-name) + (fatal-error 'wrong-definition + "The entity ~a does not name a ~a in module ~a." + name expected module-name)) + +(define (signal-abstract-type name module-name) + (fatal-error 'abstract-type + "The entity ~a names an abstract type in module ~a;~%~ + you cannot import or export its constructors." + name module-name)) + +(define (signal-extra-constituent entity name what) + (fatal-error 'extra-constituent + "The entity specification ~a includes the ~a name ~a,~%~ + which is not present in its definition." + entity what name)) + +(define (signal-missing-constituent entity name what) + (fatal-error 'missing-constituent + "The entity specification ~a does not include the ~a name ~a,~%~ + which is part of its definition." + entity what name)) + +(define (signal-duplicate-names-in-entity entity) + (fatal-error 'duplicate-names-in-entity + "The entity specification ~a includes duplicate names." + entity)) + +(define (signal-export-method-var name) + (fatal-error 'export-method-var + "You can't export the method ~a like an ordinary variable." + name)) + +(define (signal-prelude-renaming def name) + (recoverable-error 'cant-rename-core + "Names in PreludeCore cannot be renamed: ~a was renamed to ~a" + (def-name def) name)) + +(define (signal-non-local-fixity op) + (recoverable-error 'fixity-must-be-local + "The fixity for ~A will be ignored since it is not defined in this module" + op)) + +(define (signal-fixity-not-var/con op) + (recoverable-error 'fixity-requires-var-or-con + "The fixity for ~A will be ignored since it is not a value or constructor" + op)) diff --git a/import-export/ie-utils.scm b/import-export/ie-utils.scm new file mode 100644 index 0000000..20b6c1d --- /dev/null +++ b/import-export/ie-utils.scm @@ -0,0 +1,121 @@ + +;;; This file contains utilities, globals, and macros used by the +;;; import-export system. + +(define *new-exports-found?* '#f) ; used by the fixpoint iteration + +;;; A group is a collection of related symbols. It is represented +;;; by a list of (name,def) pairs. The first element is the head +;;; of the group; the group is entered in the export table under the +;;; name of the head only. Groups for vars and synonyms have only the +;;; head. Data types and classes have the constructors or methods in +;;; the tail of the group. + +(define (group-name x) ; name of the head + (tuple-2-1 (car x))) + +(define (group-definition x) ; definition of the head + (tuple-2-2 (car x))) + +;;; The name & entry are the head of the group. Others is a list of +;;; name - definition pairs. +(define (make-group name entry . others) + (if (null? others) + (list (cons name entry)) + (cons (cons name entry) (car others)))) + +(define (hidden-constructors? group) + (null? (cdr group))) + +(define (strip-constructors group) + (list (car group))) + +;;; rename-group applies the current renaming to every +;;; name in a group. When uses, a renaming is marked to allow unused +;;; renamings to be detected. + +(define (rename-group g renamings) + (if (null? renamings) + g + (map (lambda (n-d) + (let* ((def (tuple-2-2 n-d)) + (keep-name? (or (con? def) (var? def))) + (n (tuple-2-1 n-d)) + (name (if keep-name? n (add-con-prefix/symbol n))) + (renaming (locate-renaming name renamings))) + (cond (renaming + (let ((new-name + (if keep-name? + (renaming-to renaming) + (remove-con-prefix/symbol + (renaming-to renaming))))) + (when (and (def-prelude? def) + (not (eq? (def-name def) new-name))) + (signal-prelude-renaming def new-name) + (setf new-name (def-name def))) + (setf (renaming-referenced? renaming) '#t) + (tuple new-name def))) + (else n-d)))) + g))) + +(define (locate-renaming name renamings) + (if (null? renamings) + '#f + (if (eq? name (renaming-from (car renamings))) + (car renamings) + (locate-renaming name (cdr renamings))))) + +(define (gather-algdata-group name def) + (cons (tuple name def) + (gather-group (algdata-constrs def)))) + +(define (gather-class-group name def) + (cons (tuple name def) + (gather-group (class-method-vars def)))) + +(define (gather-group defs) + (if (null? defs) + '() + (let ((local-name (local-name (car defs)))) + (if (eq? local-name '#f) + '() + (cons (tuple local-name (car defs)) + (gather-group (cdr defs))))))) + +;;; These deal with `hiding' lists. + +;;; Note: as per the new report, no need to worry about anything but the +;;; group head and the entity name since only var, Class(..),Alg(..) allowed + +(define (in-hiding-list? group hiding) + (cond ((null? hiding) + '#f) + ((eq? (entity-name (car hiding)) (group-name group)) + '#t) + (else (in-hiding-list? group (cdr hiding))))) + +(define (remove-entity group hiding) + (cond ((eq? (entity-name (car hiding)) (group-name group)) + (cdr hiding)) + (else (cons (car hiding) (remove-entity group (cdr hiding)))))) + +;;; This moves fixity information to the local symbols. This must be +;;; called after local symbols are installed but before imported +;;; symbols arrive. + +(define (attach-fixities) + (dolist (fixity-decl (module-fixities *module*)) + (let ((fixity (fixity-decl-fixity fixity-decl))) + (dolist (op (fixity-decl-names fixity-decl)) + (let ((def (resolve-toplevel-name op))) + (cond ((or (eq? def '#f) (not (eq? *module-name* (def-module def)))) + ;;; ***This is WRONG! Inner fixities may be found. + (signal-non-local-fixity op)) + ((var? def) + (setf (var-fixity def) fixity) + (setf (table-entry *fixity-table* op) fixity)) + ((con? def) + (setf (con-fixity def) fixity) + (setf (table-entry *fixity-table* op) fixity)) + (else (signal-fixity-not-var/con op)))))))) + diff --git a/import-export/ie.scm b/import-export/ie.scm new file mode 100644 index 0000000..9cd6de9 --- /dev/null +++ b/import-export/ie.scm @@ -0,0 +1,16 @@ +(define-compilation-unit ie + (source-filename "$Y2/import-export/") + (require global) + (unit ie-utils + (source-filename "ie-utils")) + (unit import-export + (source-filename "import-export")) + (unit init-modules + (source-filename "init-modules")) + (unit top-definitions + (source-filename "top-definitions")) + (unit locate-entity + (source-filename "locate-entity")) + (unit ie-errors + (source-filename "ie-errors"))) + diff --git a/import-export/import-export.scm b/import-export/import-export.scm new file mode 100644 index 0000000..25fdfcf --- /dev/null +++ b/import-export/import-export.scm @@ -0,0 +1,209 @@ +;;; This is the main driver for the import / export routine + +(define (import-export modules) + (walk-modules modules + (lambda () (add-module-to-symbol-table *module*))) + (walk-modules modules + (lambda () (init-module-structure))) + (import-export/fixpoint modules '#t) + (walk-modules modules (lambda () (check-missing-names))) + (when (memq 'import (dynamic *printers*)) + (show-export-tables modules)) + modules) + +(define (import-export/interface modules) + (walk-modules modules + (lambda () (add-module-to-symbol-table *module*))) + (walk-modules modules + (lambda () (init-module-structure))) + (walk-modules modules + (lambda () (create-top-definitions) + (attach-fixities)))) + +(define (import-export/fixpoint modules initial-cycle?) + (setf *new-exports-found?* '#f) + (walk-modules modules + (lambda () + (setf (module-fresh-exports *module*) '()) + (when initial-cycle? + (create-top-definitions) + (attach-fixities) + (import-non-local)) + (locally-import) + (locally-export))) + (when *new-exports-found?* + (import-export/fixpoint modules '#f))) + +;;; This does the non-local importing from previously defined modules + +(define (import-non-local) + (setf (module-imports *module*) + (process-non-local-imports (module-imports *module*)))) + +(define (process-non-local-imports imports) + (if (null? imports) + '() + (let* ((import (car imports))) + (with-slots import-decl (module mode specs renamings) import + (cond ((eq? *unit* (module-unit module)) + (cons import (process-non-local-imports (cdr imports)))) + ((eq? mode 'all) + (import-all-entities module specs renamings import) + (process-non-local-imports (cdr imports))) + (else + (import-named-entities module specs renamings import) + (process-non-local-imports (cdr imports)))))))) + +(define (import-all-entities module hiding renamings import-decl) + (table-for-each + (lambda (name group) + (declare (ignore name)) + (cond ((in-hiding-list? group hiding) + (setf hiding (remove-entity group hiding))) + (else + (import-group (rename-group group renamings) module)))) + (module-export-table module)) + (when (not (null? hiding)) + (remember-context import-decl + (dolist (h hiding) + (signal-unused-hiding (entity-name h) (module-name module))))) + (find-unused-renamings renamings import-decl)) + +(define (import-named-entities mod specs renamings import-decl) + (dolist (entity specs) + (let ((group (locate-entity/export-table entity mod '#t))) + (when (not (eq? group 'error)) + (setf group (rename-group group renamings)) + (import-group group mod)))) + (find-unused-renamings renamings import-decl)) + +;;; This takes a module and processes the import declarations, moving as +;;; many entities from the freshly exported components of other modules into +;;; the current module. + +(define (locally-import) + (dolist (import (module-imports *module*)) + (with-slots import-decl (module mode specs renamings) import + (if (eq? mode 'all) + (import-fresh-entities import module specs renamings) + (setf (import-decl-specs import) + (import-entities specs module renamings)))))) + +(define (import-fresh-entities import module hiding renamings) + (dolist (group (module-fresh-exports module)) + (cond ((in-hiding-list? group hiding) + (setf hiding (remove-entity group hiding))) + (else + (import-group (rename-group group renamings) module)))) + (setf (import-decl-specs import) hiding)) + +(define (import-entities entities module renamings) + (if (null? entities) + '() + (let ((group (locate-entity/export-table (car entities) module '#f))) + (cond ((eq? group 'not-found) + (cons (car entities) + (import-entities (cdr entities) module renamings))) + ((eq? group 'error) + (import-entities (cdr entities) module renamings)) + (else + (setf group (rename-group group renamings)) + (import-group group module) + (import-entities (cdr entities) module renamings)))))) + +;;; This imports a group into *module*. module is the place the group is +;;; taken from. + +(define (import-group group module) + (when (memq module (module-exported-modules *module*)) + (export-group group)) + (dolist (n-d group) + (insert-top-definition (tuple-2-1 n-d) (tuple-2-2 n-d)))) + +;;; This takes as yet unresolved exports and moves them to the export table. + +(define (locally-export) + (setf (module-exports *module*) + (export-entities (module-exports *module*)))) + +(define (export-entities entities) + (if (null? entities) + '() + (let* ((entity (car entities)) + (group (locate-entity entity))) + (cond ((eq? group 'error) + (export-entities (cdr entities))) + ((eq? group 'not-found) + (cons entity (export-entities (cdr entities)))) + (else + (export-group group) + (export-entities (cdr entities))))))) + + +;;; This moves a group into the export table. If this export is new, +;;; a flag is set. + +(define (export-group group) + (let* ((export-table (module-export-table *module*)) + (old-group (table-entry export-table (group-name group)))) + (when (or (eq? old-group '#f) + (and (hidden-constructors? old-group) + (not (hidden-constructors? group)))) + (setf (table-entry export-table (group-name group)) group) + (dolist (n-d group) + (setf (def-exported? (tuple-2-2 n-d)) '#t)) + (push group (module-fresh-exports *module*)) + (setf *new-exports-found?* '#t)))) + +(define (show-export-tables modules) + (walk-modules modules + (lambda () + (format '#t "~%Exports from module ~A~%" *module-name*) + (let ((exports '())) + (table-for-each (lambda (key val) + (push (cons key val) exports)) + (module-export-table *module*)) + (setf exports (sort-list exports + (lambda (x y) + (string-ci<? (symbol->string (car x)) + (symbol->string (car y)))))) + (dolist (e exports) + (print-exported-group (car e) (group-definition (cdr e)) + (cdr (cdr e)))))))) + +(define (print-exported-group name def extras) + (if (eq? (def-module def) *module-name*) + (format '#t " ") + (format '#t "*")) + (cond ((synonym? def) + (format '#t "type ")) + ((algdata? def) + (format '#t "data ")) + ((class? def) + (format '#t "class ")) + (else + (format '#t " "))) + (format '#t "~A" name) + (when (not (eq? name (def-name def))) + (format '#t "[~A]" (def-name def))) + (when extras + (format '#t " (") + (print-exported-group-1 extras (algdata? def))) + (format '#t "~%")) + +(define (print-exported-group-1 extras alg?) + (let* ((name (tuple-2-1 (car extras))) + (ns (symbol->string name)) + (def (tuple-2-2 (car extras)))) + (format '#t "~A" (if alg? (remove-con-prefix ns) ns)) + (when (not (eq? name (def-name def))) + (let ((name1 (symbol->string (def-name def)))) + (format '#t "[~A]" (if alg? (remove-con-prefix name1) name1)))) + (if (null? (cdr extras)) + (format '#t ")") + (begin + (format '#t ",") + (print-exported-group-1 (cdr extras) alg?))))) + + + diff --git a/import-export/init-modules.scm b/import-export/init-modules.scm new file mode 100644 index 0000000..5198c0c --- /dev/null +++ b/import-export/init-modules.scm @@ -0,0 +1,142 @@ +;;; This initializes the module ast structures. + +;;; This requires that the module table be created and updated with new +;;; modules first. *unit* must also be defined. + +;;; Things initialized there: +;;; all tables in the module structure +;;; the module slot of all import declarations and entity-modules +;;; The import Prelude is added when necessary +;;; Empty export lists are explicated + +(define (init-module-structure) + (when (not (eq? (module-type *module*) 'extension)) + ;; If this is an extension, the incremental compiler has already + ;; filled in the compilation unit. + (setf (module-unit *module*) *unit*)) + ;;; This processes the annotations. Annotations used at the top + ;;; level of the module: + ;;; {-#PRELUDE#-} : this contains definitions in the Haskell prelude + (setf (module-prelude? *module*) '#f) + (setf (module-interface-codefile *module*) '()) + (dolist (a (module-annotations *module*)) + (when (annotation-value? a) + (let ((name (annotation-value-name a))) + (cond ((eq? name '|Prelude|) + (setf (module-prelude? *module*) '#t)))))) + (cond ((eq? (module-type *module*) 'interface) + (setf (module-exported-modules *module*) (list *module*)) + (process-interface-imports *module*)) + ((eq? (module-type *module*) 'standard) + (init-standard-module)))) + +(define (init-standard-module) + (let ((seen-prelude? '#f)) + (dolist (import (module-imports *module*)) + (let* ((name (import-decl-module-name import)) + (imported-mod (locate-module name))) + (when (eq? name '|Prelude|) + (setf seen-prelude? '#t)) + (if (eq? imported-mod '#f) + (signal-undefined-module-import name) + (setf (import-decl-module import) imported-mod)) + (when (eq? name *module-name*) + (signal-self-import name)))) + (when (null? (module-exports *module*)) + (setf (module-exports *module*) + (list (make entity-module (name *module-name*) + (module *module*))))) + (when (not seen-prelude?) + (let ((prelude (locate-module '|Prelude|))) + (cond ((eq? prelude '#f) + (signal-missing-prelude)) + ((module-prelude? *module*) + (setf (module-uses-standard-prelude? *module*) '#f) + (add-imported-module prelude)) + (else + (setf (module-uses-standard-prelude? *module*) '#t) + (let ((fix-table (module-fixity-table *module*))) + (table-for-each (lambda (k v) + (setf (table-entry fix-table k) v)) + *prelude-fixity-table*)))))) + (let ((prelude-core (locate-module '|PreludeCore|))) + (if (eq? prelude-core '#f) + (signal-missing-prelude-core) + (when (module-prelude? *module*) + (add-imported-module prelude-core)))) + (setf (module-exports *module*) + (filter-complete-module-exports (module-exports *module*)))) + ) + + +(define (add-imported-module module) + (setf (module-imports *module*) + (cons (make import-decl + (module-name (module-name module)) + (module module) + (mode 'all) + (specs '()) + (renamings '())) + (module-imports *module*)))) + +(define (filter-complete-module-exports exports) + (if (null? exports) + '() + (let ((export (car exports)) + (others (filter-complete-module-exports (cdr exports)))) + (if (is-type? 'entity-module export) + (let* ((name (entity-name export)) + (exported-mod (locate-module name))) + (when (eq? exported-mod '#f) + (signal-undefined-module-export name)) + (push exported-mod (module-exported-modules *module*)) + (when (not (memq name + (cons *module-name* + (map + (lambda (import) + (import-decl-module-name import)) + (module-imports *module*))))) + (signal-export-not-imported name)) + others) + (cons export others))))) + +(define (process-interface-imports module) + (let ((imports '())) + (dolist (i (module-imports module)) + (let ((module (import-decl-module-name i)) + (renamings (import-decl-renamings i))) + (dolist (s (import-decl-specs i)) + (let* ((n (entity-name s)) + (n1 (do-interface-rename n renamings))) + (when (assq n1 imports) + (signal-multiple-imports n1)) + (push (tuple n1 (tuple module n)) imports) + (cond ((entity-class? s) + (dolist (m (entity-class-methods s)) + (let ((m1 (do-interface-rename m renamings))) + (when (assq m1 imports) + (signal-multiple-imports m1)) + (push (tuple m1 (tuple module m)) imports)))) + ((entity-datatype? s) + (dolist (m (entity-datatype-constructors s)) + (let ((m1 (do-interface-rename m renamings))) + (when (assq m1 imports) + (signal-multiple-imports m1)) + (push (tuple m1 (tuple module m)) imports))))))))) + (setf (module-interface-imports module) imports))) + +(define (signal-multiple-imports name) + (phase-error 'multuple-interface-import + "Interface file has more than one definition of ~A~%" name)) + +(define (do-interface-rename name renamings) + (if (has-con-prefix? (symbol->string name)) + (let* ((n1 (remove-con-prefix/symbol name)) + (res (locate-renaming n1 renamings))) + (if (eq? res '#f) + name + (add-con-prefix/symbol (renaming-to res)))) + (let ((res (locate-renaming name renamings))) + (if (eq? res '#f) + name + (renaming-to res))))) diff --git a/import-export/locate-entity.scm b/import-export/locate-entity.scm new file mode 100644 index 0000000..a001b62 --- /dev/null +++ b/import-export/locate-entity.scm @@ -0,0 +1,126 @@ +;;; This file deals with entities in import / export lists + +;;; This resolves an entity with the export table of a +;;; module. It returns either a group, the symbol 'error, or the symbol +;;; 'not-found. When force-error? is true, signal an error when +;;; the module is not found & return 'error. + +(define (locate-entity/export-table entity mod force-error?) + (let* ((name (entity-name entity)) + (group (table-entry (module-export-table mod) name))) + (if (eq? group '#f) + (if (not force-error?) + 'not-found + (signal-entity-not-found name (module-name mod))) + (let ((def (group-definition group))) + (cond ((is-type? 'entity-var entity) + group) + ((is-type? 'entity-con entity) + (cond ((algdata? def) + (strip-constructors group)) + ((synonym? def) + (signal-synonym-needs-dots name (module-name mod))) + (else + (signal-wrong-definition + "type constructor" name (module-name mod))))) + ((is-type? 'entity-abbreviated entity) + (cond ((algdata? def) + (cond ((hidden-constructors? group) + (if force-error? + (signal-abstract-type + name (module-name mod)) + 'not-found)) + (else + group))) + ((or (class? def) (synonym? def)) + group) + (else + (signal-wrong-definition + "class or datatype" name (module-name mod))))) + ((is-type? 'entity-class entity) + (if (class? def) + (match-constituents group (entity-class-methods entity) + entity "method") + (signal-wrong-definition "class" name (module-name mod)))) + ((is-type? 'entity-datatype entity) + (if (algdata? def) + (match-constituents group + (entity-datatype-constructors entity) + entity "constructor") + (signal-wrong-definition + "data type" name (module-name mod)))) + (else + (error "Bad entity ~s." entity)) + ))))) + +(define (match-constituents group names entity what) + (check-duplicates names entity) + (dolist (n-d (cdr group)) + (when (not (memq (tuple-2-1 n-d) names)) + (signal-extra-constituent entity (tuple-2-1 n-d) what))) + (dolist (name names) + (when (not (assq name (cdr group))) + (signal-missing-constituent entity name what))) + group) + + +;;; The following routine locates an entity in the current module. +;;; It may return 'error, 'not-found, or a group. + +(define (locate-entity entity) + (let* ((name (entity-name entity)) + (def (resolve-toplevel-name name))) + (cond ((eq? def '#f) + 'not-found) + ((is-type? 'entity-var entity) + (if (method-var? def) + (signal-export-method-var name) + (make-group name def))) + ((is-type? 'entity-con entity) + (cond ((algdata? def) + (make-group name def)) + ((synonym? def) + (signal-synonym-needs-dots name *module-name*)) + (else + (signal-wrong-definition + "type constructor" name *module-name*)))) + ((is-type? 'entity-abbreviated entity) + (cond ((algdata? def) + (require-complete-algdata + (gather-algdata-group name def))) + ((synonym? def) + (make-group name def)) + ((class? def) + (gather-class-group name def)) + (else + (signal-wrong-definition + "type constructor or class" name *module-name*)))) + ((is-type? 'entity-class entity) + (if (class? def) + (match-group-names + (gather-class-group name def) + (entity-class-methods entity) + entity + "method") + (signal-wrong-definition "class" name *module-name*))) + ((is-type? 'entity-datatype entity) + (if (algdata? def) + (match-group-names + (require-complete-algdata (gather-algdata-group name def)) + (entity-datatype-constructors entity) + entity "constructor") + (signal-wrong-definition "data type" name *module-name*))) + (else + (error "Bad entity ~s." entity))))) + +(define (require-complete-algdata group) + (if (hidden-constructors? group) + 'not-found + group)) + +(define (match-group-names group names entity what) + (when (not (eq? group 'not-found)) + (match-constituents group names entity what)) + group) + + diff --git a/import-export/top-definitions.scm b/import-export/top-definitions.scm new file mode 100644 index 0000000..07722dd --- /dev/null +++ b/import-export/top-definitions.scm @@ -0,0 +1,98 @@ +;;; File: top-definitions.scm + +;;; Description: This creates definitions for all top level (exportable) +;;; object in a module. + +(define (create-top-definitions) + (dolist (decl (module-decls *module*)) + (if (eq? (module-type *module*) 'interface) + (when (signdecl? decl) + (create-var-definitions decl (signdecl-vars decl))) + (when (valdef? decl) + (create-var-definitions + decl (collect-pattern-vars (valdef-lhs decl)))))) + (dolist (algdata (module-algdatas *module*)) + (create-alg-definitions algdata)) + (dolist (synonym (module-synonyms *module*)) + (create-syn-definitions synonym)) + (dolist (class (module-classes *module*)) + (create-class-definitions class))) + +;;; ------------------------------------------------------------------------ +;;; creation of definitions +;;; ------------------------------------------------------------------------ + +(define (create-var-definitions decl vars) + (remember-context decl + (dolist (v vars) + (let* ((var-name (var-ref-name v)) + (def (create-top-definition var-name 'var))) + (setf (var-ref-var v) def) + (push def (module-vars *module*)) + (add-new-group var-name def))))) + +;;; This also creates definitions for the constructors + +(define (create-alg-definitions algdata) + (remember-context algdata + (with-slots data-decl (simple constrs) algdata + (let* ((alg-name (tycon-name simple)) + (def (create-top-definition alg-name 'algdata))) + (setf (tycon-def simple) def) + (let ((constr-group + (map (lambda (constr) + (let* ((con-ref (constr-constructor constr)) + (con-name (con-ref-name con-ref)) + (con-def (create-top-definition con-name 'con))) + (setf (con-ref-con con-ref) con-def) + (tuple con-name con-def))) + constrs))) + (setf (algdata-constrs def) (map (function tuple-2-2) constr-group)) + (setf (tycon-def-arity def) (length (tycon-args simple))) + (add-new-group alg-name def constr-group)))))) + +(define (create-class-definitions class-decl) + (remember-context class-decl + (with-slots class-decl (class decls) class-decl + (let* ((class-name (class-ref-name class)) + (class-def (create-top-definition class-name 'class))) + (setf (class-ref-class class) class-def) + (let ((method-group + (concat + (map + (lambda (decl) + (if (is-type? 'signdecl decl) + (remember-context decl + (map (lambda (method-var) + (let* ((var-name (var-ref-name method-var)) + (def (create-top-definition + var-name 'method-var))) + (setf (method-var-class def) class-def) + (setf (method-var-default def) '#f) + (setf (var-ref-var method-var) def) + (tuple var-name def))) + (signdecl-vars decl))) + '())) + decls)))) + (setf (class-method-vars class-def) + (map (function tuple-2-2) method-group)) + (add-new-group class-name class-def method-group)))))) + +(define (create-syn-definitions synonym-decl) + (remember-context synonym-decl + (let* ((simple (synonym-decl-simple synonym-decl)) + (syn-name (tycon-name simple)) + (def (create-top-definition syn-name 'synonym))) + (setf (tycon-def simple) def) + (setf (tycon-def-arity def) (length (tycon-args simple))) + (add-new-group syn-name def)))) + +(define (add-new-group name def . others) + (when (memq *module* (module-exported-modules *module*)) + (export-group (cons (tuple name def) + (if (null? others) + '() + (car others)))))) + + + diff --git a/parser/README b/parser/README new file mode 100644 index 0000000..a2facd7 --- /dev/null +++ b/parser/README @@ -0,0 +1 @@ +This directory contains the lexer and parser. diff --git a/parser/annotation-parser.scm b/parser/annotation-parser.scm new file mode 100644 index 0000000..4ae33cf --- /dev/null +++ b/parser/annotation-parser.scm @@ -0,0 +1,184 @@ + +(define *annotation-escape* '()) + +(define (parse-annotations) + (let ((save-layout (dynamic *layout-stack*))) + (setf (dynamic *layout-stack*) '()) + (advance-token) + (let/cc annotation-escape + (setf *annotation-escape* (lambda () + (setf (dynamic *layout-stack*) save-layout) + (advance-to-annotation-end) + (funcall annotation-escape '()))) + (let ((res (start-layout (function parse-annotation-list-1)))) + (setf (dynamic *layout-stack*) save-layout) + (token-case + (end-annotation res) + (else (signal-annotation-error))))))) + +(define (parse-annotation-list-1 in-layout?) + (let ((kind (get-annotation-kind))) + (cond ((eq? kind 'decl) + (let ((d (parse-annotation-decl))) + (token-case + (\; (cons d (parse-annotation-list-1 in-layout?))) + (else (close-layout in-layout?) + (list d))))) + ((eq? kind 'value) + (let ((d (parse-annotation-value))) + (token-case + (\; (cons d (parse-annotation-list-1 in-layout?))) + (else (close-layout in-layout?) + (list d))))) + (else + (close-layout in-layout?) + '())))) + +(define (get-annotation-kind) + (token-case + ((no-advance end-annotation) 'end) + ((no-advance \() 'decl) + ((var con) + (let ((next (peek-1-type))) + (cond ((eq? next '|,|) + 'decl) + ((eq? next '|::|) + 'decl) + (else + 'value)))) + (else 'error))) + +(define (parse-annotation-decl) + (let* ((names (parse-aname-list)) + (decls (parse-aval-list))) + (make annotation-decl (names names) (annotations decls)))) + +(define (parse-aname-list) + (let ((name 'foo)) + (token-case + (var + (setf name (var->symbol))) + (con + (setf name (con->symbol))) + (else (signal-annotation-error))) + (token-case (\, (cons name (parse-aname-list))) + (|::| (list name)) + (else (signal-annotation-error))))) + + +(define (parse-aval-list) + (let ((ann (parse-annotation-value))) + (token-case (\, (cons ann (parse-aval-list))) + (else (list ann))))) + +(define (parse-annotation-value) + (token-case + (name (let* ((name (token->symbol)) + (args (parse-annotation-args name))) + (make annotation-value (name name) (args args)))))) + +(define (parse-annotation-args name) + (token-case + (\( (parse-annotation-args-1 name 0)) + (else '()))) + +;;; This routine can invoke special parsers for the arguments + +(define (parse-annotation-args-1 name i) + (let* ((argtype (get-annotation-arg-description name i)) + (arg (parse-annotation-arg argtype))) + (token-case + (\) (list arg)) + (\, (cons arg (parse-annotation-args-1 name (1+ i)))) + (else (signal-annotation-error))))) + +(define (parse-annotation-arg type) + (cond ((eq? type 'string) + (token-case + ((string no-advance) + (let ((res (car *token-args*))) + (advance-token) + res)) + (else (signal-annotation-error)))) + ;; The following is for a datatype import/export. It is + ;; Type(Con1(strs),Con2(strs),...) + ((eq? type 'integer) + (token-case + ((integer no-advance) (token->integer)) + (else (signal-annotation-error)))) + ((eq? type 'constr-list) + (parse-annotation-constr-list)) + (else + (signal-annotation-error)))) + +(define (signal-annotation-error) + (parser-error/recoverable 'annotation-error "Error in annotation syntax") + (funcall *annotation-escape*)) + +(define (parse-annotation-constr-list) + (token-case + (tycon (let ((type-name (token->symbol))) + (token-case (\( (let* ((args (parse-acl1)) + (res (tuple type-name args))) + (token-case ; leave the ) to end the args + ((no-advance \)) (list res)) + (\, (cons res (parse-annotation-constr-list))) + (else (signal-annotation-error))))) + (else (signal-annotation-error))))) + (else (signal-annotation-error)))) + +(define (parse-acl1) + (token-case + (con (let ((con-name (con->symbol))) + (token-case (\( (let ((str-args (parse-string-list))) + (token-case + (\, (cons (tuple con-name str-args) + (parse-acl1))) + (\) (list (tuple con-name str-args))) + (else (signal-annotation-error))))) + (else (signal-annotation-error))))) + (else (signal-annotation-error)))) + +(define (parse-string-list) + (token-case + ((string no-advance) + (let ((res (read-lisp-object (car *token-args*)))) + (advance-token) + (token-case + (\) (list res)) + (\, (cons res (parse-string-list))) + (else (signal-annotation-error))))) + (else (signal-annotation-error)))) + +(define (advance-to-annotation-end) + (token-case + (eof '()) + (end-annotation + (advance-token)) + (else + (advance-token) + (advance-to-annotation-end)))) + +(define *known-annotations* '( + (|LispName| string) + (|Prelude|) + (|Strictness| string) + (|Strict|) + (|NoConversion|) + (|Inline|) + (|STRICT|) + (|ImportLispType| constr-list) + (|ExportLispType| constr-list) + (|Complexity| integer) + )) + +(define (get-annotation-arg-description annotation i) + (let ((s (assq annotation *known-annotations*))) + (cond ((eq? s '#f) + (parser-error/recoverable 'unknown-annotation + "Annotation ~A is not defined in this system - ignored." + annotation) + 'unknown) + ((>= i (length s)) + 'error) + (else (list-ref s (1+ i)))))) diff --git a/parser/decl-parser.scm b/parser/decl-parser.scm new file mode 100644 index 0000000..bf924b5 --- /dev/null +++ b/parser/decl-parser.scm @@ -0,0 +1,175 @@ +;;; File: decl-parser Author: John + +(define (parse-decl) + (let ((decl-type (find-decl-type))) + (cond ((eq? decl-type 'signdecl) + (parse-signdecl)) + ((eq? decl-type 'pat-or-op) + (parse-pat-or-op)) + ((eq? decl-type 'fundef) + (parse-fundef)) + ((eq? decl-type 'plus-def) + (parse-plus-def)) + ((eq? decl-type 'annotation) + (make annotation-decls (annotations (parse-annotations))))))) + +;;; This looks at the first tokens in a definition to determine it's type. +;;; var (:: | ,) - signdecl +;;; var apat-start - function definition +;;; (var | _) + - definition of infix + +;;; anything alse - pattern binding or infix definition + +(define (find-decl-type) + (let* ((saved-excursion (save-scanner-state)) + (decl-type + (token-case + (var (scan-var) + (token-case + ((\, \:\:) 'signdecl) + (apat-start 'fundef) + (+ 'plus-def) + (else 'pat-or-op))) + (_ (token-case + (+ 'plus-def) + (else 'pat-or-op))) + (begin-annotation 'annotation) + (else 'pat-or-op)))) + (restore-excursion saved-excursion) + decl-type)) + +;;; These are the different flavors of decl parsers + +(define (parse-signdecl) + (save-parser-context + (trace-parser signdecl + (let ((vars (parse-signdecl-vars))) + (require-token \:\: + (signal-missing-token "`::'" "signature declaration")) + (let ((signature (parse-signature))) + (make signdecl (vars vars) (signature signature))))))) + +(define (parse-signdecl-vars) + (token-case + (var (let ((var (var->ast))) + (token-case (\, (cons var (parse-signdecl-vars))) + (else (list var))))) + (else (signal-missing-token "<var>" "signature declaration")))) + +(define (parse-pat-or-op) + (trace-parser patdef + (let* ((line-number (capture-current-line)) + (pat (parse-pat))) + (token-case + (varop (parse-infix-def pat line-number)) + (else (add-rhs pat '() '#f line-number)))))) + +(define (parse-infix-def pat1 line-number) + (let* ((op (make var-pat (var (varop->ast)))) + (pat2 (parse-pat))) + (add-rhs op (list pat1 pat2) '#t line-number))) + +(define (parse-fundef) + (trace-parser fundef + (let* ((start-line (capture-current-line)) + (fn (parse-apat)) ; must be a single variable + (args (parse-apat-list))) + (add-rhs fn args '#f start-line)))) + +(define (parse-plus-def) + (trace-parser plus-def + (let* ((start-line (capture-current-line)) + (var (parse-apat))) + (parse-infix-def var start-line)))) + +(define (add-rhs pat args infix? start-line) + (let* ((rhs (parse-rhs)) + (decls (parse-where-decls)) + (single (make single-fun-def + (args args) + (rhs-list rhs) + (where-decls decls) + (infix? infix?))) + (valdef (make valdef (lhs pat) (definitions (list single))))) + (setf (ast-node-line-number single) start-line) + (setf (ast-node-line-number valdef) start-line) + valdef)) + +(define (parse-rhs) + (token-case + (= (let ((rhs (parse-exp))) + (list (make guarded-rhs (guard (make omitted-guard)) (rhs rhs))))) + (\| (parse-guarded-rhs)) + (else + (signal-missing-token "`=' or `|'" "rhs of valdef")))) + +(define (parse-guarded-rhs) ; assume just past | + (trace-parser guard + (let ((guard (parse-exp-i))) ; 1.2 change + (require-token = (signal-missing-token "`='" "guarded rhs")) + (let* ((exp (parse-exp)) + (res (make guarded-rhs (guard guard) (rhs exp)))) + (token-case + (\| (cons res (parse-guarded-rhs))) + (else (list res))))))) + +(define (parse-where-decls) + (token-case + (|where| + (parse-decl-list)) + (else '()))) + +(define (parse-decl-list) + (start-layout (function parse-decl-list-1))) + +(define (parse-decl-list-1 in-layout?) + (token-case + ((apat-start begin-annotation) + (let ((decl (parse-decl))) + (token-case + (\; (decl-cons decl (parse-decl-list-1 in-layout?))) + (else (close-layout in-layout?) + (list decl))))) + (else + (close-layout in-layout?) + '()))) + +;;; This adds a new decl to a decl list. Successive decls for the same fn +;;; are combined. + +(define (decl-cons decl decl-list) + (cond ((null? decl-list) + (list decl)) + (else (nconc (combine-decls decl (car decl-list)) (cdr decl-list))))) + +(define (decl-push decl decl-stack) + (cond ((null? decl-stack) + (list decl)) + (else (nconc (nreverse (combine-decls (car decl-stack) decl)) + (cdr decl-stack))))) + +(define (combine-decls decl1 decl2) + (if (and (is-type? 'valdef decl1) + (is-type? 'valdef decl2) + (same-decl-var? (valdef-lhs decl1) (valdef-lhs decl2))) + (if (eqv? (length (single-fun-def-args (car (valdef-definitions decl1)))) + (length (single-fun-def-args (car (valdef-definitions decl2))))) + (begin + (setf (valdef-definitions decl1) + (nconc (valdef-definitions decl1) + (valdef-definitions decl2))) + (list decl1)) + (signal-multiple-definitions-arity-mismatch (valdef-lhs decl1))) + (list decl1 decl2))) + +(define (same-decl-var? pat1 pat2) + (and (is-type? 'var-pat pat1) + (is-type? 'var-pat pat2) + (eq? (var-ref-name (var-pat-var pat1)) + (var-ref-name (var-pat-var pat2))))) + +(define (signal-multiple-definitions-arity-mismatch pat) + (parser-error 'multiple-definitions-arity-mismatch + "Definition of ~a does not match arity of previous definition." + pat)) + + diff --git a/parser/exp-parser.scm b/parser/exp-parser.scm new file mode 100644 index 0000000..6f941ae --- /dev/null +++ b/parser/exp-parser.scm @@ -0,0 +1,230 @@ +;;; File: expr-parser Author: John + +(define (parse-exp) + (trace-parser exp + (parse-exp-0))) + +(define (parse-exp-0) ;; This picks up expr type signatures + (let ((exp (parse-exp-i))) + (token-case + (\:\: (let ((signature (parse-signature))) + (make exp-sign (exp exp) (signature signature)))) + (else exp)))) + +(define (parse-exp-i) ;; This collects a list of exps for later prec parsing + (let ((exps (parse-infix-exps))) + (if (null? (cdr exps)) + (car exps) + (make pp-exp-list (exps exps))))) + +(define (parse-infix-exps) + (token-case + (- (cons (make negate) (parse-infix-exps))) + (\\ (list (parse-lambda))) + (|let| (list (parse-let))) + (|if| (list (parse-if))) + (|case| (parse-possible-app (parse-case))) + (else (let ((aexp (parse-aexp))) + (parse-possible-app aexp))))) + +(define (parse-possible-app exp) + (token-case + (aexp-start + (let ((exp2 (parse-aexp))) + (parse-possible-app (make app (fn exp) (arg exp2))))) + (varop + (let ((varop (varop->ast))) + (if (eq-token? '\)) + (list exp varop) + `(,exp ,varop ,@(parse-infix-exps))))) + (conop + (let ((conop (conop->ast))) + (if (eq-token? '\)) + (list exp conop) + `(,exp ,conop ,@(parse-infix-exps))))) + (else (list exp)))) + +(define (parse-lambda) + (trace-parser lambda + (save-parser-context + (let ((pats (parse-apat-list))) + (require-token -> (signal-missing-token "`->'" "lambda expression")) + (let ((exp (parse-exp))) + (make lambda (pats pats) (body exp))))))) + +(define (parse-let) + (trace-parser let + (save-parser-context + (let ((decls (parse-decl-list))) + (require-token |in| (signal-missing-token "`in'" "let expression")) + (let ((exp (parse-exp))) + (make let (decls decls) (body exp))))))) + +(define (parse-if) + (trace-parser if + (save-parser-context + (let ((test-exp (parse-exp))) + (require-token |then| (signal-missing-token "`then'" "if expression")) + (let ((then-exp (parse-exp))) + (require-token |else| (signal-missing-token "`else'" "if expression")) + (let ((else-exp (parse-exp))) + (make if (test-exp test-exp) + (then-exp then-exp) + (else-exp else-exp)))))))) + +(define (parse-case) + (trace-parser case + (save-parser-context + (let ((exp (parse-exp))) + (require-token |of| (signal-missing-token "`of'" "case expression")) + (let ((alts (start-layout (function parse-alts)))) + (make case (exp exp) (alts alts))))))) + +(define (parse-alts in-layout?) + (token-case + (pat-start + (let ((alt (parse-alt))) + (token-case + (\; (cons alt (parse-alts in-layout?))) + (else (close-layout in-layout?) + (list alt))))) + (else + (close-layout in-layout?) + '()))) + +(define (parse-alt) + (trace-parser alt + (let* ((pat (parse-pat)) + (rhs-list (token-case + (-> (let ((exp (parse-exp))) + (list (make guarded-rhs (guard (make omitted-guard)) + (rhs exp))))) + (\| (parse-guarded-alt-rhs)) + (else (signal-missing-token "`->' or `|'" "rhs of alt")))) + (decls (parse-where-decls))) + (make alt (pat pat) (rhs-list rhs-list) (where-decls decls))))) + +(define (parse-guarded-alt-rhs) + (let ((guard (parse-exp))) + (require-token -> (signal-missing-token "`->'" "alt")) + (let* ((exp (parse-exp)) + (res (make guarded-rhs (guard guard) (rhs exp)))) + (token-case + (\| (cons res (parse-guarded-alt-rhs))) + (else (list res)))))) + +(define (parse-aexp) + (trace-parser aexp + (token-case + (var (save-parser-context (var->ast))) + (con (save-parser-context (con->ast))) + (literal (literal->ast)) + (\( + (token-case + (\) (**con/def (core-symbol "UnitConstructor"))) + ((no-advance -) (parse-exp-or-tuple)) + (varop + (let ((varop (varop->ast))) + (make-right-section varop))) + (conop + (let ((conop (conop->ast))) + (make-right-section conop))) + (else + (parse-exp-or-tuple)))) + (\[ + (token-case + (\] (make list-exp (exps '()))) + (else + (let ((exp (parse-exp))) + (token-case + (\, (let ((exp2 (parse-exp))) + (token-case + (\] (make list-exp (exps (list exp exp2)))) + (\.\. (token-case + (\] (make sequence-then (from exp) (then exp2))) + (else + (let ((exp3 (parse-exp))) + (require-token + \] + (signal-missing-token + "`]'" "sequence expression")) + (make sequence-then-to (from exp) (then exp2) + (to exp3)))))) + (else + (make list-exp + (exps `(,exp ,exp2 ,@(parse-exp-list)))))))) + (\.\. (token-case + (\] (make sequence (from exp))) + (else + (let ((exp2 (parse-exp))) + (require-token + \] + (signal-missing-token "`]'" "sequence expression")) + (make sequence-to (from exp) (to exp2)))))) + (\] (make list-exp (exps (list exp)))) + (\| (parse-list-comp exp)) + (else + (signal-invalid-syntax + "a list, sequence, or list comprehension"))))))) + (else + (signal-invalid-syntax "an aexp"))))) + +(define (make-right-section op) + (let ((exps (parse-infix-exps))) + (token-case + (\) (make pp-exp-list (exps (cons op exps)))) + (else (signal-missing-token "`)'" "right section expression"))))) + +(define (parse-exp-list) + (token-case + (\] '()) + (\, (let ((exp (parse-exp))) (cons exp (parse-exp-list)))) + (else (signal-missing-token "`]' or `,'" "list expression")))) + +(define (parse-exp-or-tuple) + (let ((exp (parse-exp))) + (token-case + (\) exp) ; Note - sections ending in an op are parsed elsewhere + (else (make-tuple-cons (cons exp (parse-tuple-exp))))))) + +(define (parse-tuple-exp) + (token-case + (\) '()) + (\, (let ((exp (parse-exp))) (cons exp (parse-tuple-exp)))) + (else (signal-missing-token + "`)' or `,'" "tuple or parenthesized expression")))) + +;;; List comprehensions + +;;; Assume | has been consumed + +(define (parse-list-comp exp) + (save-parser-context + (let ((quals (parse-qual-list))) + (make list-comp (exp exp) (quals quals))))) + +(define (parse-qual-list) + (let ((qual (parse-qual))) + (token-case + (\, (cons qual (parse-qual-list))) + (\] (list qual)) + (else (signal-missing-token "`]' or `,'" "list comprehension"))))) + +(define (parse-qual) + (trace-parser qual + (save-parser-context + (let* ((saved-excursion (save-scanner-state)) + (is-gen? (and (scan-pat) (eq-token? '<-)))) + (restore-excursion saved-excursion) + (cond (is-gen? + (let ((pat (parse-pat))) + (advance-token) ; past the <- + (let ((exp (parse-exp))) + (make qual-generator (pat pat) (exp exp))))) + (else + (let ((exp (parse-exp))) + (make qual-filter (exp exp))))))))) + +(define (make-tuple-cons args) + (let ((tuple-con (**con/def (tuple-constructor (length args))))) + (**app/l tuple-con args))) diff --git a/parser/interface-parser.scm b/parser/interface-parser.scm new file mode 100644 index 0000000..184fdb0 --- /dev/null +++ b/parser/interface-parser.scm @@ -0,0 +1,98 @@ +;;; This is the parser for interface files. + +(define (parse-tokens/interface tokens) + (init-token-stream tokens) + (let ((interface (token-case + (|interface| (parse-interface)) + (|module| (interface-required-error)) + (else (crud-in-interface-error))))) + (cons interface (parse-interface-list)))) + +(define (interface-required-error) + (parser-error 'interface-required "Expecting `interface' keyword")) + +(define (crud-in-interface-error) + (parser-error 'unexpected-interface-crud "Junk after interface")) + +(define (parse-interface-list) + (token-case + (|interface| + (let ((interface (parse-interface))) + (cons interface (parse-interface-list)))) + (|module| (interface-required-error)) + (eof '()) + (else (crud-in-interface-error)))) + +(define (parse-interface) + (token-case + (modid + (let ((module-name (token->symbol))) + (require-token |where| + (signal-missing-token "`where'" "interface definition")) + (let ((mod-ast (make module (name module-name) + (type 'interface) + (exports '())))) + (start-layout (lambda (in-layout?) + (parse-interface-decls mod-ast in-layout? 'import)))))))) + +(define (parse-interface-decls mod-ast in-layout? state) + (token-case + (|import| (let ((import (parse-import))) + (when (not (eq? (import-decl-mode import) 'by-name)) + (phase-error 'illegal-import + "Imports in interfaces must specify specific entities")) + (if (eq? state 'import) + (push-decl-list import (module-imports mod-ast)) + (signal-misplaced-import))) + (terminate-interface-topdecl mod-ast in-layout? state)) + (|infix| (terminate-interface-topdecl mod-ast in-layout? + (parse-fixity 'n mod-ast state))) + (|infixl| (terminate-interface-topdecl mod-ast in-layout? + (parse-fixity 'l mod-ast state))) + (|infixr| (terminate-interface-topdecl mod-ast in-layout? + (parse-fixity 'r mod-ast state))) + (|data| (let ((data-decl (parse-type-decl '#t))) + (push-decl-list data-decl (module-algdatas mod-ast))) + (terminate-interface-topdecl mod-ast in-layout? 'topdecl)) + (|type| (let ((synonym-decl (parse-synonym-decl))) + (push-decl-list synonym-decl (module-synonyms mod-ast))) + (terminate-interface-topdecl mod-ast in-layout? 'topdecl)) + (|class| (let ((class-decl (parse-class-decl))) + (check-class-default-decls class-decl) + (push-decl-list class-decl (module-classes mod-ast))) + (terminate-interface-topdecl mod-ast in-layout? 'topdecl)) + (|instance| (let ((instance-decl (parse-instance-decl '#t))) + (push-decl-list instance-decl (module-instances mod-ast))) + (terminate-interface-topdecl mod-ast in-layout? 'topdecl)) + (var (let ((decl (parse-signdecl))) + (setf (module-decls mod-ast) + (decl-push decl (module-decls mod-ast)))) + (terminate-interface-topdecl mod-ast in-layout? 'topdecl)) + ((begin-annotation no-advance) + (let ((annotations (parse-annotations))) + (setf (module-annotations mod-ast) + (append (module-annotations mod-ast) annotations))) + (terminate-interface-topdecl mod-ast in-layout? state)) + (else + (maybe-end-interface mod-ast in-layout?)))) + +(define (maybe-end-interface mod-ast in-layout?) + (cond ((or (eq-token? '|interface|) (eq-token? 'eof) (eq-token? '\}) + (eq-token? '$\})) + (close-layout in-layout?) + (wrapup-module mod-ast) + mod-ast) + (else + (signal-invalid-syntax "a topdecl")))) + +(define (terminate-interface-topdecl mod-ast in-layout? state) + (token-case + (\; (parse-interface-decls mod-ast in-layout? state)) + (else (maybe-end-interface mod-ast in-layout?)))) + +(define (check-class-default-decls class-decl) + (dolist (d (class-decl-decls class-decl)) + (when (valdef? d) + (remember-context d + (recoverable-error 'no-defaults-in-interface + "Class defaults should not be put in interface files"))))) diff --git a/parser/lexer.scm b/parser/lexer.scm new file mode 100644 index 0000000..7230613 --- /dev/null +++ b/parser/lexer.scm @@ -0,0 +1,651 @@ +;;; File: parser/lexer Author: John + +;;; token data structure: a list with the token type in the +;;; car and other information in the rest of the list. Symbols +;;; designate the token type. + +;;; Reserved tokens use the name as the type and have no args. +;;; Reserved tokens: +;;; case class data default deriving else hiding if import in infix +;;; infixl infixr instance interface let module of renaming then to +;;; type where .. :: => = @ \ | ~ <- -> ` +;;; Other tokens: +;;; (file string) +;;; (newline line indent-column) +;;; (conid string) +;;; (varid string) +;;; (consym string) +;;; (varsym string) +;;; (comment string) ;;; not used at the moment +;;; (integer integer) +;;; (float integer fraction exponent) +;;; (string string) +;;; (eof) + + +;;; *** All of the stuff for lexing character and string literals is +;;; *** broken because it assumes that the host Lisp uses the ASCII +;;; *** encoding for characters and supports at least 255 characters. +;;; *** I have marked the specific places in the code where these +;;; *** assumptions are made, but fixing the problem will probably +;;; *** require more drastic changes anyway -- such as using integers +;;; *** instead of characters and vectors of integers instead of characters +;;; *** throughout the compiler. + +(define *max-char* 255) ; highest char-code allowed. + +;;; This defines the long names of the control chars. Note that some of +;;; this duplicates the table above & the reader. + +(define *control-char-names* '( + ("NUL" . 0) ("SOH" . 1) ("STX" . 2) ("ETX" . 3) + ("EOT" . 4) ("ENQ" . 5) ("ACK" . 6) ("BEL" . 7) + ("BS" . 8) ("HT" . 9) ("LF" . 10) ("VT" . 11) + ("FF" . 12) ("CR" . 13) ("SO" . 14) ("SI" . 15) + ("DLE" . 16) ("DC1" . 17) ("DC2" . 18) ("DC3" . 19) + ("DC4" . 20) ("NAK" . 21) ("SYN" . 22) ("ETB" . 23) + ("CAN" . 24) ("EM" . 25) ("SUB" . 26) ("ESC" . 27) + ("FS" . 28) ("GS" . 29) ("RS" . 30) ("US" . 31) + ("SP" . 32) ("DEL" . 127))) + +;;; This defines the short names for a few control chars. This +;;; is keyed off the previous table + +(define *short-control-char-names* '( + (#\a . "BEL") (#\b . "BS") (#\f . "FF") (#\n . "LF") + (#\r . "CR") (#\t . "HT") (#\v . "VT"))) + +;;; This is used in the ^X construct. Assume that ^X = code for ^A + X-A +;;; *** This is an invalid assumption. + +(define *control-A* 1) + +;;; This function is the interface between the lexer and the rest +;;; of the system. Note that the `file' reported in error messages +;;; must be bound in an outer context. + + +;;; *** I think this function should be binding these variables and not +;;; *** just assigning them. + +(define (lex-port port literate?) + (setf *lex-literate?* literate?) + (setf *current-line* 1) + (setf *current-col* 0) + (setf *on-new-line?* '#t) + (setf *save-col?* '#f) + (setf *port* port) + (setf *tokens* '()) + (setf *char* (read-char *port*)) + (setf *peek-char* (read-char *port*)) + (when (eof-object? *char*) + (setf *char* '#\space)) + (when (eof-object? *peek-char*) + (setf *peek-char* '#\space)) + (setf *at-eof/p?* '#f) + (setf *at-eof?* '#f) + (when *lex-literate?* + (process-literate-comments '#t)) + (parse-till-eof) + (nreverse *tokens*)) + +(define (parse-till-eof) + (cond (*at-eof?* + (emit-token 'eof) + '()) + (else + (lex-one-token) + (parse-till-eof)))) + +;;; There is an assumption that the scanner never peeks beyond a newline. +;;; In literate mode, this may reveal the wrong thing. + +(define (advance-char) + (if (and *lex-literate?* (eqv? *char* #\newline)) + (process-literate-comments '#f) + (advance-char-1))) + +(define (advance-char-1) + (cond ((eqv? *char* #\newline) + (setf *on-new-line?* '#t) + (incf (the fixnum *current-line*)) + (setf *current-col* 0)) + ((eqv? *char* #\tab) + (incf (the fixnum *current-col*) (- 8 (modulo *current-col* 8)))) + (else + (incf (the fixnum *current-col*)))) + (setf *char* *peek-char*) + (setf *at-eof?* *at-eof/p?*) + (setf *peek-char* (read-char *port*)) + (when (eof-object? *peek-char*) + (setf *at-eof/p?* '#t) + (setf *peek-char* '#\space)) + *char*) + +(define (peek-char-2) + (let ((ch (peek-char *port*))) + (if (eof-object? ch) + '#\space + ch))) + +(define (lex-one-token) + (setf *start-line* *current-line*) ; capture the loc at the start of the token + (setf *start-col* *current-col*) + (unless *at-eof?* + (char-case *char* + (whitechar + (advance-char) + (lex-one-token)) + (#\- (char-case *peek-char* + (#\- (lex-comment)) + (#\> (advance-char) + (advance-char) + (emit-token '\-\>)) + (#\} (signal-missing-begin-comment) + (advance-char) + (advance-char) + (lex-one-token)) + (else + (lex-varsym)))) + (#\{ (cond ((char=? *peek-char* '#\-) + (advance-char) + (advance-char) + (cond ((char=? *char* '#\#) + (advance-char) + (emit-token 'begin-annotation)) + (else + (lex-ncomment) + (lex-one-token)))) + (else + (advance-char) + (emit-token '\{ )))) + (small (lex-varid)) + (large (lex-conid)) + (#\( (advance-char) + (emit-token '\()) + (#\: (lex-consym)) + (#\` (advance-char) + (emit-token '\`)) + ((symbol presymbol) (lex-varsym)) + (digit (lex-numeric)) + (#\' (lex-char)) + (#\" (lex-string)) + (#\) (advance-char) + (emit-token '\))) + (#\, (advance-char) + (emit-token '\,)) + (#\; (advance-char) + (emit-token '\;)) + (#\[ (advance-char) + (emit-token '\[)) + (#\] (advance-char) + (emit-token '\])) + (#\_ (advance-char) + (emit-token '\_)) + (#\} (advance-char) + (emit-token '\})) + (else + (signal-invalid-character *char*) + (advance-char) + (lex-one-token))))) + +(define (signal-missing-begin-comment) + (lexer-error 'missing-begin-comment + "`-}' appears outside of a nested comment.")) + +(define (signal-invalid-character ch) + (lexer-error 'invalid-character + "Invalid character `~a' appears in source program." ch)) + +(define (advance-past-white) + (unless *at-eof?* + (char-case *char* + (whitechar + (advance-char) + (advance-past-white)) + (else + '())))) + +(define (process-literate-comments at-start?) + (unless at-start? (advance-char-1)) + (let ((l (classify-line))) + (cond ((or *at-eof?* (eq? l 'program)) + '()) + ((eq? l 'blank) + (skip-literate-comment '#t)) + (else + (when (not at-start?) + (lexer-error 'blank-line-needed + "Literate comments must be preceeded by a blank line")) + (skip-literate-comment '#f))))) + +(define (skip-literate-comment prev-blank) + (skip-past-line) + (let ((l (classify-line))) + (cond (*at-eof?* + '()) + ((eq? l 'comment) + (skip-literate-comment '#f)) + ((eq? l 'blank) + (skip-literate-comment '#t)) + (else + (when (not prev-blank) + (lexer-error 'blank-line-needed + "Literate comments must be followed by a blank line")))))) + +(define (classify-line) + (if *at-eof?* + 'blank + (char-case *char* + (#\> + (advance-char-1) + 'program) + (#\newline 'blank) + (whitechar + (classify-line-1)) + (else 'comment)))) + +(define (classify-line-1) + (advance-char-1) + (char-case *char* + (#\newline 'blank) + (whitechar (classify-line-1)) + (else 'comment))) + +(define (skip-past-line) + (when (not *at-eof?*) + (char-case *char* + (#\newline + (advance-char-1)) + (else + (advance-char-1) + (skip-past-line))))) + +(define (lex-comment) ;; a -- style comment + (advance-char) + (cond (*at-eof?* (lexer-eof-in-comment *current-line*)) + ((char=? *char* #\newline) + (lex-one-token)) + (else + (lex-comment)))) + +(define (lexer-eof-in-comment start-line) + (signal-eof-in-comment start-line) + (lex-one-token)) ; will return the eof token + +(define (signal-eof-in-comment start-line) + (lexer-error 'eof-in-comment + "End of file in comment starting at line ~A." start-line)) + +;;; Here *char* and *peek-char* are the first two chars on a line. + +(define (scan-symbol) + (scan-list-of (symbol #\:))) + +(define (scan-var-con) + (scan-list-of (large small digit #\' #\_))) + +(define (lex-ncomment) + (lex-ncomment-1 *current-line*)) + +(define (lex-ncomment-1 start-line) + (if *at-eof?* + (lexer-eof-in-comment start-line) + (char-case *char* + (#\- (cond ((char=? *peek-char* #\}) + (advance-char) + (advance-char)) + (else + (advance-char) + (lex-ncomment-1 start-line)))) + (#\{ (cond ((char=? *peek-char* #\-) + (advance-char) + (advance-char) + (lex-ncomment) + (lex-ncomment-1 start-line)) + (else + (advance-char) + (lex-ncomment-1 start-line)))) + (else + (advance-char) + (lex-ncomment-1 start-line))))) + +(define (lex-varid) + (let ((sym (scan-var-con))) + (parse-reserved sym varid + "case" "class" + "data" "default" "deriving" + "else" + "hiding" + "if" "import" "in" "infix" "infixl" "infixr" "instance" "interface" + "let" + "module" + "of" + "renaming" + "then" "to" "type" + "where"))) + +(define (lex-conid) + (let ((sym (scan-var-con))) + (emit-token/string 'conid sym))) + +(define (lex-consym) + (let ((sym (scan-symbol))) + (cond ((string=/list? (cdr sym) ":") + (emit-token '\:\:)) + (else + (emit-token/string 'consym sym))))) + +(define (lex-varsym) + (let ((sym (scan-symbol))) + (cond ((and (string=/list? sym "<") (char=? *char* #\-)) + (advance-char) + (emit-token '\<\-)) + ((and (string=/list? sym "#") + (char=? *char* #\-) + (char=? *peek-char* #\})) + (advance-char) + (advance-char) + (emit-token 'end-annotation)) + (else + (parse-reserved sym varsym + ".." + "=>" "=" + "@" + "\\" + "|" + "~"))))) + +(define (lex-integer radix) + (lex-integer-1 radix 0)) + +(define (lex-integer-1 radix psum) + (declare (type fixnum radix) + (type integer psum)) + (let ((d (char->digit *char* radix))) + (if d + (begin + (advance-char) + (lex-integer-1 radix (+ (* psum radix) (the fixnum d)))) + psum))) + +(define (lex-fraction int-part denominator) + (declare (type integer int-part denominator)) + (let ((d (char->digit *char* 10))) + (if d + (begin + (advance-char) + (lex-fraction + (+ (* int-part 10) (the fixnum d)) (* denominator 10))) + (values int-part denominator)))) + +(define (lex-numeric) + (let ((int-part (lex-integer 10))) + (if (and (char=? *char* #\.) + (char->digit *peek-char* 10)) + (lex-float int-part) + (emit-token 'integer int-part)))) + +(define (lex-float int-part) + (advance-char) + (multiple-value-bind (numerator denominator) (lex-fraction int-part 1) + (let ((no-exponent + (lambda () (emit-token 'float numerator denominator 0)))) + (char-case *char* + (exponent + (char-case *peek-char* + (digit + (advance-char) + (lex-float/exp numerator denominator 1)) + ((#\+ #\-) + (cond ((char->digit (peek-char-2) 10) + (let ((sign (if (char=? *peek-char* '#\+) 1 -1))) + (advance-char) + (advance-char) + (lex-float/exp numerator denominator sign))) + (else + (funcall no-exponent)))) + (else + (funcall no-exponent)))) + (else + (emit-token 'float numerator denominator 0)))))) + +(define (lex-float/exp numerator denominator sign) + (let ((exponent (lex-integer 10))) + (emit-token 'float numerator denominator (* sign exponent)))) + +(define (lex-char) + (advance-char) + (let ((c + (char-case *char* + (#\' (signal-null-character) + '#\?) + (#\\ (lex-escaped-char '#f)) + ((#\space graphic) + (let ((ch *char*)) + (advance-char) + ch)) + (else + (signal-bad-character-constant *char*) + (advance-char) + `#\?)))) + (cond ((char=? *char* '#\') + (advance-char) + (emit-token 'char c)) + (else + (signal-missing-char-quote) + (skip-to-quote-or-eol))))) + +(define (signal-null-character) + (lexer-error 'null-character + "Null character '' is illegal - use '\\'' for a quote.")) + +(define (signal-bad-character-constant ch) + (lexer-error 'bad-character-constant + "The character `~a' may not appear in a character literal." ch)) + +(define (signal-missing-char-quote) + (lexer-error 'missing-char-quote + "Character constant has more than one character.")) + + +(define (skip-to-quote-or-eol) + (if *at-eof?* + (lex-one-token) + (char-case *char* + (#\' (advance-char) + (lex-one-token)) + (#\newline (advance-char) + (lex-one-token)) + (else + (advance-char) + (skip-to-quote-or-eol))))) + +(define (lex-string) + (advance-char) + (emit-token 'string (list->string (gather-string-chars)))) + +(define (gather-string-chars) + (char-case *char* + (#\\ + (let ((ch (lex-escaped-char '#t))) + (if (eq? ch 'null) + (gather-string-chars) + (cons ch (gather-string-chars))))) + (#\" + (advance-char) + '()) + ((graphic #\space) + (let ((ch *char*)) + (advance-char) + (cons ch (gather-string-chars)))) + (#\newline + (signal-missing-string-quote) + '()) + (else + (signal-bad-string-constant *char*) + (advance-char) + (gather-string-chars)))) + +(define (signal-missing-string-quote) + (lexer-error 'missing-string-quote + "String continued over end of line.")) + +(define (signal-bad-string-constant ch) + (lexer-error 'bad-string-constant + "The character `~a' may not appear in a string literal." ch)) + + +(define (convert-stupid-control-character-names) + (let ((c1 *char*) + (c2 *peek-char*)) + (advance-char) + (advance-char) + (let ((s2 (string c1 c2)) + (s3 (string c1 c2 *char*))) + (let ((srch3 (assoc s3 *control-char-names*))) + (cond (srch3 + (advance-char) + (integer->char (cdr srch3))) + (else + (let ((srch2 (assoc s2 *control-char-names*))) + (cond (srch2 + (integer->char (cdr srch2))) + (else + (signal-bad-control-char s3) + `#\?))))))))) + +(define (signal-bad-control-char name) + (lexer-error 'invalid-control-char + "`~a' is not a recognized control character name." name)) + + +(define (lex-escaped-char in-string?) + (advance-char) + (char-case *char* + ((#\a #\b #\f #\n #\r #\t #\v) + (let* ((ccode (cdr (assoc *char* *short-control-char-names*))) + (ccode1 (cdr (assoc ccode *control-char-names*)))) + (advance-char) + (integer->char ccode1))) + ((#\\ #\' #\") + (let ((ch *char*)) + (advance-char) + ch)) + (#\& + (advance-char) + (cond (in-string? 'null) + (else + (signal-bad-&-escape) + '#\?))) + (#\^ + ;; *** This code is problematic because it assumes + ;; *** (1) that you can do the arithmetic on the character codes + ;; *** (2) that the resulting integer can actually be coerced to + ;; *** the right character object in the host Lisp. + (advance-char) + (char-case *char* + ((large #\@ #\[ #\\ #\] #\^ #\_) + (let ((code (+ (- (char->integer *char*) + (char->integer '#\A)) + *control-A*))) + (advance-char) + (integer->char code))) + (else + (signal-bad-^-escape *char*) + '#\?))) + (large + (convert-stupid-control-character-names)) + (digit + (convert-num-to-char (lex-integer 10))) + (#\o + (advance-char) + (cond ((char->digit *char* 8) + (convert-num-to-char (lex-integer 8))) + (else + (signal-missing-octal-digits) + '#\?))) + (#\x + (advance-char) + (cond ((char->digit *char* 16) + (convert-num-to-char (lex-integer 16))) + (else + (signal-missing-hex-digits) + `#\?))) + (whitechar + (cond (in-string? + (lex-gap)) + (else + (signal-bad-gap) + `#\?))) + (else + (signal-bad-escape *char*) + `#\?))) + +(define (signal-bad-&-escape) + (lexer-error 'bad-&-escape + "The escape `\\&' is not allowed inside a character literal.")) + +(define (signal-bad-^-escape ch) + (lexer-error 'bad-^-escape + "The escape `\\^~a' is not recognized." ch)) + +(define (signal-missing-octal-digits) + (lexer-error 'missing-octal-digits + "No digits provided for `\\o' escape.")) + +(define (signal-missing-hex-digits) + (lexer-error 'missing-hex-digits + "No digits provided for `\\x' escape.")) + +(define (signal-bad-gap) + (lexer-error 'invalid-gap + "Gaps are not allowed inside character literals.")) + +(define (signal-bad-escape ch) + (lexer-error 'bad-escape + "The escape `\\~a' is not recognized." ch)) + + + +;;; *** This code is problematic because it assumes that integers +;;; *** between 0 and 255 map on to characters with the corresponding +;;; *** ASCII encoding in the host Lisp, and that the host Lisp actually +;;; *** supports 255 characters. + +(define (convert-num-to-char num) + (cond ((and (>= num 0) (>= *max-char* num)) + (integer->char num)) + (else + (signal-char-out-of-range num) + '#\?))) + +(define (signal-char-out-of-range num) + (lexer-error 'char-out-of-range + "There is no character corresponding to code ~s." num)) + + +(define (lex-gap) + (cond (*at-eof?* + (signal-eof-in-gap) + 'null) + (else + (char-case *char* + (whitechar + (advance-char) + (lex-gap)) + (#\\ + (advance-char) + 'null) + (else + (signal-missing-gap) + 'null))))) + + +(define (signal-eof-in-gap) + (lexer-error 'eof-in-gap + "End of file encountered inside gap.")) + +(define (signal-missing-gap) + (lexer-error 'missing-gap + "Missing gap delimiter, or junk inside gap.")) diff --git a/parser/module-parser.scm b/parser/module-parser.scm new file mode 100644 index 0000000..2ffa391 --- /dev/null +++ b/parser/module-parser.scm @@ -0,0 +1,312 @@ +;;; File: module-parser Author: John + +;;; This is for using the parser to parse strings. + +(define (parse-from-string string parse-proc filename) + (dynamic-let ((*current-file* filename)) + (call-with-input-string string + (lambda (port) + (let ((tokens (lex-port port '#f))) + (init-token-stream tokens) + (let ((res (funcall parse-proc))) + (if (not (eq-token? 'eof)) + (signal-leftover-tokens) + res))))))) + +(define (signal-leftover-tokens) + (fatal-error 'leftover-tokens + "Leftover tokens after parsing.")) + + +;;; This file deals with the basic structure of a module. It also adds +;;; the `module Main where' required by abbreviated modules. + +(define (parse-tokens tokens) + (init-token-stream tokens) + (let ((mod (token-case + (|module| (parse-module)) + (else (parse-modules/named '|Main| '()))))) + (cons mod (parse-module-list)))) + +(define (parse-module) + (token-case + (modid (let* ((mod-name (token->symbol)) + (exports (parse-exports))) + (require-token + |where| + (signal-missing-token "`where'" "module definition")) + (parse-modules/named mod-name exports))) + (else (signal-missing-token "<modid>" "module definition")))) + +(define (parse-module-list) + (token-case + (|module| + (let ((mod (parse-module))) + (cons mod (parse-module-list)))) + (eof '()) + (else (signal-missing-module)))) + +(define (signal-missing-module) + (parser-error 'missing-module + "Missing `module', or leftover junk after module definition.")) + +(define (parse-exports) + (token-case + (\( (parse-export-list)) + (else '()))) + +(define (parse-export-list) + (let ((entity (parse-entity 'export))) + (token-case + (\) (list entity)) + (\, (cons entity (parse-export-list))) + (else (signal-missing-token "`)' or ','" "export list"))))) + +(define (parse-modules/named mod-name exports) + (trace-parser module + (let ((mod-ast (make module + (name mod-name) + (type 'standard) + (exports exports) + (default *standard-module-default*)))) + (start-layout (lambda (in-layout?) + (parse-module-decls mod-ast in-layout? 'import)))))) + +;;; The mod-ast fields are kept in non-reversed order by appending +;;; each decl to the end of the appropriate list. This loses for +;;; value decls, so these are in reversed order!! + +(define (parse-module-decls mod-ast in-layout? state) + (token-case + (|import| (let ((import (parse-import))) + (if (eq? state 'import) + (push-decl-list import (module-imports mod-ast)) + (signal-misplaced-import))) + (terminate-topdecl mod-ast in-layout? state)) + (|infix| (terminate-topdecl mod-ast in-layout? + (parse-fixity 'n mod-ast state))) + (|infixl| (terminate-topdecl mod-ast in-layout? + (parse-fixity 'l mod-ast state))) + (|infixr| (terminate-topdecl mod-ast in-layout? + (parse-fixity 'r mod-ast state))) + (|data| (let ((data-decl (parse-type-decl '#f))) + (push-decl-list data-decl (module-algdatas mod-ast))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + (|type| (let ((synonym-decl (parse-synonym-decl))) + (push-decl-list synonym-decl (module-synonyms mod-ast))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + (|class| (let ((class-decl (parse-class-decl))) + (push-decl-list class-decl (module-classes mod-ast))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + (|instance| (let ((instance-decl (parse-instance-decl '#f))) + (push-decl-list instance-decl (module-instances mod-ast))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + (|default| (let ((types + (token-case + (\( (token-case (\) '()) + (else (parse-type-list)))) + (else (list (parse-type)))))) + (if (eq? (module-default mod-ast) *standard-module-default*) + (setf (module-default mod-ast) + (make default-decl (types types))) + (signal-multiple-defaults))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + ((begin-annotation no-advance) + (let ((annotations (parse-annotations))) + (setf (module-annotations mod-ast) + (append (module-annotations mod-ast) annotations))) + (terminate-topdecl mod-ast in-layout? state)) + (pat-start (let ((decl (parse-decl))) + (setf (module-decls mod-ast) + (decl-push decl (module-decls mod-ast)))) + (terminate-topdecl mod-ast in-layout? 'topdecl)) + (else + (maybe-end-module mod-ast in-layout? state)))) + +(define (signal-misplaced-import) + (parser-error 'misplaced-import + "The import declaration is misplaced.")) + +(define (signal-multiple-defaults) + (parser-error 'multiple-defaults + "There are multiple default declarations.")) + +(define (terminate-topdecl mod-ast in-layout? state) + (token-case + (\; (parse-module-decls mod-ast in-layout? state)) + (else (maybe-end-module mod-ast in-layout? state)))) + +(define (maybe-end-module mod-ast in-layout? state) + (declare (ignore state)) + (cond ((or (eq-token? '|module|) (eq-token? 'eof) (eq-token? '\}) + (eq-token? '$\})) + (close-layout in-layout?) + (wrapup-module mod-ast) + mod-ast) + (else + (signal-invalid-syntax "a topdecl")))) + +(define (wrapup-module mod-ast) + (setf (module-decls mod-ast) + (nreverse (module-decls mod-ast))) + (when (and (null? (module-imports mod-ast)) + (null? (module-decls mod-ast)) + (null? (module-algdatas mod-ast)) + (null? (module-synonyms mod-ast)) + (null? (module-instances mod-ast)) + (null? (module-classes mod-ast))) + (signal-empty-module))) + +(define (signal-empty-module) + (parser-error 'empty-module "Module definition is empty.")) + +(define (parse-import) + (save-parser-context + (token-case + (modid (let ((mod (token->symbol)) + (mode 'all) + (specs '())) + (token-case + (\( (setf mode 'by-name) + (token-case + (\) (setf specs '())) + (else (setf specs (parse-import-list))))) + (|hiding| (require-token + \( + (signal-missing-token "`('" "hiding clause")) + (setf specs (parse-import-list))) + (else '())) + (let ((renamings (token-case (|renaming| + (require-token + \( + (signal-missing-token + "`('" "renaming clause")) + (parse-renamings)) + (else '())))) + (make import-decl (module-name mod) (mode mode) (specs specs) + (renamings renamings))))) + (else + (signal-missing-token "<modid>" "import declaration"))))) + +(define (parse-import-list) + (let ((import (parse-entity 'import))) + (token-case + (\, (cons import (parse-import-list))) + (\) (list import)) + (else (signal-missing-token "`)' or `,'" "import list"))))) + +(define (parse-renamings) + (let ((renaming + (save-parser-context + (token-case + (var (let ((name1 (var->symbol))) + (require-token + |to| + (signal-missing-token "`to'" "import renaming clause")) + (token-case + (var (let ((name2 (var->symbol))) + (make renaming (from name1) (to name2) + (referenced? '#f)))) + (else (signal-invalid-syntax "import renaming clause"))))) + (con (let ((name1 (con->symbol))) + (require-token + |to| + (signal-missing-token "`to'" "import renaming clause")) + (token-case + (con (let ((name2 (con->symbol))) + (make renaming (from name1) (to name2) + (referenced? '#f)))) + (else (signal-invalid-syntax "import renaming clause"))))) + (else (signal-invalid-syntax "import renaming clause")))))) + (token-case (\, (cons renaming (parse-renamings))) + (\) (list renaming))))) + +(define (parse-fixity associativity mod-ast state) + (let ((fixity-decl + (save-parser-context + (let* ((prec (token-case + (k (let ((p (token->integer))) + (cond ((<= p 9) + p) + (else + (signal-bad-fixity) + 9)))) + (else 9))) + (ops (parse-op-list)) + (fixity (make fixity (associativity associativity) + (precedence prec)))) + (make fixity-decl (fixity fixity) (names ops)))))) + (push-decl-list fixity-decl (module-fixities mod-ast)) + (cond ((or (eq? state 'import) + (eq? state 'fixity)) + 'fixity) + (else + (signal-misplaced-fixity) + state)))) + + +(define (signal-bad-fixity) + (parser-error 'bad-fixity + "Expecting fixity value of 0 - 9.")) + +(define (signal-misplaced-fixity) + (parser-error 'misplaced-fixity "The fixity declaration is misplaced.")) + +(define (parse-op-list) + (let ((name (token-case + (op (op->symbol)) + (else (signal-missing-token "<op>" "fixity declaration"))))) + (token-case + (\, (cons name (parse-op-list))) + (else (list name))))) + +(define (parse-entity context) + (trace-parser entity + (save-parser-context + (token-case + (var (var->entity)) + (tycon + (let ((name (token->symbol))) + (token-case + (\( (token-case + (\.\. (require-token + '\) + (signal-missing-token "`)'" "class or datatype entity")) + (make entity-abbreviated (name name))) + (var (parse-entity-class name)) + (con (parse-entity-datatype name)) + (\) (make entity-class (name name) (methods '()))) + (else (signal-invalid-syntax "an entity")))) + (\.\. (if (eq? context 'export) + (make entity-module (name name)) + (signal-invalid-syntax "an entity"))) + (else + (make entity-con (name name)))))) + (else (signal-invalid-syntax "an entity")))))) + +(define (parse-entity-class class-name) + (let ((vars (parse-var-list))) + (make entity-class (name class-name) (methods vars)))) + +(define (parse-entity-datatype type-name) + (let ((constrs (parse-con-list))) + (make entity-datatype (name type-name) (constructors constrs)))) + +(define (parse-var-list) + (token-case + (var (let ((name (var->symbol))) + (token-case + (\) (list name)) + (\, (cons name (parse-var-list))) + (else + (signal-missing-token "`)' or `,'" "class entity"))))) + (else (signal-missing-token "<var>" "class entity")))) + +(define (parse-con-list) + (token-case + (con (let ((name (con->symbol))) + (token-case + (\) (list name)) + (\, (cons name (parse-con-list))) + (else (signal-missing-token "`)' or `,'" "datatype entity"))))) + (else (signal-missing-token "<con>" "datatype entity")))) diff --git a/parser/parser-debugger.scm b/parser/parser-debugger.scm new file mode 100644 index 0000000..40d9382 --- /dev/null +++ b/parser/parser-debugger.scm @@ -0,0 +1,81 @@ +;;; These routines are strictly for debugging the parser. They could +;;; be removed from the system later. + +;;; define some debugging stuff +;;; Here's the debugging control: +;;; Capabilities: +;;; record start (line,token,production,k) +;;; record end (line,token,prodection,k) +;;; print end (line,token,prodection,k,value) +;;; break start +;;; break end + +(define *parser-debug-options* '()) +(define *parser-debug-lines* '()) +(define *parser-debug-id* 0) + +(define (watch-lines . lines) + (setf *parser-debug-lines* lines)) + +(define (watching-this-line?) + (and (not (eq? *parser-debug-lines* 'none)) + (or (null? *parser-debug-lines*) + (and (>= *current-line* (car *parser-debug-lines*)) + (or (null? (cdr *parser-debug-lines*)) + (<= *current-line* (cadr *parser-debug-lines*))))))) + +(define (ptrace-print-obj x) + (pprint x)) + +(define (ptrace-breakpoint) + (error "Breakpoint~%")) + +(define (parser-show-context id tag msg) + (format '#t "~A parse of ~A(~A) Line: ~A Token: ~A" + msg tag id *current-line* *token*) + (when (not (null? *token-args*)) + (format '#t " ~A" *token-args*)) + (format '#t "~%")) + +(define (ptrace-clear) + (setf *parser-debug-options* '())) + +(define (ptrace-pop) + (pop *parser-debug-options*)) + +(define (ptrace-watch . things) + (dolist (x things) + (push (cons x 'watch) *parser-debug-options*))) + +(define (ptrace-show . things) + (dolist (x things) + (push (cons x 'show) *parser-debug-options*))) + +(define (ptrace-break . things) + (dolist (x things) + (push (cons x 'break) *parser-debug-options*))) + +;;; Routines called by the trace-parser macro + +(define (tracing-parse/entry tag) + (let ((all? (assq 'all *parser-debug-options*)) + (this? (assq tag *parser-debug-options*))) + (cond ((or all? this?) + (incf *parser-debug-id*) + (parser-show-context *parser-debug-id* tag "Entering") + (when (and this? (eq? (cdr this?) 'break)) + (ptrace-breakpoint)) + *parser-debug-id*) + (else 0)))) + +(define (tracing-parse/exit tag id res) + (let ((all? (assq 'all *parser-debug-options*)) + (this? (assq tag *parser-debug-options*))) + (when (and (or all? this?) (not (eq? tag 0))) + (setf (dynamic *returned-obj*) res) + (parser-show-context id tag "Exiting") + (when (and this? (eq? (cdr this?) 'show)) + (ptrace-print-obj res)) + (when (and this? (eq? (cdr this?) 'break)) + (ptrace-breakpoint))))) + diff --git a/parser/parser-driver.scm b/parser/parser-driver.scm new file mode 100644 index 0000000..cd42d3d --- /dev/null +++ b/parser/parser-driver.scm @@ -0,0 +1,48 @@ + +;;; This is the top level entry to the parse. The input is a list of file +;;; names to be parsed and the output is a list of modules. Interface files +;;; generate modules similar to ordinary files. + +(define (parse-files filenames) + (let ((all-mods '())) + (dolist (file filenames) + (let* ((ext (filename-type file)) + (mods (cond ((string=? ext ".hs") + (parse-single-file file)) + ((string=? ext ".lhs") + (parse-single-file/literate file)) + ((string=? ext ".hi") + (parse-single-file/interface file))))) + (setf all-mods (append all-mods mods)))) + all-mods)) + +(define (parse-single-file filename) + (parse-single-file-1 filename '#f '#f)) + +(define (parse-single-file/literate filename) + (parse-single-file-1 filename '#t '#f)) + +(define (parse-single-file/interface filename) + (parse-single-file-1 filename '#f '#t)) + +(define (parse-single-file-1 filename literate? interface?) + (when (memq 'reading *printers*) + (format '#t "Reading Haskell source file ~s.~%" filename)) + (when (not (file-exists? filename)) + (signal-file-not-found filename)) + (dynamic-let ((*current-file* filename)) + (let ((mods '())) + (call-with-input-file filename + (lambda (port) + (let* ((tokens (lex-port port literate?)) + (module-asts (if interface? + (parse-tokens/interface tokens) + (parse-tokens tokens)))) + (setf mods module-asts)))) + (when (memq 'parse *printers*) + (dolist (m mods) + (format '#t "~%") + (print-full-module m))) + mods))) + + diff --git a/parser/parser-errors.scm b/parser/parser-errors.scm new file mode 100644 index 0000000..ae4d097 --- /dev/null +++ b/parser/parser-errors.scm @@ -0,0 +1,74 @@ +;;; This contains parser error handlers. They, in turn, call the +;;; system error handlers. + +(define (lexer-error id . msgs) + (parser-error/common id 'recoverable msgs '#t) + `#\?) + +(define (parser-error id . msgs) + (parser-error/common id 'phase msgs '#f) + (if (null? *layout-stack*) + (abort-compilation) + (recover-to-next-decl *token-stream*))) + +(define (parser-error/recoverable id . args) + (parser-error/common id 'recoverable args '#f)) + +(define (parser-error/common id type msgs in-lexer?) + (let ((place + (if in-lexer? + (list "Error occured at in file ~A at line ~A, column ~A." + *current-file* *current-line* *current-col*) + (list "Error occured at in file ~A at line ~A, token ~A." + *current-file* *current-line* + (cond ((null? *token-args*) + *token*) + ((null? (cdr *token-args*)) + (car *token-args*)) + (else *token-args*)))))) ; could be better + (haskell-error id type (list place msgs)))) + +(define (recover-to-next-decl tokens) + (cond ((null? tokens) + (abort-compilation)) + ((eq? (car (car tokens)) 'line) + (search-layout-stack *layout-stack* tokens (caddr (car tokens)))) + (else (recover-to-next-decl (cdr tokens))))) + +(define (search-layout-stack layouts tokens column) + (cond ((null? layouts) + (abort-compilation)) + ((> column (layout-col (car layouts))) + (recover-to-next-decl (cdr tokens))) + ((= column (layout-col (car layouts))) + (setf *current-col* column) + (setf *current-line* (cadr (car tokens))) + (setf *token-stream* (cdr tokens)) + (advance-token) ; loads up *token* + ;; *** layout-recovery-fn is not defined anywhere! + (funcall (layout-recovery-fn (car layouts)))) + (else + (setf *layout-stack* (cdr *layout-stack*)) + (search-layout-stack (cdr layouts) tokens column)))) + + +;;; Here are some very commonly used signalling functions. +;;; Other (more specific) signalling functions are defined near +;;; the places where they are called. + + +;;; This is used when a particular token isn't found. + +(define (signal-missing-token what where) + (parser-error 'missing-token + "Missing ~a in ~a." what where)) + + +;;; This is used to signal more complicated parse failures involving +;;; failure to match a nonterminal. + +(define (signal-invalid-syntax where) + (parser-error 'invalid-syntax + "Invalid syntax appears where ~a is expected." where)) + + diff --git a/parser/parser-globals.scm b/parser/parser-globals.scm new file mode 100644 index 0000000..528e582 --- /dev/null +++ b/parser/parser-globals.scm @@ -0,0 +1,27 @@ +;;; Global vars used in the parser + +(define *current-line* '()) ; current line the scanner is on +(define *current-col* '()) ; current col; valid at start of line & + ; after where,let,of + +;;; Lexer + +(define *lex-literate?* '#f) +(define *start-line* 0) +(define *start-col* 0) +(define *on-new-line?* '#t) +(define *save-col?* '#f) +(define *port* '()) +(define *tokens* '()) +(define *char* 0) +(define *peek-char* 0) +(define *at-eof/p?* 0) +(define *at-eof?* 0) +(define *on-new-line? '#f) + +;;; Parser + +(define *token-stream* '()) ; remaining tokens to be parsed +(define *token* '()) ; current token type +(define *token-args* '()) ; current token arguments +(define *layout-stack* '()) ; columns at which layout is being done diff --git a/parser/parser-macros.scm b/parser/parser-macros.scm new file mode 100644 index 0000000..c4f5a63 --- /dev/null +++ b/parser/parser-macros.scm @@ -0,0 +1,327 @@ +;;; Macro definitions for the parser & lexer. + + +;;; This macro allows debugging of the lexer. Before releasing, this can +;;; be replaced by (begin ,@body) for faster code. + +(define-syntax (trace-parser tag . body) +; `(begin +; (let* ((k (tracing-parse/entry ',tag)) +; (res (begin ,@body))) +; (tracing-parse/exit ',tag k res) +; res)) + (declare (ignore tag)) + `(begin ,@body) + ) + +;;; Macros used by the lexer. + +;;; The lexer used a macro, char-case, to dispatch on the syntactic catagory of +;;; a character. These catagories (processed at compile time) are defined +;;; here. Note that some of these definitions use the char-code +;;; directly and would need updating for different character sets. + +(define *lex-definitions* + '((vtab 11) ; define by ascii code to avoid relying of the reader + (formfeed 12) + (whitechar #\newline #\space #\tab formfeed vtab) + (small #\a - #\z) + (large #\A - #\Z) + (digit #\0 - #\9) + (symbol #\! #\# #\$ #\% #\& #\* #\+ #\. #\/ #\< #\= #\> #\? #\@ + #\\ #\^ #\|) + (presymbol #\- #\~) + (exponent #\e #\E) + (graphic large small digit + #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ + #\, #\- #\. #\/ #\: #\; #\< #\= #\> #\? #\@ + #\[ #\\ #\] #\^ #\_ #\` #\{ #\| #\} #\~) + (charesc #\a #\b #\f #\n #\r #\t #\v #\\ #\" #\' #\&) + (cntrl large #\@ #\[ #\\ #\] #\^ #\_))) + +;;; The char-case macro is similar to case using characters to select. +;;; The following capabilities are added by char-case: +;;; pre-defined constants are denoted by symbols (defined above) +;;; ranges of characters are represented using -. For example, +;;; (#\a - #\z #\A - #\Z) denotes all alphabetics. +;;; numbers refer to the char code of a character. +;;; The generated code is optimized somewhat to take advantage of +;;; consecutive character ranges. With a little work, this could be +;;; implemented using jump tables someday. + +(define-syntax (char-case exp . alts) + (expand-char-case exp alts)) + +(define (expand-char-case exp alts) + (let ((temp (gensym))) + `(let ((,temp ,exp)) + ,(expand-char-case1 temp alts)))) + +(define (expand-char-case1 temp alts) + (if (null? alts) + '() + (let* ((alt (car alts)) + (test (car alt)) + (body (cons 'begin (cdr alt))) + (rest (expand-char-case1 temp (cdr alts)))) + (cond ((eq? test 'else) + body) + (else + `(if (or ,@(gen-char-tests temp + (if (pair? test) test (list test)))) + ,body + ,rest)))))) + +(define (gen-char-tests temp tests) + (gen-char-tests-1 temp + (sort-list (gather-char-tests tests) (function char<?)))) + +(define (gen-char-tests-1 temp chars) + (cond ((null? chars) + '()) + ((long-enough-run? chars 3) + (gen-range-check temp (car chars) (car chars) (cdr chars))) + (else + `((char=? ,temp ',(car chars)) + ,@(gen-char-tests-1 temp (cdr chars)))))) + +(define (gen-range-check temp first current chars) + (if (and (pair? chars) (consec-chars? current (car chars))) + (gen-range-check temp first (car chars) (cdr chars)) + `((and (char>=? ,temp ',first) + (char<=? ,temp ',current)) + ,@(gen-char-tests-1 temp chars)))) + +(define (consec-chars? c1 c2) + (eqv? (+ 1 (char->integer c1)) (char->integer c2))) + +(define (long-enough-run? l n) + (or (eqv? n 1) + (and (pair? (cdr l)) + (consec-chars? (car l) (cadr l)) + (long-enough-run? (cdr l) (1- n))))) + +(define (gather-char-tests tests) + (cond ((null? tests) + '()) + ((symbol? (car tests)) + (let ((new-test (assq (car tests) *lex-definitions*))) + (if new-test + (gather-char-tests (append (cdr new-test) (cdr tests))) + (error "Unknown character class: ~A~%" (car tests))))) + ((integer? (car tests)) + (cons (integer->char (car tests)) + (gather-char-tests (cdr tests)))) + ((and (pair? (cdr tests)) (eq? '- (cadr tests))) + (letrec ((fn (lambda (a z) + (if (char>? a z) + (gather-char-tests (cdddr tests)) + (cons a (funcall + fn (integer->char + (+ 1 (char->integer a))) z)))))) + (funcall fn (car tests) (caddr tests)))) + ((char? (car tests)) + (cons (car tests) (gather-char-tests (cdr tests)))) + (else + (error "Invalid selector in char-case: ~A~%" (car tests))))) + +;;; This macro scans a list of characters on a given syntaxtic catagory. +;;; The current character is always included in the resulting list. + +(define-syntax (scan-list-of char-type) + `(letrec ((test-next (lambda () + (char-case *char* + (,char-type + (let ((c *char*)) + (advance-char) + (cons c (funcall test-next)))) + (else '()))))) + (let ((c *char*)) + (advance-char) + (cons c (funcall test-next))))) + +;;; This macro tests for string equality in which the strings are +;;; represented by lists of characters. The comparisons are expanded +;;; inline (really just a little partial evaluation going on here!) for +;;; fast execution. The tok argument evaluate to a list of chars. The string +;;; argument must be a string constant, which is converted to characters +;;; as the macro expands. + +(define-syntax (string=/list? tok string) + (let ((temp (gensym))) + `(let ((,temp ,tok)) + ,(expand-string=/list? temp (string->list string))))) + +(define (expand-string=/list? var chars) + (if (null? chars) + `(null? ,var) + (let ((new-temp (gensym))) + `(and (pair? ,var) + (char=? (car ,var) ',(car chars)) + (let ((,new-temp (cdr ,var))) + ,(expand-string=/list? new-temp (cdr chars))))))) + +;;; This macro extends the string equality defined above to search a +;;; list of reserved words quickly for keywords. It does this by a case +;;; dispatch on the first character of the string and then processing +;;; the remaining characters wirh string=/list. This would go a little +;;; faster with recursive char-case statements, but I'm a little too +;;; lazy at for this at the moment. If a keyword is found is emitted +;;; as a symbol. If not, the token string is emitted with the token +;;; type indicated. Assume the string being scanned is a list of +;;; chars assigned to a var. (Yeah - I know - I should add a gensym +;;; var for this argument!!). + +(define-syntax (parse-reserved var token-type . reserved-words) + (let ((sorted-rws (sort-list reserved-words (function string<?)))) + `(let ((thunk (lambda () (emit-token/string ',token-type ,var)))) + (char-case (car ,var) + ,@(expand-parse-reserved var + (group-by-first-char (list (car sorted-rws)) (cdr sorted-rws))) + (else (funcall thunk)))))) + +(define (group-by-first-char group rest) + (cond ((null? rest) + (list group)) + ((char=? (string-ref (car group) 0) + (string-ref (car rest) 0)) + (group-by-first-char (append group (list (car rest))) (cdr rest))) + (else + (cons group (group-by-first-char (list (car rest)) (cdr rest)))))) + +(define (expand-parse-reserved var groups) + (if (null? groups) + '() + `((,(string-ref (caar groups) 0) + (cond ,@(expand-parse-reserved/group var (car groups)) + (else (funcall thunk)))) + ,@(expand-parse-reserved var (cdr groups))))) + +(define (expand-parse-reserved/group var group) + (if (null? group) + '() + `(((string=/list? (cdr ,var) + ,(substring (car group) 1 (string-length (car group)))) + (emit-token ',(string->symbol (car group)))) + ,@(expand-parse-reserved/group var (cdr group))))) + + +;;; The following macros are used by the parser. + +;;; The primary macro used by the parser is token-case, which dispatches +;;; on the type of the current token (this is always *token* - unlike the +;;; lexer, no lookahead is provided; however, some of these dispatches are +;;; procedures that do a limited lookahead. The problem with lookahead is that +;;; the layout rule adds tokens which are not visible looking into the +;;; token stream directly. + +;;; Unlike char-case, the token is normally advanced unless the selector +;;; includes `no-advance'. The final else also avoids advancing the token. + +;;; In addition to raw token types, more complex types can be used. These +;;; are defined here. The construct `satisfies fn' calls the indicated +;;; function to determine whether the current token matches. + +;;; If the token type to be matched is not a constant, the construct +;;; `unquote var' matches the current token against the type in the var. + +(define *predefined-syntactic-catagories* '( + (+ satisfies at-varsym/+?) + (- satisfies at-varsym/-?) + (tycon no-advance conid) + (tyvar no-advance varid) + (var no-advance varid satisfies at-varsym/paren?) + (con no-advance conid satisfies at-consym/paren?) + (name no-advance var con) + (consym/paren no-advance satisfies at-consym/paren?) + (varsym? no-advance varsym) + (consym? no-advance consym) + (varid? no-advance varid) + (conid? no-advance conid) + (op no-advance varsym consym \`) + (varop no-advance varsym satisfies at-varid/quoted?) + (conop no-advance consym satisfies at-conid/quoted?) + (modid no-advance conid) + (literal no-advance integer float char string) + (numeric no-advance integer float) + (k no-advance integer) + (+k no-advance satisfies at-+k?) + (-n no-advance satisfies at--n?) + (apat-start no-advance varid conid literal _ \( \[ \~) + (pat-start no-advance - apat-start) + (atype-start no-advance tycon tyvar \( \[) + (aexp-start no-advance varid conid \( \[ literal) + )) + +;;; The format of token-case is +;;; (token-case +;;; (sel1 . e1) (sel2 . e2) ... [(else . en)]) +;;; If the sel is a symbol it is the same as a singleton list: (@ x) = ((@) x) + +;;; Warning: this generates rather poor code! Should be fixed up someday. + +(define-syntax (token-case . alts) + `(cond ,@(map (function gen-token-case-alt) alts))) + +(define (gen-token-case-alt alt) + (let ((test (car alt)) + (code (cdr alt))) + (cond ((eq? test 'else) + `(else ,@code)) + ((symbol? test) + (gen-token-case-alt-1 (expand-catagories (list test)) code)) + (else + (gen-token-case-alt-1 (expand-catagories test) code))))) + +(define (expand-catagories terms) + (if (null? terms) + terms + (let ((a (assq (car terms) *predefined-syntactic-catagories*)) + (r (expand-catagories (cdr terms)))) + (if (null? a) + (cons (car terms) r) + (expand-catagories (append (cdr a) r)))))) + +(define (gen-token-case-alt-1 test code) + `((or ,@(gen-token-test test)) + ,@(if (memq 'no-advance test) '() '((advance-token))) + ,@code)) + +(define (gen-token-test test) + (cond ((null? test) + '()) + ((eq? (car test) 'no-advance) + (gen-token-test (cdr test))) + ((eq? (car test) 'unquote) + (cons `(eq? *token* ,(cadr test)) (gen-token-test (cddr test)))) + ((eq? (car test) 'satisfies) + (cons (list (cadr test)) (gen-token-test (cddr test)))) + (else + (cons `(eq? *token* ',(car test)) (gen-token-test (cdr test)))))) + +;;; require-tok requires a specific token to be at the scanner. If it +;;; is found, the token is advanced over. Otherwise, the error +;;; routine is called. + +(define-syntax (require-token tok error-handler) + `(token-case + (,tok '()) + (else ,error-handler))) + +;;; The save-parser-context macro captures the current line & file and +;;; attaches it to the ast node generated. + +(define-syntax (save-parser-context . body) + (let ((temp1 (gensym)) + (temp2 (gensym))) + `(let ((,temp1 (capture-current-line)) + (,temp2 (begin ,@body))) + (setf (ast-node-line-number ,temp2) ,temp1) + ,temp2))) + +(define (capture-current-line) + (make source-pointer (line *current-line*) (file *current-file*))) + +(define-syntax (push-decl-list decl place) + `(setf ,place (nconc ,place (list ,decl)))) + diff --git a/parser/parser.scm b/parser/parser.scm new file mode 100644 index 0000000..7a91930 --- /dev/null +++ b/parser/parser.scm @@ -0,0 +1,54 @@ +;;; parser.scm -- compilation unit definition for the lexer and parser +;;; +;;; author : John +;;; date : 10 Dec 1991 +;;; + +(define-compilation-unit parser + (source-filename "$Y2/parser/") + (require global) + (unit parser-globals + (source-filename "parser-globals.scm")) + (unit parser-macros + (source-filename "parser-macros.scm") + (require parser-globals)) + (unit parser-errors + (source-filename "parser-errors.scm") + (require parser-macros)) + (unit lexer + (source-filename "lexer.scm") + (require parser-macros)) + (unit token + (source-filename "token.scm") + (require parser-macros)) + (unit parser-driver + (source-filename "parser-driver.scm") + (require parser-macros)) + (unit module-parser + (source-filename "module-parser.scm") + (require parser-macros)) + (unit interface-parser + (source-filename "interface-parser.scm") + (require parser-macros)) + (unit decl-parser + (source-filename "decl-parser.scm") + (require parser-macros)) + (unit type-parser + (source-filename "type-parser.scm") + (require parser-macros)) + (unit typedecl-parser + (source-filename "typedecl-parser.scm") + (require parser-macros)) + (unit exp-parser + (source-filename "exp-parser.scm") + (require parser-macros)) + (unit annotation-parser + (source-filename "annotation-parser.scm") + (require parser-macros)) + (unit pattern-parser + (source-filename "pattern-parser.scm") + (require parser-macros)) + (unit parser-debugger + (source-filename "parser-debugger.scm") + (require parser-macros))) + diff --git a/parser/pattern-parser.scm b/parser/pattern-parser.scm new file mode 100644 index 0000000..39a82cc --- /dev/null +++ b/parser/pattern-parser.scm @@ -0,0 +1,220 @@ +;;; File: pattern-parser Author: John + +;;; This parses the pattern syntax except for the parts which need to be +;;; resolved by precedence parsing. + +;;; This parses a list of alternating pats & conops. + +(define (parse-pat) + (trace-parser pat + (let ((res (parse-pat/list))) + (if (null? (cdr res)) + (car res) + (make pp-pat-list (pats res)))))) + +;;; This parses a list of patterns with intervening conops and + patterns + +(define (parse-pat/list) + (token-case + (con (let ((pcon (pcon->ast))) + (setf (pcon-pats pcon) (parse-apat-list)) + (cons pcon (parse-pat/tail)))) + (-n + (advance-token) ; past - + (token-case + (numeric (let ((val (literal->ast))) + (cons (make pp-pat-negated) + (cons (make const-pat (value val)) + (parse-pat/tail))))) + (else + (signal-missing-token "<number>" "negative literal pattern")))) + (var + (let ((var (var->ast))) + (token-case + (+k (cons (make var-pat (var var)) + (parse-+k-pat))) + (@ (let ((pattern (parse-apat))) + (cons (make as-pat (var var) (pattern pattern)) + (parse-pat/tail)))) + (else (cons (make var-pat (var var)) (parse-pat/tail)))))) + (_ + (let ((pat (make wildcard-pat))) + (token-case + (+k (cons pat (parse-+k-pat))) + (else (cons pat (parse-pat/tail)))))) + (else (let ((apat (parse-apat))) + (cons apat (parse-pat/tail)))))) + + +(define (parse-+k-pat) + (advance-token) ; past + + (token-case + (k (let ((val (literal->ast))) + (cons (make pp-pat-plus) + (cons (make const-pat (value val)) + (parse-pat/tail))))) + (else (signal-missing-token "<integer>" "successor pattern")))) + +(define (parse-pat/tail) + (token-case + (conop + (let ((con (pconop->ast))) + (cons con (parse-pat/list)))) + (else '()))) + +(define (parse-apat) + (trace-parser apat + (token-case + (var (let ((var (var->ast))) + (token-case + (@ + (let ((pattern (parse-apat))) + (make as-pat (var var) (pattern pattern)))) + (else (make var-pat (var var)))))) + (con (pcon->ast)) + (literal (let ((value (literal->ast))) + (make const-pat (value value)))) + (_ (make wildcard-pat)) + (\( (token-case + (\) (**pcon/def (core-symbol "UnitConstructor") '())) + (else + (let ((pat (parse-pat))) + (token-case + (\, (**pcon/tuple (cons pat (parse-pat-list '\))))) + (\) pat) + (else + (signal-missing-token "`)' or `,'" "pattern"))))))) + (\[ (token-case + (\] (make list-pat (pats '()))) + (else (make list-pat (pats (parse-pat-list '\])))))) + (\~ (let ((pattern (parse-apat))) + (make irr-pat (pattern pattern)))) + (else + (signal-invalid-syntax "an apat"))))) + +(define (parse-pat-list term) ;; , separated + (let ((pat (parse-pat))) + (token-case + (\, (cons pat (parse-pat-list term))) + ((unquote term) (list pat)) + (else + (signal-missing-token + (if (eq? term '\)) "`)'" "`]'") + "pattern"))))) + +(define (parse-apat-list) ;; space separated + (token-case + (apat-start + (let ((pat (parse-apat))) + (cons pat (parse-apat-list)))) + (else + '()))) + +;;; The following routine scans patterns without creating ast structure. +;;; They return #t or #f depending on whether a valid pattern was encountered. +;;; The leave the scanner pointing to the next token after the pattern. + +(define (scan-pat) ; same as parse-pat/list + (and + (token-case + (con (scan-con) + (scan-apat-list)) + (-n (advance-token) + (token-case + (numeric (advance-token) + '#t) + (else '#f))) + (var (and (scan-var) + (token-case + (@ (scan-apat)) + (+k (scan-+k)) + (else '#t)))) + (_ (scan-+k)) + (else (scan-apat))) + (scan-pat/tail))) + +(define (scan-pat/tail) + (token-case + (conop (and (scan-conop) + (scan-pat))) + (else '#t))) + +(define (scan-apat) + (token-case + (var (scan-var) + (token-case + (@ (scan-apat)) + (else '#t))) + (con (scan-con)) + (literal (advance-token) + '#t) + (_ '#t) + (\( (token-case + (\) '#t) + (else + (and (scan-pat) + (token-case + (\, (scan-pat-list '\))) + (\) '#t) + (else '#f)))))) + (\[ (token-case + (\] '#t) + (else (scan-pat-list '\])))) + (\~ (scan-apat)) + (else '#f))) + +(define (scan-pat-list term) + (and (scan-pat) + (token-case + (\, (scan-pat-list term)) + ((unquote term) '#t) + (else '#f)))) + +(define (scan-apat-list) + (token-case + (apat-start + (and (scan-apat) + (scan-apat-list))) + (else '#t))) + +(define (scan-var) + (token-case + (varid '#t) + (\( (token-case + (varsym + (token-case + (\) '#t) + (else '#f))) + (else '#f))) + (else '#f))) + +(define (scan-con) + (token-case + (conid '#t) + (\( (token-case + (consym + (token-case + (\) '#t) + (else '#f))) + (else '#f))) + (else '#f))) + +(define (scan-conop) + (token-case + (consym '#t) + (\` (token-case + (conid + (token-case + (\` '#t) + (else '#f))) + (else '#f))) + (else '#f))) + +(define (scan-+k) + (token-case + (+k (advance-token) ; past the + + (token-case + (integer '#t) + (else '#f))) + (else '#t))) + diff --git a/parser/token.scm b/parser/token.scm new file mode 100644 index 0000000..6ca9981 --- /dev/null +++ b/parser/token.scm @@ -0,0 +1,364 @@ +;;; This file abstracts the representation of tokens. It is used by both +;;; the lexer & parser. This also contains routines for converting +;;; individual tokens to ast structure. Routines used by the +;;; token-case macro in `satisfies' clauses are here too. + +;;; Lexer routines for emitting tokens: + +(define (emit-token type . args) + (cond (*on-new-line?* + (push (list 'line *start-line* *start-col*) *tokens*)) + (*save-col?* + (push (list 'col *start-col*) *tokens*))) + (push (cons type args) *tokens*) + (setf *on-new-line?* '#f) + (setf *save-col?* (memq type '(|where| |of| |let|)))) + +(define (emit-token/string type string-as-list) + (emit-token type (list->string string-as-list))) + +;;; Parser routines: + +;;; These routines take care of the token stream in the parser. They +;;; maintain globals for the current token and its location. + +;;; Globals used: +;;; *token-stream* remaining tokens to be parsed +;;; *token* current token type +;;; *token-args* current token arguments +;;; *layout-stack* columns at which layout is being done +;;; *current-line* current line the scanner is on +;;; *current-col* current col; valid at start of line & after where,let,of +;;; *current-file* + +(define (init-token-stream tokens) + (setf *token-stream* tokens) + (setf *layout-stack* '()) + (advance-token)) + +(define (advance-token) + (cond ((null? *token-stream*) + (setf *token* 'eof)) + (else + (let* ((token (car *token-stream*))) + (setf *token-stream* (cdr *token-stream*)) + (advance-token-1 (car token) (cdr token)))))) + +(define (advance-token-1 type args) + (cond ((eq? type 'file) + (setf *current-file* (car args)) + (advance-token)) + ((eq? type 'col) + (setf *current-col* (car args)) + (advance-token)) + ((eq? type 'line) ;; assume blank lines have been removed + (let ((line (car args)) + (col (cadr args))) + (setf *current-line* line) + (setf *current-col* col) + (setf *token-stream* + (resolve-layout *token-stream* *layout-stack*))) + (advance-token)) + (else + (setf *token* type) + (setf *token-args* args) + type))) + +(define (insert-extra-token tok-type stream) ; used by layout + (cons (list tok-type) stream)) + +;;; This looks for the { to decide of layout will apply. If so, the layout +;;; stack is pushed. The body function, fn, is called with a boolean which +;;; tells it the whether layout rule is in force. + +;;; *** The CMU CL compiler barfs with some kind of internal error +;;; *** on this function. See the revised definition below. + +;(define (start-layout fn) +; (token-case +; (\{ (funcall fn '#f)) +; (else +; (let/cc recovery-fn +; (push (cons *current-col* (lambda () +; (let ((res (funcall fn '#t))) +; (funcall recovery-fn res)))) +; *layout-stack*) +; (funcall fn '#t))))) + +(define (start-layout fn) + (token-case + (\{ (funcall fn '#f)) + (else + (let/cc recovery-fn + (start-layout-1 fn recovery-fn))))) + +(define (start-layout-1 fn recovery-fn) + (push (cons *current-col* + (lambda () + (let ((res (funcall fn '#t))) + (funcall recovery-fn res)))) + *layout-stack*) + (funcall fn '#t)) + +(define (layout-col x) + (car x)) + +(define (layout-recovery-fn x) + (cdr x)) + +(define (close-layout in-layout?) + (cond (in-layout? + (setf *layout-stack* (cdr *layout-stack*)) + (token-case + ($\} '()) ; the advance-token routine may have inserted this + (else '()))) + (else + (token-case + (\} '()) + (else + (signal-missing-brace)))))) + +(define (signal-missing-brace) + (parser-error 'missing-brace + "Missing `}'.")) + +(define (resolve-layout stream layout-stack) + (if (null? layout-stack) + stream + (let ((col (layout-col (car layout-stack)))) + (declare (type fixnum col)) + (cond ((= (the fixnum *current-col*) col) + (insert-extra-token '\; stream)) + ((< (the fixnum *current-col*) col) + (insert-extra-token + '$\} (resolve-layout stream (cdr layout-stack)))) + (else + stream) + )))) + + +;;; The following routines are used for backtracking. This is a bit of +;;; a hack at the moment. + +(define (save-scanner-state) + (vector *token* *token-args* *token-stream* *layout-stack* *current-line* + *current-col*)) + +(define (restore-excursion state) + (setf *token* (vector-ref state 0)) + (setf *token-args* (vector-ref state 1)) + (setf *token-stream* (vector-ref state 2)) + (setf *layout-stack* (vector-ref state 3)) + (setf *current-line* (vector-ref state 4)) + (setf *current-col* (vector-ref state 5))) + +(define (eq-token? type) + (eq? type *token*)) + +(define (eq-token-arg? str) + (string=? str (car *token-args*))) + +;;; lookahead into the token stream + +(define (peek-1-type) + (peek-toks 0 *token-stream*)) + +(define (peek-2-type) + (peek-toks 1 *token-stream*)) + +;;; This is a Q&D way of looking ahead. It does not expand the layout +;;; as it goes so there may be missing } and ;. This should not matter +;;; in the places where this is used since these would be invalid anyway. +;;; To be safe, token types are rechecked while advancing to verify the +;;; lookahead. + +(define (peek-toks n toks) + (declare (type fixnum n)) + (cond ((null? toks) + 'eof) + ((memq (caar toks) '(col line)) + (peek-toks n (cdr toks))) + ((eqv? n 0) + (caar toks)) + (else (peek-toks (1- n) (cdr toks))))) + +;; These routines handle the `satisfies' clauses used in token-case. + +(define (at-varsym/+?) + (and (eq? *token* 'varsym) + (string=? (car *token-args*) "+"))) + +(define (at-varsym/-?) + (and (eq? *token* 'varsym) + (string=? (car *token-args*) "-"))) + +(define (at-varsym/paren?) + (and (eq? *token* '\() + (eq? (peek-1-type) 'varsym) + (eq? (peek-2-type) '\)))) + +(define (at-consym/paren?) + (and (eq? *token* '\() + (eq? (peek-1-type) 'consym) + (eq? (peek-2-type) '\)))) + +(define (at-varid/quoted?) + (and (eq? *token* '\`) + (eq? (peek-1-type) 'varid))) + +(define (at-conid/quoted?) + (and (eq? *token* '\`) + (eq? (peek-1-type) 'conid))) + +(define (at-+k?) + (and (at-varsym/+?) + (eq? (peek-1-type) 'integer))) + +(define (at--n?) + (and (at-varsym/-?) + (memq (peek-1-type) '(integer float)))) + +;;; The following routines convert the simplest tokens to AST structure. + +(define-local-syntax (return+advance x) + `(let ((x ,x)) + (advance-token) + x)) + +(define (token->symbol) + (return+advance + (string->symbol (car *token-args*)))) + +(define (token->symbol/con) ; for conid, aconid + (return+advance + (string->symbol (add-con-prefix (car *token-args*))))) + +(define (var->symbol) + (token-case + (\( (token-case + (varsym? + (let ((res (token->symbol))) + (token-case + (\) res) + (else (signal-missing-token "`)'" "var"))))) + (else (signal-missing-token "<varsym>" "var")))) + (varid? (token->symbol)))) + +(define (var->ast) + (let ((vname (var->symbol))) + (make var-ref (name vname) (infix? '#f) (var *undefined-def*)))) + +(define (var->entity) + (let ((vname (var->symbol))) + (make entity-var (name vname)))) + +(define (con->symbol) + (token-case + (\( (token-case + (consym? + (let ((res (token->symbol/con))) + (token-case + (\) res) + (else (signal-missing-token "`)'" "con"))))) + (else (signal-missing-token "<consym>" "con")))) + (conid? (token->symbol/con)))) + +(define (varop->symbol) + (token-case + (\` (token-case + (varid? + (let ((res (token->symbol))) + (token-case + (\` res) + (else (signal-missing-token "``'" "varop"))))) + (else (signal-missing-token "<varid>" "varop")))) + (varsym? (token->symbol)))) + +(define (varop->ast) + (let ((varop-name (varop->symbol))) + (make var-ref (name varop-name) (infix? '#t) (var *undefined-def*)))) + +(define (conop->symbol) + (token-case + (\` (token-case + (conid? + (let ((res (token->symbol/con))) + (token-case + (\` res) + (else (signal-missing-token "``'" "conop"))))) + (else (signal-missing-token "<conid>" "conop")))) + (consym? (token->symbol/con)))) + +(define (conop->ast) + (let ((conop-name (conop->symbol))) + (make con-ref (name conop-name) (infix? '#t) (con *undefined-def*)))) + +(define (op->symbol) + (token-case + (\` (token-case + (conid? + (let ((res (token->symbol/con))) + (token-case + (\` res) + (else (signal-missing-token "``'" "op"))))) + (varid? + (let ((res (token->symbol))) + (token-case + (\` res) + (else (signal-missing-token "``'" "op"))))) + (else (signal-missing-token "<conid> or <varid>" "op")))) + (consym? (token->symbol/con)) + (varsym? (token->symbol)))) + +(define (con->ast) ; for conid, aconid + (let ((name (con->symbol))) + (make con-ref (name name) (con *undefined-def*) (infix? '#f)))) + +(define (pcon->ast) ; for aconid, conid + (let ((name (con->symbol))) + (make pcon (name name) (con *undefined-def*) (pats '()) (infix? '#f)))) + +(define (pconop->ast) ; for aconop, conop + (let ((name (conop->symbol))) + (make pcon (name name) (con *undefined-def*) (pats '()) (infix? '#t)))) + +(define (tycon->ast) ; for aconid + (let ((name (token->symbol))) + (make tycon (name name) (def *undefined-def*) (args '())))) + +(define (class->ast) ; for aconid + (let ((name (token->symbol))) + (make class-ref (name name) (class *undefined-def*)))) + +(define (tyvar->ast) ; for avarid + (let ((name (token->symbol))) + (make tyvar (name name)))) + +(define (token->integer) ; for integer + (return+advance + (car *token-args*))) + +(define (integer->ast) ; for integer + (return+advance + (make integer-const (value (car *token-args*))))) + +(define (float->ast) + (return+advance + (make float-const (numerator (car *token-args*)) + (denominator (cadr *token-args*)) + (exponent (caddr *token-args*))))) + +(define (string->ast) + (return+advance + (make string-const (value (car *token-args*))))) + +(define (char->ast) + (return+advance + (make char-const (value (car *token-args*))))) + +(define (literal->ast) + (token-case + ((no-advance integer) (integer->ast)) + ((no-advance float) (float->ast)) + ((no-advance string) (string->ast)) + ((no-advance char) (char->ast)))) diff --git a/parser/type-parser.scm b/parser/type-parser.scm new file mode 100644 index 0000000..79c5dbf --- /dev/null +++ b/parser/type-parser.scm @@ -0,0 +1,116 @@ +;;; File: type-parser Author: John + +(define (parse-type) + (let ((type (parse-btype))) + (token-case + (-> + (**tycon/def (core-symbol "Arrow") (list type (parse-type)))) + (else type)))) + +(define (parse-btype) + (token-case + (tycon (let* ((tycon (tycon->ast)) + (tycon-args (parse-atype-list))) + (setf (tycon-args tycon) tycon-args) + tycon)) + (else + (parse-atype)))) + +(define (parse-atype-list) + (token-case + (atype-start + (let ((atype (parse-atype))) + (cons atype (parse-atype-list)))) + (else '()))) + +(define (parse-atype) + (token-case + (tyvar (tyvar->ast)) + (tycon (tycon->ast)) + (\( (token-case + (\) (**tycon/def (core-symbol "UnitType") '())) + (else + (let ((type (parse-type))) + (token-case + (\) type) + (\, (let ((types (cons type (parse-type-list)))) + (**tycon/def (tuple-tycon (length types)) types))) + (else + (signal-missing-token "`)' or `,'" "type expression"))))))) + (\[ (let ((type (parse-type))) + (require-token \] (signal-missing-token "`]'" "type expression")) + (**tycon/def (core-symbol "List") (list type)))) + (else + (signal-invalid-syntax "an atype")))) + +(define (parse-type-list) + (let ((type (parse-type))) + (token-case (\, (cons type (parse-type-list))) + (\) (list type)) + (else (signal-missing-token "`)' or `,'" "type expression"))))) + +;;; This is used to determine whether a type is preceded by a context + +(define (has-optional-context?) + (let* ((saved-excursion (save-scanner-state)) + (res (token-case + (conid + (token-case + (varid (eq-token? '=>)) + (else '#f))) + (\( (scan-context)) + (else '#f)))) + (restore-excursion saved-excursion) + res)) + +(define (scan-context) + (token-case + (conid + (token-case + (varid + (token-case + (\) (eq-token? '=>)) + (\, (scan-context)) + (else '#f))) + (else '#f))) + (else '#f))) + +(define (parse-context) + (let ((contexts (token-case + (tycon + (list (parse-single-context))) + (\( (parse-contexts)) + (else + (signal-invalid-syntax "a context"))))) + (require-token => (signal-missing-token "`=>'" "context")) + contexts)) + +(define (parse-single-context) + (let ((class (class->ast))) + (token-case + (tyvar + (let ((tyvar (token->symbol))) + (make context (class class) (tyvar tyvar)))) + (else (signal-missing-token "<tyvar>" "class assertion"))))) + +(define (parse-contexts) + (token-case + (tycon (let ((context (parse-single-context))) + (token-case + (\, (cons context (parse-contexts))) + (\) (list context)) + (else (signal-missing-token "`)' or `,'" "context"))))) + (else (signal-missing-token "<tycon>" "class assertion")))) + +(define (parse-optional-context) + (if (has-optional-context?) + (parse-context) + '())) + +(define (parse-signature) + (let* ((contexts (parse-optional-context)) + (type (parse-type))) + (make signature (context contexts) (type type)))) + + +
\ No newline at end of file diff --git a/parser/typedecl-parser.scm b/parser/typedecl-parser.scm new file mode 100644 index 0000000..4995dc7 --- /dev/null +++ b/parser/typedecl-parser.scm @@ -0,0 +1,163 @@ +;;; File: parser/typedecl-parser Author: John + +(define (parse-type-decl interface?) + (save-parser-context + (let* ((sig (parse-signature)) + (contexts (signature-context sig)) + (simple (signature-type sig)) + (deriving '()) + (constrs '())) + ;; #t = builtins ([] (,,) ->) not allowed + (check-simple simple '#t "type declaration") + (let ((annotations (parse-constr-annotations))) + (token-case + (= (setf constrs (parse-constrs)) + (token-case + (|deriving| + (setf deriving + (token-case + (\( + (token-case + (\) '()) + (else (parse-class-list)))) + (tycon (list (class->ast))) + (else (signal-invalid-syntax "a deriving clause"))))))) + (else + (when (not interface?) + (signal-missing-constructors)))) + (make data-decl (context contexts) (simple simple) + (constrs constrs) (deriving deriving) + (annotations annotations)))))) + +(define (signal-missing-constructors) + (parser-error 'missing-constructors + "Data type definition requires constructors")) + +(define (check-simple simple fresh? where) + (when (not (tycon? simple)) + (signal-not-simple where)) + (when (and fresh? (not (eq? (tycon-def simple) *undefined-def*))) + (signal-not-simple where)) + (let ((tyvars (map (lambda (arg) + (when (not (tyvar? arg)) + (signal-not-simple where)) + (tyvar-name arg)) + (tycon-args simple)))) + (when (not (null? (find-duplicates tyvars))) + (signal-unique-tyvars-required)))) + +(define (signal-unique-tyvars-required) + (parser-error 'unique-tyvars-required + "Duplicate type variables appear in simple.")) + +(define (signal-not-simple where) + (parser-error 'not-simple "Simple type required in ~a." where)) + +(define (parse-constrs) + (let ((constr (parse-constr))) + (token-case + (\| (cons constr (parse-constrs))) + (else (list constr))))) + +(define (parse-constr) + (save-parser-context + (let ((saved-excursion (save-scanner-state))) + (token-case + (consym/paren + (parse-prefix-constr)) + (else + (let ((type1 (parse-btype)) + (anns (parse-constr-annotations))) + (token-case + (conop + (parse-infix-constr (tuple type1 anns))) + (else + (restore-excursion saved-excursion) + (parse-prefix-constr))))))))) + +(define (parse-prefix-constr) + (token-case + (con + (let* ((con (con->ast)) + (types (parse-constr-type-list))) + (make constr (constructor con) (types types)))) + (else + (signal-missing-token "<con>" "constrs list")))) + +(define (parse-constr-type-list) + (token-case + (atype-start + (let* ((atype (parse-atype)) + (anns (parse-constr-annotations))) + (cons (tuple atype anns) + (parse-constr-type-list)))) + (else '()))) + +(define (parse-infix-constr t+a1) + (let* ((con (conop->ast)) + (type2 (parse-btype)) + (anns (parse-constr-annotations))) + (make constr (constructor con) (types (list t+a1 (tuple type2 anns)))))) + +(define (parse-class-list) + (token-case + (tycon (let ((class (class->ast))) + (token-case + (\, (cons class (parse-class-list))) + (\) (list class)) + (else (signal-missing-token "`)' or `,'" "deriving clause"))))) + (else (signal-missing-token "<tycon>" "deriving clause")))) + +(define (parse-constr-annotations) + (token-case + ((begin-annotation no-advance) + (let ((annotations (parse-annotations))) + (append annotations (parse-constr-annotations)))) + (else '()))) + +(define (parse-synonym-decl) + (save-parser-context + (let* ((sig (parse-signature)) + (contexts (signature-context sig)) + (simple (signature-type sig))) + (check-simple simple '#t "type synonym declaration") + (when (not (null? contexts)) + (signal-no-context-in-synonym)) + (require-token = (signal-missing-token "`='" "type synonym declaration")) + (let ((body (parse-type))) + (make synonym-decl (simple simple) (body body)))))) + +(define (signal-no-context-in-synonym) + (parser-error 'no-context-in-synonym + "Context is not permitted in type synonym declaration.")) + +(define (parse-class-decl) + (save-parser-context + (let ((supers (parse-optional-context))) + (token-case + (tycon + (let ((class (class->ast))) + (token-case + (tyvar + (let* ((class-var (token->symbol)) + (decls (parse-where-decls))) + (make class-decl (class class) (super-classes supers) + (class-var class-var) (decls decls)))) + (else + (signal-missing-token "<tyvar>" "class declaration"))))) + (else (signal-missing-token "<tycon>" "class declaration")))))) + +(define (parse-instance-decl interface?) + (save-parser-context + (let ((contexts (parse-optional-context)) + (decls '())) + (token-case + (tycon + (let* ((class (class->ast)) + (simple (parse-type))) + (when (not interface?) + (setf decls (parse-where-decls))) + (check-simple simple '#f "instance declaration") + (make instance-decl (context contexts) (class class) + (simple simple) (decls decls)))) + (else (signal-missing-token "<tycon>" "instance declaration")))))) diff --git a/prec/README b/prec/README new file mode 100644 index 0000000..ea455c4 --- /dev/null +++ b/prec/README @@ -0,0 +1,2 @@ +This directory contains the code walker for the scoping and +precedence parsing phase of the compiler. diff --git a/prec/prec-parse.scm b/prec/prec-parse.scm new file mode 100644 index 0000000..9df06a6 --- /dev/null +++ b/prec/prec-parse.scm @@ -0,0 +1,253 @@ +;;; prec-parse.scm -- do precedence parsing of expressions and patterns +;;; +;;; author : John & Sandra +;;; date : 04 Feb 1992 +;;; +;;; + + +;;; ================================================================== +;;; Handling for pp-exp-list +;;; ================================================================== + +;;; This function is called during the scope phase after all of the +;;; exps in a pp-exp-list have already been walked. Basically, the +;;; purpose is to turn the original pp-exp-list into something else. +;;; Look for the section cases first and treat them specially. + +;;; Sections are handled by inserting a magic cookie (void) into the +;;; list where the `missing' operand of the section would be and then +;;; making sure the cookie stays at the top. + +;;; Unary minus needs checking to avoid things like a*-a. + +(define (massage-pp-exp-list exps) + (let* ((first-term (car exps)) + (last-term (car (last exps))) + (type (cond ((infix-var-or-con? first-term) 'section-l) + ((infix-var-or-con? last-term) 'section-r) + (else 'exp))) + (exps1 (cond ((eq? type 'section-l) + (cons (make void) exps)) + ((eq? type 'section-r) + (append exps (list (make void)))) + (else exps))) + (parsed-exp (parse-pp-list '#f exps1))) + (if (eq? type 'exp) + parsed-exp + (if (or (not (app? parsed-exp)) + (not (app? (app-fn parsed-exp)))) + (begin + (signal-section-precedence-conflict + (if (eq? type 'section-l) first-term last-term)) + (make void)) + (let ((rhs (app-arg parsed-exp)) + (op (app-fn (app-fn parsed-exp))) + (lhs (app-arg (app-fn parsed-exp)))) + (if (eq? type 'section-l) + (if (void? lhs) + (make section-l (op op) (exp rhs)) + (begin + (signal-section-precedence-conflict first-term) + (make void))) + (if (void? rhs) + (make section-r (op op) (exp lhs)) + (begin + (signal-section-precedence-conflict last-term) + (make void))))))))) + + +;;; ================================================================== +;;; Handling for pp-pat-list +;;; ================================================================== + +;;; In this case, we have to do an explicit walk of the pattern looking +;;; at all of its subpatterns. +;;; ** This is a crock - the scope walker needs fixing. + +(define (massage-pattern pat) + (cond ((is-type? 'as-pat pat) + (setf (as-pat-pattern pat) (massage-pattern (as-pat-pattern pat))) + pat) + ((is-type? 'irr-pat pat) + (setf (irr-pat-pattern pat) (massage-pattern (irr-pat-pattern pat))) + pat) + ((is-type? 'plus-pat pat) + (setf (plus-pat-pattern pat) (massage-pattern (plus-pat-pattern pat))) + pat) + ((is-type? 'pcon pat) + (when (eq? (pcon-con pat) *undefined-def*) + (setf (pcon-con pat) (lookup-toplevel-name (pcon-name pat)))) + (setf (pcon-pats pat) (massage-pattern-list (pcon-pats pat))) + pat) + ((is-type? 'list-pat pat) + (setf (list-pat-pats pat) (massage-pattern-list (list-pat-pats pat))) + pat) + ((is-type? 'pp-pat-list pat) + (parse-pp-list '#t (massage-pattern-list (pp-pat-list-pats pat)))) + (else + pat))) + +(define (massage-pattern-list pats) + (map (function massage-pattern) pats)) + + +;;; ================================================================== +;;; Shared support +;;; ================================================================== + +;;; This is the main routine. + +(define (parse-pp-list pattern? l) + (mlet (((stack terms) (push-pp-stack '() l))) + (pp-parse-next-term pattern? stack terms))) + +(define (pp-parse-next-term pattern? stack terms) + (if (null? terms) + (reduce-complete-stack pattern? stack) + (let ((stack (reduce-stronger-ops pattern? stack (car terms)))) + (mlet (((stack terms) + (push-pp-stack (cons (car terms) stack) (cdr terms)))) + (pp-parse-next-term pattern? stack terms))))) + +(define (reduce-complete-stack pattern? stack) + (if (pp-stack-op-empty? stack) + (car stack) + (reduce-complete-stack pattern? (reduce-pp-stack pattern? stack)))) + +(define (reduce-pp-stack pattern? stack) + (let ((term (car stack)) + (op (cadr stack))) + (if pattern? + (cond ((pp-pat-plus? op) + (let ((lhs (caddr stack))) + (cond ((or (not (const-pat? term)) + (and (not (var-pat? lhs)) + (not (wildcard-pat? lhs)))) + (signal-plus-precedence-conflict term) + (cddr stack)) + (else + (cons (make plus-pat (pattern lhs) + (k (integer-const-value + (const-pat-value term)))) + (cdddr stack)))))) + ((pp-pat-negated? op) + (cond ((const-pat? term) + (let ((v (const-pat-value term))) + (if (integer-const? v) + (setf (integer-const-value v) + (- (integer-const-value v))) + (setf (float-const-numerator v) + (- (float-const-numerator v))))) + (cons term (cddr stack))) + (else + (signal-minus-precedence-conflict term) + (cons term (cddr stack))))) + (else + (setf (pcon-pats op) (list (caddr stack) term)) + (cons op (cdddr stack)))) + (cond ((negate? op) + (cons (**app (**var/def (core-symbol "negate")) term) + (cddr stack))) + (else + (cons (**app op (caddr stack) term) (cdddr stack))))))) + +(define (pp-stack-op-empty? stack) + (null? (cdr stack))) + +(define (top-stack-op stack) + (cadr stack)) + +(define (push-pp-stack stack terms) + (let ((term (car terms))) + (if (or (negate? term) (pp-pat-negated? term)) + (begin + (when (and stack (stronger-op? (car stack) term)) + (unary-minus-prec-conflict term)) + (push-pp-stack (cons term stack) (cdr terms))) + (values (cons term stack) (cdr terms))))) + +(define (reduce-stronger-ops pattern? stack op) + (cond ((pp-stack-op-empty? stack) stack) + ((stronger-op? (top-stack-op stack) op) + (reduce-stronger-ops pattern? (reduce-pp-stack pattern? stack) op)) + (else stack))) + +(define (stronger-op? op1 op2) + (let ((fixity1 (get-op-fixity op1)) + (fixity2 (get-op-fixity op2))) + (cond ((> (fixity-precedence fixity1) (fixity-precedence fixity2)) + '#t) + ((< (fixity-precedence fixity1) (fixity-precedence fixity2)) + '#f) + (else + (let ((a1 (fixity-associativity fixity1)) + (a2 (fixity-associativity fixity2))) + (if (eq? a1 a2) + (cond ((eq? a1 'l) + '#t) + ((eq? a1 'r) + '#f) + (else + (signal-precedence-conflict op1 op2) + '#t)) + (begin + (signal-precedence-conflict op1 op2) + '#t)))) + ))) + +(define (get-op-fixity op) + (cond ((var-ref? op) + (pp-get-var-fixity (var-ref-var op))) + ((con-ref? op) + (pp-get-con-fixity (con-ref-con op))) + ((pcon? op) + (pp-get-con-fixity (pcon-con op))) + ((or (negate? op) (pp-pat-negated? op)) + (pp-get-var-fixity (core-symbol "-"))) + ((pp-pat-plus? op) + (pp-get-var-fixity (core-symbol "+"))) + (else + (error "Bad op ~s in pp-parse." op)))) + +(define (pp-get-var-fixity def) + (if (eq? (var-fixity def) '#f) + default-fixity + (var-fixity def))) + +(define (pp-get-con-fixity def) + (if (eq? (con-fixity def) '#f) + default-fixity + (con-fixity def))) + +;;; Error handlers + +(define (signal-section-precedence-conflict op) + (phase-error 'section-precedence-conflict + "Operators in section body have lower precedence than section operator ~A." + op)) + +(define (signal-precedence-conflict op1 op2) + (phase-error 'precedence-conflict + "The operators ~s and ~s appear consecutively, but they have the same~%~ + precedence and are not either both left or both right associative.~% + You must add parentheses to avoid a precedence conflict." + op1 op2)) + +(define (signal-plus-precedence-conflict term) + (phase-error 'plus-precedence-conflict + "You need to put parentheses around the plus-pattern ~a~%~ + to avoid a precedence conflict." + term)) + +(define (signal-minus-precedence-conflict arg) + (phase-error 'minus-precedence-conflict + "You need to put parentheses around the negative literal ~a~%~ + to avoid a precedence conflict." + arg)) + +(define (unary-minus-prec-conflict arg) + (recoverable-error 'minus-precedence-conflict + "Operator ~A too strong for unary minus - add parens please!~%" + arg)) + diff --git a/prec/prec.scm b/prec/prec.scm new file mode 100644 index 0000000..a7948f2 --- /dev/null +++ b/prec/prec.scm @@ -0,0 +1,18 @@ +;;; prec.scm -- module definition for scoping/precedence-parsing phase +;;; +;;; author : Sandra Loosemore +;;; date : 13 Feb 1992 +;;; + + +(define-compilation-unit prec + (source-filename "$Y2/prec/") + (require ast haskell-utils) + (unit scope + (source-filename "scope.scm")) + (unit prec-parse + (source-filename "prec-parse.scm"))) + + + + diff --git a/prec/scope.scm b/prec/scope.scm new file mode 100644 index 0000000..e57ed64 --- /dev/null +++ b/prec/scope.scm @@ -0,0 +1,367 @@ +;;; scope.scm -- variable scoping and precedence parsing phase +;;; +;;; author : John & Sandra +;;; date : 11 Feb 1992 +;;; +;;; + + +;;;=================================================================== +;;; Basic support +;;;=================================================================== + +(define (scope-modules modules) + (walk-modules modules + (lambda () + (setf (module-decls *module*) (scope-ast-decls (module-decls *module*))) + (dolist (a (module-annotations *module*)) +;;; This is currently bogus since it assumes only vars are annotated. + (when (annotation-decl? a) + (dolist (n (annotation-decl-names a)) + (let ((v (table-entry *symbol-table* n))) + (when (or (eq? v '#f) (not (var? v))) + (fatal-error 'unknown-annotation-name + "~A: not a var in annotation decl~%" n)) + (when (not (eq? (def-module v) *module-name*)) + (fatal-error 'non-local-name-in-annotation + "~A: not a local var in annotation decl~%" n)) + (setf (var-annotations v) + (append (var-annotations v) + (annotation-decl-annotations a)))))))))) + +;;; Define the basic walker and some helper functions. + +(define-walker scope ast-td-scope-walker) + +(define (scope-ast-1 x env) +; (call-walker scope x env)) + (remember-context x + (call-walker scope x env))) + + +(define (scope-ast/list l env) + (scope-ast/list-aux l env) + l) + +(define (scope-ast/list-aux l env) + (when (not (null? l)) + (setf (car l) (scope-ast-1 (car l) env)) + (scope-ast/list-aux (cdr l) env))) + +;;; This filters out signdecls from decl lists. These declarations are moved +;;; into the var definitions. + +(define (scope-ast/decl-list l env) + (if (null? l) + '() + (let ((x (scope-ast-1 (car l) env)) + (rest (scope-ast/decl-list (cdr l) env))) + (if (or (annotation-decls? x) + (and (signdecl? x) + (not (eq? (module-type *module*) 'interface)))) + rest + (begin + (setf (car l) x) + (setf (cdr l) rest) + l))))) + +;;; This is the main entry point. It is called by the driver +;;; on each top-level decl in the module. + +(define (scope-ast-decls x) + (let ((result (scope-ast/decl-list x '()))) +; (pprint result) ;*** debug + result)) + + +;;; All top-level names are entered in the *symbol-table* hash table. +;;; This is done by the import/export phase of the compiler before +;;; we get here. +;;; The env is a list of a-lists that associates locally-defined names with +;;; their definitions. Each nested a-list corresponds to a "level" or +;;; scope. +;;; *** If many variables are being added in each scope, it might be +;;; *** better to use a table instead of an alist to represent each contour. + +(define (lookup-name name env) + (if (null? env) + (lookup-toplevel-name name) + (let ((info (assq name (car env)))) + (if info + (cdr info) + (lookup-name name (cdr env)))))) + + +;;; Some kinds of names (e.g. type definitions) appear only at top-level, +;;; so use this to look for them directly. + +(define (lookup-toplevel-name name) + (or (resolve-toplevel-name name) + (begin + (signal-undefined-symbol name) + *undefined-def*))) + + +;;; Some kinds of lookups (e.g., matching a signature declaration) +;;; require that the name be defined in the current scope and not +;;; an outer one. Use this function. + +(define (lookup-local-name name env) + (if (null? env) + (lookup-toplevel-name name) + (let ((info (assq name (car env)))) + (if info + (cdr info) + (begin + (signal-undefined-local-symbol name) + *undefined-def*))))) + + +;;; Add local declarations to the environment, returning a new env. +;;; Do not actually walk the local declarations here. + +(define *scope-info* '()) + +(define (add-local-declarations decls env) + (if (null? decls) + env + (let ((contour '())) + (dolist (d decls) + (if (is-type? 'valdef d) + (setf contour + (add-bindings (collect-pattern-vars (valdef-lhs d)) + contour)))) + (cons contour env)))) + + +;;; Similar, but for adding lambda and function argument bindings to the +;;; environment. + +(define (add-pattern-variables patterns env) + (if (null? patterns) + env + (let ((contour '())) + (dolist (p patterns) + (setf contour (add-bindings (collect-pattern-vars p) contour))) + (cons contour env)))) + + +;;; Given a list of var-refs, create defs for them and add them to +;;; the local environment. +;;; Also check to see that there are no duplicates. + +(define (add-bindings var-refs contour) + (dolist (v var-refs) + (when (eq? (var-ref-var v) *undefined-def*) + (let* ((name (var-ref-name v)) + (def (create-local-definition name))) + (setf (var-ref-var v) def) + (if (assq name contour) + (signal-multiple-bindings name) + (push (cons name def) contour))))) + contour) + + +;;; Error signalling utilities. + +(define (signal-undefined-local-symbol name) + (phase-error 'undefined-local-symbol + "The name ~a has no definition in the current scope." + name)) + +(define (signal-multiple-signatures name) + (phase-error 'multiple-signatures + "There are multiple signatures for the name ~a." + name)) + +(define (signal-multiple-bindings name) + (phase-error 'multiple-bindings + "The name ~a appears more than once in a function or pattern binding." + name)) + + + +;;;=================================================================== +;;; Default traversal methods +;;;=================================================================== + + +(define-local-syntax (make-scope-code slot type) + (let ((stype (sd-type slot)) + (sname (sd-name slot))) + (cond ((and (symbol? stype) + (or (eq? stype 'exp) + (subtype? stype 'exp))) + `(setf (struct-slot ',type ',sname object) + (scope-ast-1 (struct-slot ',type ',sname object) env))) + ((and (pair? stype) + (eq? (car stype) 'list) + (symbol? (cadr stype)) + (or (eq? (cadr stype) 'exp) + (subtype? (cadr stype) 'exp))) + `(setf (struct-slot ',type ',sname object) + (scope-ast/list (struct-slot ',type ',sname object) env))) + (else +; (format '#t "Scope: skipping slot ~A in ~A~%" +; (sd-name slot) +; type) + '#f)))) + + +(define-modify-walker-methods scope + (guarded-rhs ; exp slots + if ; exp slots + app ; exp slots + integer-const float-const char-const string-const ; no slots + list-exp ; (list exp) slot + sequence sequence-to sequence-then sequence-then-to ; exp slots + section-l section-r ; exp slots + omitted-guard overloaded-var-ref ; no slots + negate ; no slots + sel + prim-definition + con-number cast + ) + (object env) + make-scope-code) + + +;;;=================================================================== +;;; valdef-structs +;;;=================================================================== + + +;;; Signature declarations must appear at the same level as the names +;;; they apply to. There must not be more than one signature declaration +;;; applying to a given name. + +(define-walker-method scope signdecl (object env) + (let ((signature (signdecl-signature object))) + (resolve-signature signature) + (let ((gtype (ast->gtype (signature-context signature) + (signature-type signature)))) + (dolist (v (signdecl-vars object)) + (when (eq? (var-ref-var v) *undefined-def*) + (setf (var-ref-var v) + (lookup-local-name (var-ref-name v) env))) + (let ((def (var-ref-var v))) + (when (not (eq? def *undefined-def*)) + ;; The lookup-local-name may fail if there is a program error. + ;; In that case, skip this. + (if (var-signature def) + (signal-multiple-signatures (var-ref-name v)) + (setf (var-signature def) gtype)))))) + object)) + +;;; This attaches annotations to locally defined vars in the same +;;; manner as signdecl annotations. + +(define-walker-method scope annotation-decls (object env) + (let ((anns (annotation-decls-annotations object))) + (dolist (a anns) + (cond ((annotation-value? a) + (recoverable-error 'unknown-annotation "Unknown annotation: ~A" a)) + ((annotation-decl? a) + (dolist (v (annotation-decl-names a)) + (let ((name (lookup-local-name v env))) + (when (not (eq? name *undefined-def*)) + (setf (var-annotations name) + (append (var-annotations name) + (annotation-decl-annotations a)))))))))) + object) + +(define-walker-method scope exp-sign (object env) + (resolve-signature (exp-sign-signature object)) + (setf (exp-sign-exp object) (scope-ast-1 (exp-sign-exp object) env)) + object) + +;;; By the time we get to walking a valdef, all the variables it +;;; declares have been entered into the environment. All we need to +;;; do is massage the pattern and recursively walk the definitions. + +(define-walker-method scope valdef (object env) + (setf (valdef-module object) *module-name*) + (setf (valdef-lhs object) (massage-pattern (valdef-lhs object))) + (setf (valdef-definitions object) + (scope-ast/list (valdef-definitions object) env)) + object) + + +;;; For a single-fun-def, do the where-decls first, and then walk the +;;; rhs in an env that includes both the where-decls and the args. + +(define-walker-method scope single-fun-def (object env) + (setf env (add-pattern-variables (single-fun-def-args object) env)) + (setf env (add-local-declarations (single-fun-def-where-decls object) env)) + (setf (single-fun-def-where-decls object) + (scope-ast/decl-list (single-fun-def-where-decls object) env)) + (setf (single-fun-def-args object) + (massage-pattern-list (single-fun-def-args object))) + (setf (single-fun-def-rhs-list object) + (scope-ast/list (single-fun-def-rhs-list object) env)) + object) + + +;;;=================================================================== +;;; exp-structs +;;;=================================================================== + +(define-walker-method scope lambda (object env) + (setf env (add-pattern-variables (lambda-pats object) env)) + (setf (lambda-pats object) (massage-pattern-list (lambda-pats object))) + (setf (lambda-body object) (scope-ast-1 (lambda-body object) env)) + object) + +(define-walker-method scope let (object env) + (setf env (add-local-declarations (let-decls object) env)) + (setf (let-decls object) (scope-ast/decl-list (let-decls object) env)) + (setf (let-body object) (scope-ast-1 (let-body object) env)) + object) + + +;;; Case alts are treated very much like single-fun-defs. + +(define-walker-method scope case (object env) + (setf (case-exp object) (scope-ast-1 (case-exp object) env)) + (dolist (a (case-alts object)) + (let ((env (add-pattern-variables (list (alt-pat a)) env))) + (setf env (add-local-declarations (alt-where-decls a) env)) + (setf (alt-where-decls a) + (scope-ast/decl-list (alt-where-decls a) env)) + (setf (alt-pat a) (massage-pattern (alt-pat a))) + (setf (alt-rhs-list a) + (scope-ast/list (alt-rhs-list a) env)))) + object) + + +(define-walker-method scope var-ref (object env) + (when (eq? (var-ref-var object) *undefined-def*) + (setf (var-ref-var object) + (lookup-name (var-ref-name object) env))) + object) + +(define-walker-method scope con-ref (object env) + (declare (ignore env)) + (when (eq? (con-ref-con object) *undefined-def*) + (setf (con-ref-con object) + (lookup-toplevel-name (con-ref-name object)))) + object) + +(define-walker-method scope list-comp (object env) + (dolist (q (list-comp-quals object)) + (cond ((is-type? 'qual-generator q) + (setf (qual-generator-exp q) + (scope-ast-1 (qual-generator-exp q) env)) + (setf env + (add-pattern-variables (list (qual-generator-pat q)) env)) + (setf (qual-generator-pat q) + (massage-pattern (qual-generator-pat q)))) + ((is-type? 'qual-filter q) + (setf (qual-filter-exp q) + (scope-ast-1 (qual-filter-exp q) env))))) + (setf (list-comp-exp object) (scope-ast-1 (list-comp-exp object) env)) + object) + +(define-walker-method scope pp-exp-list (object env) + (massage-pp-exp-list (scope-ast/list (pp-exp-list-exps object) env))) + diff --git a/printers/README b/printers/README new file mode 100644 index 0000000..36530ed --- /dev/null +++ b/printers/README @@ -0,0 +1,19 @@ +This directory contains print routines for the structures defined in +the ast/ directory. + +The global *print-structure* controls printing of objects in the +structure system. Values are: + haskell -- Prints haskell format expressions from ast + struct -- Prints the raw structs (with circularity check) + top -- Prints top level only of the struct + +The file defs.scm has the basic hooks to the printer mechanism. The +idea is that when *print-structure* is 'haskell, the print function stored +in the type descriptor will get used. If there isn't a print function, +or if *print-structure* is false, then the thing will print out in +some generic way that's good for debugging purposes. + +The macro define-printer is used to associate a print function with a +structure type. Since these can be defined on the fly, the print +dispatching routine has to look up the inheritance chain of type +descriptors looking for the first inherited type that has a printer. diff --git a/printers/print-exps.scm b/printers/print-exps.scm new file mode 100644 index 0000000..2a9d89b --- /dev/null +++ b/printers/print-exps.scm @@ -0,0 +1,410 @@ +;;; print-exps.scm -- print expression AST structures +;;; +;;; author : Sandra Loosemore +;;; date : 10 Jan 1992 +;;; +;;; This file corresponds to ast/exp-structs.scm. +;;; + +(define-ast-printer lambda (object xp) + (with-ast-block (xp) + (write-string "\\ " xp) + (write-delimited-list + (lambda-pats object) xp (function write-apat) "" "" "") + (write-string " ->" xp) + (write-whitespace xp) + (write (lambda-body object) xp))) + +(define-ast-printer let (object xp) + (write-lets-body "let " (let-decls object) (let-body object) xp)) + +(define (write-lets-body let-name decls body xp) + (pprint-logical-block (xp '() "" "") ; no extra indentation + (write-string let-name xp) + (write-layout-rule (remove-recursive-grouping decls) xp (function write)) + (write-whitespace xp) + (write-string "in " xp) + (write body xp))) + +(define-ast-printer if (object xp) + (with-ast-block (xp) + (write-string "if " xp) + (write (if-test-exp object) xp) + (write-whitespace xp) + (with-ast-block (xp) + (write-string "then" xp) + (write-whitespace xp) + (write (if-then-exp object) xp)) + (write-whitespace xp) + (with-ast-block (xp) + (write-string "else" xp) + (write-whitespace xp) + (write (if-else-exp object) xp)))) + +(define-ast-printer case (object xp) + (with-ast-block (xp) + (write-string "case " xp) + (write (case-exp object) xp) + (write-string " of" xp) + (write-whitespace xp) + (write-layout-rule (case-alts object) xp (function write)))) + +(define-ast-printer alt (object xp) + (with-ast-block (xp) + (write (alt-pat object) xp) + (dolist (r (alt-rhs-list object)) + (write-whitespace xp) + (unless (is-type? 'omitted-guard (guarded-rhs-guard r)) + (write-string "| " xp) + (write (guarded-rhs-guard r) xp)) + (write-string " -> " xp) + (write (guarded-rhs-rhs r) xp)) + (write-wheredecls (alt-where-decls object) xp))) + +(define-ast-printer exp-sign (object xp) + (with-ast-block (xp) + (write (exp-sign-exp object) xp) + (write-string " ::" xp) + (write-whitespace xp) + (write (exp-sign-signature object) xp))) + +;;; Have to look for application of special-case constructors before +;;; doing the normal prefix/infix cases. + +(define-ast-printer app (object xp) + (let* ((fn (app-fn object)) + (arg (app-arg object))) + (multiple-value-bind (con args) (extract-constructor fn (list arg)) + (cond ;; ((eq? con (core-symbol "UnitConstructor")) + ;; *** Does this ever happen? + ;; (write-string "()" xp)) + ((and con (is-tuple-constructor? con)) + (write-commaized-list args xp)) + (else + (multiple-value-bind (fixity op arg1) (extract-infix-operator fn) + (if fixity + (write-infix-application fixity op arg1 arg xp) + (write-prefix-application fn arg xp)))) + )))) + + +(define (write-infix-application fixity op arg1 arg2 xp) + (let ((precedence (fixity-precedence fixity)) + (associativity (fixity-associativity fixity))) + (with-ast-block (xp) + (write-exp-with-precedence + arg1 (1+ precedence) (if (eq? associativity 'l) 'l '#f) xp) + (write-whitespace xp) + (write op xp) + (write-whitespace xp) + (write-exp-with-precedence + arg2 (1+ precedence) (if (eq? associativity 'r) 'r '#f) xp)))) + +(define (write-prefix-application fn arg xp) + (with-ast-block (xp) + (write-exp-with-precedence fn 10 '#f xp) + (write-whitespace xp) + (write-aexp arg xp))) + + +;;; Write an expression with at least the given precedence. If the +;;; actual precedence is lower, put parens around it. + +(define *print-exp-parens* '#f) + +(define (write-exp-with-precedence exp precedence associativity xp) + (if *print-exp-parens* + (write-aexp exp xp) + (if (< (precedence-of-exp exp associativity) precedence) + (begin + (write-char #\( xp) + (write exp xp) + (write-char #\) xp)) + (write exp xp)))) + + +;;; Similar to the above: write an aexp. + +(define *print-original-code* '#t) + +(define (write-aexp object xp) + (if (is-type? 'save-old-exp object) + (write-aexp (if *print-original-code* + (save-old-exp-old-exp object) + (save-old-exp-new-exp object)) + xp) + (if (or (is-type? 'aexp object) + (pp-exp-list-section? object) + (is-type? 'negate object)) + (write object xp) + (begin + (write-char #\( xp) + (write object xp) + (write-char #\) xp))))) + + +;;; The infix? slot on var-ref and con-ref structs refers to whether +;;; the thing appears as an infix operator or not, not whether the name +;;; has operator or identifier syntax. + +(define-ast-printer var-ref (object xp) + (let ((name (var-ref-name object))) + (if (var-ref-infix? object) + (write-varop name xp) + (write-varid name xp)))) + +(define-ast-printer con-ref (object xp) + (if (eq? (con-ref-con object) (core-symbol "UnitConstructor")) + (write-string "()" xp) + (let ((name (con-ref-name object))) + (if (con-ref-infix? object) + (write-conop name xp) + (write-conid name xp))))) + + +(define-ast-printer integer-const (object xp) + (write (integer-const-value object) xp)) + +(define-ast-printer float-const (object xp) + (let* ((numerator (float-const-numerator object)) + (denominator (float-const-denominator object)) + (exponent (float-const-exponent object)) + (whole (quotient numerator denominator)) + (fraction (remainder numerator denominator))) + (write whole xp) + (write-char #\. xp) + (write-precision-integer fraction denominator xp) + (unless (zero? exponent) + (write-char #\E xp) + (write exponent xp)))) + +(define (write-precision-integer fraction denominator xp) + (cond ((eqv? denominator 1) + ; no fraction + ) + ((eqv? denominator 10) + (write-digit fraction xp)) + (else + (write-digit (quotient fraction 10) xp) + (write-precision-integer (remainder fraction 10) + (quotient denominator 10) + xp)) + )) + +(define (write-digit n xp) + (write-char (string-ref "0123456789" n) xp)) + + +;;; Character and string printers need to handle weird escapes. +;;; Fortunately we can just choose one canonical style for printing +;;; unprintable characters. + +(define-ast-printer char-const (object xp) + (write-char #\' xp) + (write-char-literal (char-const-value object) xp #\') + (write-char #\' xp)) + +(define-ast-printer string-const (object xp) + (write-char #\" xp) + (let ((s (string-const-value object))) + (dotimes (i (string-length s)) + (write-char-literal (string-ref s i) xp #\"))) + (write-char #\" xp)) + +(define (write-char-literal c xp special) + (cond ((eqv? c special) + (write-char #\\ xp) + (write c xp)) + ((eqv? c #\newline) + (write-char #\\ xp) + (write-char #\n xp)) + (else + (let ((code (char->integer c))) + (if (and (>= code 32) (< code 128)) + ;; printing ascii characters + (write-char c xp) + ;; "control" characters print in \ddd notation + (begin + (write-char #\\ xp) + (write code xp))))) + )) + +(define-ast-printer list-exp (object xp) + (write-delimited-list + (list-exp-exps object) xp (function write) "," "[" "]")) + +(define-ast-printer sequence (object xp) + (with-ast-block (xp) + (write-string "[" xp) + (write (sequence-from object) xp) + (write-string "..]" xp))) + +(define-ast-printer sequence-to (object xp) + (with-ast-block (xp) + (write-string "[" xp) + (write (sequence-to-from object) xp) + (write-string " .." xp) + (write-whitespace xp) + (write (sequence-to-to object) xp) + (write-string "]" xp))) + +(define-ast-printer sequence-then (object xp) + (with-ast-block (xp) + (write-string "[" xp) + (write (sequence-then-from object) xp) + (write-string "," xp) + (write-whitespace xp) + (write (sequence-then-then object) xp) + (write-string "..]" xp))) + +(define-ast-printer sequence-then-to (object xp) + (with-ast-block (xp) + (write-string "[" xp) + (write (sequence-then-to-from object) xp) + (write-string "," xp) + (write-whitespace xp) + (write (sequence-then-to-then object) xp) + (write-string " .." xp) + (write-whitespace xp) + (write (sequence-then-to-to object) xp) + (write-string "]" xp))) + +(define-ast-printer list-comp (object xp) + (with-ast-block (xp) + (write-string "[" xp) + (write (list-comp-exp object) xp) + (write-string " |" xp) + (write-whitespace xp) + (write-delimited-list + (list-comp-quals object) xp (function write) "," "" "") + (write-string "]" xp))) + + +(define-ast-printer section-l (object xp) + (let* ((exp (section-l-exp object)) + (op (section-l-op object)) + (fixity (operator-fixity op)) + (precedence (fixity-precedence fixity))) + (with-ast-block (xp) + (write-string "(" xp) + (write op xp) + (write-whitespace xp) + (write-exp-with-precedence exp (1+ precedence) '#f xp) + (write-string ")" xp)))) + +(define-ast-printer section-r (object xp) + (let* ((exp (section-r-exp object)) + (op (section-r-op object)) + (fixity (operator-fixity op)) + (precedence (fixity-precedence fixity))) + (with-ast-block (xp) + (write-string "(" xp) + (write-exp-with-precedence exp (1+ precedence) '#f xp) + (write-whitespace xp) + (write op xp) + (write-string ")" xp)))) + +(define-ast-printer qual-generator (object xp) + (with-ast-block (xp) + (write (qual-generator-pat object) xp) + (write-string " <-" xp) + (write-whitespace xp) + (write (qual-generator-exp object) xp))) + +(define-ast-printer qual-filter (object xp) + (write (qual-filter-exp object) xp)) + + +;;; A pp-exp-list with an op as the first or last element is really +;;; a section. These always get parens and are treated like aexps. +;;; Other pp-exp-lists are treated as exps with precedence 0. +;;; Bleah... Seems like the parser ought to recognize this up front.... +;;; Yeah but I'm lazy ... + +(define-ast-printer pp-exp-list (object xp) + (let ((section? (pp-exp-list-section? object))) + (if section? (write-char #\( xp)) + (write-delimited-list + (pp-exp-list-exps object) xp (function write-aexp) "" "" "") + (if section? (write-char #\) xp)))) + +(define-ast-printer negate (object xp) + (declare (ignore object)) + (write-string "-" xp)) + +(define-ast-printer def (object xp) + (write-string (symbol->string (def-name object)) xp)) + +(define-ast-printer con (object xp) + (write-string (remove-con-prefix (symbol->string (def-name object))) xp)) + +(define-ast-printer con-number (object xp) + (with-ast-block (xp) + (write-string "con-number/" xp) + (write (con-number-type object) xp) + (write-whitespace xp) + (write-aexp (con-number-value object) xp))) + +(define-ast-printer sel (object xp) + (with-ast-block (xp) + (write-string "sel/" xp) + (write (sel-constructor object) xp) + (write-whitespace xp) + (write (sel-slot object) xp) + (write-whitespace xp) + (write-aexp (sel-value object) xp))) + +(define-ast-printer is-constructor (object xp) +(with-ast-block (xp) + (write-string "is-constructor/" xp) + (write (is-constructor-constructor object) xp) + (write-whitespace xp) + (write-aexp (is-constructor-value object) xp))) + +(define-ast-printer void (object xp) + (declare (ignore object)) + (write-string "Void" xp)) + +;;; Special cfn constructs + +(define-ast-printer case-block (object xp) + (with-ast-block (xp) + (write-string "case-block " xp) + (write (case-block-block-name object) xp) + (write-whitespace xp) + (write-layout-rule (case-block-exps object) xp (function write)))) + +(define-ast-printer return-from (object xp) + (with-ast-block (xp) + (write-string "return-from " xp) + (write (return-from-block-name object) xp) + (write-whitespace xp) + (write (return-from-exp object) xp))) + +(define-ast-printer and-exp (object xp) + (with-ast-block (xp) + (write-string "and " xp) + (write-layout-rule (and-exp-exps object) xp (function write)))) + +;;; Expression types used by the type checker. + +(define-ast-printer dict-placeholder (object xp) + (cond ((not (eq? (dict-placeholder-exp object) '#f)) + (write (dict-placeholder-exp object) xp)) + (else + (write-string "%" xp) + (write-string (symbol->string + (def-name (dict-placeholder-class object))) xp)))) + +(define-ast-printer recursive-placeholder (object xp) + (cond ((not (eq? (recursive-placeholder-exp object) '#f)) + (write (recursive-placeholder-exp object) xp)) + (else + (write-varid (def-name (recursive-placeholder-var object)) xp)))) + +;;; This should probably have a flag to allow the dictionary converted code +;;; to be printed during debugging. + +(define-ast-printer save-old-exp (object xp) + (write (save-old-exp-old-exp object) xp)) + diff --git a/printers/print-modules.scm b/printers/print-modules.scm new file mode 100644 index 0000000..2372714 --- /dev/null +++ b/printers/print-modules.scm @@ -0,0 +1,125 @@ +;;; print-modules.scm -- print routines for module-related AST structures +;;; +;;; author : Sandra Loosemore +;;; date : 6 Jan 1992 +;;; +;;; +;;; This file corresponds to the file ast/modules.scm. + +;;; Note: by default, only the module name is printed. To print the +;;; full module, the function print-full-module must be called. + +(define *print-abbreviated-modules* '#t) + +(define-ast-printer module (object xp) + (if *print-abbreviated-modules* + (begin + (write-string "Module " xp) + (write-string (symbol->string (module-name object)) xp)) + (do-print-full-module object xp))) + +(define (print-full-module object . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (dynamic-let ((*print-abbreviated-modules* '#f)) + (pprint object stream)))) + +(define (do-print-full-module object xp) + (dynamic-let ((*print-abbreviated-modules* '#t)) + (let ((modid (module-name object)) + (exports (module-exports object)) + (body (append (module-imports object) + (module-fixities object) + (module-synonyms object) + (module-algdatas object) + (module-classes object) + (module-instances object) + (if (or (not (module-default object)) + (eq? (module-default object) + *standard-module-default*)) + '() + (list (module-default object))) + (module-decls object)))) + (write-string "module " xp) + (write-modid modid xp) + (when (not (null? exports)) + (write-whitespace xp) + (write-commaized-list exports xp)) + (write-wheredecls body xp)))) + +(define-ast-printer import-decl (object xp) + (let ((modid (import-decl-module-name object)) + (mode (import-decl-mode object)) + (specs (import-decl-specs object)) + (renamings (import-decl-renamings object))) + (with-ast-block (xp) + (write-string "import " xp) + (write-modid modid xp) + (if (eq? mode 'all) + (when (not (null? specs)) + (write-whitespace xp) + (write-string "hiding " xp) + (write-commaized-list specs xp)) + (begin + (write-whitespace xp) + (write-commaized-list specs xp))) + (when (not (null? renamings)) + (write-whitespace xp) + (write-string "renaming " xp) + (write-commaized-list renamings xp)) + ))) + +(define-ast-printer entity-module (object xp) + (write-modid (entity-name object) xp) + (write-string ".." xp)) + +(define-ast-printer entity-var (object xp) + (write-varid (entity-name object) xp)) + +(define-ast-printer entity-con (object xp) + (write-tyconid (entity-name object) xp)) + +(define-ast-printer entity-abbreviated (object xp) + (write-tyconid (entity-name object) xp) + (write-string "(..)" xp)) + +(define-ast-printer entity-class (object xp) + (with-ast-block (xp) + (write-tyclsid (entity-name object) xp) + (write-whitespace xp) + (write-delimited-list (entity-class-methods object) xp + (function write-varid) "," "(" ")"))) + +(define-ast-printer entity-datatype (object xp) + (with-ast-block (xp) + (write-tyconid (entity-name object) xp) + (write-whitespace xp) + (write-delimited-list (entity-datatype-constructors object) xp + (function write-conid) "," "(" ")"))) + + +(define-ast-printer renaming (object xp) + (with-ast-block (xp) + (write-varid-conid (renaming-from object) xp) + (write-string " to" xp) + (write-whitespace xp) + (write-varid-conid (renaming-to object) xp))) + +;;; *** Should it omit precedence if it's 9? + +(define-ast-printer fixity-decl (object xp) + (let* ((fixity (fixity-decl-fixity object)) + (associativity (fixity-associativity fixity)) + (precedence (fixity-precedence fixity)) + (ops (fixity-decl-names object))) + (with-ast-block (xp) + (cond ((eq? associativity 'l) + (write-string "infixl " xp)) + ((eq? associativity 'r) + (write-string "infixr " xp)) + ((eq? associativity 'n) + (write-string "infix " xp))) + (write precedence xp) + (write-whitespace xp) + (write-delimited-list ops xp (function write-varop-conop) "," "" "")))) diff --git a/printers/print-ntypes.scm b/printers/print-ntypes.scm new file mode 100644 index 0000000..c018f40 --- /dev/null +++ b/printers/print-ntypes.scm @@ -0,0 +1,61 @@ +;;; These printers deal with ntype structures. + +;;; Too much of this file is copied from print-types! + +(define-ast-printer ntyvar (object xp) + (let ((object (prune object))) + (if (ntyvar? object) + (begin + (write-char #\t xp) + (write (tyvar->number object) xp)) + (write object xp)))) + +;;; Various type special cases have a magic cookie in the def field. + +(define-ast-printer ntycon (object xp) + (let ((tycon (ntycon-tycon object))) + (if (eq? tycon '#f) + (write-string "<Bogus tycon>" xp) + (print-general-tycon tycon (ntycon-args object) object xp)))) + +(define-ast-printer gtype (object xp) + (let ((var 0) + (res '())) + (dolist (classes (gtype-context object)) + (let ((v (gtyvar->symbol var))) + (dolist (class classes) + (push (**context (**class/def class) v) res))) + (incf var)) + (write-contexts (reverse res) xp) + (write (gtype-type object) xp))) + +(define-ast-printer gtyvar (object xp) + (write-string (symbol->string (gtyvar->symbol (gtyvar-varnum object))) xp)) + +(define (gtyvar->symbol n) + (cond ((< n 26) + (list-ref '(|a| |b| |c| |d| |e| |f| |g| + |h| |i| |j| |k| |l| |m| |n| + |o| |p| |q| |r| |s| |t| |u| + |v| |w| |x| |y| |z|) + n)) + (else + (string->symbol (format '#f "g~A" (- n 25)))))) + +(define-ast-printer recursive-type (object xp) + (write (recursive-type-type object) xp)) + +(define (tyvar->number tyvar) + (tyvar->number-1 tyvar (dynamic *printed-tyvars*) 1)) + +(define (tyvar->number-1 tyvar vars n) + (cond ((null? vars) + (setf (dynamic *printed-tyvars*) + (nconc (dynamic *printed-tyvars*) (list tyvar))) + n) + ((eq? tyvar (car vars)) + n) + (else + (tyvar->number-1 tyvar (cdr vars) (1+ n))))) + + diff --git a/printers/print-types.scm b/printers/print-types.scm new file mode 100644 index 0000000..53d3bee --- /dev/null +++ b/printers/print-types.scm @@ -0,0 +1,201 @@ +;;; print-types.scm -- print type-related AST structures +;;; +;;; author : Sandra Loosemore +;;; date : 15 Jan 1991 +;;; +;;; This file corresponds to the stuff in ast/type-structs.scm +;;; + +(define-ast-printer tyvar (object xp) + (write-avarid (tyvar-name object) xp)) + + +;;; Various type special cases have a magic cookie in the def field. + +(define-ast-printer tycon (object xp) + (print-general-tycon (tycon-def object) (tycon-args object) object xp)) + +(define (print-general-tycon def args object xp) + (cond ((eq? def (core-symbol "Arrow")) + (write-arrow-tycon args xp)) + ((eq? def (core-symbol "UnitType")) + (write-unit-tycon xp)) + ((eq? def (core-symbol "List")) + (write-list-tycon args xp)) + ((is-tuple-tycon? def) + (write-tuple-tycon args xp)) + (else + (write-ordinary-tycon def args object xp)))) + +(define (write-arrow-tycon args xp) + (with-ast-block (xp) + (write-btype (car args) xp) + (write-string " ->" xp) + (write-whitespace xp) + (write (cadr args) xp))) + +(define (write-unit-tycon xp) + (write-string "()" xp)) + +(define (write-list-tycon args xp) + (with-ast-block (xp) + (write-char #\[ xp) + (write (car args) xp) + (write-char #\] xp))) + +(define (write-tuple-tycon args xp) + (write-commaized-list args xp)) + +(define (write-ordinary-tycon def args object xp) + (with-ast-block (xp) + (if (tycon? object) + (write-tyconid (tycon-name object) xp) + (write-tyconid (def-name def) xp)) + (when (not (null? args)) + (write-whitespace xp) + (write-delimited-list + args xp (function write-atype) "" "" "")))) + + +;;; All of the special cases above except "Arrow" are atypes, as is +;;; a tyvar or a tycon with no arguments. + +(define (write-atype object xp) + (let ((object (maybe-prune object))) + (if (or (tyvar? object) + (gtyvar? object) + (ntyvar? object) + (is-some-tycon? object + (lambda (def) + (or (eq? def (core-symbol "UnitType")) + (eq? def (core-symbol "List")) + (is-tuple-tycon? def))))) + (write object xp) + (begin + (write-char #\( xp) + (write object xp) + (write-char #\) xp))))) + + +;;; A btype is any type except the arrow tycon. + +(define (write-btype object xp) + (let ((object (maybe-prune object))) + (if (or (and (tycon? object) + (eq? (tycon-def object) (core-symbol "Arrow"))) + (and (ntycon? object) + (eq? (ntycon-tycon object) (core-symbol "Arrow")))) + (begin + (write-char #\( xp) + (write object xp) + (write-char #\) xp)) + (write object xp)))) + +(define (maybe-prune object) + (if (ntyvar? object) + (prune object) + object)) + +(define (is-some-tycon? object fn) + (let ((object (maybe-prune object))) + (or (and (tycon? object) + (or (null? (tycon-args object)) + (funcall fn (tycon-def object)))) + (and (ntycon? object) + (or (null? (ntycon-args object)) + (funcall fn (ntycon-tycon object))))))) + +(define-ast-printer context (object xp) + (with-ast-block (xp) + (write (context-class object) xp) + (write-whitespace xp) + (write-avarid (context-tyvar object) xp))) + +(define-ast-printer signature (object xp) + (write-contexts (signature-context object) xp) + (write (signature-type object) xp)) + +(define (write-contexts contexts xp) + (when (not (null? contexts)) + (if (null? (cdr contexts)) + (write (car contexts) xp) + (write-commaized-list contexts xp)) + (write-string " =>" xp) + (write-whitespace xp))) + +(define-ast-printer synonym-decl (object xp) + (with-ast-block (xp) + (write-string "type " xp) + (write (synonym-decl-simple object) xp) + (write-string " =" xp) + (write-whitespace xp) + (write (synonym-decl-body object) xp))) + +(define-ast-printer data-decl (object xp) + (with-ast-block (xp) + (write-string "data " xp) + (write-contexts (data-decl-context object) xp) + (write (data-decl-simple object) xp) + (write-whitespace xp) + (write-char #\= xp) + (write-whitespace xp) + (write-delimited-list + (data-decl-constrs object) xp (function write) " |" "" "") + (write-whitespace xp) + (let ((deriving (data-decl-deriving object))) + (when (not (null? deriving)) + (write-string "deriving " xp) + (if (null? (cdr deriving)) + (write (car deriving) xp) + (write-commaized-list deriving xp)))))) + +(define-ast-printer constr (object xp) + (if (con-ref-infix? (constr-constructor object)) + (with-ast-block (xp) + (write-btype (car (constr-types object)) xp) + (write-whitespace xp) + (write (constr-constructor object) xp) + (write-whitespace xp) + (write-btype (cadr (constr-types object)) xp)) + (with-ast-block (xp) + (write (constr-constructor object) xp) + (when (not (null? (constr-types object))) + (write-whitespace xp) + (write-delimited-list + (constr-types object) xp (function write-atype) "" "" ""))))) + + +(define-ast-printer class-decl (object xp) + (with-ast-block (xp) + (write-string "class " xp) + (write-contexts (class-decl-super-classes object) xp) + (write (class-decl-class object) xp) + (write-whitespace xp) + (write-avarid (class-decl-class-var object) xp) + (write-wheredecls (class-decl-decls object) xp))) + +(define-ast-printer instance-decl (object xp) + (with-ast-block (xp) + (write-string "instance " xp) + (write-contexts (instance-decl-context object) xp) + (write (instance-decl-class object) xp) + (write-whitespace xp) + (write-atype (instance-decl-simple object) xp) + (write-wheredecls (instance-decl-decls object) xp))) + + +;;; Don't print out default decl if the value is the default. + +(define-ast-printer default-decl (object xp) + (with-ast-block (xp) + (write-string "default " xp) + (let ((types (default-decl-types object))) + (if (null? (cdr types)) + (write (car types) xp) + (write-commaized-list types xp))))) + +(define-ast-printer class-ref (object xp) + (write-tyclsid (class-ref-name object) xp)) + + + diff --git a/printers/print-valdefs.scm b/printers/print-valdefs.scm new file mode 100644 index 0000000..908adea --- /dev/null +++ b/printers/print-valdefs.scm @@ -0,0 +1,180 @@ +;;; print-valdefs.scm -- print AST structures for local declarations +;;; +;;; author : Sandra Loosemore +;;; date : 14 Jan 1992 +;;; +;;; This file corresponds to ast/valdef-structs.scm. +;;; +;;; + + + +(define-ast-printer signdecl (object xp) + (with-ast-block (xp) + (write-delimited-list (signdecl-vars object) xp (function write) "," "" "") + (write-string " ::" xp) + (write-whitespace xp) + (write (signdecl-signature object) xp))) + + +;;; This interacts with the layout rule stuff. See util.scm. + +(define-ast-printer valdef (object xp) + (let ((lhs (valdef-lhs object)) + (definitions (valdef-definitions object))) + (write-definition lhs (car definitions) xp) + (dolist (d (cdr definitions)) + (if (dynamic *print-pretty*) + (pprint-newline 'mandatory xp) + (write-string "; " xp)) + (write-definition lhs d xp)))) + + +(define (write-definition lhs d xp) + (with-ast-block (xp) + (let ((args (single-fun-def-args d)) + (rhs-list (single-fun-def-rhs-list d)) + (where-decls (single-fun-def-where-decls d)) + (infix? (single-fun-def-infix? d))) + (write-lhs lhs args infix? xp) + (write-rhs rhs-list xp) + (write-wheredecls where-decls xp) + ))) + +(define (write-lhs lhs args infix? xp) + (cond ((null? args) + ;; pattern definition + (write-apat lhs xp) + ) + ;; If there are args, the lhs is always a var-pat pointing to a + ;; var-ref. The infix? slot from the single-fun-def must override + ;; the slot on the var-ref, since there can be a mixture of + ;; infix and prefix definitions for the same lhs. + (infix? + ;; operator definition + (when (not (null? (cddr args))) + (write-char #\( xp)) + (write-apat (car args) xp) + (write-whitespace xp) + (write-varop (var-ref-name (var-pat-var lhs)) xp) + (write-whitespace xp) + (write-apat (cadr args) xp) + (when (not (null? (cddr args))) + (write-char #\) xp) + (write-whitespace xp) + (write-delimited-list (cddr args) xp (function write-apat) + "" "" ""))) + (else + ;; normal prefix function definition + (write-varid (var-ref-name (var-pat-var lhs)) xp) + (write-whitespace xp) + (write-delimited-list args xp (function write-apat) "" "" "")) + )) + +(define (write-rhs rhs-list xp) + (let ((guard (guarded-rhs-guard (car rhs-list))) + (rhs (guarded-rhs-rhs (car rhs-list)))) + (when (not (is-type? 'omitted-guard guard)) + (write-string " | " xp) + (write guard xp)) + (write-string " =" xp) + (write-whitespace xp) + (write rhs xp) + (when (not (null? (cdr rhs-list))) + (write-newline xp) + (write-rhs (cdr rhs-list) xp)))) + + +;;; Pattern printers + + +;;; As per jcp suggestion, don't put whitespace after @; line break comes +;;; before, not after (as is the case for other infix-style punctuation). + +(define-ast-printer as-pat (object xp) + (with-ast-block (xp) + (write (as-pat-var object) xp) + (write-whitespace xp) + (write-string "@" xp) + (write-apat (as-pat-pattern object) xp))) + +(define (write-apat pat xp) + (if (or (is-type? 'apat pat) + (is-type? 'pp-pat-plus pat) ; hack per jcp + (and (is-type? 'pcon pat) + (or (null? (pcon-pats pat)) + (eq? (pcon-con pat) (core-symbol "UnitConstructor")) + (is-tuple-constructor? (pcon-con pat))))) + (write pat xp) + (begin + (write-char #\( xp) + (write pat xp) + (write-char #\) xp)))) + +(define-ast-printer irr-pat (object xp) + (write-string "~" xp) + (write-apat (irr-pat-pattern object) xp)) + +(define-ast-printer var-pat (object xp) + (write (var-pat-var object) xp)) + +(define-ast-printer wildcard-pat (object xp) + (declare (ignore object)) + (write-char #\_ xp)) + +(define-ast-printer const-pat (object xp) + (write (const-pat-value object) xp)) + +(define-ast-printer plus-pat (object xp) + (write (plus-pat-pattern object) xp) + (write-string " + " xp) + (write (plus-pat-k object) xp)) + + + +(define-ast-printer pcon (object xp) + (let ((name (pcon-name object)) + (pats (pcon-pats object)) + (infix? (pcon-infix? object)) + (def (pcon-con object))) + (cond ((eq? def (core-symbol "UnitConstructor")) + (write-string "()" xp)) + ((is-tuple-constructor? def) + (write-commaized-list pats xp)) + ((null? pats) + (if infix? + ;; infix pcon with no arguments can happen inside pp-pat-list + ;; before precedence parsing happens. + (write-conop name xp) + (write-conid name xp))) + (infix? + ;; This could be smarter about dealing with precedence of patterns. + (with-ast-block (xp) + (write-apat (car pats) xp) + (write-whitespace xp) + (write-conop name xp) + (write-whitespace xp) + (write-apat (cadr pats) xp))) + (else + (with-ast-block (xp) + (write-conid name xp) + (write-whitespace xp) + (write-delimited-list pats xp (function write-apat) "" "" ""))) + ))) + +(define-ast-printer list-pat (object xp) + (write-delimited-list + (list-pat-pats object) xp (function write) "," "[" "]")) + +(define-ast-printer pp-pat-list (object xp) + (write-delimited-list (pp-pat-list-pats object) xp (function write-apat) + "" "" "")) + +(define-ast-printer pp-pat-plus (object xp) + (declare (ignore object)) + (write-string "+ " xp)) + +(define-ast-printer pp-pat-negated (object xp) + (declare (ignore object)) + (write-string "-" xp)) + diff --git a/printers/printers.scm b/printers/printers.scm new file mode 100644 index 0000000..3ac4fe6 --- /dev/null +++ b/printers/printers.scm @@ -0,0 +1,28 @@ +;;; printers.scm -- compilation unit definition for structure printers +;;; +;;; author : Sandra Loosemore +;;; date : 3 Jan 1992 +;;; +;;; + +(define-compilation-unit printer-support + (source-filename "$Y2/printers/") + (require global) + (unit util + (source-filename "util.scm"))) + +(define-compilation-unit printers + (source-filename "$Y2/printers/") + (require printer-support) + (unit print-exps + (source-filename "print-exps.scm")) + (unit print-modules + (source-filename "print-modules.scm")) + (unit print-types + (source-filename "print-types.scm")) + (unit print-ntypes + (source-filename "print-ntypes.scm")) + (unit print-valdefs + (source-filename "print-valdefs.scm")) + ) + diff --git a/printers/util.scm b/printers/util.scm new file mode 100644 index 0000000..498aa25 --- /dev/null +++ b/printers/util.scm @@ -0,0 +1,214 @@ +;;; util.scm -- utilities for printing AST structures +;;; +;;; author : Sandra Loosemore +;;; date : 15 Jan 1992 +;;; +;;; + + +;;; The AST syntax printers are only used if this variable is true. + +(define *print-ast-syntax* '#t) + + +;;; Here's a macro for defining AST printers. + +(define-syntax (define-ast-printer type lambda-list . body) + (let ((printer (symbol-append 'write- type))) + `(begin + (define (,printer ,@lambda-list) ,@body) + (define-struct-printer ,type ,printer)) + )) + + +;;; This variable controls how much indentation to perform on block +;;; bodies. + +(define *print-ast-indent* 2) + + +;;; Begin a logical block with the default indentation. + +(define-syntax (with-ast-block xp-stuff . body) + (let ((xp (car xp-stuff))) + `(pprint-logical-block (,xp '() "" "") + (pprint-indent 'block (dynamic *print-ast-indent*) ,xp) + (pprint-pop) ; prevents unused variable warning + ,@body))) + + +;;; Write a space and maybe a fill line break. + +(define (write-whitespace xp) + (write-char #\space xp) + (pprint-newline 'fill xp)) + + +;;; Write a space and maybe a mandatory line break. + +(define (write-newline xp) + (write-char #\space xp) + (pprint-newline 'mandatory xp)) + + + +;;; Write a list of things separated by delimiters and maybe +;;; surrounded by delimiters. + +(define (write-delimited-list objects xp fn delim prefix suffix) + (pprint-logical-block (xp '() prefix suffix) + (do ((objects objects (cdr objects))) + ((null? objects) '#f) + (pprint-pop) + (funcall fn (car objects) xp) + (when (cdr objects) + (write-string delim xp) + (write-whitespace xp))))) + + +;;; Here's a couple common special cases of the above. + +(define (write-commaized-list objects xp) + (write-delimited-list objects xp (function write) "," "(" ")")) + +(define (write-ordinary-list objects xp) + (write-delimited-list objects xp (function write) "" "" "")) + + +;;; Here's another helper function that's used to implement the layout +;;; rule. The layout rule is only used to format output if *print-pretty* +;;; is true. +;;; *** should do pprint-indent here? + +(define (write-layout-rule objects xp fn) + (pprint-logical-block (xp '() + (if (dynamic *print-pretty*) "" "{") + (if (dynamic *print-pretty*) "" "}")) + (do ((objects objects (cdr objects))) + ((null? objects) '#f) + (pprint-pop) + (funcall fn (car objects) xp) + (when (cdr objects) + (if (dynamic *print-pretty*) + (pprint-newline 'mandatory xp) + (write-string "; " xp)))))) + + +;;; This filters a list of decls, removing the recursive marker added by +;;; dependency analysis. + +(define (remove-recursive-grouping decls) + (cond ((null? decls) '()) + ((is-type? 'recursive-decl-group (car decls)) + (append (recursive-decl-group-decls (car decls)) + (remove-recursive-grouping (cdr decls)))) + (else + (cons (car decls) (remove-recursive-grouping (cdr decls)))))) + +;;; Write where-decls, using the layout rule if appropriate. + +(define (write-wheredecls decls xp) + (when (not (null? decls)) + (write-whitespace xp) + (write-string "where" xp) + (write-whitespace xp) + (write-layout-rule (remove-recursive-grouping decls) xp (function write)))) + + +;;; Write an ordinary variable name. + +(define (write-avarid name xp) + (write-string (symbol->string name) xp)) + + +;;; Constructor name symbols have a funny prefix attached; have to strip +;;; this off, so can't just print the symbol using write-avarid. + +(define (write-aconid name xp) + (let ((s (symbol->string name))) + (write-string (substring s 1 (string-length s)) xp))) + + +;;; There are a couple places where conids and varids are mixed up +;;; together. + +(define (conid? name) + (eqv? (string-ref (symbol->string name) 0) #\;)) + +(define (write-varop-conop name xp) + (if (conid? name) + (write-conop name xp) + (write-varop name xp))) + +(define (write-varid-conid name xp) + (if (conid? name) + (write-conid name xp) + (write-varid name xp))) + + + +;;; Stuff for writing a variable name as either an operator or an ordinary +;;; variable ID. This is necessary because some kinds of symbol names +;;; default to being operators and others default to being ordinary names. +;;; Bleah.... + + +(define (write-varop name xp) + (if (avarid? name) + (begin + (write-char #\` xp) + (write-avarid name xp) + (write-char #\` xp)) + (write-avarid name xp))) + +(define (write-varid name xp) + (if (avarid? name) + (write-avarid name xp) + (begin + (write-char #\( xp) + (write-avarid name xp) + (write-char #\) xp)))) + + +;;; This tests for alphabetic rather than lower-case characters +;;; so that gensym'ed variables with uppercase names don't print funny. + +(define (avarid? name) + (let ((ch (string-ref (symbol->string name) 0))) + (char-alphabetic? ch))) + + +;;; Similar stuff for doing constructor names. Moby bleah.... + +(define (write-conop name xp) + (if (aconid? name) + (begin + (write-char #\` xp) + (write-aconid name xp) + (write-char #\` xp)) + (write-aconid name xp))) + +(define (write-conid name xp) + (if (aconid? name) + (write-aconid name xp) + (begin + (write-char #\( xp) + (write-aconid name xp) + (write-char #\) xp)))) + +(define (aconid? name) + (let ((ch (string-ref (symbol->string name) 1))) + (char-upper-case? ch))) + + +;;; These are officially aconid in the syntax, but they aren't +;;; prefixed so write them using write-avarid instead. Barf. + +(define (write-modid name xp) + (write-avarid name xp)) + +(define (write-tyconid name xp) + (write-avarid name xp)) + +(define (write-tyclsid name xp) + (write-avarid name xp)) diff --git a/progs/README b/progs/README new file mode 100644 index 0000000..8b28d8f --- /dev/null +++ b/progs/README @@ -0,0 +1,9 @@ +This directory contains Haskell source code. +Subdirectories: +prelude The prelude used in this system +tutorial The online supplement to the Hudak & Fasel tutorial +demo A set of random demo programs +lib Various random extensions + +Other programs can be found in the Haskell program library on the +official Haskell ftp sites. diff --git a/progs/demo/Calendar.hs b/progs/demo/Calendar.hs new file mode 100644 index 0000000..fa2e4a4 --- /dev/null +++ b/progs/demo/Calendar.hs @@ -0,0 +1,138 @@ +-- This is a modification of the calendar program described in section 4.5 +-- of Bird and Wadler's ``Introduction to functional programming'', with +-- two ways of printing the calendar ... as in B+W, or like UNIX `cal': +-- +-- Use from within Yale Haskell: +-- +-- Main> :l Calendar +-- Now in module Calendar. +-- Calendar> @ do cal 1992 +-- Calendar> :e +-- +-- ... Unix style calendar ... +-- +-- Calendar> @ do calendar 1992 +-- Calendar> :e +-- +-- ... Bird and Wadler style calendar ... +-- +-- Calendar> + +module Calendar(cal,calendar) where + +infixr 5 `above`, `beside` + +do cal year = appendChan stdout (cal year) exit done + +-- Picture handling: + +type Picture = [[Char]] + +height, width :: Picture -> Int +height p = length p +width p = length (head p) + +above, beside :: Picture -> Picture -> Picture +above = (++) +beside = zipWith (++) + +stack, spread :: [Picture] -> Picture +stack = foldr1 above +spread = foldr1 beside + +empty :: (Int,Int) -> Picture +empty (h,w) = copy h (copy w ' ') + +block, blockT :: Int -> [Picture] -> Picture +block n = stack . map spread . group n +blockT n = spread . map stack . group n + +group :: Int -> [a] -> [[a]] +group n [] = [] +group n xs = take n xs : group n (drop n xs) + +lframe :: (Int,Int) -> Picture -> Picture +lframe (m,n) p = (p `beside` empty (h,n-w)) `above` empty (m-h,n) + where h = height p + w = width p + +-- Information about the months in a year: + +monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31] + where feb | leap year = 29 + | otherwise = 28 + +leap year = if year`mod`100 == 0 then year`mod`400 == 0 + else year`mod`4 == 0 + +monthNames = ["January","February","March","April", + "May","June","July","August", + "September","October","November","December"] + +jan1st year = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7 + where last = year - 1 + +firstDays year = take 12 + (map (`mod`7) + (scanl (+) (jan1st year) (monthLengths year))) + +-- Producing the information necessary for one month: + +dates fd ml = map (date ml) [1-fd..42-fd] + where date ml d | d<1 || ml<d = [" "] + | otherwise = [rjustify 3 (show d)] + +-- The original B+W calendar: + +calendar :: Int -> String +calendar = unlines . block 3 . map picture . months + where picture (mn,yr,fd,ml) = title mn yr `above` table fd ml + title mn yr = lframe (2,25) [mn ++ " " ++ show yr] + table fd ml = lframe (8,25) + (daynames `beside` entries fd ml) + daynames = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"] + entries fd ml = blockT 7 (dates fd ml) + months year = zip4 monthNames + (copy 12 year) + (firstDays year) + (monthLengths year) + +-- In a format somewhat closer to UNIX cal: + +cal :: Int -> String +cal year = unlines (banner year `above` body year) + where banner yr = [cjustify 75 (show yr)] `above` empty (1,75) + body = block 3 . map (pad . pic) . months + pic (mn,fd,ml) = title mn `above` table fd ml + pad p = (side`beside`p`beside`side)`above`end + side = empty (8,2) + end = empty (1,25) + title mn = [cjustify 21 mn] + table fd ml = daynames `above` entries fd ml + daynames = [" Su Mo Tu We Th Fr Sa"] + entries fd ml = block 7 (dates fd ml) + months year = zip3 monthNames + (firstDays year) + (monthLengths year) + +-- Additional (B+W)-isms: these really ought to go in a separate module, +-- in a spearate file. But for ease of packaging this simple application, +-- it doesn't seem worth the trouble! + +copy :: Int -> a -> [a] +copy n x = take n (repeat x) + +space :: Int -> String +space n = copy n ' ' + +-- Simple string formatting: + +cjustify, ljustify, rjustify :: Int -> String -> String + +cjustify n s = space halfm ++ s ++ space (m - halfm) + where m = n - length s + halfm = m `div` 2 +ljustify n s = s ++ space (n - length s) +rjustify n s = space (n - length s) ++ s + +-- End of calendar program diff --git a/progs/demo/README b/progs/demo/README new file mode 100644 index 0000000..4a683cd --- /dev/null +++ b/progs/demo/README @@ -0,0 +1,15 @@ + +This directory contains Haskell demo programs. All of these programs +compile and execute properly. + +This directory contains: + + +fact.hs factorial +merge.hs merge sort +pfac.hs parallel factorial +primes.hs prime number generator +qs.hs quick sort +queens.hs N queens +symalg/ A symbolic algebra program +prolog/ A prolog interpreter diff --git a/progs/demo/X11/animation/README b/progs/demo/X11/animation/README new file mode 100644 index 0000000..c14b867 --- /dev/null +++ b/progs/demo/X11/animation/README @@ -0,0 +1,22 @@ +In his paper "A Functional Animation Starter Kit" [ARYA88], Kevi Arya +proposes an approach to animation that uses functional languages. As +Arya describes, the cost of computing power is falling. This is making +the use of computer animation much more prevalent. However, languages +such as C make it difficult to program animations. What is needed is +a simpler, faster and more accessible way to program graphics. Functional +languages are a very effective means for this, due to their higher order +functions. + + Kevi Arya goes on to provide such a functional animation package in +the language Miranda. Haskell in particular is good functional language for +two reasons. It is a completely functional language, doing even I/O in a +functional manner. Variables are evaluated in a lazy manner allowing infinite +lists to be manipulated easily, which suits the infinite frames format +of animation. + +The following animations are provided here: + + seaside.hs - a seaside scene + planets.hs - planets in orbit + palm.hs - another seaside scene + birds.hs - flying birds diff --git a/progs/demo/X11/animation/animation.hs b/progs/demo/X11/animation/animation.hs new file mode 100644 index 0000000..3c0750c --- /dev/null +++ b/progs/demo/X11/animation/animation.hs @@ -0,0 +1,16 @@ +-- This bundles all the animation stuff into a single module. + +module Animation(R_Ptypes..,R_Constants..,R_Utility..,R_Picture..,R_Behaviour.., + R_Movie..,R_Shapes..,R_Defaults..,R_Inbetween.., + R_Display..) where +import R_Ptypes +import R_Constants +import R_Utility +import R_Picture +import R_Behaviour +import R_Movie +import R_Shapes +import R_Defaults +import R_Inbetween +import R_Display + diff --git a/progs/demo/X11/animation/animation.hu b/progs/demo/X11/animation/animation.hu new file mode 100644 index 0000000..0dd71ee --- /dev/null +++ b/progs/demo/X11/animation/animation.hu @@ -0,0 +1,6 @@ +animation.hs +r_movie.hu +r_defaults.hu +r_shapes.hu +r_inbetween.hu +r_display.hu diff --git a/progs/demo/X11/animation/birds.hs b/progs/demo/X11/animation/birds.hs new file mode 100644 index 0000000..daba730 --- /dev/null +++ b/progs/demo/X11/animation/birds.hs @@ -0,0 +1,28 @@ +module Birds where + +import Animation + +bird :: Movie +--bird = osc [bird1,bird2] +bird = rOVERLAY + [apply (bPar [right,right,right,right]) bm1, + apply (bPar [up,right,right,right]) bm2] + where bm1 = osc [bird1] + bm2 = osc [bird2] + +bird1 = [(black,b1)] + where b1 = [(0,90),(20,100),(30,110),(40,110),(50,100),(110,120), + (130,100),(120,90),(80,90),(0,90), + (80,90),(90,70),(140,50),(120,90),(80,90), + (80,90),(70,70),(80,60),(90,70)] + +bird2 = [(red,b2)] + where b2 = [(0,60),(20,70),(30,80),(40,80),(50,70),(110,70), + (140,30),(110,35),(100,35),(70,50),(50,60),(0,60), + (70,50),(100,90),(150,100),(120,60),(110,35), + (70,50),(65,100),(85,115),(97,86)] + +main = getEnv "DISPLAY" exit + (\ host -> displaym host 30 bird) + + diff --git a/progs/demo/X11/animation/birds.hu b/progs/demo/X11/animation/birds.hu new file mode 100644 index 0000000..cd94b30 --- /dev/null +++ b/progs/demo/X11/animation/birds.hu @@ -0,0 +1,3 @@ +:o= all +birds.hs +animation.hu diff --git a/progs/demo/X11/animation/doc.tex b/progs/demo/X11/animation/doc.tex new file mode 100644 index 0000000..1b66751 --- /dev/null +++ b/progs/demo/X11/animation/doc.tex @@ -0,0 +1,578 @@ + +% This is obsolete regarding the X system -- jcp + +% -*-latex-*- +% Creator: John Tinmouth +% Creation Date: Thu May 9 1991 +\documentstyle[11pt]{article} +\newcommand{\X}[1]{{#1}\index{{#1}}} +\begin{document} + +\title{A Functional Animation Package in Haskell} +\author{ + John Tinmouth\\ + Computer Science Senior Project\\ + Yale University\\ + Professor Paul Hudak } +\date{9 May 1991} +\maketitle + + + +\section{Introduction} + + In his paper "A Functional Animation Starter Kit" [ARYA88], Kevi Arya +proposes an approach to animation that uses functional languages. As +Arya describes, the cost of computing power is falling. This is making +the use of computer animation much more prevalent. However, languages +such as C make it difficult to program animations. What is needed is +a simpler, faster and more accessible way to program graphics. Functional +languages are a very effective means for this, due to their higher order +functions. + + Kevi Arya goes on to provide such a functional animation package in +the language Miranda. Haskell in particular is good functional language for +two reasons. It is a completely functional language, doing even I/O in a +functional manner. Variables are evaluated in a lazy manner allowing infinite +lists to be manipulated easily, which suits the infinite frames format +of animation. As it is now possible to complete the implementation of +this package is Haskell, my work has been converting these Miranda programs +to Haskell version 1.0-0, Yale Haskell Group. + + + +\section{How to Use the Graphics: Overview} + + By using higher order functions, it becomes very easy to do rapid +prototyping of animations. You can quickly throw out an animation of +simple images manipulated in simple ways. For example, if there was +an image of a car, and you wanted it to move left, you could almost +just describe it in english, and that would be the animation. +\begin{verbatim} + movie = apply left car +\end{verbatim} + + After the simple model is done, converting it to a more complex model +is simple. Simply make the image, "car" in this case, more complex, and +then modify the "left" function, and you are done. + + There are three stages in making a movie. First of all, you must +define your basic images. These will tend to be Pics put into lists, either +finite or infinite, to be basic Movies. Second, you decide precisely +what kind of motion you want in animation. These are behaviours. A behaviour +modifies a movie over time, changing each successive frame. This includes +motion, changing size, changing from one image to another and so forth. These +are applied to your basic Movies. Third, you must combine your basic Movies +into your final Movie. If you want a scene of clouds and a man walking, you +must overlay your basic Movie of clouds with your Movie of a walking man. + +\section {Original Images or Pics} + + A Movie is a list of frames called Pics. Each of these Pics is a list +of colored polygons. The Pic is a Color followed by a list of Vectors, +representing the vertices of the Polygon. The original Pic usually must +be entered by hand, although simple generation routines for boxes, +triangles and circles are available. You need to produce some of these +basic images in one way or another, so that you have something to +manipulate. + + To make a Movie, you need a list of these Pics. With a single Pic, you +can generate a sequence of that Pic. With several Pics, you can oscillate +through the Pics in an inifinite list. To generate an infinite list of +Pics of p1, define a Movie, m1 = i p1. + The following datatypes are used in this package: + +\begin{verbatim} +type Vec = (Int,Int) +type Color = Int +type Poly = (Color,[Vec]) +type Pic = [Poly] +type Movie = [Pic] +type Behaviour = [Pic -> Pic] +\end{verbatim} + + +\subsection {Modifying Pics} + + Starting with a single Pic, it is possible to create a short list of +Pics to oscillate on. You can flip it, scale it, or otherwise modify the +original Pic (p1) in some way to create another Pic (p2). You can either +keep doing this and produce N images for a Movie of [p1,p2,...,pN], or use +the interpolation functions available to shift from p1 to p2 in N frames, +resulting in a Movie [p1,interp1,interp2,...,interpN-2,p2]. + The list of specific Pic-to-Pic functions is included in the next section, +along with short explanations of what they do. + +\subsection {Pic-to-Pic Functions Available} + +\begin{verbatim} +overlay_Pic Args: Pic Pic + This takes 2 Pics and just puts them together into one Pic. + module: R_Picture + +put_Pic Args: Vec Pic Pic + This overlays the two Pics, putting Pic-1's center the Vec + distance away from Pic-2's center. + module: R_Picture + +over_Pic Args: Pic Pic + This puts two images on top of one another, explicitly + centering the first on top of the second and forms one Pic. + module: R_Picture + +above_Pic Args: Pic Pic + This puts the first Pic above the second Pic, at a distance + of half the combined heights of the Pics and overlays them + to form one Pic. + module: R_Picture + +beside_Pic Args: Pic Pic + This puts the first Pic to the right of the second Pic, at + a distance of half the combined widths of the Pics and + overlays them to form one Pic. + module: R_Picture + +beside2_Pic Args: Pic Pic + Withouth analysing the widths of the Pics, it puts the + first Pic the width of the second Pic to the right and + overlays them to form one Pic. + module: R_Picture + +scale_Pic Args: Int Pic + This scales the picture in elevenths around its own origin + and returns that Pic. So if the Int is 22, the Pic will + scaled by a factor of 2 (22/11). + module: R_Picture + +scale_rel_Pic Args: Vev Int Pic + This is another scaling function, but it scales the image + from the Vec, treating it as the origin. + module: R_Picture + +mov_Pic Args: Vec Pic + This moves the Pic by the amount of the vector. + module: R_Picture + +movto_Pic Args: Vec Pic + This moves the Pic's center to the Vec. + module: R_Picture + +to_orig Args: Pic + This moves the Pic's center to the lower,left side of + the Pic. + module: R_Picture + +rot_Pic Args: Vec Float Pic + This rotates the Pic by the Float in radians, using the Vec + as the origin of rotation. + module: R_Picture + +twist_Pic Args: Float Pic + This rotates the Pic by the Float amount of radians around + its own center. + module: R_Picture + +rot_Pic' Args: Vec Pic + This rotates the Pic by a certain amount (set in R_Constants) + using the Vec as the center of rotation. The set amount of + rotation makes it faster than rot_Pic. + module: R_Picture + +twist_Pic' Args: Pic + This rotates the Pic by a certain amoutn (set in R_Constants) + around the Pic's origin. The set amount of rotation makes + it faster than twist_Pic. + module: R_Picture + +flipx_Pic Args: Int Pic + This flips the Pic around the line x=Int, essentially giving + a mirror image of the Pic, reversing right and left. + module: R_Picture + + +flipy_Pic Args: Int Pic + This flips the Pic around the line y=Int, mirror-imaging the + Pic, reversing up and down. + module: R_Picture + +flip_Pic Args: Pic + This flips the Pic around its own x-origin, reversing + left and right. + module: R_Picture + +flock_Pic Args: Int Pic + This takes the image Pic and copies it out Int*Int times in + a Int by Int grid pattern, and returns that as an Pic. + module: R_Picture + +set_Color Args: Int Pic + This takes an Int standing for a color, and changes the + color of the Pic to that. + module: R_Picture +\end{verbatim} + +\subsection{Other Functions for Manipulating Pics} + +\begin{verbatim} +i Args: Any + This will take anything and return an infinite stream of them. + module: R_Utility + +osc Args: [Any] + This will take a Movie, which is a list of Pics and + oscillate them. + [p1] will give [p1,p1,p1,p1....] + [p1,p2,p3,p4] will give [p1,p2,p3,p4,p3,p2,p1,p2...] + module: R_Utility +\end{verbatim} + +\section{Behaviours and their Application to Movies} + + A Behaviour is a list of functions that will convert one Pic to +another Pic. This list then can be applied to any Movie with one +of the application functions (most often apply). The beauty of the Behaviour +is that once you have a behaviour for moving left, you can move any +Movie left without rewriting the routine every time. + + There are specific functions that take a Behaviour and a Movie and +return a new Movie. These are apply and while. If you had a Movie of a +man walking in place, and a Behaviour called left that moves Pics ever +increasing distances left, then you could create a man walking left by: +\begin{verbatim} + apply left man +\end{verbatim} + + If you want to apply more than one Behaviour to a Movie, you must first +decide whether to do that in sequence or in parallel, and use bSeq and bPar +to reduce the list of Behaviours to a single Behaviour, and then apply +that to a movie. For example: +\begin{verbatim} + apply (bPar left up) gull +\end{verbatim} +will take a Movie of a gull and move the Pics up and left. + + Most of the basic Behaviours are defined in R\_Behaviour. + + +\subsection{Defining Customized Packages of Behaviours} + + Often you will have more specialized, or just simpler Behaviours you +want to use. Using the Behaviours and Pic-to-Pic functions, it is very +easy to create your own small library of Behaviours. R\_Defaults is a +module of such Behaviours. For example, to create a Behaviour to move +a Movie right, you would create a list of mov\_Pic's, each taking a +everincreasingly large x-coordinate. +\begin{verbatim} + right = [ mov_Pic (x,y) | (x,y) <- zip [0,10,..] [0,..] ] +\end{verbatim} + + Or if you wanted a behavour to place a Movie at (100,100) twice as +large as before, you could create a new Behaviour from old ones as: + scaleat= bPar [movto (i (100,100)), scale (i 22)] + +\subsection{Behaviours Available} +\begin{verbatim} +flip Args: none + This will flip every Pic around its x-origin, resulting in + mirror images reversing left and right. + module: R_Behaviour + +twist' Args: none + This will rotate each Pic by the amount rotunit (see + R_Constants) around its origin. + module: R_Behaviour + +mov Args: [Vec] + This will move each Pic by its corresponding vector. + module: R_Behaviour + +movto Args: [Vec] + This will move each Pic's origin to its corresponding vector. + module: R_Behaviour + +circ_mov Args: Float Float + This will move each Pic in a circle, of radius of the first + Float and by an increment of the second Float, using (0,0) + as the origin of rotation. + module: R_Behaviour + +scale Args: [Int] + Scales every Pic on its origin by the the corresponding Int + in the list. These Ints represents elevenths, so that a + [2,2,...] will scale every Pic by 2/11 . + module: R_Behaviour + +scale_rel Args: Vec [Int] + Same as scale, except that the Pics are all scaled using the + Vec as the point of origin. + module: R_Behaviour + +twist Args: [Float] + This will rotate every Pic by its corresponding Float from + the list in radians. + module: R_Behaviour + +set_color Args: [Int] + This sets each Pic to the color indicated by its + corresponding int in the list. + module: R_Behaviour + +rot Args: [Vec] [Float] + This will rotate each Pic around its corresponding Vec by + its corresponding Float in radians. + module: R_Behaviour + +big Args: none + Scales every Pic up by scaleunit + module: R_Defaults + +huge Args: none + This scales every Pic up by 2*scaleunit + module: R_Defaults + +small Args: none + This scales every Pic down by 10/11 + module: R_Defaults + +tiny Args: none + This scale every Pic down by 5/11 + module: R_Defaults + +bigger Args: none + This scales every Pic in the list by scaleunit more + than the previous Pic, so that the n-th element is + scaled up by (n-1)*scaleunit + module: R_Defaults + +smaller Args: none + This scales every Pic down, so that the n-th element + is scaled down by (n-1)*(10/11) + module: R_Defaults + +ccw Args: none + This rotates every Pic by one rotunit more than the + previous Pic, in a counterclockwise fashion. + module: R_Defaults + +cw Args: none + This rotates every Pic by one rotunit more than the + previous Pic, in a clockwise fashion. + module: R_Defaults + +up Args: none + This moves every Pic up by one unit more than the + Previous Pic, so that the n-th element is moved up + (n-1) units. + module: R_Defaults + +down Args: none + This is same as up, but the Pics move down. + module: R_Defaults + +right Args: none + This is same as up, but the Pics move right. + module: R_Defaults + +left Args: none + This is same as up, but the Pics move left. + module: R_Defaults +\end{verbatim} + +\subsection{Functions For Behaviours} + +\begin{verbatim} +do Args: Int Behaviour + This takes the first Int elements of the Behaviour and + return that. + module: R_Behaviour + +rpt Args: Int Behaviour + This takes an Int and returns a Behaviour of length Int. + However, the n-th Pic-to-Pic in the Behaviour returned + is made up of the first through (n-1)the Pic-to-Pics of + the input list. + module: R_Behaviour + +forever Args: Behaviour + This makes a finite Behaviour list an infinite one by + appending the list to itself endlessly. + module: R_Behaviour + +apply Args: Behaviour Movie + This takes a Behaviour and applies it to a Movie + module: R_Behaviour + +while Args: (Boolean function) Behaviour Movie + As long as the Boolean function evaluates true, this + takes a Behaviour and applies it to a Movie. When it + evaluates to false, no more Pics are produced and + the Movie is cut short there. + module: R_Behaviour + +bseq Args: Behaviour Behaviour + This takes two Behaviour and creates one Behaviour made + up of the two inputs applies in sequence. + module: R_Behaviour + +bSeq Args: [Behaviour] Behaviour + This takes two Behaviour and creates one Behaviour made + up of the two inputs applies in sequence. + module: R_Behaviour + +bpar Args: Behaviour Behaviour + This takes two Behaviour and creates one Behaviour made + up of the two inputs applies in parallel. + module: R_Behaviour + +bPar Args: [Behaviour] Behaviour + This takes two Behaviour and creates one Behaviour made + up of the two inputs applies in parallel. + module: R_Behaviour +\end{verbatim} + +\section{Creating the Final Movie} + + Finally, you have your basic Movies made up of Pictures and Behaviours. +Now you need to combine them into one Movie. The functions that do this +are found in the module R\_Movie. These functions will take a list of +Movies and return a single Movie combining all the Movies in the list. +How they are combined can be controlled to some extent. Usually they are +just overlayed, but they can be put beside one another, or on top of +one another, or put a Vec distance apart. + + It is also possible to use a combination of these forms. If you wanted +to overaly M1 and M2, and then put that beside M3, you would do: +\begin{verbatim} + rBESIDE [M3, rOVERLAY [M1,M2] ] +\end{verbatim} +This is acceptable as rOVERLAY will return a single Movie. + +\subsection{Movie Combining Functions} + +\begin{verbatim} +rABOVE Args: [Movie] + Puts all the Movies into one movie, all above one another. + module: R_Movie + +rBESIDE Args: [Movie] + Puts all the Movies into one movie, all beside one another. + module: R_Movie + +rBESIDE2 Args: [Movie] + Using their absolute coordinates, puts all the Movies + beside one another. + module: R_Movie + +rOVER Args: [Movie] + This lays the Movies on top of one another, centering + each Pic so that they share the same origin. + module: R_Movie + +rOVERLAY Args: [Movie] + This lays the Movies on top of one another, centering + each Pic so that they share the smae origin. + module: R_Movie + +pUT Args: [Vec] Movie Movie + This takes a list of Vec, and puts each Pic of the + first Movie in the location of the corresponding + Vec on top of the Pic of the second Movie and + returns that list as the new Movie. + module: R_Movie + +\end{verbatim} + +\section{Displaying Your Movie} + + Once you have your function for the Movie defined, you need to output +it in some way. Currently, this is done by outputting characters to a file and +running a C Program in X-Windows that displays the contents of the file +as a graphic in the X system. First of all, you must convert the +Movie variable to a stream of characters. This is done by running +"showm" on the Movie. Be carefull you don't try to convert an infinite list +into characters as the compiler will take awhile to do this. Instead, take +a certain number of frames and convert them with "showm". +\begin{verbatim} + man\_vm = rOVERLAY [man,vm] + man\_vmstring = showm (take 20 man&vm) +\end{verbatim} + Now that you have this string, you need to write it to disk. The +"writetofile" function does this. It takes a characater string(ie [Char] ) +as an argument, and then prompts you for a filename. It then writes the +string to the filename. So to put man\_vm string into a file: +\begin{verbatim} + main = writetofile man_vmstring +\end{verbatim} +and run the program, where you will prompted for the filename. Or you could: +\begin{verbatim} + main = writetofile (showm (take 20 man_vm)) +\end{verbatim} +to make it more compact. + + +\subsection{Miscellaneous Usefull Functions} + +\begin{verbatim} +inbetween Args: Int Pic Pic + This takes an Int and two Pics and returns a Movie + with Int Pics interpolating between the two Pics. + module: R_Inbetween + +tween Args: Int Movie Movie + This takes an Int and two Movies and returns one + Movie made up of the first Movie, Int number of + frames of Pics interpolating between the last + Pic of the first Movie and the first Pic of the + second Movie, followed by the second Movie + module: R_Inbetween + +box Args: Int Int Int + This takes 3 Ints, the color, width and height of + the box and returns a Pic of a box + module: R_Shapes + +tri Args: Int Vec Vec Vec + This takes a color and three vectors and returns a + Pic of a triangle of that colour with those vertices. + module: R_Shapes + +circ Args: Int Int Int + This takes a color, the radius and the number of points + around the circle, and returns a circle with origin at + (0,0). + module: R_Shapes +\end{verbatim} + +\pagebreak +\large {\bf Appendix: C Programs to Display on X-Windows} +\\ +\\ + The program currently used to run these graphics is called "xcshow". +This takes one argument, the name of the file to be run. When run +in X-Windows, it will produce a window with the first Pic. To run it, click +on the left mouse button inside the window. Clicking again will freeze it. +This will keep cycling through the file, replaying again when it hits the +end of the file, until the window is killed. + + There is also "xshow" which is used to run the monochrome Movies, as +"xcshow" is used to run the color Movies. As this animation package +only produces color Movies, it isn't too usefull. + + +\pagebreak +\large {\bf References} +\\ +\\ +\begin{verbatim} +[ARYA88] "The Formal Analysis of a Functiona Animation System", Kevi Arya, + DPhil,Thesis,Oxford University, Programming Research Group, + April 1988 + +[ARYA89] "Processes In A Functional Animation System", Kevi Arya,IBM + T.J. Research Center, 1989 + +[HASK90] "Report On The Programming Language Haskell, Version 1.0", + YALEU/DCS/RR-777,Yale University,1990 +\end{verbatim} + +\end{document} diff --git a/progs/demo/X11/animation/palm.hs b/progs/demo/X11/animation/palm.hs new file mode 100644 index 0000000..9deef12 --- /dev/null +++ b/progs/demo/X11/animation/palm.hs @@ -0,0 +1,47 @@ +module Palm (main) where + +import Animation +import SeaFigs + +main = getEnv "DISPLAY" exit + (\ host -> displaym host 30 trans) + +trans :: Movie +trans = manright++change++gull2 + +manright::Movie +manright = mirrorx (take 10 (apply left man)) + +gull2::Movie +gull2 = apply (bPar [right,up,huge,huge,huge,(mov (i (275,0)))]) gull + +change::Movie +change = inbetween 5 manf1 gull1 + where gull1 = head gull2 + manf1 = last manright + + + +mirrorx :: Movie -> Movie +mirrorx m = map (flipx_Pic x) m + where (x,_)=orig_Movie m + + +orig_Movie :: Movie -> Vec +orig_Movie m = ((x2-x1) `div` 2,(y2-y1) `div` 2) + where x2 = reduce max (map maxx m) + x1 = reduce min (map minx m) + y2 = reduce max (map maxy m) + y1 = reduce min (map miny m) + +maxx :: Pic -> Int +maxx p = reduce max [x | (c,q) <- p, (x,y) <- q] + +minx :: Pic -> Int +minx p = reduce min [x | (c,q) <- p, (x,y) <- q] + +maxy :: Pic -> Int +maxy p = reduce max [y | (c,q) <- p, (x,y) <- q] + +miny :: Pic -> Int +miny p = reduce min [y | (c,q) <- p, (x,y) <- q] diff --git a/progs/demo/X11/animation/palm.hu b/progs/demo/X11/animation/palm.hu new file mode 100644 index 0000000..a86fcb9 --- /dev/null +++ b/progs/demo/X11/animation/palm.hu @@ -0,0 +1,3 @@ +:o= all +palm.hs +seafigs.hu diff --git a/progs/demo/X11/animation/planets.hs b/progs/demo/X11/animation/planets.hs new file mode 100644 index 0000000..38f278a --- /dev/null +++ b/progs/demo/X11/animation/planets.hs @@ -0,0 +1,30 @@ +module Planets (main) where + +import Animation + +planets:: Float -> Float -> Int -> Int -> Int -> Int -> Movie +planets i1 i2 r1 r2 c1 c2 + = rOVERLAY + [ apply f1 earth, + apply (bpar f1 f2) moon + ] + where f1 = circ_mov (fromIntegral r1) i1 + f2 = circ_mov (fromIntegral r2) i2 + earth = osc [mov_Pic (vplus center (r1,0)) (box c1 30 30)] + moon = osc [mov_Pic (vplus center (r1+r2,0)) (box c2 15 15)] + +gen a b c d = c :(gen a b (c+b) d) + + +planet_scene:: Movie +planet_scene = rOVERLAY + [apply (bpar (set_color (i yellow)) (movto (i center))) orb, + planets (pi/40.0) (pi/10.0) 450 80 darkblue lightblue, + planets (pi/20.0) (pi/8.0) 300 50 brown black, + planets (pi/10.0) (pi/4.0) 150 40 green red + ] + +orb = osc [circ red 50 10] + +main = getEnv "DISPLAY" exit + (\ host -> displaym host 60 planet_scene) diff --git a/progs/demo/X11/animation/planets.hu b/progs/demo/X11/animation/planets.hu new file mode 100644 index 0000000..3473372 --- /dev/null +++ b/progs/demo/X11/animation/planets.hu @@ -0,0 +1,3 @@ +:o= all +planets.hs +animation.hu diff --git a/progs/demo/X11/animation/r_behaviour.hs b/progs/demo/X11/animation/r_behaviour.hs new file mode 100644 index 0000000..6f58e3b --- /dev/null +++ b/progs/demo/X11/animation/r_behaviour.hs @@ -0,0 +1,158 @@ +{-********************************************************************** + MODULE R_BEHAVIOUR + + This module defines the basic Behaviours available to manipulate + Movies. These functions can either be used directly, or used to + easily create personnalized Behaviours (see R_Defaults). + There are the Behaviours that affect one Movie, which are mov,movto + circ_mov,scale,scale_rel,rot,flip and set_color. These change some + aspect of the movie over time. + There are functions that combine several movies into one, namely + bseq,bSeq,bpar and bPar. + Some functions modify the Behaviours. These are do, rpt and forever. + They put limits on how long the Behaviour is. + Finally, there are the functions that apply the Behaviours to a Movie. + These are apply and while. Apply applies a Behaviour to a Movie until + it runs out of Movie or Behaviour. While takes a conditional and + applies the Behaviour to it until that condition is fullfilled. + +***********************************************************************-} + +module R_Behaviour (mov,movto,circ_mov,scale,scale_rel,rot,flipb, + set_color, + bseq,bSeq,bpar,bPar, + do,rpt,forever, + apply,while ) where + +import R_Ptypes +import R_Utility +import R_Picture + + -- takes a Pic to Pic and makes an infinite list Behaviour out of it +makeb1 :: (Pic->Pic) -> Behaviour +makeb1 f = f : makeb1 f + + -- takes a movie and flips it around the x-origin using flip_Pic +flipb :: Behaviour +flipb = makeb1 flip_Pic + + -- twist makes twist_Pic into a Behaviour, rotating the image by rotunit +twist' :: Behaviour +twist' = makeb1 twist_Pic' + + -- makeb2 makes a Behaviour out of a function that takes a list and a + -- function and outputs a Behaviour. +makeb2 :: (a->Pic->Pic) -> [a] -> Behaviour +makeb2 f [] = [] +makeb2 f (v:vs) = f v : makeb2 f vs + + -- mov takes a list of Vec's and applies each Pic-to-Pic in the Behaviour + -- list to its corresponding Vec, and gives back a new Behaviour +mov :: [Vec] ->Behaviour +mov = makeb2 mov_Pic + + -- movto creates a list of Pic-to-Pic Behaviours that move each Pic to its + -- corresponding Vec +movto :: [Vec] -> Behaviour +movto = makeb2 movto_Pic + + -- produces a Behaviour that produces movement in a circle, taking + -- the radius and the increment as arguments. +circ_mov :: Float -> Float -> Behaviour +circ_mov r inc = mov (map (vmin' (head vs')) vs') + where vs = [ (r*(cos theta),r*(sin theta)) | + theta <- gen inc 0.0 ] + vmin' x y = vmin y x + vs' = map vftov vs + +gen :: Float -> Float -> [Float] +gen b c = c : (gen b (c+b) ) + + + -- scale outputs a list of Pic-to-Pic's that scale according to its + -- corresponding Int in the input list +scale :: [Int] -> Behaviour +scale = makeb2 scale_Pic + + -- scale_rel does the same thing, but centers on the lower-left corner of + -- the image +scale_rel :: Vec -> [Int] -> Behaviour +scale_rel v = makeb2 (scale_rel_Pic v) + + -- twist outputs a list of Behaviours that rotate each pick by its + -- corresponding Float in the list +twist :: [Float] -> Behaviour +twist = makeb2 twist_Pic + + -- set_color takes a list of Colors, and returns a list of Pic-to-Pic's + -- that change to the corresponding color in the list +set_color :: [Color] -> Behaviour +set_color = makeb2 set_Color_Pic + + -- makeb3 takes a function with two inputs, and two input lists and + -- returns a behaviour made up of functions with inputs fromt the lists +makeb3 :: (a->b->Pic->Pic) -> [a] -> [b] -> Behaviour +makeb3 f [] (p:ps) = [] +makeb3 f (v:vs) [] = [] +makeb3 f (v:vs) (p:ps) = f v p : makeb3 f vs ps + + -- rot produces behaviours rotating by the Float, around the point + -- of the Vec, both provided by lists. +rot :: [Vec] -> [Float] -> Behaviour +rot = makeb3 rot_Pic + + -- bseq takes two Behaviours and combines them into one, in sequence. + -- It first applies all of the first Behaviour, then all of the second +bseq :: Behaviour -> Behaviour -> Behaviour +bseq ps [] = [] +bseq [] qs = [] +bseq ps qs = ps ++ (mapc (last ps) qs) + + -- bSeq takes a list of Behaviour and makes them into one Behaviour, in + -- sequence. +bSeq :: [Behaviour] -> Behaviour +bSeq = reduce bseq + + -- bpar takes two behaviours and applies them both simultaneously, + -- producing a list of Pic-to-Pic's, each one made up of a function + -- from the first list combined with a function from the second list +bpar :: Behaviour -> Behaviour -> Behaviour +bpar [] (q:qs) = [] +bpar (p:ps) [] = [] +bpar (p:ps) (q:qs) = (p.q):(bpar ps qs) + + -- bPar takes a list of Behaviours and makes them all into one Behaviour, + -- in paralell +bPar :: [Behaviour] -> Behaviour +bPar = reduce bpar + + -- takes the first n POic-to-Pics in a Behaviour and returns that Behaviour +do :: Int -> Behaviour -> Behaviour +do n f = take n f + + -- applies bseq to the list of behaviours, so that the nth element of + -- the returned list has n-1 behaviours in it, applied in sequence +rpt :: Int -> Behaviour -> Behaviour +rpt n f = replicate n bseq [] f + + -- takes the behaviour and applies all the behaviours up the nth element + -- to the nth element, in an infinite list +forever :: Behaviour -> Behaviour +forever f = bseq f (forever f) + + -- takes a behaviour, applies each from to a Pic in a Movie and returns + -- the new Movie +apply :: Behaviour -> Movie -> Movie +apply [] ms = [] +apply fs [] = [] +apply (f:fs) (m:ms) = (f m):(apply fs ms) + + -- applies the Behaviour to the Movie until the condition is fullfilled, + -- then returns the movie to that point +while :: (Pic -> Bool) -> Behaviour -> Movie -> Movie +while c [] ms = [] +while c fs [] = [] +while c (f:fs) (m:ms) = if (c m) then ( (f m):(while c fs ms)) + else [] + + diff --git a/progs/demo/X11/animation/r_behaviour.hu b/progs/demo/X11/animation/r_behaviour.hu new file mode 100644 index 0000000..afa52bb --- /dev/null +++ b/progs/demo/X11/animation/r_behaviour.hu @@ -0,0 +1,3 @@ +:o= all +r_behaviour.hs +r_picture.hu diff --git a/progs/demo/X11/animation/r_constants.hs b/progs/demo/X11/animation/r_constants.hs new file mode 100644 index 0000000..f36e3f2 --- /dev/null +++ b/progs/demo/X11/animation/r_constants.hs @@ -0,0 +1,129 @@ +{-**************************************************************** + MODULE R_CONSTANTS + + This module sets up all the constants used in this functional + animation package. + Defined here are the basic units of movement, scale and rotation. + The screen height and width are set, and the various parts of + the screen such as the top-middle, lower-left and center are + all set. Finally the color values used by xcshow, the c-program + that displays the movies in X, are set. + +******************************************************************-} + +module R_Constants (fps, unit, hf, qt, scaleunit, rotunit, + nullpic, nullseq, + sinunit,cosunit, + screenwid, screenht, botl, leftm, topl, topm, topr, + rightm, botr, botm, center, + white,black,red,green,darkblue,lightblue,brown,yellow, + colorName, allColors + ) where + +import R_Ptypes + + -- units are set. The scaleunit is in 11th, so that the 12 is + -- actually 12/11'ths +fps :: Int +unit :: Int +hf :: Int +qt :: Int +scaleunit :: Int +fps = 25 +unit = 15 +hf = unit `div` 2 +qt = unit `div`4 +scaleunit = 12 + --scaleunit is div'ed by 12 later + +rotunit :: Float +rotunit = pi/18 +sinunit = sin rotunit +cosunit = cos rotunit + + +nullpic :: Pic +nullpic = [] +nullseq :: Movie +nullseq= nullpic : [ nullseq2 | nullseq2 <- nullseq] + + -- Screen Parameters +screenwid :: Int +screenwid = 800 +screenht :: Int +screenht = 800 + +botl :: Vec +leftm :: Vec +topl :: Vec +topm :: Vec +topr :: Vec +rightm :: Vec +botr :: Vec +botm :: Vec +center :: Vec + +leftmb :: Vec +leftmt :: Vec +topml :: Vec +topmr :: Vec +rightmt :: Vec +rightmb :: Vec +botml :: Vec +botmr :: Vec + +botl = ( 0, 0 ) +leftm = ( 0, screenht `div` 2) +topl = ( 0, screenht ) +topm = ( screenwid `div` 2, screenht ) +topr = ( screenwid, screenht ) +rightm = ( screenwid, screenht `div` 2 ) +botr = ( screenwid, 0 ) +botm = ( screenwid `div` 2, 0 ) +center = ( screenwid `div` 2, screenht `div` 2 ) + +leftmb = ( 0, screenht `div` 4 ) +leftmt = ( 0, (screenht*3) `div` 4 ) +topml = ( screenwid `div` 4, screenht ) +topmr = ( (screenwid*3) `div` 4, screenht ) +rightmt = ( screenwid, (screenht*3) `div` 4 ) +rightmb = ( screenwid, screenht `div` 4 ) +botml = ( screenwid `div` 4, 0 ) +botmr = ( (screenwid*3) `div` 4, 0 ) + + -- Colors values set to names + +white :: Color +white = 1 +black :: Color +black = 2 +red :: Color +red = 4 +green :: Color +green = 6 +darkblue :: Color +darkblue = 8 +lightblue :: Color +lightblue = 10 +yellow :: Color +yellow = 12 +brown :: Color +brown = 14 + +colorName :: Color -> String +colorName 1 = "white" +colorName 2 = "black" +colorName 4 = "red" +colorName 6 = "green" +colorName 8 = "blue" +colorName 10 = "lightblue" +colorName 12 = "yellow" +colorName 14 = "brown" + +allColors :: [Color] +allColors = [1,2,4,6,8,10,12,14] + + + + + diff --git a/progs/demo/X11/animation/r_constants.hu b/progs/demo/X11/animation/r_constants.hu new file mode 100644 index 0000000..d61580f --- /dev/null +++ b/progs/demo/X11/animation/r_constants.hu @@ -0,0 +1,3 @@ +:o= all +r_constants.hs +r_ptypes.hu diff --git a/progs/demo/X11/animation/r_curve.hs b/progs/demo/X11/animation/r_curve.hs new file mode 100644 index 0000000..14d288c --- /dev/null +++ b/progs/demo/X11/animation/r_curve.hs @@ -0,0 +1,60 @@ +{-************************************************************** + MODULE R_CURVE + + This module produces sequences of numbers to be used by + Behaviours. The sequences used for moving or scaling can + be produced here, in either linear sequences or accelerating + and decelerating sequences. + The acceleration functions produce floats, so the vftov function + would have to be used to convert floating point vectors to integer + vectors. + +***************************************************************-} + +module R_Curve(lnr,hold, acc, dec, accdec, decacc) where + +import R_Ptypes +import R_Constants +import R_Utility +import R_Picture +import R_Behaviour + + -- lnr takes the start, finish and the number of intervals and + -- produces a linear list of ints going from the start to finish. +lnr :: Int -> Int -> Int ->[Int] +lnr start fin n = take n [start,(start+step)..] + where step = ((fin-start)`div`(n-1)) + + -- hold produces an infinite number of ints starting at v, modified + -- by step every time. +hold :: Int -> Int -> [Int] +hold v step = [v,v+step..] + + -- acc accelerates from 0 to the max in n steps. +acc :: Int -> Int -> Int -> [Int] +acc min max n = min:acc' min (max-min) n 1 + +acc' :: Int -> Int -> Int -> Int -> [Int] +acc' min max n c | (c>n) = [] +acc' min max n c = (min + (((max*c*c) `div` (n*n)))) + : (acc' min max n (c+1)) + + + -- dec decelerates from the max to 0 in n steps. +dec :: Int -> Int -> Int -> [Int] +dec min max n = reverse (acc min max n) + + -- accdec accelerates from start up to max and back to fin, in an steps + -- accelerating and dn steps decelerating +accdec :: Int -> Int -> Int -> Int -> Int -> [Int] +accdec start max fin an dn = (acc start max an)++(tail (dec fin max dn)) + + -- decacc decelerates from start to min in dn steps and then accelerates + -- back up to fin in an more steps +decacc :: Int -> Int -> Int -> Int -> Int -> [Int] +decacc start min fin dn an = (dec min start dn)++(tail (acc min fin an)) + + + + + diff --git a/progs/demo/X11/animation/r_curve.hu b/progs/demo/X11/animation/r_curve.hu new file mode 100644 index 0000000..9aa9629 --- /dev/null +++ b/progs/demo/X11/animation/r_curve.hu @@ -0,0 +1,3 @@ +:o= all +r_curve.hs +r_behaviour.hu diff --git a/progs/demo/X11/animation/r_defaults.hs b/progs/demo/X11/animation/r_defaults.hs new file mode 100644 index 0000000..1b7070a --- /dev/null +++ b/progs/demo/X11/animation/r_defaults.hs @@ -0,0 +1,76 @@ +{-**************************************************************** + MODULE R_DEFAULTS + + This module uses the R_Behaviour module to define convient and + easy to use behaviours. These aren't very sophistated, but they + can be used to quickly animate a movie. For more sophistated + animation, a similiar library of sophistocated personnalized + functions can be created. + +******************************************************************-} + +module R_Defaults (big, huge, bigger, smaller, ccw, cw, + up, down, left, right,small,tiny) +where + +import R_Ptypes +import R_Constants +import R_Utility +import R_Picture +import R_Behaviour + + + -- big scales everything up by the scaleunit (now 12/11ths) +big :: Behaviour +big = [scale_Pic x | x <- [scaleunit,scaleunit..]] + + -- huge scales everything up by twice the scaleunit (24/11ths) +huge :: Behaviour +huge= [scale_Pic x | x <- [scaleunit*2,(scaleunit*2)..]] + + -- small scales everything down by 10/11ths +small :: Behaviour +small = [scale_Pic x | x <- [s,s..]] + where s = 10 + + -- tiny scales everything down by 5/11ths +tiny :: Behaviour +tiny = [scale_Pic x | x <- [s,s..]] + where s = 5 + + -- bigger causes the Pics to be scaled up by 12/11ths,24/11ths,36/11ths + -- and so on, everincreasing. +bigger :: Behaviour +bigger = [scale_Pic x | x <- (rept (\x -> div (x*scaleunit) 11) 1)] + + -- smaller causes the Pics to be scaled downwards in ever decreasing + -- amounts. +smaller :: Behaviour +smaller = [scale_Pic x | x <- (rept (\x -> div (x*10) 11) 1)] + + -- a hardwired version of ccw that rotates the Pics by one rotunit + -- more every Pic, counterclockwise. +ccw :: Behaviour +ccw = [twist_Pic x | x <- [0.0,rotunit..]] + + -- same as ccw, but rotates the Pics clockwise +cw :: Behaviour +cw = [twist_Pic x | x <- [0.0,-rotunit..]] + + -- moves the Pic up by one more unit every Pic. +up :: Behaviour +up = [mov_Pic (x,y) | (x,y)<- zip2 [0,0..] [0,unit..]] + + -- moves the Pic down by one more unit every Pic. +down :: Behaviour +down = [mov_Pic (x,y) | (x,y)<-zip2 [0,0..] [0,-unit]] + + -- moves the Pic left by one more unit every Pic. +left :: Behaviour +left = [mov_Pic (x,y) | (x,y)<- zip2 [0,-unit..] [0,0..]] + + -- moves the Pic right by one more unit every Pic. +right :: Behaviour +right = [mov_Pic (x,y) | (x,y)<- zip2 [0,unit..] [0,0..]] + + diff --git a/progs/demo/X11/animation/r_defaults.hu b/progs/demo/X11/animation/r_defaults.hu new file mode 100644 index 0000000..f945bbc --- /dev/null +++ b/progs/demo/X11/animation/r_defaults.hu @@ -0,0 +1,3 @@ +:o= all +r_defaults.hs +r_behaviour.hu diff --git a/progs/demo/X11/animation/r_display.hs b/progs/demo/X11/animation/r_display.hs new file mode 100644 index 0000000..19f1d4a --- /dev/null +++ b/progs/demo/X11/animation/r_display.hs @@ -0,0 +1,114 @@ +module R_Display (displaym) where + +import R_Ptypes +import R_Utility +import Xlib +import R_Constants + +displaym :: String -> Int -> Movie -> IO () + +displaym host n movie = + let + movie' = cycle (take n (map (map translatePoly) movie)) + in + xOpenDisplay host + `thenIO` \ display -> + let (screen:_) = xDisplayRoots display + fg_color = xScreenBlackPixel screen + bg_color = xScreenWhitePixel screen + color_map = xScreenDefaultColormap screen + getPixels [] = returnIO [] + getPixels (c:cs) = + xLookupColor color_map c `thenIO` \ (xc, _) -> + xAllocColor color_map xc `thenIO` \ (p,_,_) -> + getPixels cs `thenIO` \ ps -> + returnIO (p:ps) + in + getPixels (map colorName allColors) + `thenIO` \ pixels -> + let + lookupPixel c = lookupPixel1 c allColors pixels + + lookupPixel1 x [] _ = head pixels + lookupPixel1 x (c:cs) (p:ps) = + if x == c then p + else lookupPixel1 x cs ps + parent = xScreenRoot screen + in + xMArrayCreate [lookupPixel i | i <- [0..15]] + `thenIO` \ pixelArray -> + xCreateGcontext (XDrawWindow parent) + [XGCBackground bg_color, + XGCForeground fg_color] + `thenIO` \ gcontext -> + xCreateGcontext (XDrawWindow parent) + [XGCBackground bg_color, + XGCForeground bg_color] + `thenIO` \ blank_gcontext -> + xCreateWindow parent + (XRect 100 100 500 500) + [XWinBackground bg_color, + XWinEventMask (XEventMask [XButtonPress])] + `thenIO` \window -> + let depth = xDrawableDepth (XDrawWindow window) + in + xCreatePixmap (XSize 500 500) depth (XDrawWindow parent) + `thenIO` \ pixmap -> + xMapWindow window + `thenIO` \() -> + let + dispFrame m = + xDrawRectangle (XDrawPixmap pixmap) + blank_gcontext + (XRect 0 0 500 500) + True + `thenIO_` + dispPic m + `thenIO_` + xCopyArea (XDrawPixmap pixmap) gcontext (XRect 0 0 500 500) + (XDrawWindow window) (XPoint 0 0) + `thenIO_` + xDisplayForceOutput display + + dispPic [] = returnIO () + dispPic (p:ps) = dispPoly p `thenIO_` dispPic ps + + dispPoly (c, vec) = +-- xLookupColor color_map (colorName c) `thenIO` \ ec -> +-- xAllocColor color_map ec `thenIO` \ p -> + xMArrayLookup pixelArray c `thenIO` \p -> + xUpdateGcontext gcontext [XGCForeground p] `thenIO` \ () -> +-- xSetGcontextForeground gcontext (lookupPixel c) `thenIO` \ () -> + xDrawLines (XDrawPixmap pixmap) gcontext vec True + + untilButton3 (frame:frames) = + let + action = dispFrame frame `thenIO_` untilButton3 frames + in + xEventListen display `thenIO` \count -> + if count == 0 then action else + xGetEvent display `thenIO` \event -> + case (xEventType event) of + XButtonPressEvent -> + case (xEventCode event) of + 3 -> returnIO () + _ -> action + _ -> action + in + printString ("Click right button to end.\n") `thenIO_` + untilButton3 movie' `thenIO_` + xFreePixmap pixmap `thenIO_` + xCloseDisplay display + +type Movie' = [Pic'] +type Pic' = [Poly'] +type Poly' = (Int, [XPoint]) + +translatePoly :: Poly -> Poly' +translatePoly (c, vs) = (c, flatten_2 vs) + +flatten_2 [] = [] +flatten_2 ((a,b):r) = (XPoint (a `div` 2) (b `div` 2)):(flatten_2 r) + +printString :: String -> IO () +printString s = appendChan "stdout" s abort (returnIO ()) diff --git a/progs/demo/X11/animation/r_display.hu b/progs/demo/X11/animation/r_display.hu new file mode 100644 index 0000000..23f2c77 --- /dev/null +++ b/progs/demo/X11/animation/r_display.hu @@ -0,0 +1,6 @@ +:o= foldr inline constant +r_constants.hu +r_utility.hu +r_ptypes.hu +r_display.hs +$HASKELL_LIBRARY/X11/xlib.hu diff --git a/progs/demo/X11/animation/r_inbetween.hs b/progs/demo/X11/animation/r_inbetween.hs new file mode 100644 index 0000000..a7fb7d3 --- /dev/null +++ b/progs/demo/X11/animation/r_inbetween.hs @@ -0,0 +1,82 @@ +{-****************************************************************** + MODULE R_INBETWEEN + + This module takes care of interpolation functions. Basically, + given two Pics, inbetween will give you a movie gradually + converting from one Pic to the other Pic, using linear interpolation. + Tween will take two Movies, and append them, interpolating n + frames between the last Pic of the first Movie and the first Pic of + the last Movie. + +******************************************************************-} + +module R_Inbetween (inbetween,tween) where + +import R_Ptypes +import R_Utility +import R_Picture +import R_Behaviour + + -- inbetween takes an int and two Pics, and interpolates n Pics + -- of interpolated Pics. +inbetween :: Int -> Pic -> Pic -> Movie +inbetween n p1 p2 | (length p1 == length p2) = + ((zip1.(map (inbetweenp n))).zip1) [p1,p2] +inbetween n p1 p2 = inbetween n [(col,p1')] [(col,p2')] + where p1' = concat [ vs | (c,vs) <- p1] + p2' = concat [ vs | (c,vs) <- p2] + col = head [ c | (c,vs) <- p1 ] + + -- inbetweenp takes a list of 2 Polygons ([[Vec]]) and returns a + -- sequence of interpolated Polygons. Should the Number of vertices + -- of one Polygon be less than those in the other, it splits it so + -- as to have two Polygons of the same length. +inbetweenp :: Int -> Pic -> Pic +inbetweenp n [(c1,vs),(c2,ws)] = + if ((length vs) < (length ws)) then + inbetween1 (split (length ws) (c1,vs)) (c2,ws) 0 n + else if ((length vs) > (length ws)) then + inbetween1 (c1,vs) (split (length vs) (c2,ws)) 0 n + else inbetween1 (c1,vs) (c2,ws) 0 n + + + -- inbetween1 returns a sequence of interpolated Polygons. +inbetween1 :: Poly -> Poly -> Int -> Int -> Pic +inbetween1 p1 p2 m n | m>n || n<=0 = [] +inbetween1 p1 p2 m n = inbetween2 p1 p2 m n + :inbetween1 p1 p2 (m+1) n + + -- inbetween2 returns ONE of the required sequence of + -- interpolated Polygons. +inbetween2 :: Poly -> Poly -> Int -> Int -> Poly +inbetween2 (c1,vs) (c2,ws) p q = (c1, map (partway p q) (zip1 [vs,ws])) + + -- split splits up a Polygon so as to have the given #vertices. +split :: Int -> Poly -> Poly +split n (c,vs) = (c, split' n vs) + +split' :: Int -> [Vec] -> [Vec] +split' n vs | n<= (length vs) = vs +split' n vs = if (n>double) then + split' n (split' double vs) + else + v1:(mid v1 v2):(split' (n-2) (v2:vss)) + where double = 2*((length vs)) - 1 + (v1:v2:vss) = vs + + + -- tween will interpolate n Pics transforming the last Pic of + -- the first Movie into the first Pic of the second Movie, and + -- then run the second Movie +tween :: Int -> Movie -> Movie -> Movie +tween n m1 [] = m1 +tween n m1 m2 = m1 ++ (inbetween n (last m1) (head m2')) ++ (tail m2') + where m2' = apply (mov (repeat v)) m2 + v = vmin (orig_Pic (last m1)) (orig_Pic (head m2)) + + -- tweens will take a list of Movies and append them all, interpolating + -- n frames between every Movie. +tweens :: Int -> [Movie] -> Movie +tweens n = foldr (tween n) [] + + diff --git a/progs/demo/X11/animation/r_inbetween.hu b/progs/demo/X11/animation/r_inbetween.hu new file mode 100644 index 0000000..52771d0 --- /dev/null +++ b/progs/demo/X11/animation/r_inbetween.hu @@ -0,0 +1,3 @@ +:o= all +r_inbetween.hs +r_behaviour.hu diff --git a/progs/demo/X11/animation/r_movie.hs b/progs/demo/X11/animation/r_movie.hs new file mode 100644 index 0000000..a97a452 --- /dev/null +++ b/progs/demo/X11/animation/r_movie.hs @@ -0,0 +1,114 @@ +{-********************************************************************* + MODULE R_MOVIE + + This module contains necessary functions for editing Movies. There + are several that give information on a Movie, such as the heights or + wirdths of its Pics. The others all deal with the various ways of + combining various Movies into one Movie, a vital set of functions. + +*********************************************************************-} + +module R_Movie (ht, wid, orig, + above, rABOVE, beside, rBESIDE,rBESIDE2, over, rOVER, + overlay, rOVERLAY, pUT, + uncurry, curry + ) where + +import R_Ptypes +import R_Constants +import R_Utility +import R_Picture + + -- takes a function and a list and returns a new list of element operated + -- on by the function. +promote:: (a->b)->[a]->[b] +promote f [] = [] +promote f [p] = f p:promote f [p] +promote f (p:ps) = f p:promote f ps + + -- promote1 takes a function that analyzes a Pic, and then applies it + -- to analyse a movie, returning a list. +promote1:: (Pic->a) -> Movie -> [a] +promote1 f ps = [f p | p <- ps] + + -- ht takes a Movie and returns a list of the heights of the Pics +ht :: Movie -> [Int] +ht = promote1 ht_Pic + + -- wid takes a Movie and returns a list of the widths of the Pics +wid :: Movie -> [Int] +wid = promote1 wid_Pic + + -- orig takes a Movie and returns a list of vectors that are the + -- origins of the Pics +orig:: Movie -> [Vec] +orig = promote1 orig_Pic + + -- promote2 takes a function accepting an element and a Pic, and + -- applies the function to the Movie and list, producing a new Movie +promote2:: (a->Pic->Pic) -> [a] -> Movie -> Movie +promote2 f ps qs = [f p q | (p,q) <- zip2 ps qs] + + -- takes two Movies and puts them above one another +above:: Movie -> Movie -> Movie +above = promote2 above_Pic + + -- takes a list of Movies and puts them all above one another +rABOVE:: [Movie] -> Movie +rABOVE = reduce above + + -- takes two Movies and puts them beside one another +beside:: Movie -> Movie -> Movie +beside = promote2 beside_Pic + + -- takes a list of Movies and puts them all beside one another +rBESIDE:: [Movie] -> Movie +rBESIDE = reduce beside + + -- same as beside, but with absolute coordinates. +beside2:: Movie -> Movie -> Movie +beside2 = promote2 beside2_Pic + + -- same as rBESIDE, but with absolute coordinates. +rBESIDE2:: [Movie] -> Movie +rBESIDE2 = reduce beside2 + + -- puts one Movie on top of the other Movie +over:: Movie -> Movie -> Movie +over = promote2 over_Pic + + -- takes a list of Movies, and puts the n-th on top of the first + -- through 9n-1)th. +rOVER:: [Movie] -> Movie +rOVER = reduce over + + -- just overlays the two Movies by appending the Pics. +overlay:: Movie -> Movie -> Movie +overlay = promote2 overlay_Pic + + -- overlays a list of Movies by appending the Pics +rOVERLAY:: [Movie] -> Movie +rOVERLAY = reduce overlay + + -- promote3 takes a function that takes two items and a Pic and + -- returns a Pic, and then applies it to two input lists and a Movie, + -- producing a new Movie. +promote3:: (a->b->Pic->Pic) -> [a] -> [b] -> Movie -> Movie +promote3 f ps qs rs = [f p q r | (p,q,r) <- zip3 ps qs rs] + + -- pUT takes a list of Vectors, and puts each Pic of the first Movie + -- in the location of the corresponding vector, on top of the Pic of + -- the second Movie, and returns that list as a new Movie. +pUT:: [Vec] -> Movie -> Movie -> Movie +pUT = promote3 put_Pic + + -- uncurry takes a function that takes two elements and a list of + -- two elements and applies the function to them. +uncurry:: (a->a->b) -> [a] -> b +uncurry f [a,b] = f a b + + -- curry takes a function that takes a list, and two elements, and + -- then applies the function to the elements in a list. +curry:: ([a]->b) -> a -> a -> b +curry f a b = f [a,b] + diff --git a/progs/demo/X11/animation/r_movie.hu b/progs/demo/X11/animation/r_movie.hu new file mode 100644 index 0000000..0023a04 --- /dev/null +++ b/progs/demo/X11/animation/r_movie.hu @@ -0,0 +1,3 @@ +:o= all +r_movie.hs +r_picture.hu diff --git a/progs/demo/X11/animation/r_picture.hs b/progs/demo/X11/animation/r_picture.hs new file mode 100644 index 0000000..ed3a50f --- /dev/null +++ b/progs/demo/X11/animation/r_picture.hs @@ -0,0 +1,188 @@ +{-************************************************************ + MODULE R_PICTURE + + This module contains all the functions that can be used to manipulate + Pic's. The user will probably never use any of these functions. They + are used by Behaviours and such higher-order functions, which apply + these routines to all the Pic's in the list. + +*************************************************************-} + +module R_Picture (close_Pic, ht_Pic, wid_Pic, orig_Pic, + overlay_Pic, put_Pic, over_Pic, above_Pic, beside_Pic, + map_Pic,beside2_Pic, + scale_Pic, scale_rel_Pic, mov_Pic, rot_Pic, twist_Pic, + twist_Pic', flipx_Pic, flipy_Pic, flip_Pic, {- flock_Pic, -} + set_Color_Pic, + to_orig_Pic, + movto_Pic + ) where + +import R_Ptypes +import R_Constants +import R_Utility + + -- close_Pic makes sure that the polygon is closed +close_Pic:: Pic -> Pic +close_Pic p = map close_Poly p + where + close_Poly (c,ply) | (head ply) == (last ply) = (c,ply) + close_Poly (c,ply) = (c,ply++(tail (reverse ply))) + + --these functions find the max and min x and y coordinates of a Pic +maxx :: Pic -> Int +maxx p = reduce max [x | (c,q) <- p, (x,y) <- q] + +minx :: Pic -> Int +minx p = reduce min [x | (c,q) <- p, (x,y) <- q] + +maxy :: Pic -> Int +maxy p = reduce max [y | (c,q) <- p, (x,y) <- q] + +miny :: Pic -> Int +miny p = reduce min [y | (c,q) <- p, (x,y) <- q] + + -- these functions find the height, width and origin of a Pic +ht_Pic :: Pic -> Int +ht_Pic p = (maxy p) - (miny p) + +wid_Pic :: Pic -> Int +wid_Pic p = (maxx p) - (minx p) + +orig_Pic:: Pic -> Vec +orig_Pic p = ( (maxx p + minx p) `div` 2, (maxy p + miny p) `div` 2 ) + +-- PICTURE COMBINING OPERATIONS: + + -- overlay_Pic just takes 2 Pics and puts them together into one +overlay_Pic:: Pic -> Pic -> Pic +overlay_Pic p q = p ++ q + + -- put_Pic overlays the Pics, offsetting the first Pic by a vector + -- amount from the origin of the second +put_Pic:: Vec -> Pic -> Pic -> Pic +put_Pic v p q = overlay_Pic + (movto_Pic (vplus (orig_Pic q) v) p ) + q + + -- over_Pic puts one Pic directly on top of the other +over_Pic:: Pic -> Pic -> Pic +over_Pic p q = put_Pic (0,0) p q + + -- above_Pic puts the first Pic on top of the second +above_Pic:: Pic -> Pic -> Pic +above_Pic p q = put_Pic (0,(((ht_Pic q) + (ht_Pic p)) `div` 2)) p q + + -- beside_Pic puts the first Pic beside the second. The width of + -- the Pic is defined as the max x minus the min x, so a moving + -- figure will stand still in this implementation +beside_Pic:: Pic -> Pic -> Pic +beside_Pic p q = put_Pic (((wid_Pic q)+(wid_Pic p)) `div` 2, 0) p q + + -- beside2_Pic puts the first Pic beside the second, without + -- shifting to the width of the Pic. It uses the absolute coordinates. +beside2_Pic:: Pic -> Pic -> Pic +beside2_Pic p q = put ((wid_Pic q), 0) p q + where put v p q = overlay_Pic (mov_Pic v p) q + + + -- The following maps a given function over the Vector-list of each Polygon: +map_Pic:: (Vec -> Vec) -> Pic -> Pic +map_Pic f p = map f' p + where f' (c,vs) = (c, map f vs) + +-- THE GEOMETRIC TRANSFORMATIONS: + + -- scales the Pic by r, where r is in units of 11th. ie r=1, the Pic is + -- scaled by 1/11 to its origin. +scale_Pic :: Int -> Pic -> Pic +scale_Pic r p + = map_Pic (scalep r) p + where scalep r (v1,v2) = (div ((r*(v1-dx))+dx) 11,div ((r*(v2-dy))+dy) 11) + dx = fst (orig_Pic p) + dy = snd (orig_Pic p) + + -- this is another scaling function, but it centers the image at the Vec +scale_rel_Pic :: Vec -> Int -> Pic -> Pic +scale_rel_Pic v r + = map_Pic (scalep r) + where scalep r (v1,v2) = (div ((r*(v1-dx))+dx) 11,div ((r*(v2-dy))+dy) 11) + dx = fst v + dy = snd v + + -- moves a Pic by the vector amount +mov_Pic:: Vec -> Pic -> Pic +mov_Pic v = map_Pic (vplus v) + + -- moves a Pic to the vector +movto_Pic:: Vec -> Pic -> Pic +movto_Pic v p = mov_Pic (vmin v (orig_Pic p)) p + + -- moves the origin of the Pic to the lower left side of the Pic +to_orig_Pic:: Pic -> Pic +to_orig_Pic p = mov_Pic (-mx,-my) p + where mx = minx p + my = miny p + + -- rotates the Pic about the Vector by theta +rot_Pic :: Vec -> Float -> Pic -> Pic +rot_Pic (a,b) theta + = map_Pic (rotp (a,b) theta) + where rotp (a,b) t (v1,v2) + = vftov (a2+ (u * cos theta - v * sin theta), + b2+ (u * sin theta + v * cos theta)) + where u = u1 -a2 + v = u2 -b2 + (u1,u2) = vtovf (v1,v2) + (a2,b2) = vtovf (a,b) + + -- rotates a Pic about its origin by theta +twist_Pic :: Float -> Pic -> Pic +twist_Pic theta p = rot_Pic (orig_Pic p) theta p + + + -- hardwired version of rot_Pic that runs faster by rotating a set + -- unit, the rotunit, every time +rot_Pic':: Vec -> Pic -> Pic +rot_Pic' (a,b) = map_Pic (rotp (a,b)) + where rotp (a,b) (v1,v2) + = vftov (a2+ (u * cosunit - v * sinunit), + b2+ (u * sinunit + v * cosunit)) + where u = u1-a2 + v = u2-b2 + (u1,u2) = vtovf (v1,v2) + (a2,b2) = vtovf (a,b) + + -- hardwired version of twist_Pic that runs faster using rot_Pic' +twist_Pic':: Pic -> Pic +twist_Pic' p = rot_Pic' (orig_Pic p) p + + -- flips the Pic about the line x=n (x-coordinates change) +flipx_Pic :: Int -> Pic -> Pic +flipx_Pic n = map_Pic (flipvx n) + where + flipvx n (a,b) = (2*(n-a)+a,b) + + -- flips the Pic about the line y=n (y-coordinates change) +flipy_Pic :: Int -> Pic -> Pic +flipy_Pic n = map_Pic (flipvy n) + where + flipvy n (a,b) = (a, 2*(n-b)+b) + + -- flips the Pic about its own x origin. +flip_Pic:: Pic -> Pic +flip_Pic p = map_Pic (flipvx x) p + where (x,y) = orig_Pic p + flipvx n (a,b) = (2*(n-a)+a,b) + + -- copies the Pic into another Pic n*n times in an n by n array pattern +flock_Pic :: Int -> Pic -> Pic +flock_Pic 1 p = p +flock_Pic (n+2) p = beside_Pic (flock_Pic (n-1) p) (row n p) + where row n p = replicate n above_Pic nullpic p + + -- changes the color of the Pic +set_Color_Pic:: Color -> Pic -> Pic +set_Color_Pic c p = map f p + where f (c',vs) = (c,vs) + diff --git a/progs/demo/X11/animation/r_picture.hu b/progs/demo/X11/animation/r_picture.hu new file mode 100644 index 0000000..932d87c --- /dev/null +++ b/progs/demo/X11/animation/r_picture.hu @@ -0,0 +1,4 @@ +:o= all +r_picture.hs +r_constants.hu +r_utility.hu diff --git a/progs/demo/X11/animation/r_ptypes.hs b/progs/demo/X11/animation/r_ptypes.hs new file mode 100644 index 0000000..c020f82 --- /dev/null +++ b/progs/demo/X11/animation/r_ptypes.hs @@ -0,0 +1,67 @@ +{-*********************************************************************** + MODULE PTYPES + + This module contains the definitions for all the basic datatypes used to + create functional movies. + The basis of all the images is the Poly, which is a tuple of a color + and a list of points. This is displayed as a polygon of that color. The + form is a line drawn to each of the points, in order. + A list of these Poly's is a Pic, or picture. Each picture is a single + frame of the movie. A list of Pic's makes up a Movie, which is a series + of Pic's displayed in order. + Behaviours affect the movies, such as moving them left, or right. + PictoPic's affect a single picture. + The other functions simply convert regular values such as integers + and floats to the datatypes used by the functional programming. + +************************************************************************-} + + +module R_Ptypes (Vec(..), Color(..), Pic(..), Poly(..), Movie(..), Behaviour(..), PictoPic(..), Process(..), + Vecfloat(..), + Msg(..), Chan(..), + Val (..), + ntov, vtov, nstov, vstov, pstov, bstov + ) where + + + --These are the basic data types for storing and manipulating the movies. + +type Vec = (Int,Int) +type Color = Int +type Pic = [Poly] +type Poly = (Color,[Vec]) +type Movie = [Pic] +type Behaviour = [Pic -> Pic] +type PictoPic = Pic -> Pic + +type Process = [Msg] -> [Msg] +type Msg = [(Chan,Val)] +type Chan = [Char] + +data Val = N Int | V (Int,Int) | P Pic | B PictoPic + +type Vecfloat = (Float,Float) + + + +--Those convert from the various regular values to Val's. + +ntov n = N n + +vtov:: Vec -> Val +vtov v = V v + +ptov:: Pic -> Val +ptov p = P p + +nstov ns = [N n|n<-ns] + +vstov:: [Vec] -> [Val] +vstov vs = [V v|v<-vs] + +pstov:: [Pic] -> [Val] +pstov ps = [P p|p<-ps] + +bstov:: [PictoPic] -> [Val] +bstov bs = [B b|b<-bs] diff --git a/progs/demo/X11/animation/r_ptypes.hu b/progs/demo/X11/animation/r_ptypes.hu new file mode 100644 index 0000000..8a99f8f --- /dev/null +++ b/progs/demo/X11/animation/r_ptypes.hu @@ -0,0 +1,2 @@ +:o= all +r_ptypes.hs diff --git a/progs/demo/X11/animation/r_shapes.hs b/progs/demo/X11/animation/r_shapes.hs new file mode 100644 index 0000000..aef3362 --- /dev/null +++ b/progs/demo/X11/animation/r_shapes.hs @@ -0,0 +1,38 @@ +{-***************************************************************** + MODULE R_SHAPES + + This modules produces Pic's of boxes and triangles to help build + Pic's to animate. + +******************************************************************-} + +module R_Shapes (box, tri, circ_mov, circ) where + +import R_Ptypes +import R_Utility +import R_Picture +import R_Behaviour + + -- box takes four three ints, the color, width and height of the box and + -- returns a Pic of a box +box :: Int -> Int -> Int -> Pic +box c width height= [(c,[(0,0),(width,0),(width,height),(0,height),(0,0)])] + + -- tri takes a color and three vectors, and returns a Pic of a triangle + -- with the vectors as vertices +tri:: Color -> Vec -> Vec -> Vec -> Pic +tri c (x1,y1) (x2,y2) (x3,y3) = [(c,[(x1,y1),(x2,y2),(x3,y3),(x1,y1)])] + + + -- circ takes a color, the radius +circ :: Color -> Int -> Int -> Pic +circ c r inc = [(c,(r+r,r):(circ' r' inc' 1.0))] + where r' = (fromIntegral r) + inc' = (fromIntegral inc) + +circ' :: Float -> Float -> Float -> [Vec] +circ' r inc c | c>inc = [] +circ' r inc c = vftov (x+r,y+r) : (circ' r inc (c+1.0)) + where x = r*(cos((2*c*pi)/inc)) + y = r*(sin((2*c*pi)/inc)) + diff --git a/progs/demo/X11/animation/r_shapes.hu b/progs/demo/X11/animation/r_shapes.hu new file mode 100644 index 0000000..ad0bf40 --- /dev/null +++ b/progs/demo/X11/animation/r_shapes.hu @@ -0,0 +1,3 @@ +:o= all +r_shapes.hs +r_behaviour.hu diff --git a/progs/demo/X11/animation/r_utility.hs b/progs/demo/X11/animation/r_utility.hs new file mode 100644 index 0000000..9dfcc65 --- /dev/null +++ b/progs/demo/X11/animation/r_utility.hs @@ -0,0 +1,150 @@ +{-********************************************************************* + MODULE R_UTILITY + + This module contains all the basic utility functions that the other + modules need to have to write their code. These are made generally + low level functions, manipulating vectors or defining very + general functions + +**********************************************************************-} + + +module R_Utility (vtovf,vftov, + vplus, vmin, mid, partway, + mag, + reduce, power, i, + member, repeat, zip1, zip2, zip3, rept, replicate, + mapc, + append, flatten, rptseq, osc + ) where + +import R_Ptypes + + +-- CONVERSION + + -- vtovf takes a vector of integers, and converts it to a vector of floats +vtovf :: Vec -> Vecfloat +vtovf (x,y) = (fromIntegral x,fromIntegral y) + + -- vftov takes a vector of floats and converts it to a vector of integers. + -- It rounds the floats off to do this. +vftov :: Vecfloat -> Vec +vftov (x,y) = (round x,round y) + + +-- VECTOR OPERATIONS: + + -- vector addition +vplus:: Vec -> Vec -> Vec +vplus (a,b) (c,d) = (a+c,b+d) + + -- vector substraction +vmin:: Vec -> Vec -> Vec +vmin (a,b) (c,d) = (a-c,b-d) + + -- finds the midpoint between two vectors +mid:: Vec -> Vec -> Vec +mid (x1,y1) (x2,y2) = (div (x1+x2) 2,div (y1+y2) 2 ) + + -- finds a point p/q along the way between two vectors +partway :: Int -> Int -> [Vec] -> Vec +partway p q [(x1,y1),(x2,y2)] + = vplus (x1,y1) ( div (p*(x2-x1)) q, div (p*(y2-y1)) q ) + + -- finds the magnitude of two vectors +mag :: Vec -> Int +mag p = round (magfloat (vtovf p)) + +magfloat :: Vecfloat -> Float +magfloat (x,y) = sqrt (x*x + y*y) + + -- returns a vector at right angles to the input vector +normal:: Vec -> Vec +normal (x,y) = (-y,x) + + -- returns the first vector projected onto the second +project:: Vec -> Vec -> Vec +project (vx,vy) (wx,wy) = partway (vx*wx+vy*wy) (mw*mw) [(0,0),(wx,wy)] + where mw = mag (wx,wy) + + +-- HIGHER-ORDER FUNCTIONS: + + -- just foldr1. It applies a function of two inputs to an entire list + -- recursively, and displays the single element result +reduce :: (a->a->a) -> [a] -> a +reduce = foldr1 + + -- power applies a single function n times to a seed +power :: Int -> (a->a) -> a -> a +power 0 f seed = seed +power (n+1) f seed = f (power n f seed) + + -- i takes an element and returns an infinite list of them +i :: a -> [a] +i x = x: (i x) + + -- checks to see if x is in the list of xs +member :: (Eq a) => [a] -> a -> Bool +member [] x = False +member (y:ys) x = x == y || member ys x + + -- zip1 takes lists of lists, and rearranges them so that all the first + -- elements are in the first list, all the second in the second and so on. +zip1 :: (Eq a) => [[a]] -> [[a]] +zip1 xs | member xs [] = [] +zip1 xs = (map head xs):(zip1 (map tail xs)) + + -- takes two lists and makes a list of tuples. +zip2 :: [a] -> [b] -> [(a,b)] +zip2=zip + + -- rept takes a function and a list of elements, and applies the function + -- n-1 times to the n-th element +rept :: (a->a) -> a -> [a] +rept f x = x:(rept f (f x)) + + -- replicate creates an list n elements long of a, with the function + -- applies to the n-th element n-1 times. +replicate :: Int -> (a->a->a) -> a -> a -> a +replicate 0 f zero a = zero +replicate 1 f zero a = a +replicate (n+2) f zero a = f a (replicate (n+1) f zero a) + + -- mapc is a map function for lists of functions (behaviours) +mapc :: (a->b) -> [c->a] -> [c->b] +mapc f as = [f.a | a <- as] + + +-- FUNCTIONS OVER SEQUENCES: + + -- append takes a list of lists, and makes them into one giant happy list. +append :: [[a]] -> [a] +append = foldr (++) [] + + -- flatten takes a list of lists of tuples and gives one giant happy list + -- of single elements back. +flatten:: [[(a,a)]] -> [a] +flatten s = foldr f [] (append s) + where f (x,y) [] = [x,y] + f (x,y) (z:zs) = x:y:(z:zs) + + -- rptseq takes a list of elements and applies a function to them, + -- n-1 times for the n-th element, but using map +rptseq :: (a->a) -> [a] -> [a] +rptseq f [] = [] +rptseq f (x:xs) = x:rptseq f (map f xs) + + -- osc takes a list, and makes sure it oscillates. If the head is + -- equal to the tail, it simply repeats the sequence infinitely. If + -- the head is not equal to the tail, it adds the sequence then adds + -- the reversed sequence minus the first and last elements, and then repeats +osc :: [a] -> [a] +osc s | (length s) == 0 = [] +osc s | (length s) == 1 = head s: osc s +osc s = (s ++ (((tail.reverse).tail) s)) ++ (osc s) + + + + diff --git a/progs/demo/X11/animation/r_utility.hu b/progs/demo/X11/animation/r_utility.hu new file mode 100644 index 0000000..6fac189 --- /dev/null +++ b/progs/demo/X11/animation/r_utility.hu @@ -0,0 +1,3 @@ +:o= all +r_utility.hs +r_ptypes.hu diff --git a/progs/demo/X11/animation/seafigs.hs b/progs/demo/X11/animation/seafigs.hs new file mode 100644 index 0000000..c216a63 --- /dev/null +++ b/progs/demo/X11/animation/seafigs.hs @@ -0,0 +1,158 @@ +module Seafigs (sky,blue_sky,clouds,clouds2,gull,man,sun,vm,windmill,palm) where + +import Animation + +blue_sky:: Movie +blue_sky = osc [box lightblue 1000 1000] + +sky:: Color -> Movie +sky c = osc [box c 1000 1000] + +clouds2:: Movie +clouds2 = apply (mov (i (cld_wid,0))) (rBESIDE[cld,cld]) + where cld_wid = -(wid_Pic (cld!!0)) + cld= apply (bPar [right,mov (repeat (250,-50))]) cldm1 + cldm1=osc[cloud1] + +clouds:: Movie +clouds + = rOVERLAY + [apply (bPar [right,mov (repeat (250,-50))]) cloudm1, + apply (bPar [right,mov (repeat (0,-50))]) cloudm2, + apply (bPar [right,mov (repeat (250,-75))]) cloudm2, + apply (bPar [right,flipb,smaller,mov(repeat (200,-100))]) cloudm2, + apply (bPar [right,flipb,smaller,mov(repeat (300,-125))]) cloudm1, + apply (bPar [right,right,mov (repeat (-50,50))]) cloudm1] + where cloudm1 = osc [cloud1] + cloudm2 = osc [cloud2] + + +cloud1 = [(white,ply)] + where ply = [(142,301),(169,309),(180,315),(192,312), + (196,308),(202,302),(216,300),(224,308), + (238,312),(258,311),(274,301),(278,283), + (265,279),(246,279),(230,281),(197,286), + (185,288),(167,287),(148,287),(136,292), + (136,292),(142,301)] + + +cloud2 = [(white,ply)] + where ply = [(51,262), (56,266), + (66,265), (90,264), (92,266), (98,270), + (111,268),(137,268),(155,266),(174,266), + (183,262),(183,253),(162,251),(136,254), + (132,250),(126,248),(115,252),(109,253), + (98,252), (90,253), (88,254), (67,254), + (56,252), (49,254), (47,259), (51,262)] + +gull :: Movie +gull = osc [gull1,gull2] + +gull1 = [(black,[(2,4),(6,4),(9,2),(10,0),(11,2), + (16,4),(20,4)])] + +gull2 = [(black,[(0,0),(2,2),(6,3),(9,2),(12,3), + (16,2),(18,0)])] + +man :: Movie +man = osc [man1,man2,man3] + + +man1 = [(black,[(0,0),(10,0),(20,40),(30,60),(40,20), + (60,0),(50,0)]), + (black,[(0,40),(20,60),(30,80),(50,70),(60,60)]), + (black,[(30,60),(30,100)]), + (black,[(30,100),(25,100),(20,105),(23,112), + (20,115),(30,120),(35,120),(40,115), + (40,110),(35,105),(30,100)]) + ] + +man2 = [(black,[(20,0),(30,0),(20,40),(30,60),(45,30), + (60,20),(50,0)]), + (black,[(0,60),(20,60),(20,80),(40,80),(50,60)]), + (black,[(30,60),(20,100)]), + (black,[(20,100),(15,100),(10,105),(13,112), + (10,115),(20,120),(30,120),(30,115), + (30,110),(25,105),(20,100)]) + ] + +man3 = [(black,[(0,15),(5,10),(15,45),(30,60),(35,25), + (44,10),(35,0)]), + (black,[(10,40),(22,60),(20,80),(40,75),(45,44)]), + (black,[(30,60),(20,100)]), + (black,[(20,100),(19,100),(14,105),(17,112), + (14,115),(24,120),(34,120),(34,115), + (34,110),(29,105),(200,100)]) + ] + +sun :: Movie +sun = osc [sun'] + where + sun' = reduce overlay_Pic [sun1, + twist_Pic (pi/24.0) sun1, + twist_Pic (pi/12.0) sun1] + +sun1 = [(yellow,[(43,16),(18,27),(9,51),(20,71),(42,81), + (66,73),(76,47),(69,25),(43,15),(43,16)])] + +vm :: Movie +vm = osc[vm1,vm2] + +vm1 = beside_Pic (box brown 10 15) + (above_Pic light1 (box brown 40 80)) + where light1 = box yellow 10 10 + +vm2 = beside_Pic (box brown 10 15) + (reduce above_Pic [light,light2,box brown 40 80]) + where light2 = over_Pic (box red 10 10) (box white 5 5) + light = [ (red,[(5,5), (10,2), (0,30),(5,5)]), + (red,[(20,2),(25,5),(30,30),(20,2)]), + (red,[(15,15),(20,15),(15,50),(10,25)])] + +windmill :: Movie +windmill + = apply + (bpar (mov (repeat (unit*3,0))) (scale_rel (0,0) (repeat 3))) + (overlay body (apply (movto (repeat (100,400))) prop)) + +blade = osc [tri red (0,0) (100,0) (50,300)] +prop = apply cw fan + +fan = rOVERLAY [fan1,fan2,fan3,fan4] +fan1 = blade +fan2 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan1 +fan3 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan2 +fan4 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan3 + +body = osc [ [(brown,[(0,0),(200,0),(170,300), + (100,400),(30,300),(0,0)]) ] ] + + +palm :: Movie +palm + = osc palms + where palms = inbetween 3 palm1 (flipx_Pic 100 palm1) + palm1 = reduce overlay_Pic [trunk,frond1,frond2,frond3,frond4] + where frond1 = [ (green,[(50,60),(60,70),(80,60)]), + (green,[(50,70),(60,80),(80,70)]), + (green,[(50,80),(55,90),(70,80)]), + (green,[(60,70),(55,90),(50,100)]) ] + + frond2 = flipx_Pic 50 frond1 + + frond3 = [ (green,[(10,70),(5,80)]), + (green,[(10,80),(10,90)]), + (green,[(20,90),(20,100)]), + (green,[(30,95),(40,104)]), + (green,[(5,80),(20,100),(40,104), + (50,100)])] + + frond4 = [(green,[(0,100),(5,110)]), + (green,[(15,105),(15,115)]), + (green,[(25,105),(30,115)]), + (green,[(35,105),(40,115)]), + (green,[(5,110),(30,115),(50,110), + (50,100)])] + + trunk = [(brown,[(100,0),(95,40),(80,80), + (70,90),(60,97),(50,100)])] diff --git a/progs/demo/X11/animation/seafigs.hu b/progs/demo/X11/animation/seafigs.hu new file mode 100644 index 0000000..83fcfcf --- /dev/null +++ b/progs/demo/X11/animation/seafigs.hu @@ -0,0 +1,3 @@ +:o= all +animation.hu +seafigs.hs diff --git a/progs/demo/X11/animation/seaside.hs b/progs/demo/X11/animation/seaside.hs new file mode 100644 index 0000000..fe11e12 --- /dev/null +++ b/progs/demo/X11/animation/seaside.hs @@ -0,0 +1,25 @@ +module Seaside (main) where + +import Animation +import Seafigs + +seaside :: Movie +seaside = rOVERLAY [blue_sky, + apply (bPar [up,cw,movto (repeat botm)]) sun, + apply right clouds, + apply (bPar [right,bigger]) gull, + apply (bPar [right,right,bigger]) gull, + apply (bPar [up,up,right,bigger]) gull, + apply (bPar [up,right,right,right]) gull, + windm, + apply (mov (repeat botm)) palm, + man_and_vm + ] + where man_and_vm = rBESIDE2 [manfig, vm] + manfig = apply left (apply (mov (i (700,0))) + man) + windm = apply (mov (i (500,0))) windmill + + +main = getEnv "DISPLAY" exit + (\ host -> displaym host 30 (map (flipy_Pic 500) seaside)) diff --git a/progs/demo/X11/animation/seaside.hu b/progs/demo/X11/animation/seaside.hu new file mode 100644 index 0000000..df2c4b9 --- /dev/null +++ b/progs/demo/X11/animation/seaside.hu @@ -0,0 +1,5 @@ +:o= all +seaside.hs +seafigs.hu + + diff --git a/progs/demo/X11/draw/README b/progs/demo/X11/draw/README new file mode 100644 index 0000000..b844d2b --- /dev/null +++ b/progs/demo/X11/draw/README @@ -0,0 +1 @@ +This is the draw program used in the X window documentation diff --git a/progs/demo/X11/draw/draw.hs b/progs/demo/X11/draw/draw.hs new file mode 100644 index 0000000..1ba68ce --- /dev/null +++ b/progs/demo/X11/draw/draw.hs @@ -0,0 +1,41 @@ +module Draw where + +import Xlib + +main = getEnv "DISPLAY" exit (\ host -> draw host) + +draw :: String -> IO () +draw host = + xOpenDisplay host `thenIO` \ display -> + let (screen:_) = xDisplayRoots display + fg_color = xScreenBlackPixel screen + bg_color = xScreenWhitePixel screen + root = xScreenRoot screen + in + xCreateWindow root + (XRect 100 100 400 400) + [XWinBackground bg_color, + XWinEventMask (XEventMask [XButtonMotion, + XButtonPress, + XKeyPress])] + `thenIO` \window -> + xMapWindow window `thenIO` \() -> + xCreateGcontext (XDrawWindow root) + [XGCBackground bg_color, + XGCForeground fg_color] `thenIO` \ gcontext -> + let + handleEvent :: XPoint -> IO () + handleEvent last = + xGetEvent display `thenIO` \event -> + let pos = xEventPos event + in + case (xEventType event) of + XButtonPressEvent -> handleEvent pos + XMotionNotifyEvent -> + xDrawLine (XDrawWindow window) gcontext last pos `thenIO` \() -> + handleEvent pos + XKeyPressEvent -> xCloseDisplay display + _ -> handleEvent last + in + appendChan stdout "Press any key to quit.\n" exit done `thenIO` \ _ -> + handleEvent (XPoint 0 0) diff --git a/progs/demo/X11/draw/draw.hu b/progs/demo/X11/draw/draw.hu new file mode 100644 index 0000000..f09a72e --- /dev/null +++ b/progs/demo/X11/draw/draw.hu @@ -0,0 +1,2 @@ +$HASKELL_LIBRARY/X11/xlib.hu +draw.hs diff --git a/progs/demo/X11/gobang/README b/progs/demo/X11/gobang/README new file mode 100644 index 0000000..d5634a4 --- /dev/null +++ b/progs/demo/X11/gobang/README @@ -0,0 +1,66 @@ +gobang Weiming Wu & Niping Wu + + +Introduction + +Our final project is to design and implement a Gobang game under +X-Window3.2 environment, using the Haskell programming language. Users +can play the game human-vs-human. The program also provides a robot +player with whom the user can play the game with. We wrote altogether +ten modules which were saved in different files to control the whole +game. + + +About Gobang + +The checkerboard of Gobang consists of 19 vertical lines and 19 +horizontal lines. Two players in turn place a unit on the +checkerboard. Each unit should be put on an unoccupied intersection +of a vertical and a horizontal line. The winner is the player who +first makes five consecutive units on either vertical, horizontal or +diagonal direction. + +The program is able to perform the following tasks: 1) Use a new +window under X-Window interface to display the checkerboard. Players +will use a mouse to place units onto the chessboard, where a unit is a +circle with the color black or white. 2) Prompt for the names of both +players and display them. 3) Calculate the time both players have +used up. 4) Supervise the progress of the game, declare winner and +end the game once one player wins. 5) At each point of the game, +store the progress of the game, so players can review each step during +the game. 6) There are five buttons on the screen which would provide +some special services such as starting a new game, quitting the game, +saving the game, importing the saved game, or reviewing the game as +soon as the user selects the corresponding buttons. 7) Provide a +moderately well robot player for that game (using minimum-maximum +algorithm). + + +Running Gobang + +A window titled "gobang" will appear on the screen. On it is a +checkerboard, clocks and buttons. There will be an instruction saying +"Please enter the name of player-1". The user can do two things: +either enter the name of a player or choose the "import" button. Once +the "import" button is selected, an unfinished game, which was saved +in the file "###go.bhs###" will be imported. Please notice that the +character "@" is reserved for the robot player, so if the user types +in @ as the name of the first player, it is assumed that player-1 is +the robot player. Then the name of player 2 is prompted. The game +starts and at each turn an instruction like "Please enter your play." +would appear on the screen. The user should put a unit onto the +checkerboard. If the button is clicked on a wrong place or a unit is +put onto an occupied position, an error message saying "Wrong Point. +Please reenter." will appear on the screen and the user should reenter +his play. The marker next to the name of a player indicates whose +turn it is. At any point of the game the user can choose the other +four buttons. If the "new" button is selected, the present game will +be terminated and a new blank checkerboard will be displayed on the +screen; if the "review" button is selected, one step of the previous +plays will be displayed each time after the user hits any key; if the +"save" button is selected, the steps so far will be saved into the +file "###go.bhs###"; if the "quit" button is selected, the game will +be terminated. + + + diff --git a/progs/demo/X11/gobang/gobang.hs b/progs/demo/X11/gobang/gobang.hs new file mode 100644 index 0000000..f4844dc --- /dev/null +++ b/progs/demo/X11/gobang/gobang.hs @@ -0,0 +1,364 @@ +module Gobang where + +import Xlib +import Utilities +import Redraw +import Weights + +getXInfo :: String -> IO XInfo +getXInfo host = + xOpenDisplay host `thenIO` \ display -> + let (screen:_) = xDisplayRoots display + fg_pixel = xScreenBlackPixel screen + bg_pixel = xScreenWhitePixel screen + root = xScreenRoot screen + in + xCreateWindow root + (XRect 0 0 900 600) + [XWinBackground bg_pixel, + XWinEventMask (XEventMask [XButtonPress, + XKeyPress, + XExposure])] + `thenIO` \ window -> + xSetWmName window "Gobang" `thenIO` \() -> + xMapWindow window `thenIO` \() -> + xOpenFont display "10x20" `thenIO` \ playerfont -> + xOpenFont display "6x13" `thenIO` \ genericfont -> + xCreateGcontext (XDrawWindow window) + [XGCBackground bg_pixel, + XGCForeground fg_pixel] `thenIO` \ gcontext -> + xCreateGcontext (XDrawWindow window) + [XGCBackground fg_pixel, + XGCForeground bg_pixel, + XGCFont genericfont] `thenIO` \ gcontext2 -> + xCreateGcontext (XDrawWindow window) + [XGCBackground bg_pixel, + XGCForeground fg_pixel, + XGCFont playerfont] `thenIO` \ gcontextp -> + returnIO (XInfo display window gcontext gcontext2 gcontextp) + +demo = main + +main = getEnv "DISPLAY" exit $ \ host -> + xHandleError (\(XError msg) -> appendChan stdout msg exit done) $ + gobang host + +gobang :: String -> IO () +gobang host = + getXInfo host `thenIO` \ xinfo -> + xMArrayCreate [1..361] `thenIO` \ board -> + xMArrayCreate [1..361] `thenIO` \ weight1 -> + xMArrayCreate [1..361] `thenIO` \ weight2 -> + xMArrayCreate [1..722] `thenIO` \ steps -> + xMArrayCreate [""] `thenIO` \ player1 -> + xMArrayCreate [""] `thenIO` \ player2 -> + xMArrayCreate [1..4] `thenIO` \ time -> + xMArrayCreate [1] `thenIO` \ numbersteps -> + xMArrayCreate [""] `thenIO` \ promptString -> + xMArrayCreate [1] `thenIO` \ next_player -> + let state = GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player + in + initGame xinfo state `thenIO` \ _ -> + promptPlayers xinfo state `thenIO` \ _ -> + playGame xinfo state + +promptPlayers xinfo state = + let (XInfo display window gcontext gcontext2 gcontextp) = xinfo + (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + in + promptFor "player 1:" xinfo state `thenIO` \ player1_name -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 65) player1_name + `thenIO` \ _ -> + xMArrayUpdate player1 0 player1_name `thenIO` \ _ -> + promptFor "player 2:" xinfo state `thenIO` \ player2_name -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 205) player2_name + `thenIO` \ _ -> + xMArrayUpdate player2 0 player2_name `thenIO` \ _ -> + clearCmd xinfo state + +initGame :: XInfo -> GameState -> IO () +initGame xinfo + state@(GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = + getTime `thenIO` \ curtime -> + initArray time 0 2 0 `thenIO` \() -> + initArray time 2 4 curtime `thenIO` \() -> + initArray numbersteps 0 1 0 `thenIO` \() -> + initArray board 0 361 0 `thenIO` \() -> + initArray weight1 0 361 0 `thenIO` \() -> + initArray weight2 0 361 0 `thenIO` \ () -> + initArray next_player 0 1 1 `thenIO` \ () -> + clearCmd xinfo state `thenIO` \ () -> + redraw xinfo state + + +handleButton :: XPoint -> XInfo -> GameState -> GameCont -> IO () +handleButton (XPoint x y) + xinfo + state@(GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) + cont + | buttonPress 700 330 x y = initArray player1 0 1 "" `thenIO` \ _ -> + initArray player2 0 1 "" `thenIO` \ _ -> + initGame xinfo state `thenIO` \ _ -> + promptPlayers xinfo state `thenIO` \ _ -> + playGame xinfo state + | buttonPress 700 360 x y = initGame xinfo state `thenIO` \ _ -> + playGame xinfo state + | buttonPress 700 390 x y = undoGame xinfo state cont + | buttonPress 700 420 x y = loadGame xinfo state cont + | buttonPress 700 450 x y = saveGame xinfo state `thenIO` \ () -> + cont xinfo state + | buttonPress 700 480 x y = quitGame xinfo state cont + | ishelp x y = helpGame xinfo state `thenIO` \ () -> + cont xinfo state + | otherwise = cont xinfo state + +when :: Bool -> IO () -> IO () +when cond action = if cond then action else returnIO () + +undoGame xinfo@(XInfo display window gcontext gcontext2 gcontextp) + state@(GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) + cont = + xMArrayLookup next_player 0 `thenIO` \ next_p -> + xMArrayLookup player1 0 `thenIO` \ name1 -> + xMArrayLookup player2 0 `thenIO` \ name2 -> + let undoStep n = + xMArrayLookup steps (2*n) `thenIO` \ x -> + xMArrayLookup steps (2*n+1) `thenIO` \ y -> + xMArrayUpdate board ((x-1)*19 + y-1) 0 `thenIO` \ _ -> + (if (name1 == "computer" || name2 == "computer") + then draw_unit board weight1 weight2 x y + else returnIO ()) `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext2 + (XRect (x*30-15) (y*30-15) 30 30) True + `thenIO` \() -> +-- drawBoard xinfo `thenIO` \ _ -> +-- drawPieces 1 1 board xinfo `thenIO` \ _ -> + let x30 = x * 30 + y30 = y * 30 + c = XPoint x30 y30 + w = XPoint (x30-15) y30 + e = XPoint (x30+15) y30 + no = XPoint x30 (y30-15) + s = XPoint x30 (y30+15) + m = XArc (x30-3) (y30-3) 6 6 (-1.0) 6.283 + in + when (x > 1) (xDrawLine (XDrawWindow window) gcontext w c) + `thenIO` \ _ -> + when (x < 19) (xDrawLine (XDrawWindow window) gcontext c e) + `thenIO` \ _ -> + when (y > 1) (xDrawLine (XDrawWindow window) gcontext no c) + `thenIO` \ _ -> + when (y < 19) (xDrawLine (XDrawWindow window) gcontext c s) + `thenIO` \ _ -> + when ((x `elem` [4,10,16]) && (y `elem` [4,10,16])) + (xDrawArc (XDrawWindow window) gcontext m True) + `thenIO` \ _ -> + xDisplayForceOutput display `thenIO` \ _ -> + xMArrayUpdate numbersteps 0 n `thenIO` \ _ -> + xMArrayLookup next_player 0 `thenIO` \ next_p -> + xMArrayUpdate next_player 0 (if next_p == 1 then 2 else 1) + + cur_name = if next_p == 1 then name1 else name2 + last_name = if next_p == 1 then name2 else name1 + in + xMArrayLookup numbersteps 0 `thenIO` \ n -> + if n==0 then drawCmd "No more steps to undo!" xinfo state `thenIO` \ _ -> + cont xinfo state + else + if cur_name == "computer" then cont xinfo state + else + (undoStep (n-1) `thenIO` \_ -> + if (last_name == "computer" && n /= 1) then undoStep (n-2) + else + returnIO ()) `thenIO` \ _ -> + playGame xinfo state + + + + +promptFile xinfo state cont = + promptFor "File name:" xinfo state `thenIO` \ name -> + readFile name + (\ _ -> drawCmd ("Can't read file:" ++ name) xinfo state + `thenIO` \ _ -> + cont XNull) + (\ content -> cont (XSome content)) + +loadGame xinfo state cont = + promptFile xinfo state $ \ file -> + case file of + XNull -> cont xinfo state + XSome file_content -> + readGameState file_content `thenIO` \ new_state -> + let (GameState _ _ _ _ _ _ time _ _ _) = new_state + in + getTime `thenIO` \ curtime -> + initArray time 2 4 curtime `thenIO` \() -> + redraw xinfo new_state `thenIO` \ _ -> + playGame xinfo new_state + +saveGame :: XInfo -> GameState -> IO () +saveGame xinfo state = + promptFor "File name:" xinfo state `thenIO` \ name -> + showGameState state `thenIO` \ str -> + writeFile name str + (\ _ -> drawCmd ("Can't write file: " ++ name) xinfo state) + done + +quitGame :: XInfo -> GameState -> GameCont -> IO () +quitGame xinfo state cont = + let (XInfo display window gcontext gcontext2 gcontextp) = xinfo + in + promptFor "Are you sure? (y/n)" xinfo state `thenIO` \ reps -> + if (reps == "y" || reps == "Y") then xCloseDisplay display + else clearCmd xinfo state `thenIO` \ _ -> + cont xinfo state + +playGame :: XInfo -> GameState -> IO () +playGame xinfo state = + let + (XInfo display window gcontext gcontext2 gcontextp) = xinfo + (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + in + xMArrayLookup numbersteps 0 `thenIO` \ x -> + (\cont -> if x == 361 + then drawCmd "It's a tie!" xinfo state `thenIO` \ _ -> + let loop xinfo state = waitButton xinfo state (\ _ -> loop) + in loop xinfo state + else cont) $ + xMArrayLookup next_player 0 `thenIO` \ next_player_num -> + getTime `thenIO` \ curtime -> + xMArrayLookup time 0 `thenIO` \ lstm0 -> + xMArrayLookup time 1 `thenIO` \ lstm1 -> + xMArrayLookup time 2 `thenIO` \ lstm2 -> + xMArrayLookup time 3 `thenIO` \ lstm3 -> + drawCmd ("Waiting for player # " ++ (show next_player_num)) xinfo state + `thenIO` \() -> + if (next_player_num == 1) + then xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 70) + '<' `thenIO` \(trash) -> + xDrawRectangle (XDrawWindow window) gcontext2 + (XRect 840 180 40 40) True `thenIO` \() -> + xMArrayUpdate time 2 curtime `thenIO` \() -> + xMArrayUpdate time 1 (lstm1+curtime-lstm3) `thenIO` \() -> + showtime 705 270 (lstm1+curtime-lstm3) xinfo `thenIO` \() -> + xMArrayLookup player1 0 `thenIO` \ x -> + if (x == "computer") + then computerplay xinfo state + else humanplay xinfo state + else xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 210) + '<' `thenIO` \(trash) -> + xDrawRectangle (XDrawWindow window) gcontext2 + (XRect 840 40 40 40) True `thenIO` \() -> + xMArrayUpdate time 3 curtime `thenIO` \() -> + xMArrayUpdate time 0 (lstm0+curtime-lstm2) `thenIO` \() -> + showtime 705 130 (lstm0+curtime-lstm3) xinfo `thenIO` \() -> + xMArrayLookup player2 0 `thenIO` \ x -> + if (x == "computer") + then computerplay xinfo state + else humanplay xinfo state + +waitButton xinfo@(XInfo display _ _ _ _) state cont = + let + loop xinfo state = + xGetEvent display `thenIO` \ event -> + case (xEventType event) of + XExposureEvent -> may_redraw (xEventCount event == 0) xinfo state + `thenIO` \ _ -> + loop xinfo state + XButtonPressEvent -> + let pos = xEventPos event + in + handleButton pos xinfo state (cont pos) + _ -> xBell display 0 `thenIO` \ _ -> + loop xinfo state + in + loop xinfo state + +updateboard :: XInfo -> GameState -> Int -> Int -> IO () +updateboard xinfo state x y = + let (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + (XInfo display window gcontext gcontext2 gcontextp) = xinfo + in + xMArrayLookup next_player 0 `thenIO` \ next_player_num -> + xMArrayUpdate next_player 0 (if next_player_num == 1 then 2 else 1) + `thenIO` \ _ -> + xMArrayLookup numbersteps 0 `thenIO` \ z -> + xMArrayUpdate numbersteps 0 (z+1) `thenIO` \() -> + xMArrayUpdate steps (2*z) x `thenIO` \() -> + xMArrayUpdate steps (2*z+1) y `thenIO` \() -> + xMArrayLookup player1 0 `thenIO` \ name1 -> + xMArrayLookup player2 0 `thenIO` \ name2 -> + xMArrayUpdate board (19*(x-1)+y-1) next_player_num + `thenIO` \() -> + human_unit board x y `thenIO` \ win -> + if win + then drawCmd ("Player " ++ (show next_player_num) ++ " has won!") + xinfo state `thenIO` \ _ -> + let loop xinfo state = waitButton xinfo state (\ _ -> loop) + in loop xinfo state + else if (name1 == "computer" || name2 == "computer") + then draw_unit board weight1 weight2 x y `thenIO` \() -> + xMArrayUpdate weight1 (19*(x-1)+y-1) (-1) `thenIO` \() -> + xMArrayUpdate weight2 (19*(x-1)+y-1) (-1) `thenIO` \() -> + playGame xinfo state + else playGame xinfo state + +choice :: XPoint -> XInfo -> GameState -> IO () +choice (XPoint x y) xinfo@(XInfo display _ _ _ _) state = + let (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + in + case (getposition x y) of + XNull -> humanplay xinfo state + XSome (x, y) -> + xMArrayLookup board (19*(x-1)+y-1) `thenIO` \ z -> + if (z>0) + then xBell display 0 `thenIO` \ _ -> + drawCmd "Wrong point, please re-enter" xinfo state `thenIO` \() -> + humanplay xinfo state + else xMArrayLookup next_player 0 `thenIO` \ next_player_num -> + drawPiece x y xinfo (next_player_num == 1) `thenIO` \() -> + updateboard xinfo state x y + +humanplay :: XInfo -> GameState -> IO () +humanplay xinfo state = waitButton xinfo state choice + +computerplay :: XInfo -> GameState -> IO () +computerplay xinfo@(XInfo display window gcontext gcontext2 gcontextp) + state = + let process_events xinfo state cont = + xEventListen display `thenIO` \ n_event -> + if n_event == 0 then cont xinfo state + else xGetEvent display `thenIO` \ event -> + case (xEventType event) of + XButtonPressEvent -> + handleButton (xEventPos event) xinfo state cont + XExposureEvent -> + may_redraw (xEventCount event == 0) + xinfo state + `thenIO` \ _ -> + process_events xinfo state cont + XKeyPressEvent -> + process_events xinfo state cont + in + process_events xinfo state $ + \ xinfo@(XInfo display window gcontext gcontext2 gcontextp) + state@(GameState _ _ _ _ weight1 weight2 _ numbersteps _ next_player) -> + robot numbersteps weight1 weight2 `thenIO` \pt -> + let (XPoint x y) = pt + in + xMArrayLookup next_player 0 `thenIO` \ next_player_num -> + drawPiece x y xinfo (next_player_num == 1) `thenIO` \() -> + updateboard xinfo state x y + + + + diff --git a/progs/demo/X11/gobang/gobang.hu b/progs/demo/X11/gobang/gobang.hu new file mode 100644 index 0000000..d228bb2 --- /dev/null +++ b/progs/demo/X11/gobang/gobang.hu @@ -0,0 +1,7 @@ +:o= foldr inline constant +$HASKELL_LIBRARY/X11/xlib.hu +gobang.hs +misc.hi +utilities.hs +redraw.hs +weights.hs diff --git a/progs/demo/X11/gobang/misc.hi b/progs/demo/X11/gobang/misc.hi new file mode 100644 index 0000000..29a29be --- /dev/null +++ b/progs/demo/X11/gobang/misc.hi @@ -0,0 +1,7 @@ +interface Misc where + +random :: Int -> IO Int + +{-# +random :: LispName("lisp:random") +#-}
\ No newline at end of file diff --git a/progs/demo/X11/gobang/misc.hu b/progs/demo/X11/gobang/misc.hu new file mode 100644 index 0000000..42a9c68 --- /dev/null +++ b/progs/demo/X11/gobang/misc.hu @@ -0,0 +1,2 @@ +misc.hi + diff --git a/progs/demo/X11/gobang/redraw.hs b/progs/demo/X11/gobang/redraw.hs new file mode 100644 index 0000000..9ec772f --- /dev/null +++ b/progs/demo/X11/gobang/redraw.hs @@ -0,0 +1,160 @@ +module Redraw where + +import Xlib +import Utilities + +may_redraw :: Bool -> XInfo -> GameState -> IO () +may_redraw ok xinfo state = if ok then redraw xinfo state else returnIO () + +redraw :: XInfo -> GameState -> IO () + +redraw xinfo state = + let (XInfo display window gcontext gcontext2 gcontextp) = xinfo + in + xDrawRectangle (XDrawWindow window) gcontext2 (XRect 0 0 900 600) True + `thenIO` \ _ -> + drawBoard xinfo `thenIO` \ () -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 610 65) "Player 1" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 620 125) "Clock 1" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 610 205) "Player 2" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 620 265) "Clock 2" + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 700 45 130 30) False + `thenIO` \ () -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 700 105 90 30) False + `thenIO` \ () -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 700 185 130 30) False + `thenIO` \() -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 700 245 90 30) False + `thenIO` \() -> + button 700 330 "New players" xinfo `thenIO` \() -> + button 700 360 "New game" xinfo `thenIO` \() -> + button 700 390 "Undo" xinfo `thenIO` \() -> + button 700 420 "Load" xinfo `thenIO` \() -> + button 700 450 "Save" xinfo `thenIO` \() -> + button 700 480 "Quit" xinfo `thenIO` \() -> + helpButton xinfo `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 615 535 250 30) False + `thenIO` \ _ -> + let (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + in + xMArrayLookup time 0 `thenIO` \ lstm0 -> + xMArrayLookup time 1 `thenIO` \ lstm1 -> + showtime 705 270 (lstm1) xinfo `thenIO` \() -> + showtime 705 130 (lstm0) xinfo `thenIO` \() -> + xMArrayLookup player1 0 `thenIO` \ player1_name -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 65) player1_name + `thenIO` \ _ -> + xMArrayLookup player2 0 `thenIO` \ player2_name -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 205) player2_name + `thenIO` \ _ -> + xMArrayLookup promptString 0 `thenIO` \ ps -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 620 550) ps + `thenIO` \ _ -> + xMArrayLookup next_player 0 `thenIO` \ next_player_num -> + (if (next_player_num == 1) + then xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 70) '<' + else xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 210) '<') + `thenIO` \ _ -> + drawPieces 1 1 board xinfo `thenIO` \ _ -> + returnIO () + +drawHelp (XInfo display window gcontext gcontext2 gcontextp) = + xDrawRectangle (XDrawWindow window) gcontext2 (XRect 100 100 300 200) True + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 100 100 300 200) False + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 102 102 296 196) False + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 200 230 100 60) False + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 202 232 96 56) False + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 240 265) "OK" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 120) + "Two players in turn place black and white" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 135) + "pieces on the board. The winner is the" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 150) + "player who first makes five consecutive" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 165) + "pieces in either vertical, horizontal or" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 180) + "diagonal directions." + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 200) + "To play with a robot, type \"computer\" as" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 215) + "the name of another player." + + +drawBoard (XInfo display window gcontext gcontext2 gcontextp) = + drawvlines 30 30 1 `thenIO` \() -> + drawhlines 30 30 1 `thenIO` \() -> + drawmarks where + + drawvlines :: Int -> Int -> Int -> IO () + drawvlines x y z + | z <= 19 + = xDrawLine (XDrawWindow window) gcontext + (XPoint x y) (XPoint x (y+30*18)) `thenIO` \() -> + drawvlines (x+30) y (z+1) + | otherwise + = returnIO () + + drawhlines :: Int -> Int -> Int -> IO () + drawhlines x y z + | z <= 19 + = xDrawLine (XDrawWindow window) gcontext + (XPoint x y) (XPoint (x+30*18) y) `thenIO` \() -> + drawhlines x (y+30) (z+1) + | otherwise + = returnIO () + + drawmarks :: IO () + drawmarks = + map2IO (\x y -> + xDrawArc (XDrawWindow window) gcontext + (XArc x y 6 6 (-1.0) 6.283) True) + (map (\x -> 30 + x*30-3) [3,9,15,3,9,15,3,9,15]) + (map (\x -> 30 + x*30-3) [3,3,3,9,9,9,15,15,15]) + `thenIO` \ _ -> returnIO () + +map2IO :: (a -> b -> IO c) -> [a] -> [b] -> IO [c] + +map2IO f [] [] = returnIO [] +map2IO f (x:xs) (z:zs) = f x z `thenIO` \ y -> + map2IO f xs zs `thenIO` \ ys -> + returnIO (y:ys) + +drawPieces 20 _ board xinfo = returnIO () +drawPieces x 20 board xinfo = drawPieces (x+1) 1 board xinfo +drawPieces x y board xinfo = + xMArrayLookup board ((x-1)*19 + y-1) `thenIO` \ piece -> + (if (piece == 1 || piece == 2) + then drawPiece x y xinfo (piece == 1) + else returnIO ()) `thenIO` \ _ -> + drawPieces x (y+1) board xinfo + +drawPiece x y (XInfo display window gcontext gcontext2 _ ) is_black = + (if is_black then returnIO () + else xDrawArc (XDrawWindow window) gcontext2 + (XArc (30*x-10) (30*y-10) 20 20 + (-1.0) 6.283) + True) `thenIO` \ _ -> + xDrawArc (XDrawWindow window) gcontext + (XArc (30*x-10) (30*y-10) 20 20 + (-1.0) 6.283) + is_black `thenIO` \ _ -> + xDisplayForceOutput display + diff --git a/progs/demo/X11/gobang/redraw.hu b/progs/demo/X11/gobang/redraw.hu new file mode 100644 index 0000000..7d5aa14 --- /dev/null +++ b/progs/demo/X11/gobang/redraw.hu @@ -0,0 +1,4 @@ +:o= all +$HASKELL_LIBRARY/X11/xlib.hu +redraw.hs +utilities.hs diff --git a/progs/demo/X11/gobang/utilities.hs b/progs/demo/X11/gobang/utilities.hs new file mode 100644 index 0000000..fe2483b --- /dev/null +++ b/progs/demo/X11/gobang/utilities.hs @@ -0,0 +1,305 @@ +module Utilities where + +import Xlib +import Weights +import Redraw +import Misc + +data XInfo = XInfo XDisplay XWindow XGcontext XGcontext XGcontext +data GameState = GameState (XMArray String) (XMArray String) (XMArray Int) + (XMArray Int) (XMArray Int) (XMArray Int) + (XMArray Integer) (XMArray Int) + (XMArray String) (XMArray Int) + +type GameCont = XInfo -> GameState -> IO () + +xMArrayToList :: XMArray a -> IO [a] +xMArrayToList a = + let la = xMArrayLength a + loop i a = if i == la then returnIO [] + else xMArrayLookup a i `thenIO` \ x -> + loop (i+1) a `thenIO` \ xs -> + returnIO (x:xs) + in + loop 0 a + + +readGameState str = + let + [(board_lst, r1)] = reads str + [(weight1_lst, r2)] = reads r1 + [(weight2_lst, r3)] = reads r2 + [(steps_lst, r4)] = reads r3 + [(player1_lst, r5)] = reads r4 + [(player2_lst, r6)] = reads r5 + [(time_lst, r7)] = reads r6 + [(numbersteps_lst, r8)] = reads r7 + [(promptString_lst, r9)] = reads r8 + [(next_player_lst, [])] = reads r9 + in + xMArrayCreate board_lst `thenIO` \ board -> + xMArrayCreate weight1_lst `thenIO` \ weight1 -> + xMArrayCreate weight2_lst `thenIO` \ weight2 -> + xMArrayCreate steps_lst `thenIO` \ steps -> + xMArrayCreate player1_lst `thenIO` \ player1 -> + xMArrayCreate player2_lst `thenIO` \ player2 -> + xMArrayCreate time_lst `thenIO` \ time -> + xMArrayCreate numbersteps_lst `thenIO` \ numbersteps -> + xMArrayCreate promptString_lst `thenIO` \ promptString -> + xMArrayCreate next_player_lst `thenIO` \ next_player -> + returnIO (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) + +showGameState (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = + xMArrayToList board `thenIO` \ board_lst -> + xMArrayToList weight1 `thenIO` \ weight1_lst -> + xMArrayToList weight2 `thenIO` \ weight2_lst -> + xMArrayToList steps `thenIO` \ steps_lst -> + xMArrayToList player1 `thenIO` \ player1_lst -> + xMArrayToList player2 `thenIO` \ player2_lst -> + xMArrayToList time `thenIO` \ time_lst -> + xMArrayToList numbersteps `thenIO` \ numbersteps_lst -> + xMArrayToList promptString `thenIO` \ promptString_lst -> + xMArrayToList next_player `thenIO` \ next_player_lst -> + let + str =(shows board_lst . + shows weight1_lst . + shows weight2_lst . + shows steps_lst . + shows player1_lst . + shows player2_lst . + shows time_lst . + shows numbersteps_lst . + shows promptString_lst . + shows next_player_lst) [] + in + returnIO str + + +xMod :: Int -> Int -> Int +xMod x y | x >= y = xMod (x-y) y + | otherwise = x + +xRes :: Int -> Int -> Int -> Int +xRes x y z | x >= y = xRes (x-y) y (z+1) + | otherwise = z + +drawCmd :: String -> XInfo -> GameState -> IO () +drawCmd a (XInfo display window gcontext gcontext2 gcontextp) + (GameState _ _ _ _ _ _ _ _ str _) + = xDrawRectangle (XDrawWindow window) gcontext2 + (XRect 616 536 248 28) True `thenIO` \ () -> + xDrawGlyphs (XDrawWindow window) gcontext + (XPoint 620 550) a `thenIO` \ _ -> + xMArrayUpdate str 0 a `thenIO` \ _ -> + xDisplayForceOutput display + +clearCmd :: XInfo -> GameState -> IO () +clearCmd (XInfo display window gcontext gcontext2 gcontextp) + (GameState _ _ _ _ _ _ _ _ str _) + = xDrawRectangle (XDrawWindow window) gcontext2 + (XRect 616 536 248 28) True `thenIO` \() -> + xMArrayUpdate str 0 "" `thenIO` \ _ -> + xDisplayForceOutput display + +xPosition :: Int -> XPoint +xPosition a = (XPoint (xRes a 19 1) (1+ (xMod a 19))) + +initArray :: XMArray a -> Int -> Int -> a -> IO () +initArray mary x y z | x<y = xMArrayUpdate mary x z `thenIO` \() -> + initArray mary (x+1) y z + | otherwise = returnIO () + +getposition :: Int -> Int -> XMaybe (Int, Int) +getposition x y = let x1 = round ((fromIntegral x) / 30.0) + y1 = round ((fromIntegral y) / 30.0) + in + if (x1 < 1 || x1 > 19 || y1 < 1 || y1 > 19) then XNull + else XSome (x1, y1) + +addZero :: Int -> String +addZero a | a < 10 = "0" + | otherwise = "" + +printTime :: Int -> Int -> [Int] -> XInfo -> IO() +printTime x y zs (XInfo display window gcontext gcontext2 gcontextp) + = let s = head zs + m = head (tail zs) + h = head (tail (tail zs)) + in xDrawRectangle (XDrawWindow window) gcontext2 + (XRect (x-4) (y-24) 88 28) True `thenIO` \() -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint x y) + ((addZero h)++(show h)++":"++(addZero m)++(show m)++ + ":"++(addZero s)++(show s)) + `thenIO` \(trash) -> + xDisplayForceOutput display + +showtime :: Int -> Int -> Integer -> XInfo -> IO() +showtime x y z a = + let (curtm, c) = (decodeTime z (WestOfGMT 0)) + in printTime x y curtm a + +helpButton :: XInfo -> IO () +helpButton (XInfo display window gcontext gcontext2 gcontextp) = + xDrawRectangle (XDrawWindow window) gcontext (XRect 800 420 70 70) + False `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext (XRect 802 422 66 66) + False `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 810 450) "About" + `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 820 470) "Gobang" + `thenIO` \ _ -> + returnIO () + +ishelp :: Int -> Int -> Bool +ishelp x y = (x > 800 && x < 870 && y > 420 && y < 490) + +button :: Int -> Int -> String -> XInfo -> IO() +button x y a (XInfo display window gcontext gcontext2 gcontextp) = + xDrawArc (XDrawWindow window) gcontext + (XArc (x-40) (y-10) 20 20 1.5708 4.7124) True `thenIO` \() -> + xDrawRectangle (XDrawWindow window) gcontext + (XRect (x-30) (y-10) 60 20) True `thenIO` \() -> + xDrawArc (XDrawWindow window) gcontext + (XArc (x+20) (y-10) 20 20 (-1.0) 6.283) True `thenIO` \() -> + xDrawGlyphs (XDrawWindow window) gcontext2 + (XPoint (x-(length a * 3)) (y+4)) a `thenIO` \(trash) -> + xDisplayForceOutput display + +-- a b are the location of the button, c d are the point where we press the +-- button. + +buttonPress :: Int -> Int -> Int -> Int -> Bool +buttonPress a b c d | (abs (c-a))<=30 && (abs (d-b))<=10 = True + | (c-a+30)*(c-a+30)+(d-b)*(d-b)<=100 = True + | (c-a-30)*(c-a-30)+(d-b)*(d-b)<=100 = True + | otherwise = False + + + +randmax :: XMArray Int -> Int -> Int -> [Int] -> IO Int +randmax a ind max mi | ind > 360 = + let lmi = length mi + in case lmi of + 0 -> returnIO (-1) + 1 -> returnIO (head mi) + _ -> random lmi `thenIO` \ i -> + returnIO (mi !! i) + | otherwise = xMArrayLookup a ind `thenIO` \ tt3 -> + if (tt3 > max) + then randmax a (ind+1) tt3 [ind] + else if (tt3 == max) + then randmax a (ind+1) max (ind:mi) + else randmax a (ind+1) max mi + +robot :: XMArray Int -> XMArray Int -> XMArray Int -> IO XPoint +robot numbersteps weight1 weight2 + = xMArrayLookup numbersteps 0 `thenIO` \(tt5) -> + if (tt5 == 0) + then returnIO (XPoint 10 10) + else + randmax weight1 0 0 [] `thenIO` \ tmp1 -> + randmax weight2 0 0 [] `thenIO` \ tmp2 -> + xMArrayLookup weight1 tmp1 `thenIO` \ tmp3 -> + xMArrayLookup weight2 tmp2 `thenIO` \ tmp4 -> + if (tmp3 >= 200) + then returnIO (xPosition tmp1) + else if (tmp3 > tmp4) + then returnIO (xPosition tmp1) + else returnIO (xPosition tmp2) + + +promptFor prompt xinfo state = + let (GameState player1 player2 board steps weight1 weight2 time + numbersteps promptString next_player) = state + (XInfo display window gcontext gcontext2 gcontextp) = xinfo + in + xDrawRectangle (XDrawWindow window) gcontext2 + (XRect 616 536 248 28) True `thenIO` \() -> + xMArrayUpdate promptString 0 prompt `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint 620 550) prompt + `thenIO` \ _ -> + xDisplayForceOutput display `thenIO` \ _ -> + let h_base = (length prompt + 1) * 6 + 620 + getString :: Int -> String -> IO String + getString h_pos sofar = + xGetEvent display `thenIO` \event -> + case (xEventType event) of + XButtonPressEvent -> + let (XPoint x y) = xEventPos event + in + (if ishelp x y then helpGame xinfo state + else xBell display 0) + `thenIO` \ _ -> + getString h_pos sofar + XExposureEvent -> + may_redraw (xEventCount event == 0) xinfo state `thenIO` \ _ -> + xDrawGlyphs (XDrawWindow window) gcontext (XPoint h_base 550) sofar + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext + (XRect (h_base + 6 * h_pos) (550-10) 6 13) True + `thenIO` \ _ -> getString h_pos sofar + XKeyPressEvent -> + let code = xEventCode event + state = xEventState event + bs = if (sofar == "") then getString h_pos sofar + else xDrawRectangle (XDrawWindow window) gcontext2 + (XRect (h_base + 6 * h_pos) + (550-10) 6 13) + True `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext + (XRect (h_base + 6 * (h_pos - 1)) + (550-10) 6 13) + True `thenIO` \ _ -> + getString (h_pos-1) (take (length sofar - 1) sofar) + in + xKeycodeCharacter display code state `thenIO` \ char -> + case char of + (XSome '\r') -> returnIO sofar + (XSome '\DEL') -> bs + (XSome '\BS') -> bs + XNull -> getString h_pos sofar + (XSome c) -> xDrawRectangle (XDrawWindow window) gcontext2 + (XRect (h_base + 6 * h_pos) + (550-10) 6 13) + True `thenIO` \ _ -> + xDrawGlyph (XDrawWindow window) gcontext + (XPoint (h_base + 6 * h_pos) 550) c + `thenIO` \ _ -> + xDrawRectangle (XDrawWindow window) gcontext + (XRect (h_base + 6 * (h_pos + 1)) + (550-10) 6 13) + True `thenIO` \ _ -> + getString (h_pos + 1) (sofar ++ [c]) + + in + xDrawRectangle (XDrawWindow window) gcontext + (XRect h_base (550-10) 6 13) True + `thenIO` \ _ -> + getString 0 "" + + +helpGame xinfo@(XInfo display window gcontext gcontext2 gcontextp) state = + drawHelp xinfo `thenIO` \ _ -> + let + loop xinfo state = + xGetEvent display `thenIO` \ event -> + case (xEventType event) of + XExposureEvent -> may_redraw (xEventCount event == 0) xinfo state + `thenIO` \ _ -> + drawHelp xinfo `thenIO` \ _ -> + loop xinfo state + XButtonPressEvent -> + let (XPoint x y) = xEventPos event + in + if (x > 200 && x < 300 && y > 230 && y < 290) + then redraw xinfo state `thenIO` \ _ -> + returnIO () + else loop xinfo state + _ -> xBell display 0 `thenIO` \ _ -> + loop xinfo state + in + loop xinfo state + + diff --git a/progs/demo/X11/gobang/utilities.hu b/progs/demo/X11/gobang/utilities.hu new file mode 100644 index 0000000..bfccbfe --- /dev/null +++ b/progs/demo/X11/gobang/utilities.hu @@ -0,0 +1,6 @@ +:o= all +$HASKELL_LIBRARY/X11/xlib.hu +utilities.hs +weights.hs +redraw.hs +misc.hi diff --git a/progs/demo/X11/gobang/weights.hs b/progs/demo/X11/gobang/weights.hs new file mode 100644 index 0000000..1b55553 --- /dev/null +++ b/progs/demo/X11/gobang/weights.hs @@ -0,0 +1,323 @@ +module Weights where + +import Xlib +import Utilities + +xlookup :: XMArray Int -> Int -> Int -> IO Int +xlookup keyboard x y = + if (x < 1 || x > 19 || y < 1 || y > 19) + then returnIO (-2) + else xMArrayLookup keyboard ((x-1)*19+(y-1)) + + +draw_unit :: XMArray Int -> XMArray Int -> XMArray Int -> Int -> Int -> IO() +draw_unit keyboard weight1 weight2 x y = + let + update_weight :: XMArray Int->Int->Int->Int->Int->Int->Int->IO() + update_weight weight counter player x y incr_x incr_y + | x>=1 && x<=19 && y>=1 && y<=19 && counter<=4 = + cpt_weight x y player `thenIO` \wt -> + xMArrayUpdate weight ((x-1)*19+(y-1)) wt `thenIO` \() -> + update_weight weight (counter+1) player (x+incr_x) (y+incr_y) + incr_x incr_y + | otherwise = returnIO () +---------------------------------------------------------------------------- + + pattern0 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern0 a b c d e p | a==p && b==p && c==p && d==p && e==p = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern1 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern1 a b c d e f p | (a==0) && (b==p) && (c==p) && (d==p) && (e==p) && + (f==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern2 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern2 a b c d e p | (a==0 && b==p && c==p && d==p && e==p)|| + (a==p && b==p && c==p && d==p && e==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern3 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern3 a b c d e p | (a==0 && b==p && c==p && d==p && e==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern4 :: Int -> Int -> Int -> Int -> Int -> Bool + pattern4 a b c d p | (a==0 && b==p && c==p && d==p) || + (a==p && b==p && c==p && d==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern5 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern5 a b c d e f p | (a==0 && b==p && c==p && d==0 && e==p && + f==0) || + (a==0 && b==p && c==0 && d==p && e==p && + f==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern6 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern6 a b c d e p | (a==0 && b==p && c==p && d==0 && e==p) || + (a==0 && b==p && c==0 && d==p && e==p) || + (a==p && b==p && c==0 && d==p && e==0) || + (a==p && b==0 && c==p && d==p && e==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern7 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int-> Bool + pattern7 a b c d e f g p | (a==0 && b==p && c==0 && d==p && e==0 && + f==p && g==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern8 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern8 a b c d e f p | (a==0 && b==p && c==0 && d==p && e==0 && + f==p) || + (a==p && b==0 && c==p && d==0 && e==p && + f==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern9 :: Int -> Int -> Int -> Int -> Int -> Bool + pattern9 a b c d p | (a==0 && b==p && c==p && d==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern10 :: Int -> Int -> Int -> Int -> Bool + pattern10 a b c p | (a==0 && b==p && c==p) || + (a==p && b==p && c==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern11 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool + pattern11 a b c d e p | (a==0 && b==p && c==0 && d==p && e==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + pattern12 :: Int -> Int -> Int -> Int -> Int -> Bool + pattern12 a b c d p | (a==0 && b==p && c==0 && d==p) || + (a==p && b==0 && c==p && d==0) = True + | otherwise = False +---------------------------------------------------------------------------- + + direct1 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> + Int -> Int -> Int -> Int -> Int -> Int + direct1 x y pl ptN1 ptN2 ptN3 ptN4 ptN5 pt ptP1 ptP2 ptP3 ptP4 ptP5 + | (pattern0 ptN4 ptN3 ptN2 ptN1 pt pl) || + (pattern0 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern0 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern0 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern0 pt ptP1 ptP2 ptP3 ptP4 pl) = 200 + | (pattern1 ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern1 ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern1 ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern1 ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) = 40 + | (pattern2 ptN4 ptN3 ptN2 ptN1 pt pl) || + (pattern2 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern2 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern2 ptN1 pt ptP1 ptP2 ptP3 pl) = 13 + | (pattern3 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern3 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern3 ptN1 pt ptP1 ptP2 ptP3 pl) = 10 + | (pattern4 ptN3 ptN2 ptN1 pt pl) || + (pattern4 ptN2 ptN1 pt ptP1 pl) || + (pattern4 ptN1 pt ptP1 ptP2 pl) = 8 + | (pattern5 ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern5 ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern5 ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern5 ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) = 9 + | (pattern6 ptN4 ptN3 ptN2 ptN1 pt pl) || + (pattern6 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern6 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern6 ptN1 pt ptP1 ptP2 ptP3 pl) = 7 + | (pattern7 ptN5 ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern7 ptN4 ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern7 ptN3 ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern7 ptN2 ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) || + (pattern7 ptN1 pt ptP1 ptP2 ptP3 ptP4 ptP5 pl) = 6 + | (pattern8 ptN5 ptN4 ptN3 ptN2 ptN1 pt pl) || + (pattern8 ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern8 ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern8 ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern8 ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) || + (pattern8 pt ptP1 ptP2 ptP3 ptP4 ptP5 pl) = 5 + | (pattern9 ptN2 ptN1 pt ptP1 pl) || + (pattern9 ptN1 pt ptP1 ptP2 pl) = 4 + | (pattern10 ptN2 ptN1 pt pl) || + (pattern10 ptN1 pt ptP1 pl) || + (pattern10 pt ptP1 ptP2 pl) = 2 + | (pattern11 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern11 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern11 ptN1 pt ptP1 ptP2 ptP3 pl) = 3 + | (pattern12 ptN3 ptN2 ptN1 pt pl) || + (pattern12 ptN2 ptN1 pt ptP1 pl) || + (pattern12 ptN1 pt ptP1 ptP2 pl) || + (pattern12 pt ptP1 ptP2 ptP3 pl) = 1 + | otherwise = 0 +---------------------------------------------------------------------------- + + direct2 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> + Int -> Int -> Int -> Int -> Int -> Int + direct2 x y pl ptN1 ptN2 ptN3 ptN4 ptN5 pt ptP1 ptP2 ptP3 ptP4 ptP5 + | (pattern0 ptN4 ptN3 ptN2 ptN1 pt pl) || + (pattern0 ptN3 ptN2 ptN1 pt ptP1 pl) || + (pattern0 ptN2 ptN1 pt ptP1 ptP2 pl) || + (pattern0 ptN1 pt ptP1 ptP2 ptP3 pl) || + (pattern0 pt ptP1 ptP2 ptP3 ptP4 pl) = 200 + | otherwise = 0 +----------------------------------------------------------------------------- + + cpt_weight :: Int -> Int -> Int -> IO Int + cpt_weight x y player = + xMArrayLookup keyboard ((x-1)*19+(y-1)) `thenIO` \(unit) -> + if (unit /= 0) + then returnIO (-1) + else xlookup keyboard x (y-1) `thenIO` \(xyN1) -> + xlookup keyboard x (y-2) `thenIO` \(xyN2) -> + xlookup keyboard x (y-3) `thenIO` \(xyN3) -> + xlookup keyboard x (y-4) `thenIO` \(xyN4) -> + xlookup keyboard x (y-5) `thenIO` \(xyN5) -> + xlookup keyboard x (y+1) `thenIO` \(xyP1) -> + xlookup keyboard x (y+2) `thenIO` \(xyP2) -> + xlookup keyboard x (y+3) `thenIO` \(xyP3) -> + xlookup keyboard x (y+4) `thenIO` \(xyP4) -> + xlookup keyboard x (y+5) `thenIO` \(xyP5) -> + xlookup keyboard (x-1) y `thenIO` \(xN1y) -> + xlookup keyboard (x-2) y `thenIO` \(xN2y) -> + xlookup keyboard (x-3) y `thenIO` \(xN3y) -> + xlookup keyboard (x-4) y `thenIO` \(xN4y) -> + xlookup keyboard (x-5) y `thenIO` \(xN5y) -> + xlookup keyboard (x+1) y `thenIO` \(xP1y) -> + xlookup keyboard (x+2) y `thenIO` \(xP2y) -> + xlookup keyboard (x+3) y `thenIO` \(xP3y) -> + xlookup keyboard (x+4) y `thenIO` \(xP4y) -> + xlookup keyboard (x+5) y `thenIO` \(xP5y) -> + xlookup keyboard (x-1) (y-1) `thenIO` \(xN1yN1)-> + xlookup keyboard (x-2) (y-2) `thenIO` \(xN2yN2) -> + xlookup keyboard (x-3) (y-3) `thenIO` \(xN3yN3) -> + xlookup keyboard (x-4) (y-4) `thenIO` \(xN4yN4) -> + xlookup keyboard (x-5) (y-5) `thenIO` \(xN5yN5) -> + xlookup keyboard (x+1) (y+1) `thenIO` \(xP1yP1) -> + xlookup keyboard (x+2) (y+2) `thenIO` \(xP2yP2) -> + xlookup keyboard (x+3) (y+3) `thenIO` \(xP3yP3) -> + xlookup keyboard (x+4) (y+4) `thenIO` \(xP4yP4) -> + xlookup keyboard (x+5) (y+5) `thenIO` \(xP5yP5) -> + xlookup keyboard (x-1) (y+1) `thenIO` \(xN1yP1) -> + xlookup keyboard (x-2) (y+2) `thenIO` \(xN2yP2) -> + xlookup keyboard (x-3) (y+3) `thenIO` \(xN3yP3) -> + xlookup keyboard (x-4) (y+4) `thenIO` \(xN4yP4) -> + xlookup keyboard (x-5) (y+5) `thenIO` \(xN5yP5) -> + xlookup keyboard (x+1) (y-1) `thenIO` \(xP1yN1) -> + xlookup keyboard (x+2) (y-2) `thenIO` \(xP2yN2) -> + xlookup keyboard (x+3) (y-3) `thenIO` \(xP3yN3) -> + xlookup keyboard (x+4) (y-4) `thenIO` \(xP4yN4) -> + xlookup keyboard (x+5) (y-5) `thenIO` \(xP5yN5) -> + returnIO ( (direct1 x y player xyN1 xyN2 xyN3 xyN4 xyN5 player + xyP1 xyP2 xyP3 xyP4 xyP5) + + (direct1 x y player xN1y xN2y xN3y xN4y xN5y player + xP1y xP2y xP3y xP4y xP5y) + + (direct1 x y player xN1yN1 xN2yN2 xN3yN3 xN4yN4 + xN5yN5 player xP1yP1 xP2yP2 xP3yP3 xP4yP4 + xP5yP5) + + (direct1 x y player xN1yP1 xN2yP2 xN3yP3 xN4yP4 + xN5yP5 player xP1yN1 xP2yN2 xP3yN3 xP4yN4 + xP5yN5) ) +----------------------------------------------------------------------------- + +-- | 1111 && no_block = 20 +-- | 1111 && one_block = 13 +-- | 111 && no_block = 10 +-- | 111 && one_block = 8 +-- | 11 1 or 1 11 && no_block = 9 +-- | 11 1 or 1 11 && one_block =7 +-- | 1 1 1 && no_block = 6 +-- | 1 1 1 && one_block= 5 +-- | 11 && no_block = 4 +-- | 11 && one_block =2 +-- | 1 1 && no_block =3 +-- | 1 1 && one_block=1 + + in + update_weight weight1 0 1 x y 1 1 `thenIO` \() -> + update_weight weight2 0 2 x y 1 1 `thenIO` \() -> + update_weight weight1 0 1 x y 1 (-1) `thenIO` \() -> + update_weight weight2 0 2 x y 1 (-1) `thenIO` \() -> + update_weight weight1 0 1 x y (-1) (-1) `thenIO` \() -> + update_weight weight2 0 2 x y (-1) (-1) `thenIO` \() -> + update_weight weight1 0 1 x y (-1) 1 `thenIO` \() -> + update_weight weight2 0 2 x y (-1) 1 `thenIO` \() -> + update_weight weight1 0 1 x y 0 1 `thenIO` \() -> + update_weight weight2 0 2 x y 0 1 `thenIO` \() -> + update_weight weight1 0 1 x y 0 (-1) `thenIO` \() -> + update_weight weight2 0 2 x y 0 (-1) `thenIO` \() -> + update_weight weight1 0 1 x y (-1) 0 `thenIO` \() -> + update_weight weight2 0 2 x y (-1) 0 `thenIO` \() -> + update_weight weight1 0 1 x y 1 0 `thenIO` \() -> + update_weight weight2 0 2 x y 1 0 `thenIO` \() -> + returnIO () + + +human_unit :: XMArray Int -> Int -> Int -> IO(Bool) +human_unit keyboard x y = + let + pattern0 :: Int -> Int -> Int -> Int -> Int -> Bool + pattern0 a b c d e | a==b && b==c && c==d && d==e = True + | otherwise = False + + direct3 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> + Int + direct3 ptN1 ptN2 ptN3 ptN4 pt ptP1 ptP2 ptP3 ptP4 + | (pattern0 ptN4 ptN3 ptN2 ptN1 pt) || + (pattern0 ptN3 ptN2 ptN1 pt ptP1) || + (pattern0 ptN2 ptN1 pt ptP1 ptP2) || + (pattern0 ptN1 pt ptP1 ptP2 ptP3) || + (pattern0 pt ptP1 ptP2 ptP3 ptP4) = 200 + | otherwise = 0 + in + xlookup keyboard x y `thenIO` \(xy) -> + xlookup keyboard x (y-1) `thenIO` \(xyN1) -> + xlookup keyboard x (y-2) `thenIO` \(xyN2) -> + xlookup keyboard x (y-3) `thenIO` \(xyN3) -> + xlookup keyboard x (y-4) `thenIO` \(xyN4) -> + xlookup keyboard x (y+1) `thenIO` \(xyP1) -> + xlookup keyboard x (y+2) `thenIO` \(xyP2) -> + xlookup keyboard x (y+3) `thenIO` \(xyP3) -> + xlookup keyboard x (y+4) `thenIO` \(xyP4) -> + xlookup keyboard (x-1) y `thenIO` \(xN1y) -> + xlookup keyboard (x-2) y `thenIO` \(xN2y) -> + xlookup keyboard (x-3) y `thenIO` \(xN3y) -> + xlookup keyboard (x-4) y `thenIO` \(xN4y) -> + xlookup keyboard (x+1) y `thenIO` \(xP1y) -> + xlookup keyboard (x+2) y `thenIO` \(xP2y) -> + xlookup keyboard (x+3) y `thenIO` \(xP3y) -> + xlookup keyboard (x+4) y `thenIO` \(xP4y) -> + xlookup keyboard (x-1) (y-1) `thenIO` \(xN1yN1)-> + xlookup keyboard (x-2) (y-2) `thenIO` \(xN2yN2) -> + xlookup keyboard (x-3) (y-3) `thenIO` \(xN3yN3) -> + xlookup keyboard (x-4) (y-4) `thenIO` \(xN4yN4) -> + xlookup keyboard (x+1) (y+1) `thenIO` \(xP1yP1) -> + xlookup keyboard (x+2) (y+2) `thenIO` \(xP2yP2) -> + xlookup keyboard (x+3) (y+3) `thenIO` \(xP3yP3) -> + xlookup keyboard (x+4) (y+4) `thenIO` \(xP4yP4) -> + xlookup keyboard (x-1) (y+1) `thenIO` \(xN1yP1) -> + xlookup keyboard (x-2) (y+2) `thenIO` \(xN2yP2) -> + xlookup keyboard (x-3) (y+3) `thenIO` \(xN3yP3) -> + xlookup keyboard (x-4) (y+4) `thenIO` \(xN4yP4) -> + xlookup keyboard (x+1) (y-1) `thenIO` \(xP1yN1) -> + xlookup keyboard (x+2) (y-2) `thenIO` \(xP2yN2) -> + xlookup keyboard (x+3) (y-3) `thenIO` \(xP3yN3) -> + xlookup keyboard (x+4) (y-4) `thenIO` \(xP4yN4) -> + xlookup keyboard (x+1) y `thenIO` \(xP1y) -> + xlookup keyboard (x+2) y `thenIO` \(xP2y) -> + xlookup keyboard (x+3) y `thenIO` \(xP3y) -> + xlookup keyboard (x+4) y `thenIO` \(xP4y) -> + if ((direct3 xyN1 xyN2 xyN3 xyN4 xy xyP1 xyP2 xyP3 xyP4) + + (direct3 xN1y xN2y xN3y xN4y xy xP1y xP2y xP3y xP4y) + + (direct3 xN1yN1 xN2yN2 xN3yN3 xN4yN4 xy xP1yP1 xP2yP2 xP3yP3 xP4yP4) + + (direct3 xN1yP1 xN2yP2 xN3yP3 xN4yP4 xy xP1yN1 xP2yN2 xP3yN3 xP4yN4)) + >=200 + then returnIO (True) + else returnIO (False)
\ No newline at end of file diff --git a/progs/demo/X11/gobang/weights.hu b/progs/demo/X11/gobang/weights.hu new file mode 100644 index 0000000..f13aba0 --- /dev/null +++ b/progs/demo/X11/gobang/weights.hu @@ -0,0 +1,4 @@ +:o= all +$HASKELL_LIBRARY/X11/xlib.hu +weights.hs +utilities.hs diff --git a/progs/demo/X11/graphics/README b/progs/demo/X11/graphics/README new file mode 100644 index 0000000..77a2d66 --- /dev/null +++ b/progs/demo/X11/graphics/README @@ -0,0 +1,31 @@ +HENDERSON GRAPHICS LIBRARY +by Syam Gadde +and Bo Whong + +------------------------------------------------- + +To use the Henderson Library, run emacs with a module that +imports HendersonLib, such as "sqrlmt.hs". For "sqrlmt.hs", +run the dialogue "final" or "skewedfinal". + +------------------------------------------------- + +henderson.hs - Haskell source for the Henderson library. +henderson.hu +sqrlmt.hs - Haskell source for dialogue that draws "Square Limit". +sqrlmt.hu +p.pic - First of four pictures used to construct "Square Limit". +q.pic - Second of four pictures used to construct "Square Limit". +r.pic - Third of four pictures used to construct "Square Limit". +s.pic - Four of four pictures used to construct "Square Limit". +new.pic - Hudak's house +stop.pic - A "hand-drawn" stop sign border +text.pic - The word "STOP!" (hand-drawn) +strange.pic - Overlays stop.pic and Flip of text.pic +squarebox.xwd - A window dump of a box-like structure made of four + square limits. Use "xwud -in squarebox.xwd" to view. +sksl.xwd - A window dump of "squarelimit" in a skewed bounding box. + ("skewedfinal" from sqrlmt.hs.) +sl.xwd - A window dump of Square Limit. + ("squarelimit" from sqrlmt.hs.) +manual - The manual in Island Write format. diff --git a/progs/demo/X11/graphics/henderson.hs b/progs/demo/X11/graphics/henderson.hs new file mode 100644 index 0000000..8b7e4ce --- /dev/null +++ b/progs/demo/X11/graphics/henderson.hs @@ -0,0 +1,465 @@ +-- Peter Henderson's Recursive Geometry +-- Syam Gadde and Bo Whong +-- full set of modules +-- CS429 Project +-- 4/30/93 + +module HendersonLib (Hostname(..), Filename(..), VTriple(..), HendQuartet(..), + Picture(..), sendToDraw, draw, create, modify, plot) where +import Xlib + +-- ADTs and Type Synonyms -------------------------------------------------- +data Picture = Nil + | Flip Picture + | Beside Float Picture Float Picture + | Above Float Picture Float Picture + | Rot Picture + | File String + | Overlay Picture Picture + | Grid Int Int SegList + deriving Text + +data Plot = Plot Picture VTriple + | Union Plot Plot + +type Hostname = String +type Filename = String +type IntPoint = (Int,Int) +type IntSegment = (IntPoint, IntPoint) +type IntSegList = [IntSegment] +type Point = (Float,Float) +type Segment = (Point, Point) +type SegList = [Segment] +type Vector = Point +type VTriple = (Vector, Vector, Vector) +type HendQuartet = (Int, Int, Int, Int) +type PEnv = [(Filename, Picture)] + +-- vector Functions -------------------------------------------------------- +-- for adding, negating, multiplying, and dividing vectors + +addV :: Vector -> Vector -> Vector +addV (x1,y1) (x2,y2) = (x1+x2, y1+y2) + +negateV :: Vector -> Vector +negateV (x,y) = (-x,-y) + +multV :: Float-> Vector -> Vector +multV a (x,y) = (a*x, a*y) + +divV :: Float -> Vector -> Vector +divV a (x,y) = (x/a, y/a) + +-- plot Function ----------------------------------------------------------- +-- picture manipulation function + +plot :: Picture -> VTriple -> PEnv -> ((Plot, PEnv) -> IO()) -> IO() + +-- the Nil Picture is just "nothingness" so choose an abritrary representation +-- of nothingness. +plot Nil (v1, v2, v3) env cont = + plot (Grid 1 1 []) (v1,v2,v3) env cont + +-- Flipping a Picture +plot (Flip p1) (v1, v2, v3) env cont = + plot p1 (addV v1 v2, negateV v2, v3) env cont + +-- Rotate a Picture 90 degrees counterclockwise +plot (Rot p1) (v1, v2, v3) env cont = + plot p1 (addV v1 v3, negateV v3, v2) env cont + +-- Overlay one Picture over another Picture +plot (Overlay p q) (a,b,c) env cont = + plot p (a,b,c) env $ \ (plot1, env1) -> + plot q (a,b,c) env1 $ \ (plot2, env2) -> + cont ((Union plot1 plot2), env2) + +-- Place p1 Beside p2 with width ratio m to n +plot (Beside m p1 n p2) (v1, v2, v3) env cont = + plot p1 (v1, multV (m/(m+n)) v2, v3) env $ \ (plot1, env1) -> + plot p2 ((addV (multV (m/(m+n)) v2) v1), + (multV (n/(m+n)) v2), + v3) env1 $ \ (plot2, env2) -> + cont ((Union plot1 plot2), env2) + +-- Place p Above q with height ratio m to n +plot (Above m p n q) (a,b,c) env cont = + plot q (addV a (multV (m/(n+m)) c), b, multV (n/(m+n)) c) env + $ \ (plot1, env1) -> + plot p (a, b, multV (m/(m+n)) c) env1 $ \ (plot2, env2) -> + cont ((Union plot1 plot2), env2) + +-- the 'real' Picture +plot (Grid x y s) (a,b,c) env cont = + cont ((Plot (Grid x y s) (a,b,c)), env) + +-- this picture is located in a File with name name +-- lookup table: thanks to Sheng +plot (File name) (a,b,c) env cont = + case (lookupEnv env name) of + ((_, pic):_) -> plot pic (a,b,c) env cont + [] -> + readFile name (\s -> appendChan stdout ("File "++name++" not able to be read\n") exit done) + $ \s -> + let + pic = read s + newenv = (name,pic):env + in + plot pic (a,b,c) newenv cont + +lookupEnv :: PEnv -> Filename -> PEnv +lookupEnv [] _ = [] +lookupEnv ((a,b):es) name | a==name = ((a,b):es) + | otherwise = lookupEnv es name + +-- Draw Function ----------------------------------------------------------- +-- user function to draw pictures + +draw :: Hostname -> Picture -> VTriple -> HendQuartet -> IO() + +-- opens a display, screen, and window (of size specified in HendQuartet) +-- and draws Picture in the window +draw host p (a,b,c) (hm,hn,ho,hp) = + xOpenDisplay host `thenIO` \display -> -- opens display + let (screen:_) = xDisplayRoots display + fg_color = xScreenBlackPixel screen + bg_color = xScreenWhitePixel screen + root = xScreenRoot screen + in + xCreateWindow root -- opens window + (XRect hm hn ho hp) + [XWinBackground bg_color, + XWinEventMask (XEventMask [XKeyPress, + XExposure, + XButtonPress])] + `thenIO` \window -> + xSetWmName window "Henderson Graphics" `thenIO` \() -> + xSetWmIconName window "Henderson Graphics" `thenIO` \() -> + xMapWindow window `thenIO` \() -> -- show window + xDisplayForceOutput display `thenIO` \ () -> -- show window NOW + xCreateGcontext (XDrawWindow (xScreenRoot screen)) -- open a GC + [XGCBackground bg_color, + XGCForeground fg_color] `thenIO` \ gcontext -> + plot p (a,b,c) [] $ \(plt,_) -> -- make pic easier to work with + let + handleEvent = + xGetEvent display `thenIO` \event -> + case (xEventType event) of + -- Has a part of the window been uncovered? + XExposureEvent -> sendToDraw window screen display gcontext plt + `thenIO` \() -> handleEvent + _ -> xCloseDisplay display + in + handleEvent + +-- SendToDraw Function ----------------------------------------------------- +-- called by draw to actually draw the lines onto the window + +sendToDraw :: XWindow -> XScreen -> XDisplay -> XGcontext -> Plot -> IO() + +-- have a Union. so do one, and then the other. simple. +sendToDraw win screen display gcontext (Union p1 p2) = + sendToDraw win screen display gcontext p1 `thenIO` \() -> + sendToDraw win screen display gcontext p2 + +-- have just a Plot. have to do some dirty work. +sendToDraw window screen display gcontext (Plot (Grid x y s) (a,b,c)) = + let + v2p :: Vector -> XPoint + v2p (e,f) = XPoint (round e) (round f) -- convert Vector to an XPoint + fx :: Float + fx = fromIntegral x + fy :: Float + fy = fromIntegral y + drawit :: SegList -> IO() + -- draw the Grid one line at a time + drawit [] = done + drawit (((x0,y0),(x1,y1)):ss) = + xDrawLine (XDrawWindow window) + gcontext + (v2p (addV (addV a (multV (x0/fx) b)) + (multV (y0/fy) c))) + (v2p (addV (addV a (multV (x1/fx) b)) + (multV (y1/fy) c))) `thenIO` \() -> + drawit ss + in + drawit s `thenIO` \ () -> + xDisplayForceOutput display + +-- create function --------------------------------------------------------- +-- opens up a window to allow the user to create a file +-- and save it onto a file + +create :: Hostname -> Filename -> Int -> Int -> IO() + +create host filename x y = + xOpenDisplay host `thenIO` \ display -> + let + (screen:_) = xDisplayRoots display + fg_color = xScreenWhitePixel screen + bg_color = xScreenBlackPixel screen + root = xScreenRoot screen + in + xCreateWindow root + (XRect 0 0 (x+1) (y+1)) + [XWinBackground bg_color, + XWinEventMask (XEventMask [XExposure, + XKeyPress, + XButtonPress, + XPointerMotion])] + `thenIO` \window -> + xSetWmName window filename `thenIO` \() -> + xSetWmIconName window filename `thenIO` \() -> + xCreateWindow root + (XRect 0 0 100 40) + [XWinBackground bg_color] `thenIO` \window2 -> + xSetWmName window2 "pos" `thenIO` \() -> + xSetWmIconName window2 "pos" `thenIO` \() -> + xMapWindow window `thenIO` \() -> + xMapWindow window2 `thenIO` \() -> + xListFonts display "*times*bold*r*normal*18*" `thenIO` \fontlist -> + xCreateGcontext (XDrawWindow root) + [XGCBackground bg_color, + XGCForeground fg_color, + XGCFont (head fontlist)] `thenIO` \gcontext -> + let + handleEvent :: IntSegList -> IO() + handleEvent list = + xGetEvent display `thenIO` \event -> + let + point = xEventPos event + XPoint pointx pointy = point + handleEvent' :: XPoint -> IO() + handleEvent' last = + xGetEvent display `thenIO` \event2 -> + let + pos = xEventPos event2 + XPoint posx posy = pos + in + case (xEventType event2) of + XKeyPressEvent -> + appendChan stdout ((show (tup pos))++ "\n") abort $ + xDrawLine (XDrawWindow window) gcontext point pos + `thenIO` \() -> handleEvent (store list point pos) + XExposureEvent -> + redraw window gcontext list `thenIO` \() -> handleEvent' last + XMotionNotifyEvent -> + xDrawImageGlyphs (XDrawWindow window2) + gcontext + (XPoint 2 18) + ((show posx)++", "++(show posy)++" ") + `thenIO` \dummy -> handleEvent' last + _ -> + handleEvent' last + in + case (xEventType event) of + XButtonPressEvent -> + putFile display filename list x y "create" + XKeyPressEvent -> + appendChan stdout (show (tup point)) abort $ + handleEvent' point + XExposureEvent -> + redraw window gcontext list `thenIO` \() -> handleEvent list + XMotionNotifyEvent -> + xDrawImageGlyphs (XDrawWindow window2) + gcontext + (XPoint 2 18) + ((show pointx)++", "++(show pointy)++" ") + `thenIO` \dummy -> handleEvent list + _ -> + handleEvent list + in + case (checkFile filename) of + True -> handleEvent [] + False -> appendChan stdout picTypeError abort $ + xCloseDisplay display + +-- modify function --------------------------------------------------------- +-- allows the user to add onto an already existing picture file + +modify :: Hostname -> Filename -> IO() + +modify host filename = + case (checkFile filename) of + False -> appendChan stdout picTypeError abort done + True -> + readFile filename (\s -> appendChan stdout + readError abort done) $ \s-> + let + dat = read s + origlist = fFloat (getlist dat) + x = getx dat + y = gety dat + in + xOpenDisplay host `thenIO` \ display -> + let + (screen:_) = xDisplayRoots display + fg_color = xScreenWhitePixel screen + bg_color = xScreenBlackPixel screen + root = xScreenRoot screen + in + xCreateWindow root + (XRect 0 0 (x + 1) (y + 1)) + [XWinBackground bg_color, + XWinEventMask (XEventMask [XExposure, XKeyPress, + XButtonPress, XPointerMotion])] + `thenIO` \window -> + xSetWmName window filename `thenIO` \() -> + xSetWmIconName window filename `thenIO` \() -> + xCreateWindow root (XRect 0 0 100 40) + [XWinBackground bg_color] `thenIO` \window2 -> + xSetWmName window2 "pos" `thenIO` \() -> + xSetWmIconName window2 "pos" `thenIO` \() -> + xMapWindow window `thenIO` \() -> + xMapWindow window2 `thenIO` \() -> + xListFonts display "*times*bold*r*normal*18*" `thenIO` \fontlist -> + xCreateGcontext (XDrawWindow root) [XGCBackground bg_color, + XGCForeground fg_color, + XGCFont (head fontlist)] + `thenIO` \ gcontext -> + let + handleEvent :: IntSegList -> IO() + handleEvent list = + xGetEvent display `thenIO` \event -> + let + point = xEventPos event + XPoint pointx pointy = point + handleEvent' :: XPoint -> IO() + handleEvent' last = xGetEvent display `thenIO` \event2 -> + let + pos = xEventPos event2 + XPoint posx posy = pos + in + case (xEventType event2) of + XExposureEvent -> + redraw window gcontext list `thenIO` \() -> + handleEvent' last + XKeyPressEvent -> + appendChan stdout ((show (tup pos))++ "\n") abort $ + xDrawLine (XDrawWindow window) gcontext point pos + `thenIO` \() -> handleEvent (store list point pos) + XMotionNotifyEvent -> + xDrawImageGlyphs (XDrawWindow window2) gcontext + (XPoint 2 18) ((show posx)++", "++(show posy)++" ") + `thenIO` \dummy -> handleEvent' last + _ -> handleEvent' last + in + case (xEventType event) of + XButtonPressEvent -> + putFile display filename list x y "modify" + XKeyPressEvent -> + appendChan stdout (show (tup point)) abort $ + handleEvent' point + XExposureEvent -> + redraw window gcontext list `thenIO` \() -> + handleEvent list + XMotionNotifyEvent -> + xDrawImageGlyphs (XDrawWindow window2) + gcontext (XPoint 2 18) + ((show pointx)++", "++(show pointy)++" ") + `thenIO` \dummy -> handleEvent list + _ -> + handleEvent list + in + redraw window gcontext origlist `thenIO` \() -> + handleEvent origlist + +-- Miscellaneous functions ------------------------------------------------- +-- shared by the create and modify functions + +checkFile :: Filename -> Bool +checkFile name = + case (take 4 (reverse name)) of + "cip." -> True + _ -> False + +store :: IntSegList -> XPoint -> XPoint -> IntSegList +store l a b = [((xof a,yof a),(xof b,yof b))] ++ l + +xof :: XPoint -> Int +xof (XPoint x y) = x + +yof :: XPoint -> Int +yof (XPoint x y) = y + +tup :: XPoint -> IntPoint +tup (XPoint a b) = (a,b) + +ll:: IntSegment -> Int +ll ((a1,a2),(b1,b2)) = a1 + +lr:: IntSegment -> Int +lr ((a1,a2),(b1,b2)) = a2 + +rl:: IntSegment -> Int +rl ((a1,a2),(b1,b2)) = b1 + +rr:: IntSegment -> Int +rr ((a1,a2),(b1,b2)) = b2 + +getx :: Picture -> Int +getx (Grid m n o) = m + +gety :: Picture -> Int +gety(Grid m n o) = n + +getlist :: Picture -> SegList +getlist (Grid m n o) = o + +fFloat :: SegList -> IntSegList +fFloat = map (\ ((ix,iy),(jx,jy)) -> + ((round ix,round iy), (round jx,round jy))) + +readError :: String +readError = "Error: reading an invalid file\n" + +picTypeError :: String +picTypeError = "Error: files need to be of .pic type\n" + +deleteError :: String +deleteError = "Error: file can not be deleted\n" + +writeError :: String +writeError = "Error: file can not be written\n" + +modError :: String +modError = "Error: file can not be modified\n" + +redraw :: XWindow-> XGcontext -> IntSegList -> IO() +redraw window gcontext [] = done +redraw window gcontext (l:ls) = + xDrawLine (XDrawWindow window) gcontext (XPoint (ll l) (lr l)) + (XPoint (rl l) (rr l)) + `thenIO` \() -> redraw window gcontext ls + +changeList :: IntSegList -> SegList +changeList = + map (\ ((ix,iy),(jx,jy)) -> ((fromIntegral ix,fromIntegral iy), + (fromIntegral jx,fromIntegral jy))) + +putFile :: XDisplay -> Filename -> IntSegList -> + Int -> Int -> String -> IO() +putFile display name list x y flag = + let + text = show (Grid x y (changeList list)) + finishMsg = name ++ ": Done...Process completed\n" + modMsg = name ++ ": Modifying file\n" + createMsg = name ++ ": Creating file\n" + continue = + deleteFile name (\s -> appendChan stdout deleteError abort done) $ + writeFile name text (\s -> appendChan stdout writeError abort done) $ + appendChan stdout finishMsg abort $ + xCloseDisplay display + in + case (flag == "create") of + False -> appendChan stdout modMsg + (\s -> appendChan stdout modError abort done) $ + continue + True -> readFile name (\s -> appendChan stdout createMsg abort $ + writeFile name text abort + (xCloseDisplay display)) $ \s -> + continue + + + + diff --git a/progs/demo/X11/graphics/henderson.hu b/progs/demo/X11/graphics/henderson.hu new file mode 100644 index 0000000..e92b66d --- /dev/null +++ b/progs/demo/X11/graphics/henderson.hu @@ -0,0 +1,3 @@ +:o= foldr inline constant +$HASKELL_LIBRARY/X11/xlib.hu +henderson.hs diff --git a/progs/demo/X11/graphics/manual b/progs/demo/X11/graphics/manual new file mode 100644 index 0000000..17772f1 --- /dev/null +++ b/progs/demo/X11/graphics/manual @@ -0,0 +1,454 @@ +104 pgscriptver + +100 DefSpaceEx 100 DefCharEx 1 DefNormalHyphenationOn 100 +DefTypeColor (Times-Roman) DefTypeFace ENGLISH DefLanguage 12 DefPointSize +USE_POINTSIZE DefSetSize (@default) DefTypeResource + +LEFT DefJustifyFlags 2 DefBeginParaLeadValue ABSOLUTE DefBeginParaLeadMode 2 +DefEndParaLeadValue ABSOLUTE DefEndParaLeadMode 120 DefLeadValue +PROPORTIONAL DefLeadMode 1 46 0 TAB_LEFT 720 DefTab 1 46 0 +TAB_LEFT 2160 DefTab 1 46 0 TAB_LEFT 3600 DefTab 1 46 0 +TAB_LEFT 5040 DefTab 1 46 0 TAB_LEFT 6480 DefTab 1 46 0 +TAB_LEFT 7920 DefTab 1 46 0 TAB_LEFT 9360 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 0 46 0 TAB_LEFT 24480 DefTab 0 46 0 +TAB_LEFT 24480 DefTab 80 DefWSMN 100 DefWSNM 150 DefWSMX 110 +DefLSMX 100 DefLeaderEx 46 DefLeaderChar 0 DefFirstIndent 0 +DefLeftIndent 0 DefRightIndent 0 DefNumberingOn 0 DefNumberingType 0 +DefNumberingRestart 1 DefNumberingLevel 0 DefNumberingStyle 0 +DefNumberingTabAfter 1 DefNumberingShowAllLevels 1 DefNumberingStart 1 +DefNumberingIncrement () DefNumberingPrefix () DefNumberingSuffix (.) +DefNumberingSeparator (*default) DefParaResource + +0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 +DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResource + +0 DefPageDimensions 12240 DefPageWidth 15840 DefPageHeight 1440 +DefInsideMargin 1080 DefOutsideMargin 1080 DefTopMargin 1080 +DefBottomMargin 0 DefOrientation 0 DefPageStyle 1 DefColumns 360 +DefGutter (%default) DefMasterPage ResDefEnd + +0 DefFirstLeft 0 DefDocSetup 1 DefNumPages 1 AutoPage 1 +DefStartPageNum () DefPageNumPrefix 1 DefGraphicLocation document + +1 DefAutoPage +0 (%default) 1 DefPage +1 DefAutoPage +0 (%default) 2 DefPage + +POLY_OBJECT POLY_EMPTY | DefPolyType + +0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 +DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 0 +DefMasterRef +MP_CPSUCC_LINK MP_CPPRED_LINK POLY_COLUMN | | DefSLinksFlags 0 DefStreamSucc 0 +DefStreamPred +1440 1080 11160 1080 11160 14760 1440 14760 4 +POLY_OBJECT POLY_EMPTY | (%default) 0 1 TextPolygon + +POLY_OBJECT POLY_TEXT | DefPolyType + +0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 +DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 1 +DefMasterRef + +MP_CPSUCC_LINK MP_CPPRED_LINK LINK_OVERFLOW MPREF_VALID POLY_COLUMN AUTO_STREAM | | | | | +DefSLinksFlags 4 DefStreamSucc 0 DefStreamPred 3 DefTextHandle +1440 1080 11160 1080 11160 14760 1440 14760 4 +POLY_OBJECT POLY_TEXT | (1) 0 2 TextPolygon + +3 asciitextstream +<(Courier) cf ><9 cs>The Henderson Library--<eop> +by Syam Gadde<eop> +and Bo Whong<eop> +<eop> +The Henderson Library is a toolkit with which one can use Functional Geometry, +as proposed by Peter Henderson in his paper "Functional Geometry". This is a s +cheme by which "Picture"s can be described in an abstract data type, and a numb +er of functions can be applied to it. This results in a very elegant method to + produce complex pictures from simple ones. The example Henderson uses is "Squ +are Limit" by M. C. Escher, which can be constructed with four simple pictures +.<eop> +<eop> +------------------------<eop> +ADTs and Type Synonyms<eop> +<eop> +The Picture data type is composed of eight different types of pictures. They a +re:<eop> +<eop> +data<eop> +Picture = Nil - empty picture<eop> + | Flip Picture - picture flipped on the y-axis<e +op> + | Beside Float Picture Float Picture - two pictures placed side by sid +e <eop> + - in accordance to the ratio of t +he<eop> + - two floats<eop> + | Above Float Picture Float Picture - two pictures placed one on top +of<eop> + - another in accordance to the ra +tio<eop> + - of the two floats<eop> + | Rot Picture - picture is rotated 90 degrees < +eop> + - counterclockwise<eop> + | File String - picture is stored as an externa +l<eop> + - file<eop> + | Overlay Picture Picture - two pictures are drawn such tha +t<eop> + - one lays on top of the other<eo +p> + | Grid Int Int SegList - picture type that contains the +list<eop> + - of picture's line segments alon +g<eop> + - with the size of the inital pic +ture<eop> +<eop> +The type synonyms are pretty much self explanatory.<eop> +<eop> + Hostname<tab><tab><tab>- a string of the hostname<eop> + Filename <tab>- a string of the filename<e +op> + IntPoint <tab>- a tuple of integers repres +enting<eop> + <tab>- the coordinates of a point +<eop> + IntSegment <tab>- a tuple of Intpoints repre +senting<eop> + <tab>- the endpoints of a line se +gment<eop> + IntSegList <tab>- a list of IntSegments <eop +> + Point <tab>- same as IntPoint except in + place of<eop> +<tab><tab><tab> <tab>- intergers, they are floating points<eop> + Segment <tab>- same as IntSegment except +in place<eop> + <tab><tab> <tab>- of intergers, they are floating <eop> + <tab><tab><tab>- points<eop> + SegList <tab>- same as IntsegList except +in place<eop> + <tab><tab><tab><tab>- of intergers, they are floating <eop> + <tab><tab><tab>- points<eop> + Vector <tab>- a tuple of floating points + to<eop> + <tab><tab><tab>- to represent a vector<eop> + Vtriple - a 3-tuple of Vectors<eop> + HendQuartet - a 4-tuple of Integers for the s +ize<eop> + - of the Henderson window<eop> + PEnv - a tuple of a Filename and a Pic +ture<eop> + - for storing already opened file +s in<eop> + - in order to save time and memor +y<eop> + - when a file needs to be opened +more<eop> + - than once<eop> +<eop> +------------------------------------------------------------------------------- +----<eop> +Function: create (an exported function from the HendersonLib)<eop> +<eop> +The purpose of the create function is to provide the user with a function to <e +op> +draw a picture from a graphics interface. The user may choose to create a pict +ure<eop> +file by inputing the the lines and points manually into a file or (s)he may cho +ose<eop> +to use the create function.<eop> +<eop> +Functionality of create:<eop> + create :: Hostname -<ra> Filaname -<ra> Int -<ra> Int -<ra> IO()<eop +> +<eop> +create takes as input a hostname, a filename, and two integers for the size of +the <eop> +window to be opened. Two windows should appear, one for the input of lines and +<eop> +another showing the current position of the mouse. These windows will be label +ed<eop> +accordingly.<eop> +To draw a line on the file window, move the cursor to the desired position, the +n<eop> +hit any key on the keybroad. This point will be the beginning of the line segme +nt.<eop> +Next move the cursor to the position of where the user wants the end of the lin +e<eop> +segment to be, then hit any key from the keyboard again. A line should appear. +<eop> +The coordinates of the endpoints of each line drawn will also be printed out o +nto <eop> +standard output.<eop> +To signal completion of a file, press any button on the mouse. The user must < +eop> +remember though that this is only applicable after a completed drawing of a lin +e.<eop> +For example, pressing the mouse button will not work if one of the endpoints of + a<eop> +line is drawn but the other endpoint is not. create will not recognize the mous +e <eop> +button press event until a second endpoint is drawn.<eop> +<eop> +Advantages of create:<eop> + provides a quick and fun way to create a picture file.<eop> +<eop> +Disadvantages of create:<eop> + If the file does not exist, create will create the file and then store the pic +ture<eop> + to it. However, if the file exists, create will automatically delete the cont +ents<eop> + of that file before storing the new picture.<eop> +<eop> +------------------------------------------------------------------------------- +----<eop> +Function: modify (an exported function from the HendersonLib)<eop> +<eop> +The purpose of the modify function is to provide the user with a function make +<eop> +additions to an already existing picture file using a graphics interface. The +user<eop> +may choose to modify the picture file by adding the the lines and points manual +ly <eop> +into the file or (s)he may choose to use the modify function.<eop> +<eop> +Functionality of modify:<eop> + modify :: Hostname -<ra> Filaname -<ra> IO()<eop> +<eop> +modify takes as input a hostname and a filename. Tow windows should appear. Th +e <eop> +size of the draw window will be the same as the x and y coordinates already in +the<eop> +file. These windows will be labeled accordingly. The existing picture will app +ear<eop> +first before any input is allowed.<eop> +To draw a line on the file window, move the cursor to the desired position, the +n<eop> +hit any key on the keybroad. This point will be the beginning of the line segme +nt.<eop> +Next move the cursor to the position of where the user wants the end of the lin +e<eop> +segment to be, then hit any key from the keyboard again. A line should appear. +<eop> +The coordinates of the endpoints of each line drawn will also be printed out o +nto <eop> +standard output.<eop> +To signal completion of a file, press any button on the mouse. The user must < +eop> +remember though that this is only applicable after a completed drawing of a lin +e.<eop> +For example, pressing the mouse button will not work if one of the endpoints of + a<eop> +line is drawn but the other endpoint is not. modify will not recognize the mou +se <eop> +button press event until a second endpoint is drawn.<eop> +<eop> +Advantages of modify:<eop> + provides a quick and fun way to modify a picture file without having to go int +o<eop> + the file and manually add on the coordinates of the additional lines<eop> +<eop> +Disadvantages of modify:<eop> + Existing lines can not be deleted and any additional lines, whether intentiona +l or<eop> + unintentional, will be appended to the picture and stored in the file.<eop> +<eop> +--------------------------------------------------------<eop> +Function: sendToDraw<eop> +<eop> +Type of sendToDraw:<eop> + sendToDraw :: XWindow -<ra> XScreen -<ra> XDisplay -<ra> <eop> + XPixel -<ra> XPixel -<ra> Plot -<ra> IO()<eop> +<eop> +Usage:<eop> + sendToDraw win scn dis fg_color bg_color plt<eop> +<eop> +'sendToDraw' is the most primitive function in the part of the Henderson<eop> +library that deals with X windows, and therefore, can be used as a very<eop> +powerful tool. It draws a Plot plt (see 'plot' function) in the given XWindow< +eop> +win, and on the given XScreen and XDisplay scn and dis, drawing the lines in<eo +p> +the foreground color. This function allows the programmer to draw more than<eo +p> +one Picture to the same window.<eop> +<eop> +Arguments:<eop> + win - the XWindow in which to draw plt<eop> + scn - the screen which contains win<eop> + dis - the display which contains scn<eop> + fg_color - an XPixel the color of which the plt will be drawn in. Note that< +eop> +<tab>this allows the programmer to draw different plt's in different colors.<eo +p> + bg_color - unused, but required.<eop> +--------------------------------------------------------<eop> +Function: plot<eop> +<eop> +Type of 'plot':<eop> + plot :: Picture -<ra> VTriple -<ra> PEnv -<ra> ((Plot, PEnv) -<ra> IO()) -<ra +> IO()<eop> +<eop> +Usage:<eop> + plot pic (a,b,c) env func<eop> +<eop> +The 'plot' function is needed to create a Plot which would be normally sent to< +eop> +a function such as sendToDraw. 'plot' converts a Picture pic into a format<eop +> +that sendToDraw can deal with.<eop> +'plot' also takes three vectors which specify the bounding box in which the<eop +> +Picture is to be drawn. The first vector (a) specifies the upper left corner<e +op> +of the bounding box. The next two vectors specify the bounding box itself,<eop +> +with respect to the first vector. This allows for non-rectangular bounding<eop +> +boxes. For example, the vector triple ((50,50), (100,0), (0,100)) specifies<eo +p> +the following bounding box:<eop> +<eop> + (0,0)----------------------------------<eop> + |<eop> + | (50,50)<eop> + | _______________ (150,0) <eop> + | | |<eop> + | | |<eop> + | | |<eop> + | | |<eop> + | | |<eop> + | |_____________| (150,150)<eop> + | (0,150)<eop> +<eop> +<eop> +A vector triple of ((0,0), (100,300), (0,100)) would specify:<eop> +<eop> + (0,0)-------------------------------------<eop> + ||\<eop> + || \<eop> + || \<eop> + (0,100)|| \<eop> + |\ \<eop> + | \ \<eop> + | \ \<eop> + | \ \ (100,300)<eop> + | \ | <eop> + | \ |<eop> + | \ |<eop> + | \| (100,400)<eop> +<eop> +Arguments: <eop> + pic - the Picture to be converted<eop> + a - a vector specifying the upper left corner of the bounding box<eop> +<tab>of the picture.<eop> + b - a vector understood to start at 'a' and specifying the upper edge of<eop> + +<tab>the bounding box.<eop> + c - a vector understood to start at 'a' and specifying the left edge of<eop> +<tab>the bounding box.<eop> +--------------------------------------------------------<eop> +Function: draw<eop> +<eop> +Type of draw:<eop> + draw :: Hostname -<ra> Picture -<ra> VTriple -<ra> HendQuartet -<ra> IO()<eop +> +<eop> +Usage:<eop> + draw host pic (a,b,c) (m,n,p,q)<eop> +<eop> +'draw' is a higher-level function than sendToDraw, and is useful to use when<eo +p> +the programmer wishes only to draw one Picture on the screen. This function<eo +p> +does most of the work that the programmer would normally have to do when using< +eop> +sendToDraw. 'draw' opens a window at host with upper left coordinates m and n< +eop> +(on an X server that lets the user position any child window of the root<eop> +window, these coordinates mean nothing), and with width p and height q.<eop> +'draw' then calls 'plot' on pic and (a,b,c) and sends the result to sendToDraw, +<eop> +which finally draws the picture to the window.<eop> +<eop> +Arguments:<eop> + host - host on which to open a display, i.e. "tucan:0"<eop> + pic - the Picture to be drawn<eop> + (a,b,c) - the vector triple specifying the bounding box to be sent to<eop> +<tab>plot (see 'plot' function)<eop> + (m,n,p,q) - upper left corner x (m), upper left corner y (n), width (p),<eop> + +<tab>and height (q), of window to be opened.<eop> +<eop> +-----------------------------------------------------------<eop> +<eop> +Module: SquareLimit<eop> +<eop> +This module is a sample user module that can be used to draw Square Limit, a wo +odcut by M. C. Escher. To draw "SquareLimit" on your host, run the dialogue:<e +op> +<tab>final host<eop> +where 'host' is the host running X, such as "turtle:0".<eop> +<eop> +To draw a slightly more interesting picture, tun the dialogue:<eop> +<tab>skewedfinal host<eop> +and it will draw "SquareLimit" in a bounding box shaped as a diamond.<eop> +<eop> + +<textstream_end> + +POLY_OBJECT POLY_TEXT | DefPolyType + +0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 +DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 1 +DefMasterRef + +MP_CPSUCC_LINK MP_CPPRED_LINK LINK_OVERFLOW MPREF_VALID POLY_COLUMN AUTO_STREAM | | | | | +DefSLinksFlags 0 DefStreamSucc 2 DefStreamPred 3 DefTextHandle +1440 1080 11160 1080 11160 14760 1440 14760 4 +POLY_OBJECT POLY_TEXT | (2) 0 4 TextPolygon + +BeginProfile +(Number of Pages) (5) DefProfileString +(Language) (ENGLISH) DefProfileString +(Version) (IslandWrite Version 2.3) DefProfileString +(Creation Date) (gadde May 7, 1993 3:55 PM) DefProfileString +(Text Formats) (default) DefProfileString +(Container Formats) (default) DefProfileString +(Page Formats) (default) DefProfileString +(Fonts) (Courier) DefProfileString +(Fonts) (Times-Roman) DefProfileString +(File Path) () DefProfileString +(External Contents) () DefProfileString +(Title) () DefProfileString +(Status) () DefProfileString +(Distribution List) () DefProfileString +(Preparer) () DefProfileString +(Owner) () DefProfileString +(Author) () DefProfileString +(Superseded Documents) () DefProfileString +EndProfile + +pgscriptdone diff --git a/progs/demo/X11/graphics/p.pic b/progs/demo/X11/graphics/p.pic new file mode 100644 index 0000000..240b386 --- /dev/null +++ b/progs/demo/X11/graphics/p.pic @@ -0,0 +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))]
\ No newline at end of file diff --git a/progs/demo/X11/graphics/q.pic b/progs/demo/X11/graphics/q.pic new file mode 100644 index 0000000..84e27a4 --- /dev/null +++ b/progs/demo/X11/graphics/q.pic @@ -0,0 +1,2 @@ +Grid 16 16 +[((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))]
\ No newline at end of file diff --git a/progs/demo/X11/graphics/r.pic b/progs/demo/X11/graphics/r.pic new file mode 100644 index 0000000..6e37979 --- /dev/null +++ b/progs/demo/X11/graphics/r.pic @@ -0,0 +1,2 @@ +Grid 32 32 +[((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))]
\ No newline at end of file diff --git a/progs/demo/X11/graphics/s.pic b/progs/demo/X11/graphics/s.pic new file mode 100644 index 0000000..74659b7 --- /dev/null +++ b/progs/demo/X11/graphics/s.pic @@ -0,0 +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))]
\ No newline at end of file diff --git a/progs/demo/X11/graphics/sqrlmt.hs b/progs/demo/X11/graphics/sqrlmt.hs new file mode 100644 index 0000000..662cdfa --- /dev/null +++ b/progs/demo/X11/graphics/sqrlmt.hs @@ -0,0 +1,177 @@ +-- Peter Henderson's Recursive Geometry +-- Syam Gadde and Bo Whong +-- CS429 Project +-- SquareLimit User Program + +module SqrLimit where +import HendersonLib +import Xlib +{- +p = File "p.pic" + +q = File "q.pic" + +r = File "r.pic" + +s = File "s.pic" +-} +p = Grid 640 640 [((560.0,560.0),(440.0,640.0)), + ((640.0,560.0),(560.0,560.0)), + ((520.0,440.0),(640.0,480.0)), + ((400.0,480.0),(520.0,440.0)), + ((480.0,360.0),(360.0,400.0)), + ((480.0,360.0),(640.0,400.0)), + ((480.0,280.0),(640.0,320.0)), + ((320.0,320.0),(480.0,280.0)), + ((280.0,400.0),(160.0,440.0)), + ((160.0,240.0),(280.0,400.0)), + ((160.0,440.0),(160.0,240.0)), + ((120.0,480.0),(0.0,320.0)), + ((0.0,320.0),(0.0,520.0)), + ((120.0,480.0),(0.0,520.0)), + ((240.0,640.0),(160.0,480.0)), + ((400.0,480.0),(440.0,640.0)), + ((320.0,320.0),(400.0,480.0)), + ((160.0,120.0),(320.0,320.0)), + ((0.0,0.0),(160.0,120.0)), + ((640.0,240.0),(320.0,160.0)), + ((640.0,40.0),(560.0,0.0)), + ((520.0,40.0),(640.0,80.0)), + ((480.0,0.0),(520.0,40.0)), + ((480.0,80.0),(400.0,0.0)), + ((640.0,120.0),(480.0,80.0)), + ((480.0,160.0),(640.0,160.0)), + ((320.0,0.0),(480.0,160.0)), + ((240.0,40.0),(320.0,0.0)), + ((0.0,0.0),(240.0,40.0))] + +q = Grid 16 16 [((10.0,6.0),(9.0,4.0)), + ((12.0,4.0),(10.0,6.0)), + ((9.0,4.0),(12.0,4.0)), + ((0.0,6.0),(7.0,5.0)), + ((0.0,8.0),(0.0,16.0)), + ((0.0,0.0),(0.0,4.0)), + ((15.0,16.0),(16.0,14.0)), + ((16.0,12.0),(14.0,16.0)), + ((13.0,16.0),(16.0,10.0)), + ((13.0,12.0),(12.0,16.0)), + ((16.0,8.0),(13.0,12.0)), + ((15.0,6.0),(16.0,8.0)), + ((16.0,0.0),(15.0,6.0)), + ((10.0,16.0),(14.0,5.0)), + ((10.0,10.0),(10.0,7.0)), + ((8.0,16.0),(10.0,10.0)), + ((8.0,11.0),(8.0,8.0)), + ((6.0,16.0),(8.0,11.0)), + ((6.0,11.0),(4.0,16.0)), + ((6.0,9.0),(6.0,11.0)), + ((4.0,11.0),(4.0,9.0)), + ((2.0,16.0),(4.0,11.0)), + ((4.0,9.0),(0.0,8.0)), + ((6.0,9.0),(4.0,9.0)), + ((12.0,6.0),(6.0,9.0)), + ((16.0,0.0),(12.0,6.0)), + ((9.0,3.0),(8.0,1.0)), + ((11.0,1.0),(9.0,3.0)), + ((8.0,1.0),(11.0,1.0)), + ((8.0,0.0),(7.0,1.0)), + ((5.0,2.0),(7.0,1.0)), + ((6.0,0.0),(7.0,1.0)), + ((5.0,2.0),(4.0,0.0)), + ((3.0,3.0),(5.0,2.0)), + ((3.0,3.0),(0.0,4.0)), + ((2.0,0.0),(3.0,3.0))] + +r = Grid 32 32 [((32.0,0.0),(24.0,8.0)), + ((32.0,4.0),(30.0,2.0)), + ((28.0,4.0),(32.0,8.0)), + ((32.0,12.0),(26.0,6.0)), + ((24.0,8.0),(32.0,16.0)), + ((22.0,0.0),(24.0,8.0)), + ((22.0,12.0),(12.0,0.0)), + ((32.0,20.0),(22.0,12.0)), + ((24.0,26.0),(10.0,22.0)), + ((32.0,32.0),(24.0,26.0)), + ((16.0,28.0),(24.0,32.0)), + ((6.0,26.0),(16.0,28.0)), + ((16.0,32.0),(4.0,28.0)), + ((2.0,30.0),(8.0,32.0)), + ((0.0,32.0),(16.0,16.0)), + ((0.0,24.0),(10.0,12.0)), + ((4.0,8.0),(0.0,16.0)), + ((28.0,20.0),(32.0,24.0)), + ((16.0,16.0),(28.0,20.0)), + ((4.0,8.0),(16.0,16.0)), + ((2.0,4.0),(4.0,8.0)), + ((2.0,4.0),(0.0,8.0)), + ((0.0,0.0),(2.0,4.0))] + +s = Grid 32 32 [((24.0,0.0),(32.0,0.0)), + ((0.0,0.0),(16.0,0.0)), + ((30.0,14.0),(32.0,12.0)), + ((32.0,8.0),(28.0,10.0)), + ((26.0,6.0),(32.0,4.0)), + ((26.0,6.0),(24.0,0.0)), + ((30.0,14.0),(26.0,6.0)), + ((32.0,16.0),(30.0,14.0)), + ((30.0,16.0),(26.0,18.0)), + ((30.0,22.0),(30.0,16.0)), + ((26.0,18.0),(30.0,22.0)), + ((24.0,24.0),(20.0,20.0)), + ((24.0,18.0),(24.0,24.0)), + ((20.0,20.0),(24.0,18.0)), + ((20.0,0.0),(22.0,12.0)), + ((14.0,6.0),(16.0,0.0)), + ((14.0,16.0),(16.0,20.0)), + ((14.0,6.0),(14.0,16.0)), + ((20.0,24.0),(16.0,20.0)), + ((32.0,32.0),(20.0,24.0)), + ((16.0,28.0),(32.0,32.0)), + ((8.0,28.0),(16.0,28.0)), + ((0.0,32.0),(8.0,28.0)), + ((0.0,24.0),(4.0,30.0)), + ((0.0,20.0),(14.0,24.0)), + ((0.0,16.0),(16.0,20.0)), + ((0.0,12.0),(14.0,16.0)), + ((0.0,8.0),(14.0,12.0)), + ((0.0,4.0),(14.0,6.0))] + +quartet p1 p2 p3 p4 = + Above 1 (Beside 1 p1 1 p2) 1 (Beside 1 p3 1 p4) + +cyc p1 = + quartet p1 (Rot (Rot (Rot p1))) (Rot p1) (Rot (Rot p1)) + +t = quartet p q r s + +u = cyc (Rot q) + +side1 = quartet Nil Nil (Rot t) t + +side2 = quartet side1 side1 (Rot t) t + +corner1 = quartet Nil Nil Nil u + +corner2 = quartet corner1 side1 (Rot side1) u + +pseudocorner = quartet corner2 side2 (Rot side2) (Rot t) + +pseudolimit = cyc pseudocorner + +nonet p1 p2 p3 p4 p5 p6 p7 p8 p9 = + Above 1 (Beside 1 p1 2 (Beside 1 p2 1 p3)) + 2 (Above 1 (Beside 1 p4 2 (Beside 1 p5 1 p6)) + 1 (Beside 1 p7 2 (Beside 1 p8 1 p9))) + +corner = nonet corner2 side2 side2 + (Rot side2) u (Rot t) + (Rot side2) (Rot t) (Rot q) + +squarelimit = cyc corner + +final host = draw host corner ((0,0),(500,0),(0,500)) (0,0,500,500) +skewedfinal host = draw host squarelimit ((0,0),(600,200),(200,600)) (0,0,800,800) + +main = getEnv "DISPLAY" exit $ \ host -> + xHandleError ( \ (XError msg) -> appendChan stdout msg exit done) $ + final host diff --git a/progs/demo/X11/graphics/sqrlmt.hu b/progs/demo/X11/graphics/sqrlmt.hu new file mode 100644 index 0000000..7d46b0e --- /dev/null +++ b/progs/demo/X11/graphics/sqrlmt.hu @@ -0,0 +1,3 @@ +:o= foldr inline constant +henderson.hu +sqrlmt.hs diff --git a/progs/demo/X11/graphics/stop.pic b/progs/demo/X11/graphics/stop.pic new file mode 100644 index 0000000..01ed7d6 --- /dev/null +++ b/progs/demo/X11/graphics/stop.pic @@ -0,0 +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))]
\ No newline at end of file diff --git a/progs/demo/X11/graphics/strange.pic b/progs/demo/X11/graphics/strange.pic new file mode 100644 index 0000000..5484b0b --- /dev/null +++ b/progs/demo/X11/graphics/strange.pic @@ -0,0 +1,2 @@ +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")) + diff --git a/progs/demo/X11/graphics/text.pic b/progs/demo/X11/graphics/text.pic new file mode 100644 index 0000000..87fd55c --- /dev/null +++ b/progs/demo/X11/graphics/text.pic @@ -0,0 +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))]
\ No newline at end of file diff --git a/progs/demo/X11/logo/EXAMPLES.LOGO b/progs/demo/X11/logo/EXAMPLES.LOGO new file mode 100644 index 0000000..bb89632 --- /dev/null +++ b/progs/demo/X11/logo/EXAMPLES.LOGO @@ -0,0 +1,70 @@ +(to nth :index :lst + (if (equal :index 1) + then (first :lst) + else (nth (difference :index 1) (butfirst :lst)))) + +(to makelist :begin :end + (fput :begin (if (equal :begin :end) + then [[]] + else (makelist (sum :begin 1) :end)))) + +(to wheel :centerright + [(hideturtle) + (pendown) + (setangle 90) + (setxy :centerright 350) + (repeat 72 times + [(forward 2) + (left 5)])]) + +(to car + [(pendown) + (hideturtle) + (setxy 400 350) + (setangle 90) + (forward 70) + (left 90) + (forward 100) + (right 60) + (forward 80) + (left 60) + (forward 100) + (left 60) + (forward 80) + (right 60) + (forward 70) + (left 90) + (forward 70) + (left 90) + (forward 350) + (wheel 350) + (wheel 150)]) + +(to docar? + [(local "ans) + (print [do you want a car?]) + (make "ans (read)) + (if (equal (first ans) "yes) + then (car) + else [[oh well]])]) + +(to poly :size :angles + [(hideturtle) + (pendown) + (setangle 90) + (repeat :angles times + [(forward :size) + (right (div 360 :angles))])]) + +(make "x (makelist 3 12)) + +(while (less (first x) 12) + [(make "x (butfirst x)) + (print x)]) + +(clean) + +(car) + +(poly 100 5) + diff --git a/progs/demo/X11/logo/README b/progs/demo/X11/logo/README new file mode 100644 index 0000000..b483e2a --- /dev/null +++ b/progs/demo/X11/logo/README @@ -0,0 +1,104 @@ +Ki-Wing Ho and Eric Fox +Computer Science 429b +Professor Hudak +Final Project: User Manual + + +Control Commands: + + +(DO <clause> WHILE <cond>) + + Loop, executing a list of commands, then checking a condition and +looping again if the condition is true. + + +(REPEAT n TIMES) + WHILE cn cl + IF cn THEN cl1 [ELSE cl2] + +Load a file: + USE "filename + +Environment Commands: + MAKE "nm v + LOCAL "nm + TO :nm1 :nm2 :nm3 ... cl + +Text I/O: + PRINT v + READ + +Graphics Commands: + FORWARD n + BACKWARD n + SETXY n1 n2 + LEFT n + RIGHT n + PENUP + PENDOWN + HIDETURTLE + SHOWTURTLE + CLEARSCREEN + CLEAN + +Graphics Functions: + XCOR + YCOR + GETANGLE + GETPEN + GETTURTLE + +Mathematical: + SUM n1 n2 + DIFFERENCE n1 n2 + PRODUCT n1 n2 + MOD n1 n2 + DIV n1 n2 + POWER n1 n2 + +Boolean: + AND b1 b2 + OR b1 b2 + NOT b + +Predicates: + WORDP v + LISTP v + NUMBERP v + GREATER n1 n2 + LESS n1 n2 + EQUAL v1 v2 + +Word/List: + FIRST t + LAST t + FPUT t l + BUTFIRST l + WORD w1 w2 w3 ... + LIST t1 t2 t3 ... + CONCAT l1 l2 + SENTENCE t1 t2 t3 ... + + +Our Logo interpreter will only support one of the three windowing +modes: window mode, where the turtle, if it walks off the end of the +screen, just continues going and does not wrap. The two (unsupported) +modes are fence mode where the turtle cannot walk off the end, and +wrap mode. The initial turtle state will be with the turtle hidden, +the pen down, and the turtle in the center of the screen facing +upwards. + +All input (both for commands as well as user-input) will be +case-insensitive, and the interpreter needs to handle lists, words, +integers, and boolean values. Also, typing "GoodBye" at the LOGO> +prompt exits the interpreter. + +All commands will be enclosed in parentheses, and all lists of +commands will be enclosed in square brackets, so that there is no +longer any need for the keyword "End". Also, all procedures will +return the value of their last command, so that there are no Stop or +Output commands. IF statements should return the value of the last +statement executed, but all looping constructs should return no value. + + diff --git a/progs/demo/X11/logo/logo.hs b/progs/demo/X11/logo/logo.hs new file mode 100644 index 0000000..458eca1 --- /dev/null +++ b/progs/demo/X11/logo/logo.hs @@ -0,0 +1,1345 @@ +{- + +Ki-Wing Ho and Eric Fox +Computer Science 429b +Professor Hudak +Final Project: LOGO Interpreter + +-} + + + +------------------------------------------------------------------------------- +module REPLoop where + +{- + +REPLoop has two main parts: the first part (function logo) sets up the +graphics window, prints a welcome message, initializes the variable +and procedure environments and the turtle, accepts and lines's the +user input, runs the read-eval-print loop (part two), and then closes +the graphics window and exists; the second part (function repLoop) +lexes and parses each command, prints an error message if there was a +syntax error and evaluates (or tries to) if there wasn't, and then +either prints the value or an error message or exits if the value +returnd by the evaluator is "GoodBye". + +-} + +import Lexer +import Parser +import Evaluator +import Xlib + +demo = main + +main = getEnv "DISPLAY" exit $ \ host -> + xHandleError ( \ (XError msg) -> appendChan stdout msg exit done) $ + logo host + +logo :: String -> IO () + +logo host = + xOpenDisplay host `thenIO` \ display -> + + let (screen:_) = xDisplayRoots display + fg_color = xScreenWhitePixel screen + bg_color = xScreenBlackPixel screen + root = xScreenRoot screen + in + xCreateWindow root + (XRect 100 100 500 500) + [XWinBackground bg_color, + XWinBackingStore XAlwaysBackStore] + `thenIO` \ graphWindow -> + xSetWmName graphWindow "Logo" `thenIO` \ () -> + xSetWmIconName graphWindow "Logo" `thenIO` \ () -> + xMapWindow graphWindow `thenIO` \ () -> + + xCreateGcontext (XDrawWindow root) + [XGCBackground bg_color, + XGCForeground fg_color] `thenIO` \ graphContext -> + + xDisplayForceOutput display `thenIO` \ () -> + + appendChan stdout ("Welcome to LOGO!\n" ++ prompt) exit $ + readChan stdin exit $ \userInput -> + repLoop + (varEnvsInit,procEnvsInit,turtleInit) + ((lines userInput,Lexer), + (graphWindow,display,graphContext,bg_color,fg_color)) $ + xCloseDisplay display + +-- Initial Environments -- + +varEnvsInit :: VarsType +varEnvsInit = [[("GOODBYE",GoodBye)]] + +-- all user-defined commands must have dummy entries +procEnvsInit :: ProcsType +procEnvsInit = (map (makeFakeProc) + [("XCOR",0),("YCOR",0),("GETANGLE",0),("GETPEN",0), + ("GETTURTLE",0), + ("SUM",2),("DIFFERENCE",2),("PRODUCT",2),("MOD",2), + ("DIV",2),("POWER",2), + ("AND",2),("OR",2),("NOT",1), + ("WORDP",1),("LISTP",1),("NUMBERP",1),("GREATER",2), + ("EQUAL",2),("LESS",2), + ("BUTFIRST",1),("FPUT",2),("CONCAT",2), + ("FIRST",1),("LAST",1),("WORD",-2),("LIST",-2), + ("SENTENCE",-2), ("USE",1)]):[] + +turtleInit :: TurtleType +turtleInit = (500 `div` 2,500 `div` 2,90,True,False) + +-- makes a dummy procedure +makeFakeProc :: (NameType , Int) -> (NameType , ProcType) +makeFakeProc (name,num) = (name,(makeArgs num,[])) + +makeArgs :: Int -> [NameType] +makeArgs n | n > 0 = "" : makeArgs (n-1) + | otherwise = [] + +-- keep running Read-Eval-Print Loop until user types GoodBye +-- repLoop keeps running until user types "GoodBye", alternately +-- lexing, parsing, and evaluating each command +-- after a syntax error, the lex state is reset +repLoop :: EnvsType -> StateType -> IO () -> IO () +repLoop e1 (inS1,gs1) end = + let fail1 msg (is1,ls1) = errorOutput msg $ + repLoop e1 ((is1,Lexer),gs1) end + -- parser fail continuation doesn't contain graphics state + fail2 msg ((is2,ls2),gs2) = errorOutput msg $ + repLoop e1 ((is2,Lexer),gs1) end + -- evaluator fail continuation does contain graphics state + in + parse [] inS1 fail1 $ \a ts inS2 -> + if (null ts) + then + evaluate e1 a (inS2,gs1) fail2 $ \v e2 ((is3,ls3),gs3) -> + output v end $ + repLoop e2 ((is3,Lexer),gs3) end + else + fail1 "Syntax error: expected end of line" inS2 + -- repLoop will still be rerun + +-- print error message +errorOutput :: String -> IO () -> IO () +errorOutput error = appendChan stdout (error ++ prompt) abort + +-- print expression value, exiting if GoodBye +output :: Value -> IO () -> IO () -> IO () +output GoodBye end succ + = appendChan stdout "\nGoodbye!\n"abort end +output v end succ + = appendChan stdout ((valueToString v) ++ prompt) abort succ + +prompt :: String +prompt = "\nLOGO> " + + + +------------------------------------------------------------------------------- +module Evaluator where + +{- + +Evaluator takes an Abstract Syntax Tree and evaluates it in the +current environment, returning both the resultant value and the new +environment (as well as the updated state, of which only the user +input can actually be changed in the evaluator). + +A value can be of one of six types: integer, string, list, and +boolean, as well as null (for commands which don't return anything and +newly-declared local variables), and goodbye, which allows logo to +quit. + +The environment consists of three parts. The variable environment and +the procedure environment are separate (so that a name can refer both +to a variable and a procedure: Logo syntax is such that there is +never any ambiguity) are both lists of name-value association lists. +Each association list representes a "local environment", with each +successive one being more "global", so that the last environment in +the list is the global environment. Local environments are produced +by user-function invocations and removed at the end of those +invocations. + +-} + +import Lexer +import Parser +import Xlib + +type NameType = [Char] +type WordType = [Char] +type Error = [Char] + +type StateType = (InputState , GraphicsState) +type GraphicsState = (XWindow , XDisplay , XGcontext , XPixel , XPixel) +type EnvsType = (VarsType,ProcsType,TurtleType) +type VarsType = [[(NameType , Value)]] +type ProcsType = [[(NameType , ProcType)]] +type TurtleType = (Int , Int , Int , Bool , Bool) +type ProcType = ([NameType] , ClauseType) + +data Value = Null + | Num Int + | Word WordType + | List ListType + | Boolean Bool + | GoodBye + deriving Text + +data ListType = NullList | Value :* ListType + deriving Text + + +type EvalFailType = Error -> StateType -> IO () +type EvalSuccType = Value -> EnvsType -> StateType -> IO () +type EvalResType = StateType -> EvalFailType -> EvalSuccType -> IO () +type EvaluateType = EnvsType -> AST -> EvalResType + + +evaluate :: EvaluateType + +evaluate (vs,p:ps,ttl) (To newName newProc) ss fail succ + = succ Null (vs,((newName,newProc):p):ps,ttl) ss + -- procedures + +evaluate e (Read) ((i:is,ls),gs) fail succ + = succ (List (makeReadList (lexerReadLine i))) e ((is,ls),gs) + -- user input + +evaluate e1 (Print [a]) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + appendChan stdout ((valueToString v)++"\n") abort $ + succ Null e2 ss2 + -- user output + +evaluate e (Argument (Val (Word n))) ss fail succ + = lookup e n ss fail $ \v -> + succ v e ss + -- variable reference + +evaluate e (Argument (Val v)) ss fail succ + = succ v e ss + -- constant + +evaluate e (Argument (QuotedWordArg n)) ss fail succ + = succ (Word n) e ss + -- string constant + +evaluate (v:vs,ps,ttl) (Local n) ss fail succ + = succ Null (((n,Null):v):vs,ps,ttl) ss + -- local variable declaraion + -- local returns null, and sets the new local variable to null also + +evaluate e (ParseList l) ss fail succ + = succ (List l) e ss + -- lists (also constant) + +evaluate e (Loop l cond insts) ss fail succ + = evalLoop l e cond insts ss fail succ + -- loops + +evaluate e (If cond thens elses) ss fail succ + = evalIf e cond thens elses ss fail succ + -- if-then[-eles] conditionals + +evaluate e1 (Command name as1) ss fail succ + | ((na == length as1) || (na == -2)) + = evalArgs e1 as1 ss fail $ \e2 as2 ss2 -> + apply name as2 e2 ss2 fail $ \v e3 ss3 -> + succ v e3 ss3 + | na == -1 + = fail ("Function does not exist: " ++ name) ss + | otherwise + = fail ("Wrong number of arguments to " ++ name) ss + where na = numArgs e1 name + -- function applications + +evaluate e1 (Make n a) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + update e2 n v $ \e3 -> + succ v e3 ss2 + -- assignment statements, which return the assigned value + +evaluate e1 (Graphics name as1) ss fail succ + = evalArgs e1 as1 ss fail $ \e2 as2 ss2 -> + doGraphics name as2 e2 ss2 fail $ \e3 ss3 -> + succ Null e3 ss3 + -- side-effecting graphics statements, which all return null +-- end evaluate + + +-- evaluate a list of actual parameters, returning the corresponding +-- list of values +evalArgs :: EnvsType -> ParseArgs -> StateType -> EvalFailType -> + (EnvsType -> EvalArgs -> StateType -> IO ()) -> IO () +evalArgs e [] ss fail succ + = succ e [] ss +evalArgs e1 (a:as1) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + evalArgs e2 as1 ss2 fail $ \e3 as2 ss3 -> + succ e3 (v:as2) ss3 + + +-- evaluate a list of commands, returning the value of the last one +evalClause :: EnvsType -> ClauseType -> EvalResType +evalClause e [] ss fail succ + = succ Null e ss +evalClause e (a:[]) ss fail succ + = evaluate e a ss fail succ +evalClause e1 (a:as) ss fail succ + = evaluate e1 a ss fail $ \v e2 ss2 -> + evalClause e2 as ss2 fail succ + +-- convert a lexed user-input list to a list constant +makeReadList :: [WordType] -> ListType +makeReadList [] = NullList +makeReadList (w:ws) = (Word w) :* (makeReadList ws) + + +-- Variable routines -- + +-- look up a variable reference in the variable environment +-- search the most-local environments first +-- return an error if not found +lookup :: EnvsType -> NameType -> StateType -> EvalFailType -> + (Value -> IO ()) -> IO () +lookup ([],ps,ttl) name ss fail succ + = fail ("Unbound variable: " ++ name) ss +lookup ([]:vss,ps,ttl) name ss fail succ + = lookup (vss,ps,ttl) name ss fail succ +lookup (((n,v):vs):vss,ps,ttl) name ss fail succ + | n == name = succ v + | otherwise = lookup (vs:vss,ps,ttl) name ss fail succ + +-- update the variable environment +-- replace the most-local occurrance first; if none are found, +-- create a new variable and place it in the most-global environment +update :: EnvsType -> NameType -> Value -> (EnvsType -> IO ()) -> IO () +update ([]:[],ps,ttl) name value succ + = succ (((name,value):[]):[],ps,ttl) +update ([]:vss,ps,ttl) name value succ + = update (vss,ps,ttl) name value $ \(vss2,ps2,ttl2) -> + succ ([]:vss2,ps2,ttl2) +update (((n,v):vs):vss,ps,ttl) name value succ + | n == name = succ (((n,value):vs):vss,ps,ttl) + | otherwise = update (vs:vss,ps,ttl) name value $ \(vs2:vss2,ps2,ttl2) -> + succ (((n,v):vs2):vss2,ps2,ttl2) + + +-- Control structures -- + +-- evaluate loops +evalLoop :: LoopType -> EnvsType -> ConditionType -> ClauseType -> + EvalResType +evalLoop Do = evalDo +evalLoop While = evalWhile +evalLoop Repeat = evalRepeat + +-- evaluate while statements +-- loop semantics: evaluate condition; if true, evaluate clause, then loop +-- while returns null +evalWhile :: EnvsType -> ConditionType -> ClauseType -> EvalResType +evalWhile e1 cond insts ss fail succ + = evalCond e1 cond ss fail $ \b e2 ss2 -> + if b + then + evalClause e2 insts ss2 fail $ \v e3 ss3 -> + evalWhile e3 cond insts ss3 fail succ + else + succ Null e2 ss2 + +-- evaluate do-while statements +-- loop semantics: evaluate clause then evaluate condition; if true, loop +evalDo :: EnvsType -> ConditionType -> ClauseType -> EvalResType +evalDo e1 cond insts ss fail succ + = evalClause e1 insts ss fail $ \v e2 ss2 -> + evalCond e2 cond ss2 fail $ \b e3 ss3 -> + if b + then + evalDo e3 cond insts ss3 fail succ + else + succ Null e3 ss3 + +-- evaluate repeat statements +-- loop semantics: evaluate loop number as n; evaluate clause n times +-- evaluate loop number and print error if it is negative or not an integer +evalRepeat :: EnvsType -> ConditionType -> ClauseType -> EvalResType +evalRepeat e1 cond insts ss fail succ + = evaluate e1 cond ss fail $ \v e2 ss2 -> + case v of + Num n -> if (n >= 0) + then doIterations e2 n insts ss2 fail succ + else fail "Repeat: Iteration count cannot be negative" ss2 + otherwise -> fail "Repeat: Invalid iteration count" ss2 + +-- perform loop interations: evaluate "insts" "n" times +doIterations :: EnvsType -> Int -> ClauseType -> EvalResType +doIterations e 0 insts ss fail succ + = succ Null e ss +doIterations e1 (n+1) insts ss fail succ + = evalClause e1 insts ss fail $ \v e2 ss2 -> + doIterations e2 n insts ss2 fail succ + +-- evaluates conditions and returns either true, false, or an error +evalCond :: EnvsType -> ConditionType -> StateType -> EvalFailType -> + (Bool -> EnvsType -> StateType -> IO ()) -> IO () +evalCond e1 cond ss fail succ + = evaluate e1 cond ss fail $ \v e2 ss2 -> + case v of + Boolean b -> succ b e2 ss2 + otherwise -> fail "Invalid condition" ss2 + +-- evaluate if-then[-else] statements +evalIf :: EnvsType -> ConditionType -> ClauseType -> ClauseType -> EvalResType +evalIf e1 cond thens elses ss fail succ + = evalCond e1 cond ss fail $ \b e2 ss2 -> + if b + then evalClause e2 thens ss2 fail succ + else evalClause e2 elses ss2 fail succ + + +-- Function application -- + +-- returns the number of arguments to a user-defined or built-in function +-- -1 means the function wasn't found +-- -2 means the function can take any number of arguments +numArgs :: EnvsType -> CommandName -> Int +numArgs (vs,[],ttl) name + = -1 +numArgs (vs,[]:pss,ttl) name + = numArgs (vs,pss,ttl) name +numArgs (vs,((n,(formals,body)):ps):pss,ttl) name + | inList ["WORD","SENTENCE","LIST"] name = -2 + | n == name = length formals + | otherwise = numArgs (vs,ps:pss,ttl) name + +-- apply a function to its arguments +-- mostly just decides if it's user-defined or built-in, then dispatches +apply :: CommandName -> EvalArgs -> EnvsType -> EvalResType +apply n as e ss fail succ + | isBuiltIn n = applyPrimProc n as e ss fail succ + | otherwise = applyUserProc (getProc e n) as e ss fail succ + + + +-- returns procedure "name" from the procedure environment +-- searches most-local environments first +-- precondition: procedure does exist somewhere +getProc :: EnvsType -> CommandName -> ProcType +getProc (vss,[]:pss,ttl) name + = getProc (vss,pss,ttl) name +getProc (vs,((n,p):ps):pss,ttl) name + | n == name = p + | otherwise = getProc (vs,ps:pss,ttl) name + +-- apply user function: +-- bind formal parameters +-- create local enviroments +-- evaluate body of function +-- destroy local environments +-- return value of body +applyUserProc :: ProcType -> EvalArgs -> EnvsType -> EvalResType +applyUserProc (formals,body) actuals e1 ss fail succ + = bind formals actuals e1 $ \e2 -> + evalClause e2 body ss fail $ \v (vs:vss,ps:pss,ts) ss2 -> + succ v (vss,pss,ts) ss2 + +-- bind formal parameters to actuals in local environment +bind :: [NameType] -> EvalArgs -> EnvsType -> (EnvsType -> IO ()) -> IO () +bind formals actuals (vss,pss,ttl) succ + = succ ((zip formals actuals):vss,[]:pss,ttl) + + +-- Built-in functions -- + +-- returns true for built-in functions +isBuiltIn :: CommandName -> Bool +isBuiltIn = inList ["XCOR","YCOR","GETANGLE","GETPEN","GETTURTLE", + "SUM","DIFFERENCE","PRODUCT","MOD","DIV","POWER", + "AND","OR","NOT", + "WORDP","LISTP","NUMBERP","GREATER","EQUAL","LESS", + "BUTFIRST","FPUT","CONCAT", + "FIRST","LAST","WORD","LIST","SENTENCE", "USE"] + + +-- applies a built-in function to its arguments +applyPrimProc :: CommandName -> [Value] -> EnvsType -> EvalResType + +applyPrimProc "XCOR" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Num x) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "YCOR" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Num y) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "GETANGLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Num a) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "GETPEN" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Boolean p) (vs,ps,(x,y,a,p,t)) ss +applyPrimProc "GETTURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = succ (Boolean t) (vs,ps,(x,y,a,p,t)) ss + +applyPrimProc "SUM" [Num a , Num b] e ss fail succ + = succ (Num (a+b)) e ss +applyPrimProc "DIFFERENCE" [Num a , Num b] e ss fail succ + = succ (Num (a-b)) e ss +applyPrimProc "PRODUCT" [Num a , Num b] e ss fail succ + = succ (Num (a*b)) e ss +applyPrimProc "MOD" [Num a , Num b] e ss fail succ + = succ (Num (a `mod` b)) e ss +applyPrimProc "DIV" [Num a , Num b] e ss fail succ + = succ (Num (a `div` b)) e ss +applyPrimProc "POWER" [Num a , Num b] e ss fail succ + | b >= 0 = succ (Num (a^b)) e ss + | otherwise = fail ("Negative exponent: " ++ (show b)) ss + +applyPrimProc "AND" [Boolean a , Boolean b] e ss fail succ + = succ (Boolean (a && b)) e ss +applyPrimProc "OR" [Boolean a , Boolean b] e ss fail succ + = succ (Boolean (a || b)) e ss +applyPrimProc "NOT" [Boolean a] e ss fail succ + = succ (Boolean (not a)) e ss + +applyPrimProc "WORDP" [Word w] e ss fail succ + = succ (Boolean True) e ss +applyPrimProc "WORDP" [v] e ss fail succ + = succ (Boolean False) e ss +applyPrimProc "NUMBERP" [Num n] e ss fail succ + = succ (Boolean True) e ss +applyPrimProc "NUMBERP" [v] e ss fail succ + = succ (Boolean False) e ss +applyPrimProc "LISTP" [List l] e ss fail succ + = succ (Boolean True) e ss +applyPrimProc "LISTP" [v] e ss fail succ + = succ (Boolean False) e ss +applyPrimProc "GREATER" [Num a , Num b] e ss fail succ + = succ (Boolean (a > b)) e ss +applyPrimProc "EQUAL" [Num a , Num b] e ss fail succ + = succ (Boolean (a == b)) e ss +applyPrimProc "EQUAL" [Word a , Word b] e ss fail succ + = succ (Boolean (a == b)) e ss +applyPrimProc "EQUAL" [Boolean a , Boolean b] e ss fail succ + = succ (Boolean (a == b)) e ss +applyPrimProc "LESS" [Num a , Num b] e ss fail succ + = succ (Boolean (a < b)) e ss + +applyPrimProc "BUTFIRST" [Word ""] e ss fail succ + = succ (Word "") e ss +applyPrimProc "BUTFIRST" [Word (c:cs)] e ss fail succ + = succ (Word cs) e ss +applyPrimProc "BUTFIRST" [List NullList] e ss fail succ + = succ (List NullList) e ss +applyPrimProc "BUTFIRST" [List (v :* vs)] e ss fail succ + = succ (List vs) e ss +applyPrimProc "FPUT" [v , List l] e ss fail succ + = succ (List (v :* l)) e ss +applyPrimProc "CONCAT" [List l1 , List l2] e ss fail succ + = succ (List (listConcatenate l1 l2)) e ss +applyPrimProc "FIRST" [Word (c:cs)] e ss fail succ + = succ (Word (c:[])) e ss +applyPrimProc "FIRST" [List (v :* vs)] e ss fail succ + = succ v e ss +applyPrimProc "LAST" [Word (c:[])] e ss fail succ + = succ (Word (c:[])) e ss +applyPrimProc "LAST" [Word ""] e ss fail succ + = succ Null e ss +applyPrimProc "LAST" [Word (c:cs)] e ss fail succ + = applyPrimProc "LAST" [(Word cs)] e ss fail succ +applyPrimProc "LAST" [List (v :* NullList)] e ss fail succ + = succ v e ss +applyPrimProc "LAST" [List (v :* vs)] e ss fail succ + = applyPrimProc "LAST" [(List vs)] e ss fail succ +applyPrimProc "WORD" [] e ss fail succ + = succ (Word "") e ss +applyPrimProc "WORD" ((Word w):ws) e ss fail succ + = applyPrimProc "WORD" ws e ss fail $ \(Word wsc) e2 ss2 -> + succ (Word (w ++ wsc)) e2 ss2 +applyPrimProc "LIST" (v:vs) e ss fail succ + = applyPrimProc "LIST" vs e ss fail $ \(List l) e2 ss2 -> + succ (List (v :* l)) e2 ss2 +applyPrimProc "LIST" [] e ss fail succ + = succ (List NullList) e ss +applyPrimProc "SENTENCE" [] e ss fail succ + = succ (List NullList) e ss +applyPrimProc "SENTENCE" ((List l):[]) e ss fail succ + = succ (List l) e ss +applyPrimProc "SENTENCE" ((List l):vs) e ss fail succ + = applyPrimProc "SENTENCE" [List l] e ss fail $ \(List s1) e2 ss2 -> + applyPrimProc "SENTENCE" vs e2 ss2 fail $ \(List s2) e3 ss3 -> + succ (List (listConcatenate s1 s2)) e3 ss3 +applyPrimProc "SENTENCE" (v:vs) e ss fail succ + = applyPrimProc "SENTENCE" vs e ss fail $ \(List ws) e2 ss2 -> + succ (List (v :* ws)) e2 ss2 + +applyPrimProc "USE" [Word filename] + e + ss@((ins, ls), gs) + fail succ + = readFile filename (\ _ -> fail ("Can't read file: " ++ filename) ss) + $ \filecontents -> + useRepLoop e ((lines filecontents, Lexer), gs) + (\ msg s -> fail msg ss) $ \ v e s -> + succ v e ss + +applyPrimProc n _ _ ss fail _ + = fail ("Incorrect arguments: " ++ n) ss + +useRepLoop :: EnvsType -> EvalResType +useRepLoop e s@(([], ls), gs) fail succ = succ (Word "OK") e s +useRepLoop e1 s1@(inS1,gs1) fail succ = + parse [] inS1 (\ msg ins -> fail msg (ins, gs1)) $ \a ts inS2 -> + if (null ts) + then + evaluate e1 a (inS2,gs1) fail $ \v e2 s3 -> + useRepLoop e2 s3 fail succ + else + fail "Syntax error: expected end of line" (inS2, gs1) + + + +-- concatenates two lists +listConcatenate :: ListType -> ListType -> ListType +listConcatenate NullList l2 = l2 +listConcatenate (v :* l1) l2 = (v :* (listConcatenate l1 l2)) + + +-- Graphics -- + +type EvalArgs = [Value] +type GraphEnv = (Int,Int,Int,Bool) + +-- evaluates side-effecting graphics functions +-- note: none of them return values +doGraphics :: CommandName -> EvalArgs -> EnvsType -> StateType -> + EvalFailType -> (EnvsType -> StateType -> IO ()) -> IO () + +doGraphics "HIDETURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = hideTurtle x y a ss $ + succ (vs,ps,(x,y,a,p,False)) ss + -- hide turtle, appropriately adjust environment + +doGraphics "SHOWTURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ + = showTurtle x y a ss $ + succ (vs,ps,(x,y,a,p,True)) ss + -- show turtle, appropriately adjust environment + +doGraphics name as (vs,ps,(x,y,a,p,True)) ss fail succ + = hideTurtle x y a ss $ + moveTurtle name as (x,y,a,p) ss $ \(x2,y2,a2,p2) -> + showTurtle x2 y2 a2 ss $ + succ (vs,ps,(x2,y2,a2,p2,True)) ss + -- executes graphics commands if turtle is shownn + +doGraphics name as (vs,ps,(x,y,a,p,False)) ss fail succ + = moveTurtle name as (x,y,a,p) ss $ \(x2,y2,a2,p2) -> + succ (vs,ps,(x2,y2,a2,p2,False)) ss + -- executes graphics commands if turtle is not shown + +-- converts an integer to a float +toFloat :: Int -> Float +toFloat = fromInteger . toInteger + +newmod a b = let c = a `mod` b + in if (c < 0) then (c + b) else c + +-- shows the turtle, but returns nothing +showTurtle :: Int -> Int -> Int -> StateType -> IO () -> IO () +showTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) succ + = let dx1 = round (12 * cos (toFloat a * pi/180)) + dx2 = round (4 * sin (toFloat a * pi/180)) + dy1 = round (12 * sin (toFloat a * pi/180)) + dy2 = round (4 * cos (toFloat a * pi/180)) + in + xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint x y) + (XPoint (x-dx1-dx2) (y+dy1-dy2)) + `thenIO` \ () -> + xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint x y) + (XPoint (x-dx1+dx2) (y+dy1+dy2)) + `thenIO` \ () -> + xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint (x-dx1-dx2) (y+dy1-dy2)) + (XPoint (x-dx1+dx2) (y+dy1+dy2)) + `thenIO` \ () -> + xDisplayForceOutput display + `thenIO_` + succ + +-- hides the turtle, but returns nothing +hideTurtle :: Int -> Int -> Int -> StateType -> IO () -> IO () +hideTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) succ + = xUpdateGcontext graphContext [XGCForeground bg] + `thenIO_` + (showTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) $ + (xUpdateGcontext graphContext [XGCForeground fg] + `thenIO_` + succ)) + +-- performs all graphics commands that don't involve hiding/showing +-- the turtle +moveTurtle :: CommandName -> EvalArgs -> GraphEnv -> StateType -> + (GraphEnv -> IO ()) -> IO () +moveTurtle "SETXY" [Num xp,Num yp] (x,y,a,p) ss succ + = succ (xp,yp,a,p) + +-- move the turtle forward "d" times, drawing a line if pen is down +moveTurtle "FORWARD" [Num d] (x,y,a,p) + (is,(graphWindow,display,graphContext,fg,bg)) succ + = let xp = x + round (toFloat d * cos (toFloat a * pi/180)) + yp = y - round (toFloat d * sin (toFloat a * pi/180)) in + (if p + then (xDrawLine (XDrawWindow graphWindow) + graphContext + (XPoint x y) + (XPoint xp yp)) + else returnIO ()) `thenIO` \ () -> + xDisplayForceOutput display `thenIO` \ () -> + succ (xp,yp,a,p) + +-- move the turtle backward "d" pixels, drawing a line if pen is down +moveTurtle "BACKWARD" [Num d] (x,y,a,p) ss succ + = moveTurtle "FORWARD" [Num (-d)] (x,y,a,p) ss succ + +-- rotate turtle to "ap" degrees from facing due east +moveTurtle "SETANGLE" [Num ap] (x,y,a,p) ss succ + = succ (x,y,ap,p) + +-- rotate turtle counterclockwise "ap" degrees +moveTurtle "LEFT" [Num ap] (x,y,a,p) ss succ + = succ (x,y, (a + ap) `newmod` 360 ,p) + +-- rotate turtle clockwise "ap" degrees +moveTurtle "RIGHT" [Num ap] (x,y,a,p) ss succ + = succ (x,y, (a - ap) `newmod` 360 ,p) + +-- pick pen up +moveTurtle "PENUP" [] (x,y,a,p) ss succ + = succ (x,y,a,False) + +-- put pen down +moveTurtle "PENDOWN" [] (x,y,a,p) ss succ + = succ (x,y,a,True) + +-- clear screen but don't otherwise alter turtle state +moveTurtle "CLEARSCREEN" [] (x,y,a,p) + (is,(graphWindow,display,graphContext,bg,fg)) succ + = xClearArea graphWindow (XRect 0 0 500 500) True + `thenIO` \() -> + xDisplayForceOutput display + `thenIO` \() -> + succ (x,y,a,p) + +-- pick pen up and reset turtle +moveTurtle "CLEAN" [] (x,y,a,p) + (is,(graphWindow,display,graphContext,bg,fg)) succ + = xClearArea graphWindow (XRect 0 0 500 500) True + `thenIO` \() -> + xDisplayForceOutput display + `thenIO` \() -> + succ (500 `div` 2,500 `div` 2,90,True) + +-- do nothing if arguments are incorrect +moveTurtle _ _ e _ succ = succ e + + +-- valueToString, etc. -- + +-- convert a value to a string +valueToString :: Value -> String +valueToString (Word w) = w +valueToString (Num n) = show n +valueToString (Boolean True) = "TRUE" +valueToString (Boolean False) = "FALSE" +valueToString Null = "" +valueToString (List l) = "[" ++ (listToString l) ++ "]" +valueToString GoodBye = "Don't play around with this variable!" + +-- convert a list to a string +listToString :: ListType -> String +listToString NullList = "" +listToString (v :* NullList) = valueToString v +listToString (v :* l) = (valueToString v) ++ " " ++ (listToString l) + + + +------------------------------------------------------------------------------- +module Lexer where + +{- + +Lexer takes as input a line from standard input and returns an ordered +pair containing the translation of that list into tokens as well as +the current state of the lexer (how many parentheses and brackets are +still open). The state is necessary because some commands may take +multiple lines, so a bracket (say) may be left open on one line to be +closed later on. + +All unmatched close brackets and parentheses are treated as spaces +(and therefore ignored). + +The method for tokenizing commands is: + + All words are delimited by spaces, parenthesis, or brackets. + + All words beginning with a double quote are returned as quoted words + rather than normal words. + + Any character preceded by a backslash is taken as is, rather than + tokenized normally. + + All words are translated to upper case.. + +The method for tokenizing user input is: + + All words are delimited by spaces and translated to upper case. + +-} + +import Parser +import Evaluator + + +data LexState = Lexer | LexerBracket Int LexState | LexerParen Int LexState + deriving Text + +type LexerType = [Char] -> ([Token] , LexState) + +data Token = OpenBracket + | CloseBracket + | OpenParen + | CloseParen + | QuotedWord WordType + | Normal WordType deriving (Text,Eq) + + +-- call appropriate lex procedure depending upon the current lex state +lexDispatch :: LexState -> LexerType +lexDispatch (Lexer) = lexer +lexDispatch (LexerBracket n s) = lexerBracket n s +lexDispatch (LexerParen n s) = lexerParen n s + + +-- handle commands +lexer :: LexerType +lexer [] = ([] , Lexer) +lexer (' ':cs) = lexer cs +lexer ('[':cs) = let (ts , s) = lexerBracket 1 (Lexer) cs + in (OpenBracket : ts , s) +lexer ('(':cs) = let (ts , s) = lexerParen 1 (Lexer) cs + in (OpenParen : ts , s) +lexer (')':cs) = lexer cs +lexer (']':cs) = lexer cs +lexer ('"':cs) = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s) = lexer cs2 + in ((QuotedWord (upWord t)):ts , s) +lexer cs = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s) = lexer cs2 + in ((Normal (upWord t)):ts , s) + +lexerWord :: (Char -> Bool) -> [Char] -> (WordType , [Char]) +lexerWord endCond [] + = ([] , []) +lexerWord endCond (c:cs) + | c == '\\' = if cs == [] + then ("\\" , cs) + else + let (t , cs2) = lexerWord endCond (tail cs) + in ((head cs):t , cs2) + | endCond c = ([] , (c:cs)) + | otherwise = let (t , cs2) = lexerWord endCond cs + in ((toUpper c):t , cs2) + + +-- performs lexing inside brackets +lexerBracket :: Int -> LexState -> LexerType +lexerBracket n s [] + = ([] , LexerBracket n s) +lexerBracket n s (' ':cs) + = lexerBracket n s cs +lexerBracket 1 s (']':cs) + = let (ts , s2) = lexDispatch s cs + in (CloseBracket:ts , s2) +lexerBracket n s (']':cs) + = let (ts , s2) = lexerBracket (n-1) s cs + in (CloseBracket:ts , s2) +lexerBracket n s ('[':cs) + = let (ts , s2) = lexerBracket (n+1) s cs + in (OpenBracket:ts , s2) +lexerBracket n s ('(':cs) + = let (ts , s2) = lexerParen 1 (LexerBracket n s) cs + in (OpenParen:ts , s2) +lexerBracket n s (')':cs) + = lexerBracket n s cs +lexerBracket n s cs + = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s2) = lexerBracket n s cs2 + in ((Normal (upWord t)):ts , s2) + + +-- performs lexing inside parentheses +lexerParen :: Int -> LexState -> LexerType +lexerParen n s [] + = ([] , LexerParen n s) +lexerParen n s (' ':cs) + = lexerParen n s cs +lexerParen 1 s (')':cs) + = let (ts , s2) = lexDispatch s cs + in (CloseParen:ts , s2) +lexerParen n s (')':cs) + = let (ts , s2) = lexerParen (n-1) s cs + in (CloseParen:ts , s2) +lexerParen n s ('(':cs) + = let (ts , s2) = lexerParen (n+1) s cs + in (OpenParen:ts , s2) +lexerParen n s ('[':cs) + = let (ts , s2) = lexerBracket 1 (LexerParen n s) cs + in (OpenBracket:ts , s2) +lexerParen n s (']':cs) + = lexerParen n s cs +lexerParen n s ('"':cs) + = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s2) = lexerParen n s cs2 + in ((QuotedWord (upWord t)):ts , s2) +lexerParen n s cs + = let (t , cs2) = lexerWord (isDelimiter) cs + (ts , s2) = lexerParen n s cs2 + in ((Normal (upWord t)):ts , s2) + + +-- returns true for delimiters +isDelimiter :: Char -> Bool +isDelimiter = inList " []()" + +-- returns true of p is in cs +inList :: (Eq a) => [a] -> a -> Bool +inList [] p = False +inList (c:cs) p = (c == p) || (inList cs p) + + +-- handle user input +lexerReadLine :: [Char] -> [WordType] +lexerReadLine [] + = [] +lexerReadLine (' ':cs) + = lexerReadLine cs +lexerReadLine cs + = let (firstWord,restOfWords) = span (/= ' ') cs + in (upWord firstWord) : lexerReadLine restOfWords + +-- translate a word to upper case +upWord :: WordType -> WordType +upWord = map (toUpper) + + + +------------------------------------------------------------------------------- +module Parser where + +{- + +Parser takes a list of tokens, the input state, and fail and success +continuations and returns an Abstract Syntax Tree, the remaining +tokens (hopefully none), and the new input state. The input state +will be changed every time Parser runs out of tokens: it simply grabs +(and lexes) the next line of user-input. It therefore doesn't return +anything until the entire AST has been be read in, even if it spans +several lines, though parse may catch some errors before all lines +have been input. In this case, it ceases taking input and returns the +error. + +An Abstract Syntax Tree represents one command, and breaks those +commands into Ifs, Loops, Tos, Locals, Makes, Reads, Prints, +Constants, List constants, Graphics commands (which produce +side-effects), and function applications. All built-in commands that +don't fit into one of those categories are lumped into function +applications along with user-defined functions. Each type of AST is +parsed into subcommands, subclauses (lists of commands), command +arguments (also subcommands), and any other values that will be +immediately-evaluatable (such as function names). + +-} + + +import Lexer +import Evaluator + + +type CommandName = [Char] +type ClauseType = [AST] +type ConditionType = AST + +type ParseArgs = [AST] + +data ArgType = Val Value | QuotedWordArg WordType + deriving Text + +data AST = ParseList ListType + | If ConditionType ClauseType ClauseType + | Loop LoopType ConditionType ClauseType + | To NameType ProcType + | Make NameType AST + | Local NameType + | Read + | Print ParseArgs + | Argument ArgType + | Graphics CommandName ParseArgs + | Command CommandName ParseArgs deriving Text + +data LoopType = Do | While | Repeat + deriving Text + +type ParseFailType = Error -> InputState -> IO () +type ParseType = [Token] -> InputState -> ParseFailType -> + (AST -> [Token] -> InputState -> IO ()) -> IO () +type ParseClauseType = [Token] -> InputState -> ParseFailType -> + (ClauseType -> [Token] -> InputState -> IO ()) -> IO () + +type InputState = ([[Char]] , LexState) + +parse :: ParseType + +parse [] (i:is , ls) fail succ + = let (ts , ls2) = lexDispatch ls i + in parse ts (is , ls2) fail succ + +parse ((QuotedWord s) : ts) inS fail succ + = succ (Argument (QuotedWordArg s)) ts inS + +parse ((Normal s) : ts) inS fail succ + = succ (Argument (Val (process s))) ts inS + +parse (OpenParen : []) (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parse (OpenParen:ts) (is,ls2) fail succ + +parse (OpenParen : (Normal t) : ts) inS fail succ + | t == "TO" = makeProc ts inS fail succ + | t == "MAKE" = makeMake ts inS fail succ + | t == "LOCAL" = makeLocal ts inS fail succ + | t == "READ" = makeRead ts inS fail succ + | t == "PRINT" = makePrint ts inS fail succ + | t == "IF" = makeIf ts inS fail succ + | isLoop t = makeLoop t ts inS fail succ + | isGraphics t = makeGraphics t ts inS fail succ + | otherwise = makeCommand t ts inS fail succ + +parse (OpenBracket : ts) inS fail succ + = parseList ts inS fail succ + +parse ts inS@([], _) _ succ = succ (Argument (Val (Word "GOODBYE"))) ts inS + +parse _ inS fail _ + = fail "Syntax error" inS + + +-- returns true for all loop names +isLoop :: CommandName -> Bool +isLoop = inList ["DO","WHILE","REPEAT"] + +-- returns true for all side-effecting graphics command names +isGraphics :: CommandName -> Bool +isGraphics = inList ["FORWARD","BACKWARD","LEFT","RIGHT", + "SETXY","SETANGLE","PENUP","PENDOWN", + "HIDETURTLE","SHOWTURTLE","CLEARSCREEN","CLEAN"] + +-- Parse lists -- + +-- parses a list constant +parseList :: ParseType +parseList [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseList ts (is,ls2) fail succ +parseList (CloseBracket:ts) inS fail succ + = succ (ParseList NullList) ts inS +parseList (OpenBracket:ts) inS fail succ + = parseList ts inS fail $ \(ParseList l1) ts2 inS2 -> + parseList ts2 inS2 fail $ \(ParseList l2) ts3 inS3 -> + succ (ParseList ((List l1) :* l2)) ts3 inS3 +parseList ((Normal w):ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((process w) :* l)) ts2 inS2 +parseList (OpenParen:ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((Word "(") :* l)) ts2 inS2 +parseList (CloseParen:ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((Word ")") :* l)) ts2 inS2 +parseList ((QuotedWord w):ts) inS fail succ + = parseList ts inS fail $ \(ParseList l) ts2 inS2 -> + succ (ParseList ((Word w) :* l)) ts2 inS2 + + +-- parses constant values, distinguishing words from integers and booleans +process :: WordType -> Value +process "TRUE" = Boolean True +process "FALSE" = Boolean False +process ('-':w) + | all isDigit w = Num (- (stringToNum (reverse w))) + | otherwise = Word ('-':w) +process w + | all isDigit w = Num (stringToNum (reverse w)) + | otherwise = Word w + +-- converts a string to a positive integer +stringToNum :: String -> Int +stringToNum (d:[]) = charToDigit d +stringToNum (d:ds) = (charToDigit d) + 10 * stringToNum ds + +-- converts a character to a digit +charToDigit :: Char -> Int +charToDigit c = ord c - ord '0' + + +-- Parse command statements -- + +-- parses commands +-- format: (<name> <arg1> <arg2> ...) +makeCommand :: CommandName -> ParseType +makeCommand n ts inS fail succ + = parseArgs CloseParen ts inS fail $ \as ts2 inS2 -> + succ (Command n as) ts2 inS2 + + +-- parses a list of commands that are terminated by token "term"" +parseArgs :: Token -> ParseClauseType +parseArgs term [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseArgs term ts (is,ls2) fail succ +parseArgs term (t:ts) inS fail succ + | t == term = succ [] ts inS + | otherwise = parse (t:ts) inS fail $ \a ts2 inS2 -> + parseArgs term ts2 inS2 fail $ \as ts3 inS3 -> + succ (a:as) ts3 inS3 + + +-- Parse I/O statements -- + +-- parses read statements +-- format: (READ) +makeRead :: ParseType +makeRead (CloseParen:ts) inS fail succ + = succ Read ts inS +makeRead _ inS fail _ + = fail "Read: too many arguments" inS + +-- parses print statements +-- format: (PRINT <arg1>) +makePrint :: ParseType +makePrint ts inS fail succ + = parseArgs CloseParen ts inS fail $ \as ts2 inS2 -> + if (length as) == 1 + then succ (Print as) ts2 inS2 + else fail "Print: too many arguments" inS + + + +-- Parse TO statements -- + + +-- parses to statements +-- format: (TO <name> <fpname1> <fpname2> ... <clause>) +-- note: all formal parameter names must begin with a colon +makeProc :: ParseType +makeProc [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeProc ts (is,ls2) fail succ +makeProc ((Normal t):ts) inS fail succ + = parseFormals ts inS fail $ \p ts2 inS2 -> + getParen ts2 inS2 fail $ \ts3 inS3 -> + succ (To t p) ts3 inS3 +makeProc _ inS fail _ + = fail "Invalid procedure name" inS + +-- parses the formal parameters +-- takes all words beginning with a colon, and assumes everything +-- after that is part of the body +parseFormals :: [Token] -> InputState -> ParseFailType -> + (([NameType] , ClauseType) -> [Token] -> InputState -> IO ()) + -> IO () +parseFormals [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseFormals ts (is,ls2) fail succ +parseFormals (OpenBracket:ts) inS fail succ + = parseClause (OpenBracket:ts) inS fail $ \pb ts2 inS2 -> + succ ([],pb) ts2 inS2 +parseFormals ((Normal (':':c:cs)):ts) inS fail succ + = parseFormals ts inS fail $ \(formals,pb) ts2 inS2 -> + succ ((':':c:cs):formals , pb) ts2 inS2 +parseFormals ts inS fail succ + = parseClause ts inS fail $ \pb ts2 inS2 -> + succ ([],pb) ts2 inS2 + + +-- Parse MAKE statements -- + +-- parses make statements +-- format: (MAKE <name> <arg>) +-- note: <name> must be quoted +makeMake :: ParseType +makeMake [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeMake ts (is,ls2) fail succ +makeMake ((QuotedWord s):ts) inS fail succ + = parse ts inS fail $ \a ts2 inS2 -> + getParen ts2 inS2 fail $ \ts3 inS3 -> + succ (Make s a) ts3 inS3 +makeMake _ inS fail _ + = fail "Make: Improper variable name" inS + + +-- Parse LOCAL statements -- + +-- parses local statements +-- format: (LOCAL <name>) +-- note: <name> must be quoted +makeLocal :: ParseType +makeLocal [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeLocal ts (is,ls2) fail succ +makeLocal (t:[]) (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeLocal (t:ts) (is,ls2) fail succ +makeLocal ((QuotedWord s):CloseParen:ts) inS fail succ + = succ (Local s) ts inS +makeLocal _ inS fail _ + = fail "Local: improper variable name" inS + + +-- Parse IF statements -- + +-- parses if-then and if-then-else statements +-- format: (IF <cond> then <clause> [else <clause>]) +makeIf :: ParseType +makeIf [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in makeIf ts (is,ls2) fail succ +makeIf ts inS fail succ + = parse ts inS fail $ \cond ts2 inS2 -> + parseThen ts2 inS2 fail $ \thens elses ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (If cond thens elses) ts4 inS4 + + +-- parses then clauses +parseThen :: [Token] -> InputState -> ParseFailType -> + (ClauseType -> ClauseType -> [Token] -> InputState -> IO ()) -> + IO () +parseThen [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseThen ts (is,ls2) fail succ +parseThen ((Normal "THEN"):ts) inS fail succ + = parseClause ts inS fail $ \thens ts2 inS2 -> + parseElse ts2 inS2 fail $ \elses ts3 inS3 -> + succ thens elses ts3 inS3 +parseThen _ inS fail _ + = fail "IF: improper THEN clause" inS + +-- parses (optional) else clauses +parseElse :: ParseClauseType +parseElse [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseElse ts (is,ls2) fail succ +parseElse (CloseParen:ts) inS fail succ + = succ [] (CloseParen:ts) inS +parseElse ((Normal "ELSE"):ts) inS fail succ + = parseClause ts inS fail succ +parseElse _ inS fail _ + = fail "IF: improper ELSE clause" inS + +-- parses clauses +-- a clause is either a list of commands enclosed in brackets, or a +-- single command +parseClause :: ParseClauseType +parseClause [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseClause ts (is,ls2) fail succ +parseClause (OpenBracket:ts) inS fail succ + = parseArgs CloseBracket ts inS fail succ +parseClause ts inS fail succ + = parse ts inS fail $ \a ts2 inS2 -> + succ [a] ts2 inS2 + + +-- Parse Loop Statements -- + +-- parses loop statements +-- basically a dispatcher for other parse functions +makeLoop :: NameType -> ParseType +makeLoop "DO" = makeDo +makeLoop "WHILE" = makeWhile +makeLoop "REPEAT" = makeRepeat + +-- parses do statements +-- format: (DO <clause> WHILE <cond>) +makeDo :: ParseType +makeDo ts inS fail succ + = parseClause ts inS fail $ \insts ts2 inS2 -> + parseWhileCond ts2 inS2 fail $ \cond ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (Loop Do cond insts) ts4 inS4 + +-- parses while conditions (both in while and do-while loops) +-- a condition is simply a command that (hopefully) returns a boolean +parseWhileCond :: ParseType +parseWhileCond [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseWhileCond ts (is,ls2) fail succ +parseWhileCond ((Normal "WHILE"):ts) inS fail succ + = parse ts inS fail succ + +-- parses while statements +-- format: (WHILE <cond> <clause>) +makeWhile :: ParseType +makeWhile ts inS fail succ + = parse ts inS fail $ \cond ts2 inS2 -> + parseClause ts2 inS fail $ \insts ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (Loop While cond insts) ts4 inS4 + +-- parses repeat statements +-- format: (REPEAT <num> TIMES <clause>) +-- note: <num> is simply a command that (hopefully) returns an integer +makeRepeat :: ParseType +makeRepeat ts inS fail succ + = parse ts inS fail $ \num ts2 inS2 -> + parseRepeatBody ts2 inS fail $ \insts ts3 inS3 -> + getParen ts3 inS3 fail $ \ts4 inS4 -> + succ (Loop Repeat num insts) ts4 inS4 + +-- parses repeat body (just a clause) +parseRepeatBody :: ParseClauseType +parseRepeatBody [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in parseRepeatBody ts (is,ls2) fail succ +parseRepeatBody ((Normal "TIMES"):ts) inS fail succ + = parseClause ts inS fail succ +parseRepeatBody _ inS fail _ + = fail "Repeat: invalid format" inS + + +-- Parse Graphics Statements -- + +-- parses all side-effecting graphics statements +makeGraphics :: CommandName -> ParseType +makeGraphics n ts inS fail succ + = parseArgs CloseParen ts inS fail $ \as ts2 inS2 -> + succ (Graphics n as) ts2 inS2 + +-- Parse Trailing Parenthesis -- + +-- parses the closing paren terminating most commands +getParen :: [Token] -> InputState -> ParseFailType -> + ([Token] -> InputState -> IO ()) -> IO () +getParen [] (i:is,ls) fail succ + = let (ts,ls2) = lexDispatch ls i + in getParen ts (is,ls) fail succ +getParen (CloseParen:ts) inS fail succ + = succ ts inS +getParen _ inS fail _ + = fail "Expected )" inS + diff --git a/progs/demo/X11/logo/logo.hu b/progs/demo/X11/logo/logo.hu new file mode 100644 index 0000000..388e926 --- /dev/null +++ b/progs/demo/X11/logo/logo.hu @@ -0,0 +1,3 @@ +:o= foldr inline constant +$HASKELL_LIBRARY/X11/xlib.hu +logo.hs diff --git a/progs/demo/X11/mdraw/README b/progs/demo/X11/mdraw/README new file mode 100644 index 0000000..c78f7d9 --- /dev/null +++ b/progs/demo/X11/mdraw/README @@ -0,0 +1 @@ +This is a multiple screen version of the draw program. diff --git a/progs/demo/X11/mdraw/mdraw.hs b/progs/demo/X11/mdraw/mdraw.hs new file mode 100644 index 0000000..c4bb508 --- /dev/null +++ b/progs/demo/X11/mdraw/mdraw.hs @@ -0,0 +1,83 @@ +module MDraw where + +import Xlib + +mapIO :: (a -> IO b) -> [a] -> IO [b] + +mapIO f [] = returnIO [] +mapIO f (x:xs) = f x `thenIO` \ y -> + mapIO f xs `thenIO` \ ys -> + returnIO (y:ys) + +map2IO :: (a -> b -> IO c) -> [a] -> [b] -> IO [c] + +map2IO f [] [] = returnIO [] +map2IO f (x:xs) (z:zs) = f x z `thenIO` \ y -> + map2IO f xs zs `thenIO` \ ys -> + returnIO (y:ys) + +xGetEventMul :: XMArray XDisplay -> IO (Int, XEvent) +xGetEventMul displays = + let n_displays = xMArrayLength displays + loop :: Int -> IO (Int, XEvent) + loop i = if i == n_displays then loop 0 + else xMArrayLookup displays i `thenIO` \ display -> + xDisplayForceOutput display `thenIO` \ _ -> + xEventListen display `thenIO` \ n_events -> + if n_events == 0 then loop (i + 1) + else xGetEvent display `thenIO` \ event -> + returnIO (i, event) + in loop 0 + +-- takes a list of host names + +mdraw :: [String] -> IO () +mdraw hosts = + xHandleError (\ (XError msg) -> appendChan stdout msg exit done) $ + mapIO xOpenDisplay hosts `thenIO` \ displays -> + let screens = map (head . xDisplayRoots) displays + fg_colors = map xScreenBlackPixel screens + bg_colors = map xScreenWhitePixel screens + roots = map xScreenRoot screens + in + map2IO (\ root color -> + xCreateWindow root + (XRect 100 100 400 400) + [XWinBackground color, + XWinEventMask (XEventMask [XButtonMotion, + XButtonPress])]) + roots + bg_colors + `thenIO` \windows -> + mapIO xMapWindow windows `thenIO` \ _ -> + map2IO xCreateGcontext + (map XDrawWindow roots) + (map (\ color -> [XGCForeground color]) fg_colors) + `thenIO` \ gcontexts -> + xMArrayCreate displays `thenIO` \ displayArr -> + let + handleEvent lasts = + xGetEventMul displayArr `thenIO` \ (idx, event) -> + let pos = xEventPos event + in + case (xEventType event) of + XButtonPressEvent -> + xMArrayUpdate lasts idx pos `thenIO` \ () -> + handleEvent lasts + XMotionNotifyEvent -> + xMArrayLookup lasts idx `thenIO` \ last -> + map2IO (\ window gcontext -> xDrawLine (XDrawWindow window) + gcontext + last + pos) + windows + gcontexts + `thenIO` \ _ -> + xMArrayUpdate lasts idx pos `thenIO` \ () -> + handleEvent lasts + _ -> handleEvent lasts + in + xMArrayCreate (map (\ _ -> XPoint 0 0) hosts) `thenIO` \ lasts -> + handleEvent lasts `thenIO` \ _ -> + returnIO () + diff --git a/progs/demo/X11/mdraw/mdraw.hu b/progs/demo/X11/mdraw/mdraw.hu new file mode 100644 index 0000000..16296d5 --- /dev/null +++ b/progs/demo/X11/mdraw/mdraw.hu @@ -0,0 +1,3 @@ +:o= all +$HASKELL_LIBRARY/X11/xlib.hu +mdraw.hs diff --git a/progs/demo/X11/mdraw/t.hs b/progs/demo/X11/mdraw/t.hs new file mode 100644 index 0000000..77f2baf --- /dev/null +++ b/progs/demo/X11/mdraw/t.hs @@ -0,0 +1,16 @@ +module Test where +import Xlib + +xGetEventMul :: XMArray XDisplay -> IO (Int, XEvent) +xGetEventMul displays = + let n_displays = xMArrayLength displays + loop :: Int -> IO (Int, XEvent) + loop i = if i == n_displays then loop 0 + else xMArrayLookup displays i `thenIO` \ display -> + xDisplayForceOutput display `thenIO` \ _ -> + xEventListen display `thenIO` \ n_events -> + if n_events == 0 then loop (i + 1) + else xGetEvent display `thenIO` \ event -> + returnIO (i, event) + in loop 0 + diff --git a/progs/demo/X11/mdraw/t.hu b/progs/demo/X11/mdraw/t.hu new file mode 100644 index 0000000..657234c --- /dev/null +++ b/progs/demo/X11/mdraw/t.hu @@ -0,0 +1,3 @@ +:o= all +$HASKELL_LIBRARY/X11/xlib.hu +t.hs diff --git a/progs/demo/add.hs b/progs/demo/add.hs new file mode 100644 index 0000000..bdfcc2f --- /dev/null +++ b/progs/demo/add.hs @@ -0,0 +1,21 @@ +-- this is an interactive program to read in two numbers and print their sum. + +module Main where + +main = readChan stdin abort $ \userInput -> + let inputLines = lines userInput in + readInt "Enter first number: " inputLines $ \num1 inputLines1 -> + readInt "Enter second number: " inputLines1 $ \ num2 _ -> + appendChan stdout ("Their sum is: " ++ show (num1 + num2)) abort done + +readInt :: String -> [String] -> (Integer -> [String] -> Dialogue) -> Dialogue + +readInt prompt inputLines succ = + appendChan stdout prompt abort $ + case inputLines of + (l1 : rest) -> case (reads l1) of + [(x,"")] -> succ x rest + _ -> appendChan stdout + "Error - retype the number\n" abort $ + readInt prompt rest succ + _ -> appendChan stdout "Early EOF" abort done diff --git a/progs/demo/eliza.hs b/progs/demo/eliza.hs new file mode 100644 index 0000000..d7bf975 --- /dev/null +++ b/progs/demo/eliza.hs @@ -0,0 +1,267 @@ +-- Eliza: an implementation of the classic pseudo-psychoanalyst --------------- +-- +-- Gofer version by Mark P. Jones, January 12 1992 +-- +-- Adapted from a pascal implementation provided as part of an experimental +-- package from James Risner (risner@ms.uky.edu), Univ. of KY. with original +-- pascal code apparently provided by Robert Migliaccio (mig@ms.uky.edu). +------------------------------------------------------------------------------- + +import Prelude hiding (conjugate) + +main :: Dialogue +main = interact (("\n\ + \Hi! I'm Eliza. I am your personal therapy computer.\n\ + \Please tell me your problem.\n\ + \\n" ++) + . session initial [] + . filter (not.null) + . map (words . trim) + . lines) + +trim :: String -> String -- strip punctuation characters +trim = foldr cons "" . dropWhile (`elem` punct) + where x `cons` xs | x `elem` punct && null xs = [] + | otherwise = x : xs + punct = [' ', '.', '!', '?', ','] + +-- Read a line at a time, and produce some kind of response ------------------- + +session :: State -> Words -> [Words] -> String +session rs prev [] = [] +session rs prev (l:ls) = response ++ "\n\n" ++ session rs' l ls + where (response, rs') | prev == l = repeated rs + | otherwise = answer rs l + +answer :: State -> Words -> (String, State) +answer st l = (response, newKeyTab kt st) + where (response, kt) = ans (keyTabOf st) + e `cons` (r, es) = (r, e:es) + ans (e:es) | null rs = e `cons` ans es + | otherwise = (makeResponse a (head rs), (key,as):es) + where rs = replies key l + (key,(a:as)) = e + +-- Find all possible replies (without leading string for given key ------------ + +replies :: Words -> Words -> [String] +replies key l = ( map (conjugate l . drop (length key)) + . filter (prefix key . map ucase) + . tails) l + +prefix :: Eq a => [a] -> [a] -> Bool +[] `prefix` xs = True +(x:xs) `prefix` [] = False +(x:xs) `prefix` (y:ys) = x==y && (xs `prefix` ys) + +tails :: [a] -> [[a]] -- non-empty tails of list +tails [] = [] +tails xs = xs : tails (tail xs) + +ucase :: String -> String -- map string to upper case +ucase = map toUpper + +-- Replace keywords in a list of words with appropriate conjugations ---------- + +conjugate :: Words -> Words -> String +conjugate d = unwords . trailingI . map conj . maybe d -- d is default input + where maybe d xs = if null xs then d else xs + conj w = head ([m | (w',m)<-conjugates, uw==w'] ++ [w]) + where uw = ucase w + trailingI = foldr cons [] + where x `cons` xs | x=="I" && null xs = ["me"] + | otherwise = x:xs + +conjugates :: [(Word, Word)] +conjugates = prepare (oneways ++ concat [[(x,y), (y,x)] | (x,y) <- bothways]) + where oneways = [ ("me", "you") ] + bothways = [ ("are", "am"), ("we're", "was"), + ("you", "I"), ("your", "my"), + ("I've", "you've"), ("I'm", "you're") ] + prepare = map (\(w,r) -> (ucase w, r)) + +-- Response data -------------------------------------------------------------- + +type Word = String +type Words = [Word] +type KeyTable = [(Key, Replies)] +type Replies = [String] +type State = (KeyTable, Replies) +type Key = Words + +repeated :: State -> (String, State) +repeated (kt, (r:rp)) = (r, (kt, rp)) + +newKeyTab :: KeyTable -> State -> State +newKeyTab kt' (kt, rp) = (kt', rp) + +keyTabOf :: State -> KeyTable +keyTabOf (kt, rp) = kt + +makeResponse :: String -> String -> String +makeResponse ('?':cs) us = cs ++ " " ++ us ++ "?" +makeResponse ('.':cs) us = cs ++ " " ++ us ++ "." +makeResponse cs us = cs + +initial :: State +initial = ([(words k, cycle rs) | (k,rs) <-respMsgs], cycle repeatMsgs) + +respMsgs = [ ("CAN YOU", canYou), + ("CAN I", canI), + ("YOU ARE", youAre), + ("YOU'RE", youAre), + ("I DON'T", iDont), + ("I FEEL", iFeel), + ("WHY DON'T YOU", whyDont), + ("WHY CAN'T I", whyCant), + ("ARE YOU", areYou), + ("I CAN'T", iCant), + ("I AM", iAm), + ("I'M", iAm), + ("YOU", you), + ("YES", yes), + ("NO", no), + ("COMPUTER", computer), + ("COMPUTERS", computer), + ("I WANT", iWant), + ("WHAT", question), + ("HOW", question), + ("WHO", question), + ("WHERE", question), + ("WHEN", question), + ("WHY", question), + ("NAME", name), + ("BECAUSE", because), + ("CAUSE", because), + ("SORRY", sorry), + ("DREAM", dream), + ("DREAMS", dream), + ("HI", hello), + ("HELLO", hello), + ("MAYBE", maybe), + ("YOUR", your), + ("ALWAYS", always), + ("THINK", think), + ("ALIKE", alike), + ("FRIEND", friend), + ("FRIENDS", friend), + ("", nokeyMsgs) ] + +canYou = [ "?Don't you believe that I can", + "?Perhaps you would like to be able to", + "?You want me to be able to" ] +canI = [ "?Perhaps you don't want to", + "?Do you want to be able to" ] +youAre = [ "?What makes you think I am", + "?Does it please you to believe I am", + "?Perhaps you would like to be", + "?Do you sometimes wish you were" ] +iDont = [ "?Don't you really", + "?Why don't you", + "?Do you wish to be able to", + "Does that trouble you?" ] +iFeel = [ "Tell me more about such feelings.", + "?Do you often feel", + "?Do you enjoy feeling" ] +whyDont = [ "?Do you really believe I don't", + ".Perhaps in good time I will", + "?Do you want me to" ] +whyCant = [ "?Do you think you should be able to", + "?Why can't you" ] +areYou = [ "?Why are you interested in whether or not I am", + "?Would you prefer if I were not", + "?Perhaps in your fantasies I am" ] +iCant = [ "?How do you know you can't", + "Have you tried?", + "?Perhaps you can now" ] +iAm = [ "?Did you come to me because you are", + "?How long have you been", + "?Do you believe it is normal to be", + "?Do you enjoy being" ] +you = [ "We were discussing you --not me.", + "?Oh,", + "You're not really talking about me, are you?" ] +yes = [ "You seem quite positive.", + "Are you Sure?", + "I see.", + "I understand." ] +no = [ "Are you saying no just to be negative?", + "You are being a bit negative.", + "Why not?", + "Are you sure?", + "Why no?" ] +computer = [ "Do computers worry you?", + "Are you talking about me in particular?", + "Are you frightened by machines?", + "Why do you mention computers?", + "What do you think machines have to do with your problems?", + "Don't you think computers can help people?", + "What is it about machines that worries you?" ] +iWant = [ "?Why do you want", + "?What would it mean to you if you got", + "?Suppose you got", + "?What if you never got", + ".I sometimes also want" ] +question = [ "Why do you ask?", + "Does that question interest you?", + "What answer would please you the most?", + "What do you think?", + "Are such questions on your mind often?", + "What is it that you really want to know?", + "Have you asked anyone else?", + "Have you asked such questions before?", + "What else comes to mind when you ask that?" ] +name = [ "Names don't interest me.", + "I don't care about names --please go on." ] +because = [ "Is that the real reason?", + "Don't any other reasons come to mind?", + "Does that reason explain anything else?", + "What other reasons might there be?" ] +sorry = [ "Please don't apologise!", + "Apologies are not necessary.", + "What feelings do you have when you apologise?", + "Don't be so defensive!" ] +dream = [ "What does that dream suggest to you?", + "Do you dream often?", + "What persons appear in your dreams?", + "Are you disturbed by your dreams?" ] +hello = [ "How do you...please state your problem." ] +maybe = [ "You don't seem quite certain.", + "Why the uncertain tone?", + "Can't you be more positive?", + "You aren't sure?", + "Don't you know?" ] +your = [ "?Why are you concerned about my", + "?What about your own" ] +always = [ "Can you think of a specific example?", + "When?", + "What are you thinking of?", + "Really, always?" ] +think = [ "Do you really think so?", + "?But you are not sure you", + "?Do you doubt you" ] +alike = [ "In what way?", + "What resemblence do you see?", + "What does the similarity suggest to you?", + "What other connections do you see?", + "Cound there really be some connection?", + "How?" ] +friend = [ "Why do you bring up the topic of friends?", + "Do your friends worry you?", + "Do your friends pick on you?", + "Are you sure you have any friends?", + "Do you impose on your friends?", + "Perhaps your love for friends worries you." ] + +repeatMsgs = [ "Why did you repeat yourself?", + "Do you expect a different answer by repeating yourself?", + "Come, come, elucidate your thoughts.", + "Please don't repeat yourself!" ] + +nokeyMsgs = [ "I'm not sure I understand you fully.", + "What does that suggest to you?", + "I see.", + "Can you elaborate on that?", + "Say, do you have any psychological problems?" ] + +------------------------------------------------------------------------------- diff --git a/progs/demo/fact.hs b/progs/demo/fact.hs new file mode 100755 index 0000000..054183e --- /dev/null +++ b/progs/demo/fact.hs @@ -0,0 +1,14 @@ +{- This is a simple factorial program which uses the I/O system + to read the input and print the result -} + +module Main where + +fact :: Integer -> Integer +fact 0 = 1 +fact (n+1) = (n+1)*fact n +fact _ = error "Negative argument to factorial" + +main = appendChan stdout "Type in N: " abort $ + readChan stdin abort $ \ input -> + appendChan stdout (show (fact (read (head (lines input))))) abort done + diff --git a/progs/demo/improved-add.hs b/progs/demo/improved-add.hs new file mode 100644 index 0000000..bdfcc2f --- /dev/null +++ b/progs/demo/improved-add.hs @@ -0,0 +1,21 @@ +-- this is an interactive program to read in two numbers and print their sum. + +module Main where + +main = readChan stdin abort $ \userInput -> + let inputLines = lines userInput in + readInt "Enter first number: " inputLines $ \num1 inputLines1 -> + readInt "Enter second number: " inputLines1 $ \ num2 _ -> + appendChan stdout ("Their sum is: " ++ show (num1 + num2)) abort done + +readInt :: String -> [String] -> (Integer -> [String] -> Dialogue) -> Dialogue + +readInt prompt inputLines succ = + appendChan stdout prompt abort $ + case inputLines of + (l1 : rest) -> case (reads l1) of + [(x,"")] -> succ x rest + _ -> appendChan stdout + "Error - retype the number\n" abort $ + readInt prompt rest succ + _ -> appendChan stdout "Early EOF" abort done diff --git a/progs/demo/merge.hs b/progs/demo/merge.hs new file mode 100755 index 0000000..cf61f8f --- /dev/null +++ b/progs/demo/merge.hs @@ -0,0 +1,26 @@ +{- This is a simple merge sort -} + +module Merge where + +merge :: [Int] -> [Int] -> [Int] +merge [] x = x +merge x [] = x +merge l1@(a:b) l2@(c:d) | a < c = a:(merge b l2) + | otherwise = c:(merge l1 d) + +half [] = [] +half [x] = [x] +half (x:y:z) = x:r where r = half z + +sort [] = [] +sort [x] = [x] +sort l = merge (sort odds) (sort evens) where + odds = half l + evens = half (tail l) + +main = + appendChan stdout "Enter a list of integers separated by \",\"\n" abort $ + readChan stdin abort $ \ input -> + appendChan stdout + (show (sort (read ("[" ++ (head (lines input)) ++ "]")))) + abort done diff --git a/progs/demo/pascal.hs b/progs/demo/pascal.hs new file mode 100644 index 0000000..a26e9c9 --- /dev/null +++ b/progs/demo/pascal.hs @@ -0,0 +1,24 @@ +{- This uses lazy evaluation to define Pascals triangle -} + +module Main where + +pascal :: [[Int]] +pascal = [1] : [[x+y | (x,y) <- zip ([0]++r) (r++[0])] | r <- pascal] + +tab :: Int -> ShowS +tab 0 = id +tab (n+1) = showChar ' ' . tab n + +showRow :: [Int] -> ShowS +showRow [] = showChar '\n' +showRow (n:ns) = shows n . showChar ' ' . showRow ns + +showTriangle 1 (t:_) = showRow t +showTriangle (n+1) (t:ts) = tab n . showRow t . showTriangle n ts + +main = appendChan stdout "Number of rows: " abort $ + readChan stdin abort $ \input -> + appendChan stdout + (showTriangle (read (head (lines input))) pascal "") + abort done + diff --git a/progs/demo/pfac.hs b/progs/demo/pfac.hs new file mode 100644 index 0000000..516fc85 --- /dev/null +++ b/progs/demo/pfac.hs @@ -0,0 +1,21 @@ + +-- This is a parallel varient of factorial + +module Main where + +fac :: Int -> Int +fac 0 = 1 +fac n = pfac 1 n + +pfac :: Int -> Int -> Int +pfac low high | low == high = low + | low + 1 == high = (low * high) + | otherwise = pfac low mid * pfac (mid + 1) high + where + mid = (high + low) `div` 2 + +main = appendChan stdout "Type in N: " abort $ + readChan stdin abort $ \ input -> + appendChan stdout (show (fac (read (head (lines input))))) abort done + + diff --git a/progs/demo/primes.hs b/progs/demo/primes.hs new file mode 100755 index 0000000..6c8fe79 --- /dev/null +++ b/progs/demo/primes.hs @@ -0,0 +1,16 @@ +-- This program implements Eratosthenes Sieve +-- to generate prime numbers. + +module Main where + +primes :: [Int] +primes = map head (iterate sieve [2 ..]) + +sieve :: [Int] -> [Int] +sieve (p:ps) = [x | x <- ps, (x `mod` p) /= 0] + +main = appendChan stdout "How many primes? " abort $ + readChan stdin abort $ \ input -> + appendChan stdout (show (take (read (head (lines input))) primes)) + abort done + diff --git a/progs/demo/prolog/Engine.hs b/progs/demo/prolog/Engine.hs new file mode 100644 index 0000000..a269503 --- /dev/null +++ b/progs/demo/prolog/Engine.hs @@ -0,0 +1,61 @@ +-- +-- Stack based Prolog inference engine +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module Engine(prove) where + +import PrologData +import Subst + +--- Calculation of solutions: + +-- the stack based engine maintains a stack of triples (s,goal,alts) +-- corresponding to backtrack points, where s is the substitution at that +-- point, goal is the outstanding goal and alts is a list of possible ways +-- of extending the current proof to find a solution. Each member of alts +-- is a pair (tp,u) where tp is a new subgoal that must be proved and u is +-- a unifying substitution that must be combined with the substitution s. +-- +-- the list of relevant clauses at each step in the execution is produced +-- by attempting to unify the head of the current goal with a suitably +-- renamed clause from the database. + +type Stack = [ (Subst, [Term], [Alt]) ] +type Alt = ([Term], Subst) + +alts :: Database -> Int -> Term -> [Alt] +alts db n g = [ (tp,u) | (tm:*tp) <- renClauses db n g, u <- unify g tm ] + +-- The use of a stack enables backtracking to be described explicitly, +-- in the following `state-based' definition of prove: + +prove :: Database -> [Term] -> [Subst] +prove db gl = solve 1 nullSubst gl [] + where + solve :: Int -> Subst -> [Term] -> Stack -> [Subst] + solve n s [] ow = s : backtrack n ow + solve n s (g:gs) ow + | g==theCut = solve n s gs (cut ow) + | otherwise = choose n s gs (alts db n (apply s g)) ow + + choose :: Int -> Subst -> [Term] -> [Alt] -> Stack -> [Subst] + choose n s gs [] ow = backtrack n ow + choose n s gs ((tp,u):rs) ow = solve (n+1) (u@@s) (tp++gs) ((s,gs,rs):ow) + + backtrack :: Int -> Stack -> [Subst] + backtrack n [] = [] + backtrack n ((s,gs,rs):ow) = choose (n-1) s gs rs ow + + +--- Special definitions for the cut predicate: + +theCut :: Term +theCut = Struct "!" [] + +cut :: Stack -> Stack +cut (top:(s,gl,_):ss) = top:(s,gl,[]):ss +cut ss = ss + +--- End of Engine.hs diff --git a/progs/demo/prolog/Engine.hu b/progs/demo/prolog/Engine.hu new file mode 100644 index 0000000..5a64277 --- /dev/null +++ b/progs/demo/prolog/Engine.hu @@ -0,0 +1,3 @@ +Engine.hs +PrologData.hu +Subst.hu diff --git a/progs/demo/prolog/Interact.hs b/progs/demo/prolog/Interact.hs new file mode 100644 index 0000000..c8bf516 --- /dev/null +++ b/progs/demo/prolog/Interact.hs @@ -0,0 +1,76 @@ +-- +-- Interactive utility functions +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module Interact(Interactive(..), skip, end, readln, writeln, readch) where + +-- The functions defined in this module provide basic facilities for +-- writing line-oriented interactive programs (i.e. a function mapping +-- an input string to an appropriate output string). These definitions +-- are an enhancement of thos in B+W 7.8 +-- +-- skip p is an interactive program which consumes no input, produces +-- no output and then behaves like the interactive program p. +-- end is an interactive program which ignores the input and +-- produces no output. +-- writeln txt p is an interactive program which outputs the message txt +-- and then behaves like the interactive program p +-- readch act def is an interactive program which reads the first character c +-- from the input stream and behaves like the interactive +-- program act c. If the input character stream is empty, +-- readch act def prints the default string def and terminates. +-- +-- readln p g is an interactive program which prints the prompt p and +-- reads a line (upto the first carriage return, or end of +-- input) from the input stream. It then behaves like g line. +-- Backspace characters included in the input stream are +-- interpretted in the usual way. + +type Interactive = String -> String + +--- Interactive program combining forms: + +skip :: Interactive -> Interactive +skip p inn = p inn -- a dressed up identity function + +end :: Interactive +end inn = "" + +writeln :: String -> Interactive -> Interactive +writeln txt p inn = txt ++ p inn + +readch :: (Char -> Interactive) -> String -> Interactive +readch act def "" = def +readch act def (c:cs) = act c cs + +readln :: String -> (String -> Interactive) -> Interactive +readln prompt g inn = prompt ++ lineOut 0 line ++ "\n" + ++ g (noBackSpaces line) input' + where line = before '\n' inn + input' = after '\n' inn + after x = tail . dropWhile (x/=) + before x = takeWhile (x/=) + +--- Filter out backspaces etc: + +rubout :: Char -> Bool +rubout c = (c=='\DEL' || c=='\BS') + +lineOut :: Int -> String -> String +lineOut n "" = "" +lineOut n (c:cs) + | n>0 && rubout c = "\BS \BS" ++ lineOut (n-1) cs + | n==0 && rubout c = lineOut 0 cs + | otherwise = c:lineOut (n+1) cs + +noBackSpaces :: String -> String +noBackSpaces = reverse . delete 0 . reverse + where delete n "" = "" + delete n (c:cs) + | rubout c = delete (n+1) cs + | n>0 = delete (n-1) cs + | otherwise = c:delete 0 cs + +--- End of Interact.hs diff --git a/progs/demo/prolog/Interact.hu b/progs/demo/prolog/Interact.hu new file mode 100644 index 0000000..41ebb9d --- /dev/null +++ b/progs/demo/prolog/Interact.hu @@ -0,0 +1,2 @@ +Interact.hs + diff --git a/progs/demo/prolog/Main.hs b/progs/demo/prolog/Main.hs new file mode 100644 index 0000000..56d83a8 --- /dev/null +++ b/progs/demo/prolog/Main.hs @@ -0,0 +1,87 @@ +-- +-- Prolog interpreter top level module +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module Main(main) where + +import PrologData +import Parse +import Interact +import Subst +import Engine +import Version + +--- Command structure and parsing: + +data Command = Fact Clause | Query [Term] | Show | Error | Quit | NoChange + +command :: Parser Command +command = just (sptok "bye" `orelse` sptok "quit") `do` (\quit->Quit) + `orelse` + just (okay NoChange) + `orelse` + just (sptok "??") `do` (\show->Show) + `orelse` + just clause `do` Fact + `orelse` + just (sptok "?-" `seq` termlist) `do` (\(q,ts)->Query ts) + `orelse` + okay Error + +--- Main program read-solve-print loop: + +signOn :: String +signOn = "Mini Prolog Version 1.5 (" ++ version ++ ")\n\n" + +main :: Dialogue +main = --echo False abort + (appendChan stdout signOn abort + (appendChan stdout ("Reading " ++ stdlib ++ "...") abort + (readFile stdlib + (\fail -> appendChan stdout "not found\n" abort + (interpreter "")) + (\lib -> appendChan stdout "done\n" abort + (interpreter lib)) + ))) + +stdlib :: String +stdlib = "$HASKELL/progs/demo/prolog/stdlib" + +interpreter :: String -> Dialogue +interpreter lib = readChan stdin abort + (\inn -> appendChan stdout (loop startDb inn) abort done) + where startDb = foldl addClause emptyDb clauses + clauses = [r | ((r,""):_)<-map clause (lines lib)] + +loop :: Database -> String -> String +loop db = readln "> " (exec db . fst . head . command) + +exec :: Database -> Command -> String -> String +exec db (Fact r) = skip (loop (addClause db r)) +exec db (Query q) = demonstrate db q +exec db Show = writeln (show db) (loop db) +exec db Error = writeln "I don't understand\n" (loop db) +exec db Quit = writeln "Thank you and goodbye\n" end +exec db NoChange = skip (loop db) + +--- Handle printing of solutions etc... + +solution :: [Id] -> Subst -> [String] +solution vs s = [ show (Var i) ++ " = " ++ show v + | (i,v) <- [ (i,s i) | i<-vs ], v /= Var i ] + +demonstrate :: Database -> [Term] -> Interactive +demonstrate db q = printOut (map (solution vs) (prove db q)) + where vs = (nub . concat . map varsIn) q + printOut [] = writeln "no.\n" (loop db) + printOut ([]:bs) = writeln "yes.\n" (loop db) + printOut (b:bs) = writeln (doLines b) (nextReqd bs) + doLines = foldr1 (\xs ys -> xs ++ "\n" ++ ys) + nextReqd bs = writeln " " + (readch (\c->if c==';' + then writeln ";\n" (printOut bs) + else writeln "\n" (loop db)) "") + +--- End of Main.hs diff --git a/progs/demo/prolog/Main.hu b/progs/demo/prolog/Main.hu new file mode 100644 index 0000000..a936ca6 --- /dev/null +++ b/progs/demo/prolog/Main.hu @@ -0,0 +1,6 @@ +Main.hs +Parse.hu +PrologData.hu +Interact.hu +Engine.hu +Version.hu diff --git a/progs/demo/prolog/Parse.hs b/progs/demo/prolog/Parse.hs new file mode 100644 index 0000000..0487432 --- /dev/null +++ b/progs/demo/prolog/Parse.hs @@ -0,0 +1,116 @@ +-- +-- General parsing library, based on Richard Bird's parselib.orw for Orwell +-- (with a number of extensions) +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module Parse(Parser(..), fail, okay, tok, sat, orelse, seq, do, + sptok, just, listOf, many, sp, many1) where + +infixr 6 `seq` +infixl 5 `do` +infixr 4 `orelse` + +--- Type definition: + +type Parser a = [Char] -> [(a,[Char])] + +-- A parser is a function which maps an input stream of characters into +-- a list of pairs each containing a parsed value and the remainder of the +-- unused input stream. This approach allows us to use the list of +-- successes technique to detect errors (i.e. empty list ==> syntax error). +-- it also permits the use of ambiguous grammars in which there may be more +-- than one valid parse of an input string. + +--- Primitive parsers: + +-- fail is a parser which always fails. +-- okay v is a parser which always succeeds without consuming any characters +-- from the input string, with parsed value v. +-- tok w is a parser which succeeds if the input stream begins with the +-- string (token) w, returning the matching string and the following +-- input. If the input does not begin with w then the parser fails. +-- sat p is a parser which succeeds with value c if c is the first input +-- character and c satisfies the predicate p. + +fail :: Parser a +fail inn = [] + +okay :: a -> Parser a +okay v inn = [(v,inn)] + +tok :: [Char] -> Parser [Char] +tok w inn = [(w, drop n inn) | w == take n inn] + where n = length w + +sat :: (Char -> Bool) -> Parser Char +sat p [] = [] +sat p (c:inn) = [ (c,inn) | p c ] + +--- Parser combinators: + +-- p1 `orelse` p2 is a parser which returns all possible parses of the input +-- string, first using the parser p1, then using parser p2. +-- p1 `seq` p2 is a parser which returns pairs of values (v1,v2) where +-- v1 is the result of parsing the input string using p1 and +-- v2 is the result of parsing the remaining input using p2. +-- p `do` f is a parser which behaves like the parser p, but returns +-- the value f v wherever p would have returned the value v. +-- +-- just p is a parser which behaves like the parser p, but rejects any +-- parses in which the remaining input string is not blank. +-- sp p behaves like the parser p, but ignores leading spaces. +-- sptok w behaves like the parser tok w, but ignores leading spaces. +-- +-- many p returns a list of values, each parsed using the parser p. +-- many1 p parses a non-empty list of values, each parsed using p. +-- listOf p s parses a list of input values using the parser p, with +-- separators parsed using the parser s. + +orelse :: Parser a -> Parser a -> Parser a +p1 `orelse` p2 = \inn->p1 inn ++ p2 inn + +seq :: Parser a -> Parser b -> Parser (a,b) +p1 `seq` p2 = \inn->[((v1,v2),inn2) | (v1,inn1) <- p1 inn, (v2,inn2) <- p2 inn1] + +do :: Parser a -> (a -> b) -> Parser b +p `do` f = \inn->[(f v, inn1) | (v,inn1) <- p inn] + +just :: Parser a -> Parser a +just p inn = [ (v,"") | (v,inn')<- p inn, dropWhile (' '==) inn' == "" ] + +sp :: Parser a -> Parser a +sp p = p . dropWhile (' '==) + +sptok :: [Char] -> Parser [Char] +sptok = sp . tok + +many :: Parser a -> Parser [a] +many p = q + where q = ((p `seq` q) `do` makeList) `orelse` (okay []) + +many1 :: Parser a -> Parser [a] +many1 p = p `seq` many p `do` makeList + +listOf :: Parser a -> Parser b -> Parser [a] +listOf p s = p `seq` many (s `seq` p) `do` nonempty + `orelse` okay [] + where nonempty (x,xs) = x:(map snd xs) + +--- Internals: + +makeList :: (a,[a]) -> [a] +makeList (x,xs) = x:xs + +{- +-- an attempt to optimise the performance of the standard prelude function +-- `take' in Haskell B 0.99.3 gives the wrong semantics. The original +-- definition, given below works correctly and is used in the above. + +safetake :: (Integral a) => a -> [b] -> [b] +safetake _ [] = [] +safetake 0 _ = [] +safetake (n+1) (x:xs) = x : safetake n xs +-} +--- End of Parse.hs diff --git a/progs/demo/prolog/Parse.hu b/progs/demo/prolog/Parse.hu new file mode 100644 index 0000000..44cc302 --- /dev/null +++ b/progs/demo/prolog/Parse.hu @@ -0,0 +1 @@ +Parse.hs diff --git a/progs/demo/prolog/PrologData.hs b/progs/demo/prolog/PrologData.hs new file mode 100644 index 0000000..4ff3173 --- /dev/null +++ b/progs/demo/prolog/PrologData.hs @@ -0,0 +1,121 @@ +-- +-- Representation of Prolog Terms, Clauses and Databases +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module PrologData(Id(..), Atom(..), Term(..), term, termlist, varsIn, + Clause((:*)), clause, + Database, emptyDb, renClauses, addClause) where + +import Parse + +infix 6 :* + +--- Prolog Terms: + +type Id = (Int,String) +type Atom = String +data Term = Var Id | Struct Atom [Term] + deriving Eq +data Clause = Term :* [Term] +data Database = Db [(Atom,[Clause])] + +--- Determine the list of variables in a term: + +varsIn :: Term -> [Id] +varsIn (Var i) = [i] +varsIn (Struct i ts) = (nub . concat . map varsIn) ts + +renameVars :: Int -> Term -> Term +renameVars lev (Var (n,s)) = Var (lev,s) +renameVars lev (Struct s ts) = Struct s (map (renameVars lev) ts) + +--- Functions for manipulating databases (as an abstract datatype) + +emptyDb :: Database +emptyDb = Db [] + +renClauses :: Database -> Int -> Term -> [Clause] +renClauses db n (Var _) = [] +renClauses db n (Struct a _) = [ r tm:*map r tp | (tm:*tp)<-clausesFor a db ] + where r = renameVars n + +clausesFor :: Atom -> Database -> [Clause] +clausesFor a (Db rss) = case dropWhile (\(n,rs) -> n<a) rss of + [] -> [] + ((n,rs):_) -> if a==n then rs else [] + +addClause :: Database -> Clause -> Database +addClause (Db rss) r@(Struct a _ :* _) + = Db (initialPart ++ + case lastPart of + [] -> [(a,[r])] + ((n,rs):rss') -> if a==n then (n,rs++[r]):rss' + else (a,[r]):lastPart) + where (initialPart,lastPart) = span (\(n,rs) -> n<a) rss + +--- Output functions (defined as instances of Text): + +instance Text Term where + showsPrec p (Var (n,s)) + | n==0 = showString s + | otherwise = showString s . showChar '_' . shows n + showsPrec p (Struct a []) = showString a + showsPrec p (Struct a ts) = showString a . showChar '(' + . showWithSep "," ts + . showChar ')' + +instance Text Clause where + showsPrec p (t:*[]) = shows t . showChar '.' + showsPrec p (t:*gs) = shows t . showString ":-" + . showWithSep "," gs + . showChar '.' + +instance Text Database where + showsPrec p (Db []) = showString "-- Empty Database --\n" + showsPrec p (Db rss) = foldr1 (\u v-> u . showChar '\n' . v) + [ showWithTerm "\n" rs | (i,rs)<-rss ] + +--- Local functions for use in defining instances of Text: + +showWithSep :: Text a => String -> [a] -> ShowS +showWithSep s [x] = shows x +showWithSep s (x:xs) = shows x . showString s . showWithSep s xs + +showWithTerm :: Text a => String -> [a] -> ShowS +showWithTerm s xs = foldr1 (.) [shows x . showString s | x<-xs] + +--- String parsing functions for Terms and Clauses: +--- Local definitions: + +letter :: Parser Char +letter = sat (\c -> isAlpha c || isDigit c || c `elem` ":;+=-*&%$#@?/.~!") + +variable :: Parser Term +variable = sat isUpper `seq` many letter `do` makeVar + where makeVar (initial,rest) = Var (0,(initial:rest)) + +struct :: Parser Term +struct = many letter `seq` (sptok "(" `seq` termlist `seq` sptok ")" + `do` (\(o,(ts,c))->ts) + `orelse` + okay []) + `do` (\(name,terms)->Struct name terms) + +--- Exports: + +term :: Parser Term +term = sp (variable `orelse` struct) + +termlist :: Parser [Term] +termlist = listOf term (sptok ",") + +clause :: Parser Clause +clause = sp struct `seq` (sptok ":-" `seq` listOf term (sptok ",") + `do` (\(from,body)->body) + `orelse` okay []) + `seq` sptok "." + `do` (\(head,(goals,dot))->head:*goals) + +--- End of PrologData.hs diff --git a/progs/demo/prolog/PrologData.hu b/progs/demo/prolog/PrologData.hu new file mode 100644 index 0000000..362d35f --- /dev/null +++ b/progs/demo/prolog/PrologData.hu @@ -0,0 +1,2 @@ +PrologData.hs +Parse.hu diff --git a/progs/demo/prolog/README b/progs/demo/prolog/README new file mode 100644 index 0000000..73dbc1b --- /dev/null +++ b/progs/demo/prolog/README @@ -0,0 +1,3 @@ +This is a mini prolog interpreter written my Mark Jones. It +was slightly adapted from version in the hbc release. + diff --git a/progs/demo/prolog/Subst.hs b/progs/demo/prolog/Subst.hs new file mode 100644 index 0000000..f96e462 --- /dev/null +++ b/progs/demo/prolog/Subst.hs @@ -0,0 +1,65 @@ +-- +-- Substitutions and Unification of Prolog Terms +-- Mark P. Jones November 1990 +-- +-- uses Haskell B. version 0.99.3 +-- +module Subst(Subst(..), nullSubst, (>!), (@@), apply, unify) where + +import PrologData + +infixr 3 @@ +infix 4 >! + +--- Substitutions: + +type Subst = Id -> Term + +-- substitutions are represented by functions mapping identifiers to terms. +-- +-- apply s extends the substitution s to a function mapping terms to terms +-- nullSubst is the empty substitution which maps every identifier to the +-- same identifier (as a term). +-- i >! t is the substitution which maps the identifier i to the term t, +-- but otherwise behaves like nullSubst. +-- s1 @@ s2 is the composition of substitutions s1 and s2 +-- N.B. apply is a monoid homomorphism from (Subst,nullSubst,(@@)) +-- to (Term -> Term, id, (.)) in the sense that: +-- apply (s1 @@ s2) = apply s1 . apply s2 +-- s @@ nullSubst = s = nullSubst @@ s + +apply :: Subst -> Term -> Term +apply s (Var i) = s i +apply s (Struct a ts) = Struct a (map (apply s) ts) + +nullSubst :: Subst +nullSubst i = Var i + +(>!) :: Id -> Term -> Subst +(>!) i t j | j==i = t + | otherwise = Var j + +(@@) :: Subst -> Subst -> Subst +s1 @@ s2 = apply s1 . s2 + +--- Unification: + +-- unify t1 t2 returns a list containing a single substitution s which is +-- the most general unifier of terms t1 t2. If no unifier +-- exists, the list returned is empty. + +unify :: Term -> Term -> [Subst] +unify (Var x) (Var y) = if x==y then [nullSubst] else [x>!Var y] +unify (Var x) t2 = [ x >! t2 | not (x `elem` varsIn t2) ] +unify t1 (Var y) = [ y >! t1 | not (y `elem` varsIn t1) ] +unify (Struct a ts) (Struct b ss) = [ u | a==b, u<-listUnify ts ss ] + +listUnify :: [Term] -> [Term] -> [Subst] +listUnify [] [] = [nullSubst] +listUnify [] (r:rs) = [] +listUnify (t:ts) [] = [] +listUnify (t:ts) (r:rs) = [ u2 @@ u1 | u1<-unify t r, + u2<-listUnify (map (apply u1) ts) + (map (apply u1) rs) ] + +--- End of Subst.hs diff --git a/progs/demo/prolog/Subst.hu b/progs/demo/prolog/Subst.hu new file mode 100644 index 0000000..1bb92fb --- /dev/null +++ b/progs/demo/prolog/Subst.hu @@ -0,0 +1,2 @@ +Subst.hs +PrologData.hu diff --git a/progs/demo/prolog/Version.hs b/progs/demo/prolog/Version.hs new file mode 100644 index 0000000..c580f4b --- /dev/null +++ b/progs/demo/prolog/Version.hs @@ -0,0 +1 @@ +module Version where version="tree based" diff --git a/progs/demo/prolog/Version.hu b/progs/demo/prolog/Version.hu new file mode 100644 index 0000000..244a511 --- /dev/null +++ b/progs/demo/prolog/Version.hu @@ -0,0 +1 @@ +Version.hs diff --git a/progs/demo/prolog/stdlib b/progs/demo/prolog/stdlib new file mode 100644 index 0000000..76d2b8c --- /dev/null +++ b/progs/demo/prolog/stdlib @@ -0,0 +1,38 @@ +This file contains a list of predicate definitions that will automatically +be read into Mini Prolog at the beginning of a session. Each clause in this +file must be entered on a single line and lines containing syntax errors are +always ignored. This includes the first few lines of this file and provides +a simple way to include comments. + +append(nil,X,X). +append(cons(X,Y),Z,cons(X,W)):-append(Y,Z,W). + +equals(X,X). + +not(X):-X,!,false. +not(X). + +or(X,Y):-X. +or(X,Y):-Y. + +and(X,Y):-X,Y. + +reverse(nil,nil). +reverse(cons(A,X),Y):-and(reverse(X,Z),append(Z,cons(A,nil),Y)). + +palindromes(X):-and(reverse(X,Y),equals(X,Y)). + +mul2(A,B):-append(A,A,B). +mul4(A,B):-and(mul2(A,C),mul2(C,B)). +mul8(A,B):-and(mul4(A,C),mul2(C,B)). +mul16(A,B):-and(mul8(A,C),mul2(C,B)). +mul32(A,B):-and(mul16(A,C),mul2(C,B)). +mul64(A,B):-and(mul32(A,C),mul2(C,B)). +mul128(A,B):-and(mul64(A,C),mul2(C,B)). +mul256(A,B):-and(mul128(A,C),mul2(C,B)). +mul512(A,B):-and(mul256(A,C),mul2(C,B)). +mul1024(A,B):-and(mul512(A,C),mul2(C,B)). + +true. + +End of stdlib diff --git a/progs/demo/queens.hs b/progs/demo/queens.hs new file mode 100755 index 0000000..0f8de59 --- /dev/null +++ b/progs/demo/queens.hs @@ -0,0 +1,40 @@ +{- This is the n Queens problem. -} + +module Main where + +queens :: Int -> [[Int]] +queens size = queens' size size + +queens' :: Int -> Int -> [[Int]] +queens' 0 _ = [[]] +queens' (n+1) size = [q:qs | qs <- queens' n size, q <- [1..size], + not (threatens q qs)] + +threatens :: Int -> [Int] -> Bool +threatens q qs = q `elem` qs || q `elem` (diagonals 1 qs) + +diagonals :: Int -> [Int] -> [Int] +diagonals _ [] = [] +diagonals n (q:qs) = (q+n) : (q-n) : diagonals (n+1) qs + +main = appendChan stdout "Enter board size: " abort $ + readChan stdin abort $ \input -> + let line1 : ~(line2 : _) = lines input + size = read line1 + solns = read line2 + in if size == 0 then done else -- This causes the size to actually read + appendChan stdout "Number of solutions: " abort $ + appendChan stdout (concat (map (\x -> showBoard size x) + (take solns (queens size)))) + abort done + +showBoard :: Int -> [Int] -> String + +showBoard size pos = + concat (map showRow pos) ++ "\n" + where + showRow n = concat [if i == n then "Q " else ". " | i <- [1..size]] + ++ "\n" + + + diff --git a/progs/demo/quicksort.hs b/progs/demo/quicksort.hs new file mode 100644 index 0000000..30b4ab4 --- /dev/null +++ b/progs/demo/quicksort.hs @@ -0,0 +1,13 @@ +-- Quick sort for Haskell. + +module Main where + +qs :: [Int] -> [Int] +qs [] = [] +qs (a:as) = qs [x | x <- as, x <= a] ++ [a] ++ qs [x | x <- as, x > a] + +main = + appendChan stdout "Enter a list of integers separated by \",\"\n" abort $ + readChan stdin abort $ \ input -> + appendChan stdout (show (qs (read ("[" ++ (head (lines input)) ++ "]")))) + abort done diff --git a/progs/lib/README b/progs/lib/README new file mode 100644 index 0000000..910be2d --- /dev/null +++ b/progs/lib/README @@ -0,0 +1 @@ +This directory contains supported libraries for Yale Haskell. diff --git a/progs/lib/X11/README b/progs/lib/X11/README new file mode 100644 index 0000000..db748e4 --- /dev/null +++ b/progs/lib/X11/README @@ -0,0 +1,11 @@ +This directory contains the Haskell->CLX support code. + +If you see errors like "ID 42 is a :WM_RESIZE_HINTS, not a window", +you can get rid of them by loading clx-patch.lisp. This seems to be a +bug where CLX is not consistent with the protocol in some way; we've +seen it on some machines and not others. The line + +(load "$HASKELL/progs/lib/X11/clx-patch.lisp") + +can be placed in your .yhaskell file to load the patch on startup. + diff --git a/progs/lib/X11/clx-patch.lisp b/progs/lib/X11/clx-patch.lisp new file mode 100644 index 0000000..fe2a5e3 --- /dev/null +++ b/progs/lib/X11/clx-patch.lisp @@ -0,0 +1,39 @@ +(lisp:in-package 'xlib) +(defmacro generate-lookup-functions (useless-name &body types) + `(within-definition (,useless-name generate-lookup-functions) + ,@(mapcar + #'(lambda (type) + `(defun ,(xintern 'lookup- type) + (display id) + (declare (type display display) + (type resource-id id)) + (declare (values ,type)) + ,(if (member type *clx-cached-types*) + `(let ((,type (lookup-resource-id display id))) + (cond ((null ,type) ;; Not found, create and s +ave it. + (setq ,type (,(xintern 'make- type) + :display display :id id)) + (save-id display id ,type)) + ;; Found. Check the type + ,(cond ((null '()) ;*type-check?*) + `(t ,type)) + ((member type '(window pixmap)) + `((type? ,type 'drawable) ,type) +) + (t `((type? ,type ',type) ,type)) +) + ,@(when '() ;*type-check?* + `((t (x-error 'lookup-error + :id id + :display display + :type ',type + :object ,type)))))) + ;; Not being cached. Create a new one each time. + `(,(xintern 'make- type) + :display display :id id)))) + types))) +(macroexpand + (generate-lookup-functions ignore + window)) + diff --git a/progs/lib/X11/xlib.hs b/progs/lib/X11/xlib.hs new file mode 100644 index 0000000..716cc8c --- /dev/null +++ b/progs/lib/X11/xlib.hs @@ -0,0 +1,877 @@ +module Xlib(XLibTypes..,XLibPrims..) where +import XLibTypes +import XLibPrims + +module XLibTypes(XDisplay, XScreen, XWindow, XGcontext, XPixmap, + XColormap, XCursor, XFont, XImage, XMaybe(..), XError(..), + XBitmap(..), XKeysymTable(..), XBitVec(..), + XPixarray(..), XByteVec(..), XAtom(..), XProperty(..), + XPixel(..), XDrawable(..), XTime(..), XSwitch(..), + XWindowPlace(..), XEventMode(..), XEventKind(..), + XWindowVisibility(..), XWindowStackMode(..), + XPropertyState(..), XMapReqType(..), XGraphFun(..), + XEvent(..), XEventType(..), XEventSlot(..), XEventMask(..), + XEventMaskKey(..), XStateMask(..), XStateMaskKey(..), + XWinAttribute(..),XGCAttribute(..), XImAttribute(..), + XGrabAttribute(..), XArcMode(..), XCapStyle(..), + XClipMask(..), XFillRule(..), XFillStyle(..), + XFunction(..), XJoinStyle(..), XLineStyle(..), + XSubwindowMode(..), XPoint(..), XSize(..), XRect(..), + XArc(..), XBitmapFormat(..), XByteOrder(..), + XPixmapFormat(..), XVisualInfo(..), XVisualClass(..), + XFillContent(..), XBackingStore(..), XGravity(..), + XWindowClass(..), XMapState(..), XImageData(..), + XImageFormat(..), XImageType(..), XDrawDirection(..), + XColor(..), XInputFocus(..), XGrabStatus(..), + XKeysym(..), XCloseDownMode(..), XScreenSaver(..)) + where + +data XMaybe a {-# STRICT #-} = XSome a + | XNull + --deriving (Printers) + +data XDisplay = XDisplay --deriving (Printers) +data XScreen = XScreen --deriving (Printers) +data XWindow = XWindow --deriving (Printers) +data XGcontext = XGcontext --deriving (Printers) +data XPixmap = XPixmap --deriving (Printers) +data XColormap = XColormap --deriving (Printers) +data XCursor = XCursor --deriving (Printers) +data XFont = XFont --deriving (Printers) +data XImage = XImage --deriving (Printers) + +data XError {-# STRICT #-} + = XError String + --deriving Printers +data XBitmap {-# STRICT #-} + = XBitmap [[Int]] +instance Text(XBitmap) where + showsPrec p x = showString "<<XBitMap>>" + +data XKeysymTable {-# STRICT #-} + = XKeysymTable [[Integer]] +instance Text(XKeysymTable) where + showsPrec p x = showString "<<XKeysymTable>>" + +data XBitVec {-# STRICT #-} + = XBitVec [Int] +instance Text(XBitVec) where + showsPrec p x = showString "<<XBitVec>>" + +data XPixarray {-# STRICT #-} + = XPixarray [[Integer]] +instance Text(XPixarray) where + showsPrec p x = showString "<<XPixarray>>" + +data XByteVec {-# STRICT #-} + = XByteVec [Int] +instance Text(XByteVec) where + showsPrec p x = showString "<<XByteVec>>" + + +data XAtom {-# STRICT #-} + = XAtom String + --deriving (Printers) + +data XProperty {-#STRICT #-} + = XProperty [Integer] -- data + XAtom -- type + Int -- format + --deriving (Printers) + +data XPixel {-# STRICT #-} + = XPixel Integer + --deriving (Printers) + +data XDrawable {-# STRICT #-} + = XDrawWindow XWindow + | XDrawPixmap XPixmap + --deriving (Printers) + +data XTime {-# STRICT #-} + = XTime Integer + --deriving (Printers) + +data XSwitch = XOn + | XOff + --deriving (Printers) + +data XWindowPlace = XTopPlace + | XBottomPlace + --deriving (Printers) + +data XEventMode = XNormalMode + | XGrabMode + | XUngrabMode + | XWhileGrabbedMode + --deriving (Printers) + +data XEventKind = XAncestorKind + | XVirtualKind + | XInferiorKind + | XNonlinearKind + | XNonlinearVirtualKind + | XPointerKind + | XPointerRootKind + | XNoneKind + --deriving (Printers) + +data XWindowVisibility = XUnobscured + | XPartiallyObscured + | XFullyObscured + --deriving (Printers) + +data XWindowStackMode = XStackAbove + | XStackBelow + | XStackTopIf + | XStackBottomIf + | XStackOpposite + --deriving (Printers) + +data XPropertyState = XNewValueProperty + | XDeletedProperty + --deriving (Printers) + +data XMapReqType = XModifierMapping + | XKeyboardMapping + | XPointerMapping + --deriving (Printers) + +data XGraphFun {-# STRICT #-} + = XGraphFun Int -- major opcode + Int -- minor opcode + --deriving (Printers) + +data XEvent {-# STRICT #-} + = XEvent XEventType + [XEventSlot] + +data XEventType = XKeyPressEvent + | XKeyReleaseEvent + | XButtonPressEvent + | XButtonReleaseEvent + | XMotionNotifyEvent + | XEnterNotifyEvent + | XLeaveNotifyEvent + | XFocusInEvent + | XFocusOutEvent + | XKeymapNotifyEvent + | XMappingNotifyEvent + | XExposureEvent + | XGraphicsExposureEvent + | XNoExposureEvent + | XCirculateNotifyEvent + | XConfigureNotifyEvent + | XCreateNotifyEvent + | XDestroyNotifyEvent + | XGravityNotifyEvent + | XMapNotifyEvent + | XReparentNotifyEvent + | XUnmapNotifyEvent + | XVisibilityNotifyEvent + | XCirculateRequestEvent + | XColormapNotifyEvent + | XConfigureRequestEvent + | XMapRequestEvent + | XResizeRequestEvent + | XClientMessageEvent + | XPropertyNotifyEvent + | XSelectionClearEvent + | XSelectionNotifyEvent + | XSelectionRequestEvent + | XOtherEvents + --deriving Printers + +data XEventSlot {-# STRICT #-} + = XEventWindow XWindow + | XEventEventWindow XWindow + | XEventCode Int + | XEventPos XPoint + | XEventState XStateMask + | XEventTime XTime + | XEventRoot XWindow + | XEventRootPos XPoint + | XEventChild (XMaybe XWindow) + | XEventSameScreenP Bool + | XEventHintP Bool + | XEventMode XEventMode + | XEventKind XEventKind + | XEventFocusP Bool + | XEventKeymap XBitVec + | XEventRequest XMapReqType + | XEventStart Int + | XEventCount Int + | XEventRect XRect + | XEventDrawable XDrawable + | XEventXGraphFun XGraphFun + | XEventPlace XWindowPlace + | XEventBorderWidth Int + | XEventAboveSibling (XMaybe XWindow) + | XEventOverrideRedirectP Bool + | XEventParent XWindow + | XEventConfigureP Bool + | XEventVisibility XWindowVisibility + | XEventNewP Bool + | XEventInstalledP Bool + | XEventStackMode XWindowStackMode + | XEventValueMask Int + | XEventSize XSize + | XEventMessage XProperty + | XEventPropertyState XPropertyState + | XEventAtom XAtom + | XEventSelection XAtom + | XEventTarget XAtom + | XEventProperty (XMaybe XAtom) + | XEventRequestor XWindow + --deriving Printers + +data XEventMask {-# STRICT #-} + = XEventMask [XEventMaskKey] + --deriving (Printers) + +data XEventMaskKey + = XButton1Motion + | XButton2Motion + | XButton3Motion + | XButton4Motion + | XButton5Motion + | XButtonMotion + | XButtonPress + | XButtonRelease + | XColormapChange + | XEnterWindow + | XExposure + | XFocusChange + | XKeyPress + | XKeyRelease + | XKeymapState + | XLeaveWindow + | XOwnerGrabButton + | XPointerMotion + | XPointerMotionHint + | XPropertyChange + | XResizeRedirect + | XStructureNotify + | XSubstructureRedirect + | XVisibilityChange + --deriving (Printers) + +data XStateMask {-# STRICT #-} + = XStateMask [XStateMaskKey] + --deriving (Printers) + +data XStateMaskKey + = XShift + | XLock + | XControl + | XMod1 + | XMod2 + | XMod3 + | XMod4 + | XMod5 + | XButton1 + | XButton2 + | XButton3 + | XButton4 + | XButton5 + --deriving (Printers) + +data XWinAttribute {-# STRICT #-} + = XWinBackground XPixel + | XWinEventMask XEventMask + | XWinDepth Int + | XWinBorderWidth Int + | XWinClass XWindowClass + | XWinVisual Int + | XWinBorder XFillContent + | XWinBackingStore XBackingStore + | XWinBackingPlanes XPixel + | XWinBackingPixel XPixel + | XWinSaveUnder XSwitch + | XWinDoNotPropagateMask XEventMask + | XWinOverrideRedirect XSwitch + | XWinColormap XColormap + | XWinCursor XCursor + --deriving (Printers) + +data XGCAttribute {-# STRICT #-} + = XGCArcMode XArcMode + | XGCBackground XPixel + | XGCCapStyle XCapStyle + | XGCClipMask XClipMask + | XGCClipOrigin XPoint + | XGCDashOffset Int + | XGCDashes [Int] + | XGCExposures XSwitch + | XGCFillRule XFillRule + | XGCFillStyle XFillStyle + | XGCFont XFont + | XGCForeground XPixel + | XGCFunction XFunction + | XGCJoinStyle XJoinStyle + | XGCLineStyle XLineStyle + | XGCLineWidth Int + | XGCPlaneMask XPixel + | XGCStipple XPixmap + | XGCSubwindowMode XSubwindowMode + | XGCTile XPixmap + | XGCTileOrigin XPoint + --deriving (Printers) + +data XImAttribute {-# STRICT #-} + = XImBitLsbFirstP Bool + | XImBitsPerPixel Int + | XImBlueMask XPixel + | XImByteLsbFirstP Bool + | XImBytesPerLine Int + | XImData XImageData + | XImDepth Int + | XImFormat XImageFormat + | XImGreenMask XPixel + | XImSize XSize + | XImName String + | XImRedMask XPixel + | XImHotSpot XPoint + --deriving (Printers) + +data XGrabAttribute {-# STRICT #-} + = XGrabOwnerP Bool + | XGrabSyncPointerP Bool + | XGrabSyncKeyboardP Bool + | XGrabConfineTo XWindow + | XGrabCursor XCursor + --deriving (Printers) + +data XArcMode = XChord + | XPieSlice + --deriving (Printers) + +data XCapStyle = XButt + | XNotLast + | XProjecting + | XRound + --deriving (Printers) + +data XClipMask {-# STRICT #-} + = XClipMaskPixmap XPixmap + | XClipMaskRects [XRect] + | XClipMaskNone + --deriving (Printers) + +data XFillRule = XFillEvenOdd + | XFillWinding + --deriving (Printers) + +data XFillStyle = XFillOpaqueStippled + | XFillSolid + | XFillStippled + | XFillTiled + --deriving (Printers) + +data XFunction = XBoole1 + | XBoole2 + | XBooleAndC1 + | XBooleAndC2 + | XBooleAnd + | XBooleC1 + | XBooleC2 + | XBooleClr + | XBooleEqv + | XBooleIor + | XBooleNand + | XBooleNor + | XBooleOrc1 + | XBooleOrc2 + | XBooleSet + | XBooleXor + --deriving (Printers) + +data XJoinStyle = XJoinBevel + | XJoinMiter + | XJoinRound + --deriving (Printers) + +data XLineStyle = XLineSolid + | XLineDoubleDash + | XLineOnOffDash + --deriving (Printers) + +data XSubwindowMode = XClipByChildren + | XIncludeInferiors + --deriving (Printers) + +-- BASIC GEOMETRY + +data XPoint {-# STRICT #-} = XPoint Int Int -- x,y + --deriving (Printers) + +data XSize {-# STRICT #-} = XSize Int Int -- width, height + --deriving (Printers) + +data XRect {-# STRICT #-} = XRect Int Int Int Int -- x, y, width, height + --deriving (Printers) + +data XArc {-# STRICT #-} = XArc Int Int Int Int Float Float + --deriving (Printers) -- x, y, width, height, angle1, angle2 + +data XBitmapFormat {-# STRICT #-} = XBitmapFormat Int Int Bool + --deriving (Printers) -- unit, pad, lsb-first-p + +data XByteOrder = XLsbFirst + | XMsbFirst + --deriving (Printers) + +data XPixmapFormat {-# STRICT #-} = XPixmapFormat Int Int Int + --deriving (Printers) -- depth, bits-per-pixel, scanline-pad + +data XVisualInfo {-# STRICT #-} = XVisualInfo + Int -- id + XVisualClass -- class + XPixel -- red-mask + XPixel -- green-mask + XPixel -- blue-mask + Int -- bits-per-rgb + Int -- colormap-entries + --deriving (Printers) + +data XVisualClass = XDirectColor + | XGrayScale + | XPseudoColor + | XStaticColor + | XStaticGray + | XTrueColor + --deriving (Printers) + +data XFillContent {-# STRICT #-} + = XFillPixel XPixel + | XFillPixmap XPixmap + | XFillNone + | XFillParentRelative + | XFillCopy + --deriving (Printers) + +data XBackingStore = XAlwaysBackStore + | XNeverBackStore + | XBackStoreWhenMapped + | XBackStoreNotUseful + --deriving (Printers) + +data XGravity = XForget + | XStatic + | XCenter + | XEast + | XNorth + | XNorthEast + | XNorthWest + | XSouth + | XSouthEast + | XSouthWest + | XWest + --deriving (Printers) + +data XWindowClass = XInputOutput + | XInputOnly + --deriving (Printers) + +data XMapState = XUnmapped + | XUnviewable + | XViewable + --deriving (Printers) + +data XImageData {-# STRICT #-} + = XBitmapData [XBitmap] + | XPixarrayData XPixarray + | XByteVecData XByteVec + --deriving (Printers) + +data XImageFormat = XXyPixmapImage + | XZPixmapImage + | XBitmapImage + --deriving (Printers) + +data XImageType = XImageX + | XImageXy + | XImageZ + --deriving (Printers) + +data XDrawDirection = XLeftToRight + | XRightToLeft + --deriving (Printers) + +data XColor {-# STRICT #-} = XColor Float Float Float + --deriving (Printers) + +data XInputFocus {-# STRICT #-} + = XFocusWindow XWindow + | XFocusNone + | XFocusPointerRoot + | XFocusParent + --deriving (Printers) + +data XGrabStatus = XAlreadyGrabbed + | XFrozen + | XInvalidTime + | XNotViewable + | XSuccess + --deriving (Printers) + + +data XKeysym {-# STRICT #-} = XKeysym Integer + --deriving (Printers) + + +data XCloseDownMode = XDestroy + | XRetainPermanent + | XRetainTemporary + --deriving (Printers) + +data XScreenSaver {-# STRICT #-} = XScreenSaver Int Int Bool Bool + --deriving (Printers) + +{-# +ImportLispType ( + XMaybe (XSome ("not-null?", "identity", "identity"), + XNull ("null?", "'()")), + XError (XError ("cons-xerror", "x-error-string")), + XBitmap (XBitmap ("mk-bitmap", "sel-bitmap")), + XKeysymTable (XKeysymTable ("mk-keysym-table", "sel-keysym-table")), + XBitVec (XBitVec ("mk-bitvec", "sel-bitvec")), + XPixarray (XPixarray ("mk-pixarray", "sel-pixarray")), + XByteVec (XByteVec ("mk-bytevec", "sel-bytevec")), + XAtom (XAtom ("mk-atom", "sel-atom")), + XProperty (XProperty ("mk-xproperty", "sel-xproperty-data", + "sel-xproperty-type", "sel-xproperty-format")), + XDrawable (XDrawWindow ("xlib:window-p", "identity", "identity"), + XDrawPixmap ("xlib:pixmap-p", "identity", "identity")), + XSwitch ( XOn(":on"), XOff(":off")), + XWindowPlace (XTopPlace (":top"), XBottomPlace (":bottom")), + XEventMode (XNormalMode (":normal"), + XGrabMode (":grab"), + XUngrabMode (":ungrab"), + XWhileGrabbedMode (":while-grabbed")), + XEventKind (XAncestorKind (":ancestor"), + XVirtualKind (":virtual"), + XInferiorKind (":inferior"), + XNonlinearKind (":nonlinear"), + XNonlinearVirtualKind (":nonlinear-virtual"), + XPointerKind (":pointer"), + XPointerRootKind (":pointer-root"), + XNoneKind (":none")), + XWindowVisibility (XUnobscured (":unobscured"), + XPartiallyObscured (":partially-obscured"), + XFullyObscured (":fully-obscured")), + XWindowStackMode (XStackAbove (":above"), + XStackBelow (":below"), + XStackTopIf (":top-if"), + XStackBottomIf (":bottom-if"), + XStackOpposite (":opposite")), + XPropertyState (XNewValueProperty (":new-value"), + XDeletedProperty (":deleted")), + XMapReqType (XModifierMapping (":modifier"), + XKeyboardMapping (":keyboard"), + XPointerMapping (":pointer")), + XGraphFun (XGraphFun ("cons", "car", "cdr")), + XEvent (XEvent ("mk-event", "sel-event-type", "sel-event-slots")), + XEventType (XKeyPressEvent (":key-press"), + XKeyReleaseEvent (":key-release"), + XButtonPressEvent (":button-press"), + XButtonReleaseEvent (":button-release"), + XMotionNotifyEvent (":motion-notify"), + XEnterNotifyEvent (":enter-notify"), + XLeaveNotifyEvent (":leave-notify"), + XFocusInEvent (":focus-in"), + XFocusOutEvent (":focus-out"), + XKeymapNotifyEvent (":keymap-notify"), + XMappingNotifyEvent (":mapping-notify"), + XExposureEvent (":exposure"), + XGraphicsExposureEvent (":graphics-exposure"), + XNoExposureEvent (":no-exposure"), + XCirculateNotifyEvent (":circulate-notify"), + XConfigureNotifyEvent (":configure-notify"), + XCreateNotifyEvent (":create-notify"), + XDestroyNotifyEvent (":destroy-notify"), + XGravityNotifyEvent (":gravity-notify"), + XMapNotifyEvent (":map-notify"), + XReparentNotifyEvent (":reparent-notify"), + XUnmapNotifyEvent (":unmap-notify"), + XVisibilityNotifyEvent (":visibility-notify"), + XCirculateRequestEvent (":circulate-notify"), + XColormapNotifyEvent (":colormap-notify"), + XConfigureRequestEvent (":configure-request"), + XMapRequestEvent (":map-request"), + XResizeRequestEvent (":resize-request"), + XClientMessageEvent (":client-message"), + XPropertyNotifyEvent (":property-notify"), + XSelectionClearEvent (":selection-clear"), + XSelectionNotifyEvent (":selection-notify"), + XSelectionRequestEvent (":selection-request"), + XOtherEvents (":others")), + XEventSlot (XEventWindow ("is-window", "mk-window", "keyword-val"), + XEventEventWindow + ("is-event-window", "mk-event-window", "keyword-val"), + XEventCode ("is-code", "mk-code", "keyword-val"), + XEventPos ("is-pos", "mk-pos", "keyword-val"), + XEventState ("is-state", "mk-state", "keyword-val"), + XEventTime ("is-time", "mk-time", "keyword-val"), + XEventRoot ("is-root", "mk-root", "keyword-val"), + XEventRootPos ("is-root-pos", "mk-root-pos", "keyword-val"), + XEventChild ("is-child", "mk-child", "keyword-val"), + XEventSameScreenP + ("is-same-screen-p", "mk-same-screen-p", "keyword-val"), + XEventHintP ("is-hint-p", "mk-hint-p", "keyword-val"), + XEventMode ("is-mode", "mk-mode", "keyword-val"), + XEventKind ("is-kind", "mk-kind", "keyword-val"), + XEventFocusP ("is-focus-p", "mk-focus-p", "keyword-val"), + XEventKeymap ("is-keymap", "mk-keymap", "keyword-val"), + XEventRequest ("is-request", "mk-request", "keyword-val"), + XEventStart ("is-start", "mk-start", "keyword-val"), + XEventCount ("is-count", "mk-count", "keyword-val"), + XEventRect ("is-rect", "mk-rect", "keyword-val"), + XEventDrawable ("is-drawable", "mk-drawable", "keyword-val"), + XEventXGraphFun ("is-graph-fun", "mk-graph-fun", "keyword-val"), + XEventPlace ("is-place", "mk-place", "keyword-val"), + XEventBorderWidth + ("is-border-width", "mk-border-width", "keyword-val"), + XEventAboveSibling + ("is-above-sibling", "mk-above-sibling", "keyword-val"), + XEventOverrideRedirectP + ("is-override-redirect-p", "mk-override-redirect-p", "keyword-val"), + XEventParent ("is-parent", "mk-parent", "keyword-val"), + XEventConfigureP ("is-configure-p", "mk-configure-p", "keyword-val"), + XEventVisibility ("is-visibility", "mk-visibility", "keyword-val"), + XEventNewP ("is-new-p", "mk-new-p", "keyword-val"), + XEventInstalledP ("is-installed-p", "mk-installed-p", "keyword-val"), + XEventStackMode ("is-stack-mode", "mk-stack-mode", "keyword-val"), + XEventValueMask ("is-value-mask", "mk-value-mask", "keyword-val"), + XEventSize ("is-size", "mk-size", "keyword-val"), + XEventMessage ("is-message", "mk-message", "keyword-val"), + XEventPropertyState + ("is-property-state", "mk-property-state", "keyword-val"), + XEventAtom ("is-atom", "mk-atom", "keyword-val"), + XEventSelection ("is-selection", "mk-selection", "keyword-val"), + XEventTarget ("is-target", "mk-target", "keyword-val"), + XEventProperty ("is-property", "mk-property", "keyword-val"), + XEventRequestor ("is-requestor", "mk-requestor", "keyword-val")), + XEventMask (XEventMask ("x-make-event-mask", "x-event-mask-key-list")), + XEventMaskKey (XButton1Motion (":button-1-motion"), + XButton2Motion (":button-2-motion"), + XButton3Motion (":button-3-motion"), + XButton4Motion (":button-4-motion"), + XButton5Motion (":button-5-motion"), + XButtonMotion (":button-motion"), + XButtonPress (":button-press"), + XButtonRelease (":button-release"), + XColormapChange (":colormap-change"), + XEnterWindow (":enter-window"), + XExposure (":exposure"), + XFocusChange (":focus-change"), + XKeyPress (":key-press"), + XKeyRelease (":key-release"), + XKeymapState (":keymap-state"), + XLeaveWindow (":leave-window"), + XOwnerGrabButton (":owner-grab-button"), + XPointerMotion (":pointer-motion"), + XPointerMotionHint (":pointer-motion-hint"), + XPropertyChange (":property-change"), + XResizeRedirect (":resize-redirect"), + XStructureNotify (":structure-notify"), + XSubstructureRedirect (":substructure-notify"), + XVisibilityChange (":visibility-change")), + XStateMask (XStateMask ("x-make-state-mask", "x-state-mask-key-list")), + XStateMaskKey (XShift (":shift"), + XLock (":lock"), + XControl (":control"), + XMod1 (":mod-1"), + XMod2 (":mod-2"), + XMod3 (":mod-3"), + XMod4 (":mod-4"), + XMod5 (":mod-5"), + XButton1 (":button-1"), + XButton2 (":button-2"), + XButton3 (":button-3"), + XButton4 (":button-4"), + XButton5 (":button-5")), + XWinAttribute + (XWinBackground ("is-background","mk-background","keyword-val"), + XWinEventMask ("is-event-mask","mk-event-mask","keyword-val"), + XWinDepth ("is-depth","mk-depth","keyword-val"), + XWinBorderWidth ("is-border-width","mk-border-width","keyword-val"), + XWinClass ("is-class","mk-class","keyword-val"), + XWinVisual ("is-visual","mk-visual","keyword-val"), + XWinBorder ("is-border","mk-border","keyword-val"), + XWinBackingStore ("is-backing-store","mk-backing-store","keyword-val"), + XWinBackingPlanes ("is-backing-planes","mk-backing-planes","keyword-val"), + XWinBackingPixel ("is-backing-pixel","mk-backing-pixel","keyword-val"), + XWinSaveUnder ("is-save-under","mk-save-under","keyword-val"), + XWinDoNotPropagateMask ("is-do-not-propagate-mask", + "mk-do-not-propagate-mask","keyword-val"), + XWinOverrideRedirect("is-override-redirect", + "mk-override-redirect","keyword-val"), + XWinColormap ("is-colormap","mk-colormap","keyword-val"), + XWinCursor ("is-cursor","mk-cursor","keyword-val")), + XGCAttribute( + XGCArcMode ("is-arc-mode","mk-arc-mode","keyword-val"), + XGCBackground ("is-background","mk-background","keyword-val"), + XGCCapStyle ("is-cap-style","mk-cap-style","keyword-val"), + XGCClipMask ("is-clip-mask","mk-clip-mask","keyword-val"), + XGCClipOrigin ("is-clip-origin","mk-clip-origin","keyword-val"), + XGCDashOffset ("is-dash-offset","mk-dash-offset","keyword-val"), + XGCDashes ("is-dashes","mk-dashes","keyword-val"), + XGCExposures ("is-exposures","mk-exposures","keyword-val"), + XGCFillRule ("is-fill-rule","mk-fill-rule","keyword-val"), + XGCFillStyle ("is-fill-style","mk-fill-style","keyword-val"), + XGCFont ("is-font","mk-font","keyword-val"), + XGCForeground ("is-foreground","mk-foreground","keyword-val"), + XGCFunction ("is-function","mk-function","keyword-val"), + XGCJoinStyle ("is-join-style","mk-join-style","keyword-val"), + XGCLineStyle ("is-line-style","mk-line-style","keyword-val"), + XGCLineWidth ("is-line-width","mk-line-width","keyword-val"), + XGCPlaneMask ("is-plane-mask","mk-plane-mask","keyword-val"), + XGCStipple ("is-stipple","mk-stipple","keyword-val"), + XGCSubwindowMode ("is-subwindow-mode","mk-subwindow-mode","keyword-val"), + XGCTile ("is-tile","mk-tile","keyword-val"), + XGCTileOrigin ("is-tile-origin","mk-tile-origin","keyword-val")), + XImAttribute ( + XImBitLsbFirstP ("is-bit-lsb-first-p","mk-bit-lsb-first-p","keyword-val"), + XImBitsPerPixel ("is-bits-per-pixel","mk-bits-per-pixel","keyword-val"), + XImBlueMask ("is-blue-mask","mk-blue-mask","keyword-val"), + XImByteLsbFirstP ("is-byte-lsb-first-p","mk-byte-lsb-first-p","keyword-val"), + XImBytesPerLine ("is-bytes-per-line","mk-bytes-per-line","keyword-val"), + XImData ("is-data","mk-data","keyword-val"), + XImDepth ("is-depth","mk-depth","keyword-val"), + XImFormat ("is-format","mk-format","keyword-val"), + XImGreenMask ("is-green-mask","mk-green-mask","keyword-val"), + XImSize ("is-size","mk-size","keyword-val"), + XImName ("is-name","mk-name","keyword-val"), + XImRedMask ("is-red-mask","mk-red-mask","keyword-val"), + XImHotSpot ("is-hot-spot","mk-hot-spot","keyword-val")), + XGrabAttribute ( + XGrabOwnerP ("is-owner-p", "mk-owner-p", "keyword-val"), + XGrabSyncPointerP ("is-sync-pointer-p", "mk-sync-pointer-p", "keyword-val"), + XGrabSyncKeyboardP ("is-sync-keyboard-p", "mk-sync-keyboard-p", "keyword-val"), + XGrabConfineTo ("is-confine-to", "mk-confine-to", "keyword-val"), + XGrabCursor ("is-cursor", "mk-cursor", "keyword-val")), + XArcMode (XChord (":chord"), + XPieSlice (":pie-slice")), + XCapStyle (XButt (":butt"), + XNotLast (":not-last"), + XProjecting (":projecting"), + XRound (":round")), + XClipMask (XClipMaskPixmap ("xlib:pixmap-p","identity","identity"), + XClipMaskRects ("not-pixmap-and-list-p","mk-clip-mask-rects", + "sel-clip-mask-rects"), + XClipMaskNone ("null?", "()")), + XFillRule (XFillEvenOdd (":even-odd"), + XFillWinding (":winding")), + XFillStyle (XFillOpaqueStippled (":opaque-stippled"), + XFillSolid (":solid"), + XFillStippled (":stippled"), + XFillTiled (":tiled")), + XFunction (XBoole1 ("xlib::boole-1"), + XBoole2 ("xlib::boole-2"), + XBooleAndC1 ("xlib::boole-andc1"), + XBooleAndC2 ("xlib::boole-andc2"), + XBooleAnd ("xlib::boole-and"), + XBooleC1 ("xlib::boole-c1"), + XBooleC2 ("xlib::boole-c2"), + XBooleClr ("xlib::boole-clr"), + XBooleEqv ("xlib::boole-eqv"), + XBooleIor ("xlib::boole-ior"), + XBooleNand ("xlib::boole-nand"), + XBooleNor ("xlib::boole-nor"), + XBooleOrc1 ("xlib::boole-orc1"), + XBooleOrc2 ("xlib::boole-orc2"), + XBooleSet ("xlib::boole-set"), + XBooleXor ("xlib::boole-xor")), + XJoinStyle (XJoinBevel (":bevel"), + XJoinMiter (":miter"), + XJoinRound (":round")), + XLineStyle (XLineSolid (":solid"), + XLineDoubleDash (":double-dash"), + XLineOnOffDash (":on-off-dash")), + XSubwindowMode (XClipByChildren (":clip-by-children"), + XIncludeInferiors (":include-inferiors")), + XPoint(XPoint("mk-xpoint", "xpoint-x", "xpoint-y")), + XSize (XSize ("mk-xsize", "xsize-w", "xsize-h")), + XRect (XRect ("mk-xrect", "xrect-x", "xrect-y", "xrect-w", "xrect-h")), + XArc (XArc ("mk-xarc", "xarc-x", "xarc-y", "xarc-w", "xarc-h", + "xarc-a1", "xarc-a2")), + XBitmapFormat + (XBitmapFormat ("bitmap-format-p", "mk-bitmap-format", + "xlib:bitmap-format-unit", + "xlib:bitmap-format-pad", + "xlib:bitmap-format-lsb-first-p")), + XByteOrder (XLsbFirst (":lsbfirst"), + XMsbFirst (":msbfirst")), + XPixmapFormat (XPixmapFormat ("pixmap-format-p", "mk-pixmap-format", + "xlib:pixmap-format-depth", + "xlib:pixmap-format-bits-per-pixel", + "xlib:pixmap-format-scanline-pad")), + XVisualInfo + (XVisualInfo ( "visual-info-p", "mk-xvisual-info", + "xlib:visual-info-id", + "xlib:visual-info-class", + "xlib:visual-info-red-mask", + "xlib:visual-info-green-mask", + "xlib:visual-info-blue-mask", + "xlib:visual-info-bits-per-rgb", + "xlib:visual-info-colormap-entries")), + XVisualClass (XDirectColor (":direct-color"), + XGrayScale (":gray-scale"), + XPseudoColor (":pseudo-color"), + XStaticColor (":static-color"), + XStaticGray (":static-gray"), + XTrueColor (":true-color")), + XFillContent (XFillPixel ("is-fill-pixel", "identity","identity"), + XFillPixmap ("xlib:pixmap-p", "identity","identity"), + XFillNone (":none"), + XFillParentRelative (":parent-relative"), + XFillCopy (":copy")), + XBackingStore (XAlwaysBackStore (":always"), + XNeverBackStore (":never"), + XBackStoreWhenMapped (":when-mapped"), + XBackStoreNotUseful (":not-useful")), + XGravity (XForget (":forget"), + XStatic (":static"), + XCenter (":center"), + XEast (":east"), + XNorth (":north"), + XNorthEast (":north-east"), + XNorthWest (":north-west"), + XSouth (":south"), + XSouthEast (":south-east"), + XSouthWest (":south-west"), + XWest ("west")), + XWindowClass (XInputOutput (":input-output"), + XInputOnly (":input-only")), + XMapState (XUnmapped (":unmapped"), + XUnviewable (":unviewable"), + XViewable (":viewable")), + XImageData (XBitmapData ("bitmap-list-p", "haskell-list->list/identity", "list->haskell-list/identity"), + XPixarrayData ("pixarray-p", "identity", "identity"), + XByteVecData ("bytevec-p", "identity", "identity")), + XImageFormat (XXyPixmapImage (":xy-pixmap"), + XZPixmapImage (":z-pixmap"), + XBitmapImage (":bitmap")), + XImageType (XImageX ("'xlib:image-x"), + XImageXy ("'xlib:image-xy"), + XImageZ ("'xlib:image-z")), + XDrawDirection (XLeftToRight (":left-to-right"), + XRightToLeft (":right-to-left")), + XColor (XColor ("xlib:color-p", "mk-color", + "xlib:color-red", "xlib:color-green", "xlib:color-blue")), + XInputFocus (XFocusWindow ("xlib:window-p", "identity", "identity"), + XFocusNone (":none"), + XFocusPointerRoot (":pointer-root"), + XFocusParent (":parent")), + XGrabStatus (XAlreadyGrabbed (":already-grabbed"), + XFrozen (":frozen"), + XInvalidTime (":invalid-time"), + XSuccess (":success")), + XCloseDownMode (XDestroy (":destroy"), + XRetainPermanent (":retain-permanent"), + XRetainTemporary (":retain-temporary")), + XScreenSaver (XScreenSaver ("list", "car", "cadr", "caddr", "cadddr"))) + +#-} + diff --git a/progs/lib/X11/xlib.hu b/progs/lib/X11/xlib.hu new file mode 100644 index 0000000..b86b2ac --- /dev/null +++ b/progs/lib/X11/xlib.hu @@ -0,0 +1,5 @@ +:output $LIBRARYBIN/ +:stable +:o= all +xlib.hs +xlibprims.hu diff --git a/progs/lib/X11/xlibclx.scm b/progs/lib/X11/xlibclx.scm new file mode 100644 index 0000000..1f1fd6a --- /dev/null +++ b/progs/lib/X11/xlibclx.scm @@ -0,0 +1,1262 @@ +;;; xlibclx.scm -- Lisp support for Haskell/CLX interface + +;; general + +(define-syntax (nth-value n form) + (cond ((eqv? n 0) + `(values ,form)) + ((number? n) + (let ((temps '())) + (dotimes (i n) + (declare (ignorable i)) + (push (gensym) temps)) + `(multiple-value-bind ,(reverse temps) ,form + (declare (ignore ,@(reverse (cdr temps)))) + ,(car temps)))) + (else + `(lisp:nth ,n (lisp:multiple-value-list ,form))) + )) + + +(define-local-syntax (keywordify string) + `(lisp:intern ,string (lisp:find-package "KEYWORD"))) + +(define-local-syntax (xlibify string) + `(lisp:intern ,string (lisp:find-package "XLIB"))) + + + +;;; This is stuff to support slots that consist of a keyword/value +;;; pair. Note that the value is always unboxed. + +(define-syntax (make-keyword key value) + `(cons ,key ,value)) + +(define-syntax (is-keyword? x key) + `(eq? (car ,x) ,key)) + +(define-syntax (keyword-key x) `(car ,x)) +(define-syntax (keyword-val x) `(cdr ,x)) + +(define-syntax (define-keyword-constructor name) + (let* ((name-str (symbol->string name)) + (key (keywordify name-str)) + (is-name (string->symbol (string-append "IS-" name-str))) + (mk-name (string->symbol (string-append "MK-" name-str)))) + `(begin + (define (,mk-name x) (make-keyword ,key x)) + (define (,is-name x) (is-keyword? x ,key))) + )) + +(define-syntax (define-event-slot-finder slot) + (let* ((slot-str (symbol->string slot)) + (slot-key (keywordify slot-str)) + (fun (string->symbol (string-append "X-EVENT-" slot-str)))) + `(define (,fun event) (lookup-event-slot (cdr event) ,slot-key)))) + +(define (lookup-event-slot event key) + (if (null? event) + (error "non-existent event slot: ~A" key) + (if (eq? key (car event)) + (cadr event) + (lookup-event-slot (cddr event) key)))) + + +(define-syntax (define-attribute-setter entity attribute) + (let* ((entity-attr (string-append (symbol->string entity) + "-" + (symbol->string attribute))) + (fun-name (string->symbol (string-append "X-SET-" entity-attr))) + (xfun-name (xlibify entity-attr))) + `(define (,fun-name ,entity ,attribute) + (setf (,xfun-name ,entity) ,attribute)))) + +(define-syntax (make-h-tuple . args) + (let ((nargs (map (lambda (arg) `(box ,arg)) args))) + `(make-tuple ,@nargs))) + +;; type XError + +(define (cons-xerror x) + (declare (ignore x)) + (error "can't construct XError")) + +(define (x-error-string c) + (make-haskell-string (format '#f "~A" c))) + + +;;; The forces here are necessary because the thing being funcalled +;;; returns a data structure of type (IO a), and we need to do +;;; an IO a -> a transformation. + +#+lucid +(define (x-handle-error handler body) + (lisp:catch 'x-error-handle + (lcl:handler-bind ((lisp:error (mk-handler handler))) + (force (funcall body (box 'state)))))) + +#+(or cmu allegro lispworks) +(define (x-handle-error handler body) + (lisp:catch 'x-error-handle + (lisp:handler-bind ((lisp:error (mk-handler handler))) + (force (funcall body (box 'state)))))) + +#+akcl +(define (x-handle-error handler body) + (error "AKCL does not support HANDLER-BIND!")) + +(define (mk-handler handler) + (lambda (c) + (lisp:throw 'x-error-handle + (force (funcall handler + (box c) + (box 'state)))))) + +;; for type XMaybe + +(define (not-null? x) (not (null? x))) + + +;; For Bitmap, Pixarray, KeysymTable + +(define (array2->haskell-list a) + (let* ((dims (lisp:array-dimensions a)) + (i1max (car dims)) + (i2max (cadr dims))) + (declare (type fixnum i1max i2max)) + (do ((i1 (the fixnum (1- i1max)) (the fixnum (1- i1))) + (outer '())) + ((< i1 0) outer) + (declare (type fixnum i1)) + (setf outer + (cons + (box + (do ((i2 (the fixnum (1- i2max)) (the fixnum (1- i2))) + (inner '())) + ((< i2 0) inner) + (declare (type fixnum i2)) + (setf inner + (cons (box (lisp:aref a i1 i2)) + (box inner))))) + (box outer)))) + )) + + +;; Bitmap + +(define (mk-bitmap ll) + (let ((l (haskell-list->list #'haskell-list->list/identity ll))) + (lisp:make-array `(,(length l) , (length (car l))) + :element-type 'lisp:bit + :initial-contents l))) + +(define (sel-bitmap l) + (array2->haskell-list l)) + + +;; XKeysymTable + +(define (mk-keysym-table ll) + (let ((l (haskell-list->list #'haskell-list->list/identity ll))) + (lisp:make-array `(,(length l) , (length (car l))) + :element-type 'xlib:card32 + :initial-contents l))) + +(define (sel-keysym-table l) + (array2->haskell-list l)) + +;; XPixarray + +(define (mk-pixarray ll) + (let ((l (haskell-list->list #'haskell-list->list/identity ll))) + (let* ((max-num (find-max l)) + (pix-type (cond ((<= max-num 1) 'lisp:bit) + ((<= max-num 15) '(lisp:unsigned-byte 4)) + ((<= max-num 255) 'xlib:card8) + ((<= max-num 65535) 'xlib:card16) + (else 'xlib:card32)))) + (declare (type integer max-num)) + (lisp:make-array `(,(length l) , (length (car l))) + :element-type pix-type + :initial-contents l)))) + +(define (find-max l) + (let ((max 0)) + (dolist (ll l) + (dolist (lll ll) + (when (> (the integer lll) (the integer max)) + (setf max lll)))) + max)) + +(define (sel-pixarray l) + (array2->haskell-list l)) + + + + +;;; Can't use mumble vector primitives on arrays of specialized types! + +(define (array1->haskell-list a) + (declare (type lisp:vector a)) + (let ((imax (lisp:length a))) + (declare (type fixnum imax)) + (do ((i (the fixnum (1- imax)) (the fixnum (1- i))) + (result '())) + ((< i 0) result) + (declare (type fixnum i)) + (setf result + (cons (box (lisp:aref a i)) + (box result)))))) + +;; BitVec + +(define (mk-bitvec ll) + (let ((l (haskell-list->list/identity ll))) + (lisp:make-array `(,(length l)) :element-type 'lisp:bit + :initial-contents l))) + +(define (sel-bitvec l) + (array1->haskell-list l)) + +;; ByteVec + +(define (mk-bytevec ll) + (let ((l (haskell-list->list/identity ll))) + (lisp:make-array `(,(length l)) :element-type 'xlib:card8 + :initial-contents l))) + +(define (sel-bytevec l) + (array1->haskell-list l)) + + +;; XAtom +(define (mk-atom name) + (keywordify (haskell-string->string name))) + +(define (sel-atom atom) + (make-haskell-string (symbol->string atom))) + +;; XProperty +;;; watch out for name conflict with :property keyword stuff +(define (mk-xproperty d ty f) (list (haskell-list->list/identity d) ty f)) +(define (sel-xproperty-data p) (list->haskell-list/identity (car p))) +(define (sel-xproperty-type p) (cadr p)) +(define (sel-xproperty-format p) (caddr p)) + +(define (mk-event type slots) + (cons type (slots->keywords (haskell-list->list/identity slots)))) + +(define (sel-event-type event) (car event)) + +(define (sel-event-slots event) + (list->haskell-list/identity (keywords->slots (car event) (cdr event) event))) + +;; XEventSlot + +(define-keyword-constructor window) +(define-keyword-constructor event-window) +(define-keyword-constructor code) +(define-keyword-constructor pos) +(define-keyword-constructor state) +(define-keyword-constructor time) +(define-keyword-constructor root) +(define-keyword-constructor root-pos) +(define-keyword-constructor child) +(define-keyword-constructor same-screen-p) +(define-keyword-constructor hint-p) +(define-keyword-constructor mode) +(define-keyword-constructor kind) +(define-keyword-constructor focus-p) +(define-keyword-constructor keymap) +(define-keyword-constructor request) +(define-keyword-constructor start) +(define-keyword-constructor count) +(define-keyword-constructor rect) +(define-keyword-constructor drawable) +(define-keyword-constructor graph-fun) +(define-keyword-constructor place) +(define-keyword-constructor border-width) +(define-keyword-constructor above-sibling) +(define-keyword-constructor override-redirect-p) +(define-keyword-constructor parent) +(define-keyword-constructor configure-p) +(define-keyword-constructor visibility) +(define-keyword-constructor new-p) +(define-keyword-constructor installed-p) +(define-keyword-constructor stack-mode) +(define-keyword-constructor value-mask) +(define-keyword-constructor size) +(define-keyword-constructor message) +(define-keyword-constructor property-state) +(define-keyword-constructor atom) +(define-keyword-constructor selection) +(define-keyword-constructor target) +(define-keyword-constructor property) +(define-keyword-constructor requestor) + +(define-event-slot-finder window) +(define-event-slot-finder event-window) +(define-event-slot-finder code) +(define-event-slot-finder x) +(define-event-slot-finder y) +(define-event-slot-finder state) +(define-event-slot-finder time) +(define-event-slot-finder root) +(define-event-slot-finder root-x) +(define-event-slot-finder root-y) +(define-event-slot-finder child) +(define-event-slot-finder same-screen-p) +(define-event-slot-finder hint-p) +(define-event-slot-finder mode) +(define-event-slot-finder kind) +(define-event-slot-finder focus-p) +(define-event-slot-finder keymap) +(define-event-slot-finder request) +(define-event-slot-finder start) +(define-event-slot-finder count) +(define-event-slot-finder width) +(define-event-slot-finder height) +(define-event-slot-finder drawable) +(define-event-slot-finder major) +(define-event-slot-finder minor) +(define-event-slot-finder place) +(define-event-slot-finder border-width) +(define-event-slot-finder above-sibling) +(define-event-slot-finder override-redirect-p) +(define-event-slot-finder parent) +(define-event-slot-finder configure-p) +(define-event-slot-finder new-p) +(define-event-slot-finder installed-p) +(define-event-slot-finder stack-mode) +(define-event-slot-finder value-mask) +(define-event-slot-finder data) +(define-event-slot-finder type) +(define-event-slot-finder format) +(define-event-slot-finder atom) +(define-event-slot-finder selection) +(define-event-slot-finder target) +(define-event-slot-finder property) +(define-event-slot-finder requestor) + +(define (x-event-pos event) (mk-xpoint (x-event-x event) (x-event-y event))) + +(define (x-event-root-pos event) + (mk-xpoint (x-event-root-x event) (x-event-root-y event))) + +(define (x-event-size event) + (mk-xsize (x-event-width event) (x-event-height event))) + +(define (x-event-rect event) + (mk-xrect (x-event-x event) (x-event-y event) + (x-event-width event) (x-event-height event))) + +(define (x-event-graph-fun event) + (cons (x-event-major event) (x-event-minor event))) + +(define (x-event-message event) + (list (sequence->list (x-event-data event)) + (x-event-type event) + (x-event-format event))) + + +;; XEventMask + +(define (x-make-event-mask keys) + (apply (function xlib:make-event-mask) (haskell-list->list/identity keys))) + +(define (x-event-mask-key-list mask) + (list->haskell-list/identity (xlib:make-event-keys mask))) + +;; XStateMask + +(define (x-make-state-mask keys) + (apply (function xlib:make-state-mask) (haskell-list->list/identity keys))) + +(define (x-state-mask-key-list mask) + (list->haskell-list/identity (xlib:make-state-keys mask))) + + +(define-keyword-constructor background) +(define-keyword-constructor foreground) +(define-keyword-constructor event-mask) +(define-keyword-constructor depth) +(define-keyword-constructor border-width) +(define-keyword-constructor class) +(define-keyword-constructor visual) +(define-keyword-constructor border) +(define-keyword-constructor backing-store) +(define-keyword-constructor backing-planes) +(define-keyword-constructor backing-pixel) +(define-keyword-constructor save-under) +(define-keyword-constructor do-not-propagate-mask) +(define-keyword-constructor override-redirect) +(define-keyword-constructor colormap) +(define-keyword-constructor cursor) + +(define-keyword-constructor arc-mode) +(define-keyword-constructor cap-style) +(define-keyword-constructor clip-mask) +(define-keyword-constructor clip-origin) +(define-keyword-constructor dash-offset) +(define-keyword-constructor dashes) +(define-keyword-constructor exposures) +(define-keyword-constructor fill-rule) +(define-keyword-constructor fill-style) +(define-keyword-constructor font) +(define-keyword-constructor function) +(define-keyword-constructor join-style) +(define-keyword-constructor line-style) +(define-keyword-constructor line-width) +(define-keyword-constructor plane-mask) +(define-keyword-constructor stipple) +(define-keyword-constructor subwindow-mode) +(define-keyword-constructor tile) +(define-keyword-constructor tile-origin) + +(define-keyword-constructor bit-lsb-first-p) +(define-keyword-constructor bits-per-pixel) +(define-keyword-constructor blue-mask) +(define-keyword-constructor byte-lsb-first-p) +(define-keyword-constructor bytes-per-line) +(define-keyword-constructor data) +(define-keyword-constructor format) +(define-keyword-constructor green-mask) +(define-keyword-constructor size) +(define-keyword-constructor name) +(define-keyword-constructor red-mask) +(define-keyword-constructor hot-spot) + + +(define-keyword-constructor owner-p) +(define-keyword-constructor sync-pointer-p) +(define-keyword-constructor sync-keyboard-p) +(define-keyword-constructor confine-to) + + +;; XClipMask + +(define (not-pixmap-and-list-p x) + (and (pair? x) (not (xlib:pixmap-p x)))) +(define (mk-clip-mask-rects rects) + (rects->point-seq (haskell-list->list/identity rects))) +(define (sel-clip-mask-rects point-seq) + (list->haskell-list/identity (point-seq->rects point-seq))) + +;; XPoint + +(define (mk-xpoint x y) (cons x y)) +(define (xpoint-x x) (car x)) +(define (xpoint-y x) (cdr x)) + +;; XSize + +(define (mk-xsize x y) (cons x y)) +(define (xsize-w x) (car x)) +(define (xsize-h x) (cdr x)) + +;; XRect +(define (mk-xrect x y w h) (vector x y w h)) +(define (xrect-x x) (vector-ref x 0)) +(define (xrect-y x) (vector-ref x 1)) +(define (xrect-w x) (vector-ref x 2)) +(define (xrect-h x) (vector-ref x 3)) + +;; XArc + +(define (mk-xarc x y w h a1 a2) (vector x y w h a1 a2)) + +(define (xarc-x x) (vector-ref x 0)) +(define (xarc-y x) (vector-ref x 1)) +(define (xarc-w x) (vector-ref x 2)) +(define (xarc-h x) (vector-ref x 3)) +(define (xarc-a1 x) (vector-ref x 4)) +(define (xarc-a2 x) (vector-ref x 5)) + +;; BitmapFormat + +(define (mk-bitmap-format u p l) + (xlib::make-bitmap-format :unit u :pad p :lsb-first-p l)) + +;; PixmapFormat + +(define (mk-pixmap-format u p l) + (xlib::make-pixmap-format :depth u :bits-per-pixel p :scanline-pad l)) + +;; XVisualInfo + +(define (mk-xvisual-info id cl rm gm bm bs es) + (xlib::make-visual-info :id id :class cl :red-mask rm :green-mask gm + :blue-mask bm :bits-per-rgb bs :colormap-entries es)) + +;; XFillContent + +(define (is-fill-pixel x) (not (or (xlib:pixmap-p x) (symbol? x)))) + +;; XBackingStore + +;; XImageData + +(define (bitmap-list-p x) (pair? x)) +(define (pixarray-p x) (and (not (pair? x)) (eq? (lisp:array-rank x) 2))) +(define (bytevec-p x) (and (not (pair? x)) (eq? (lisp:array-rank x) 1))) + +;; XColor +(define (mk-color r g b) + (xlib:make-color :red r :green g :blue b)) + + +(define (x-print x) + (print x)) + +(define (x-set-event-mask-key mask key-sym) + (lisp:logior mask (xlib:make-event-mask key-sym))) + +(define (x-clear-event-mask-key mask key-sym) + (lisp:logand mask (lisp:lognot (xlib:make-event-mask key-sym)))) + + +(define (x-test-event-mask-key mask key-sym) + (if (eqv? 0 (lisp:logand mask (xlib:make-event-mask key-sym))) '#f '#t)) + +(define (x-set-state-mask-key mask key-sym) + (lisp:logior mask (xlib:make-state-mask key-sym))) + +(define (x-clear-state-mask-key mask key-sym) + (lisp:logand mask (lisp:lognot (xlib:make-state-mask key-sym)))) + +(define (x-test-state-mask-key mask key-sym) + (if (eqv? 0 (lisp:logand mask (xlib:make-state-mask key-sym))) '#f '#t)) + + +;;; Display is a string of the format name:d.s +;;; ignore s; if d is omitted, default it to zero. + +(define (x-open-display display) + (let* ((end (string-length display)) + (colon (or (string-position #\: display 0 end) end)) + (dot (or (string-position #\. display colon end) end))) + (declare (type fixnum end colon dot)) + (xlib:open-display + (substring display 0 colon) + :display (if (eqv? colon dot) + 0 + (string->number (substring display (1+ colon) dot)))))) + +(define (x-set-display-error-handler display error-fun) + (declare (ignore display error-fun)) + (error "not implemented")) + +(define (x-set-display-after-function display after-fun) + (declare (ignore display after-fun)) + (error "not implemented")) + +(define (x-screen-depths screen) + (let ((depths (xlib:screen-depths screen))) + (map (lambda (l) (make-h-tuple (car l) (list->haskell-list/identity (cdr l)))) + depths))) + +(define (x-screen-size screen) + (mk-xsize (xlib:screen-width screen) (xlib:screen-height screen))) + +(define (x-screen-mmsize screen) + (mk-xsize (xlib:screen-width-in-millimeters screen) + (xlib:screen-height-in-millimeters screen))) + +(define (x-create-window parent rect attrs) + (apply (function XLIB:CREATE-WINDOW) + `(:parent ,parent :x ,(xrect-x rect) :y ,(xrect-y rect) + :width ,(xrect-w rect) :height ,(xrect-h rect) + ,@(attrs->keywords attrs)))) + +(define-attribute-setter drawable border-width) + +(define (x-drawable-size drawable) + (mk-xsize (xlib:drawable-width drawable) (xlib:drawable-height drawable))) + +(define (x-drawable-resize drawable size) + (setf (xlib:drawable-width drawable) (xsize-w size)) + (setf (xlib:drawable-height drawable) (xsize-h size))) + +(define (x-window-pos window) + (mk-xpoint (xlib:drawable-x window) (xlib:drawable-y window))) + +(define (x-window-move window point) + (setf (xlib:drawable-x window) (xpoint-x point)) + (setf (xlib:drawable-y window) (xpoint-y point))) + +(define-attribute-setter window background) +(define-attribute-setter window backing-pixel) +(define-attribute-setter window backing-planes) +(define-attribute-setter window backing-store) +(define-attribute-setter window bit-gravity) +(define-attribute-setter window border) +(define-attribute-setter window colormap) + +(define (x-set-window-cursor window cursor) + (let ((val (if (null? cursor) :none cursor))) + (setf (xlib:window-cursor window) val))) + +(define-attribute-setter window do-not-propagate-mask) +(define-attribute-setter window event-mask) +(define-attribute-setter window gravity) +(define-attribute-setter window override-redirect) +(define-attribute-setter window priority) +(define-attribute-setter window save-under) + +(define (x-query-tree window) + (multiple-value-bind (children parent root) + (xlib:query-tree window) + (make-h-tuple (list->haskell-list/identity children) parent root))) + +(define (x-reparent-window window parent point) + (xlib:reparent-window window parent (xpoint-x point) (xpoint-y point))) + +(define (x-translate-coordinates source point dest) + (xlib:translate-coordinates source (xpoint-x point) (xpoint-y point) dest)) + +(define (x-create-pixmap size depth drawable) + (xlib:create-pixmap :width (xsize-w size) + :height (xsize-h size) + :depth depth + :drawable drawable)) + +(define (x-create-gcontext drawable attrs) + (apply (function XLIB:CREATE-GCONTEXT) + `(:drawable ,drawable ,@(attrs->keywords attrs)))) + +(define (x-update-gcontext gcontext attrs) + (do ((keys (attrs->keywords attrs) (cddr keys))) + ((null? keys)) + (x-update-gcontext-attr gcontext (car keys) (cadr keys)))) + +(define (x-update-gcontext-attr gcontext key attr) + (case key + (:arc-mode (setf (xlib:gcontext-arc-mode gcontext) attr)) + (:background (setf (xlib:gcontext-background gcontext) attr)) + (:cap-style (setf (xlib:gcontext-cap-style gcontext) attr)) + (:fill-style (setf (xlib:gcontext-fill-style gcontext) attr)) + (:clip-mask (setf (xlib:gcontext-clip-mask gcontext) attr)) + (:clip-x (setf (xlib:gcontext-clip-x gcontext) attr)) + (:clip-y (setf (xlib:gcontext-clip-y gcontext) attr)) + (:dash-offset (setf (xlib:gcontext-dash-offset gcontext) attr)) + (:dashes (setf (xlib:gcontext-dashes gcontext) attr)) + (:exposures (setf (xlib:gcontext-exposures gcontext) attr)) + (:fill-rule (setf (xlib:gcontext-fill-rule gcontext) attr)) + (:font (setf (xlib:gcontext-font gcontext) attr)) + (:foreground (setf (xlib:gcontext-foreground gcontext) attr)) +; (:function (setf (xlib:gcontext-function gcontext) attr)) + (:join-style (setf (xlib:gcontext-join-style gcontext) attr)) + (:line-style (setf (xlib:gcontext-line-style gcontext) attr)) +; (:line-width (setf (xlib:gcontext-line-width gcontext) attr)) +; (:plane-mask (setf (xlib:gcontext-plane-mask gcontext) attr)) +; (:stipple (setf (xlib:gcontext-stipple gcontext) attr)) + (:subwindow-mode (setf (xlib:gcontext-subwindow-mode gcontext) attr)) +; (:tile (setf (xlib:gcontext-tile gcontext) attr)) +; (:ts-x (setf (xlib:gcontext-ts-x gcontext) attr)) +; (:ts-y (setf (xlib:gcontext-ts-y gcontext) attr)) + (else (format '#t "Graphics context attribute ~A is not settable.~%" + key)))) + +(define (x-query-best-stipple dsize drawable) + (multiple-value-bind (w h) + (xlib:query-best-stipple (xsize-w dsize) (xsize-h dsize) drawable) + (mk-xsize w h))) + +(define (x-query-best-tile dsize drawable) + (multiple-value-bind (w h) + (xlib:query-best-tile (xsize-w dsize) (xsize-h dsize) drawable) + (mk-xsize w h))) + +(define (x-clear-area window rect exposures-p) + (xlib:clear-area window + :x (xrect-x rect) + :y (xrect-y rect) + :width (xrect-w rect) + :height (xrect-h rect) + :exposures-p exposures-p)) + +(define (x-copy-area src gcontext rect dest point) + (xlib:copy-area src + gcontext + (xrect-x rect) (xrect-y rect) + (xrect-w rect) (xrect-h rect) + dest + (xpoint-x point) (xpoint-y point))) + +(define (x-copy-plane src gcontext plane rect dest point) + (xlib:copy-plane src + gcontext + plane + (xrect-x rect) (xrect-y rect) + (xrect-w rect) (xrect-h rect) + dest + (xpoint-x point) (xpoint-y point))) + +(define (x-draw-point drawable gcontext point) + (xlib:draw-point drawable gcontext (xpoint-x point) (xpoint-y point))) + +(define (x-draw-points drawable gcontext points) + (xlib:draw-points drawable gcontext (points->point-seq points))) + +(define (points->point-seq points) + (if (null? points) + '() + (let ((point (car points))) + (lisp:list* (xpoint-x point) + (xpoint-y point) + (points->point-seq (cdr points)))))) + +(define (segments->point-seq segments) + (if (null? segments) + '() + (let* ((first-pair (car segments)) + (point-1 (force (tuple-select 2 0 first-pair))) + (point-2 (force (tuple-select 2 1 first-pair)))) + (lisp:list* (xpoint-x point-1) + (xpoint-y point-1) + (xpoint-x point-2) + (xpoint-y point-2) + (segments->point-seq (cdr segments)))))) + +(define (rects->point-seq rects) + (if (null? rects) + '() + (let ((rect (car rects))) + (lisp:list* (xrect-x rect) + (xrect-y rect) + (xrect-w rect) + (xrect-h rect) + (rects->point-seq (cdr rects)))))) + +(define (point-seq->rects point-seq) + (if (null? point-seq) + '() + (cons (mk-xrect (car point-seq) (cadr point-seq) + (caddr point-seq) (cadddr point-seq)) + (point-seq->rects (cddddr point-seq))))) + +(define (arcs->point-seq arcs) + (if (null? arcs) + '() + (let ((arc (car arcs))) + (lisp:list* (xarc-x arc) + (xarc-y arc) + (xarc-w arc) + (xarc-h arc) + (xarc-a1 arc) + (xarc-a2 arc) + (arcs->point-seq (cdr arcs)))))) + +(define (x-draw-line drawable gcontext point-1 point-2) + (xlib:draw-line drawable gcontext (xpoint-x point-1) (xpoint-y point-1) + (xpoint-x point-2) (xpoint-y point-2))) + +(define (x-draw-lines drawable gcontext points fill-p) + (xlib:draw-lines drawable gcontext + (points->point-seq points) :fill-p fill-p)) + +(define (x-draw-segments drawable gcontext segments) + (xlib:draw-segments drawable gcontext (segments->point-seq segments))) + +(define (x-draw-rectangle drawable gcontext rect fill-p) + (xlib:draw-rectangle drawable gcontext + (xrect-x rect) (xrect-y rect) + (xrect-w rect) (xrect-h rect) + fill-p)) + +(define (x-draw-rectangles drawable gcontext rects fill-p) + (xlib:draw-rectangles drawable gcontext + (rects->point-seq rects) + fill-p)) + +(define (x-draw-arc drawable gcontext arc fill-p) + (xlib:draw-arc drawable gcontext + (xarc-x arc) (xarc-y arc) + (xarc-w arc) (xarc-h arc) + (xarc-a1 arc) (xarc-a2 arc) + fill-p)) + +(define (x-draw-arcs drawable gcontext arcs fill-p) + (xlib:draw-arcs drawable gcontext + (arcs->point-seq arcs) + fill-p)) + +(define (x-draw-glyph drawable gcontext point element) + (nth-value 1 + (xlib:draw-glyph drawable gcontext (xpoint-x point) + (xpoint-y point) element))) + +(define (x-draw-glyphs drawable gcontext point element) + (nth-value 1 (xlib:draw-glyphs drawable gcontext (xpoint-x point) + (xpoint-y point) element))) + +(define (x-draw-image-glyph drawable gcontext point element) + (nth-value 1 (xlib:draw-image-glyph drawable gcontext (xpoint-x point) + (xpoint-y point) element))) + +(define (x-draw-image-glyphs drawable gcontext point element) + (nth-value 1 (xlib:draw-image-glyphs drawable gcontext (xpoint-x point) + (xpoint-y point) element))) + +(define (x-image-size image) + (mk-xsize (xlib:image-width image) (xlib:image-height image))) + +(define (x-image-name image) + (let ((lisp-name (xlib:image-name image))) + (cond ((null? lisp-name) "") + ((symbol? lisp-name) (symbol->string lisp-name)) + (else lisp-name)))) + +(define-attribute-setter image name) + +(define (x-image-hot-spot image) + (mk-xpoint (xlib:image-x-hot image) (xlib:image-y-hot image))) + +(define (x-set-image-hot-spot image point) + (setf (xlib:image-x-hot image) (xpoint-x point)) + (setf (xlib:image-y-hot image) (xpoint-y point))) + +(define-attribute-setter image xy-bitmap-list) +(define-attribute-setter image z-bits-per-pixel) +(define-attribute-setter image z-pixarray) + +(define (x-create-image attrs) + (apply (function xlib:create-image) (attrs->keywords attrs))) + +(define (x-copy-image image rect type) + (xlib:copy-image image :x (xrect-x rect) :y (xrect-y rect) + :width (xrect-w rect) :height (xrect-h rect) + :result-type type)) + +(define (x-get-image drawable rect pmask format type) + (xlib:get-image drawable :x (xrect-x rect) :y (xrect-y rect) + :width (xrect-w rect) :height (xrect-h rect) + :plane-mask pmask :format format :result-type type)) + +(define (x-put-image drawable gcontext image point rect) + (xlib:put-image drawable gcontext image + :src-x (xpoint-x point) :src-y (xpoint-y point) + :x (xrect-x rect) :y (xrect-y rect) + :width (xrect-w rect) :height (xrect-h rect))) + +(define (x-get-raw-image drawable rect pmask format) + (xlib:get-raw-image drawable + :x (xrect-x rect) :y (xrect-y rect) + :width (xrect-w rect) :height (xrect-h rect) + :plane-mask pmask :format format)) + +(define (x-put-raw-image drawable gcontext data depth rect left-pad format) + (xlib:put-raw-image drawable gcontext data + :depth depth + :x (xrect-x rect) :y (xrect-y rect) + :width (xrect-w rect) :height (xrect-h rect) + :left-pad left-pad :format format)) + +(define (x-font-name font) + (let ((lisp-name (xlib:font-name font))) + (cond ((null? lisp-name) "") + ((symbol? lisp-name) (symbol->string lisp-name)) + (else lisp-name)))) + +(define (x-alloc-color colormap color) + (multiple-value-bind (pixel screen-color exact-color) + (xlib:alloc-color colormap color) + (make-h-tuple pixel screen-color exact-color))) + +(define (x-alloc-color-cells colormap colors planes contiguous-p) + (multiple-value-bind (pixels mask) + (xlib:alloc-color-cells colormap colors :planes planes + :contiguous-p contiguous-p) + (make-h-tuple (list->haskell-list/identity pixels) (list->haskell-list/identity mask)))) + +(define (x-alloc-color-planes colormap colors reds greens blues contiguous-p) + (multiple-value-bind (pixels red-mask green-mask blue-mask) + (xlib:alloc-color-planes colormap colors :reds reds :greens greens + :blues blues :contiguous-p contiguous-p) + (make-h-tuple (list->haskell-list/identity pixels) + red-mask + green-mask + blue-mask))) + +(define (x-lookup-color colormap name) + (multiple-value-bind (screen-color exact-color) + (xlib:lookup-color colormap name) + (make-h-tuple screen-color exact-color))) + +(define (unzip l) + (if (null? l) + '() + (let ((h (car l))) + (lisp:list* (force (tuple-select 2 0 h)) + (force (tuple-select 2 1 h)) + (unzip (cdr l)))))) + +(define (x-store-colors colormap pixel-colors) + (xlib:store-colors colormap (unzip pixel-colors))) + +(define (x-create-cursor source mask point foreground background) + (apply (function xlib:create-cursor) + `(:source ,source + ,@(if mask `(:mask ,mask) '()) + :x ,(xpoint-x point) :y ,(xpoint-y point) + :foreground ,foreground :background ,background))) + +(define (x-create-glyph-cursor src mask foreground background) + (apply (function xlib:create-glyph-cursor) + `(:source-font ,(force (tuple-select 2 0 src)) + :source-char ,(integer->char (force (tuple-select 2 1 src))) + ,@(if mask + `(:mask-font ,(force (tuple-select 2 0 mask)) + :mask-char ,(integer->char (force (tuple-select 2 1 mask)))) + '()) + :foreground ,foreground :background ,background))) + +(define (x-query-best-cursor size display) + (multiple-value-bind (w h) + (xlib:query-best-cursor (xsize-w size) (xsize-h size) display) + (mk-xsize w h))) + +(define (x-change-property window property content) + (xlib:change-property window property + (car content) (cadr content) + (caddr content))) + +(define (x-get-property window property) + (lisp:multiple-value-bind (data type format) + (xlib:get-property window property) + (list (sequence->list data) type format))) + +(define (x-convert-selection selection type requestor property time) + (apply (function xlib:convert-selection) + `(,selection ,type ,requestor ,property ,@(if time `(,time) '())))) + +(define (x-set-selection-owner display selection time owner) + (if time + (setf (xlib:selection-owner display selection time) owner) + (setf (xlib:selection-owner display selection) owner))) + +(define (sequence->list seq) + (if (list? seq) seq + (do ((i (1- (lisp:length seq)) (1- i)) + (res '() (cons (lisp:elt seq i) res))) + ((< i 0) res)))) + +(define *this-event* '()) + +(define (translate-event lisp:&rest event-slots lisp:&key event-key + lisp:&allow-other-keys) + (setf *this-event* (cons event-key event-slots)) + '#t) + + +(define (x-get-event display) + (xlib:process-event display :handler #'translate-event :force-output-p '#t) + *this-event*) + +(define (x-queue-event display event append-p) + (apply (function xlib:queue-event) + `(,display ,(car event) ,@(cdr event) :append-p ,append-p))) + +(define (x-event-listen display) + (let ((res (xlib:event-listen display))) + (if (null? res) 0 res))) + +(define (x-send-event window event mask) + (apply (function xlib:send-event) + `(,window ,(car event) ,mask ,@(cdr event)))) + +(define (x-global-pointer-position display) + (multiple-value-bind (x y) (xlib:global-pointer-position display) + (mk-xpoint x y))) + +(define (x-pointer-position window) + (multiple-value-bind (x y same) (xlib:pointer-position window) + (if same (mk-xpoint x y) '()))) + +(define (x-motion-events window start stop) + (do ((npos '() (cons (mk-xpoint (car pos) (cadr pos)) npos)) + (pos (xlib:motion-events window :start start :stop stop) + (cdddr pos))) + ((null? pos) (nreverse npos)))) + +(define (x-warp-pointer dest-win point) + (xlib:warp-pointer dest-win (xpoint-x point) (xpoint-y point))) + +(define (x-set-input-focus display focus revert-to time) + (apply (function xlib:set-input-focus) + `(,display ,focus ,revert-to ,@(if time `(,time) '())))) + +(define (x-input-focus display) + (multiple-value-bind (focus revert-to) (xlib:input-focus display) + (make-h-tuple focus revert-to))) + +(define (x-grab-pointer window event-mask attrs time) + (apply (function xlib:grab-pointer) + `(,window ,event-mask + ,@(attrs->keywords attrs) + ,@(if time `(:time ,time) '())))) + +(define (x-ungrab-pointer display time) + (if time + (xlib:ungrab-pointer display :time time) + (xlib:ungrab-pointer display))) + +(define (x-change-active-pointer-grab display event-mask attrs time) + (apply (function xlib:change-active-pointer-grab) + `(,display ,event-mask + ,@(attrs->keywords attrs) + ,@(if time `(,time) '())))) + +(define (x-grab-button window button event-mask state-mask attrs) + (apply (function xlib:grab-button) + `(,window ,button ,event-mask :modifiers ,state-mask + ,@(attrs->keywords attrs)))) + +(define (x-ungrab-button window button modifiers) + (xlib:ungrab-button window button :modifiers modifiers)) + +(define (x-grab-keyboard window attrs time) + (apply (function xlib:grab-keyboard) + `(,window ,@(attrs->keywords attrs) + ,@(if time `(:time ,time) '())))) + +(define (x-ungrab-keyboard display time) + (if time + (xlib:ungrab-keyboard display :time time) + (xlib:ungrab-keyboard display))) + +(define (x-grab-key window key state-mask attrs) + (apply (function xlib:grab-key) + `(,window ,key :modifiers ,state-mask ,@(attrs->keywords attrs)))) + +(define (x-ungrab-key window key modifiers) + (xlib:ungrab-button window key :modifiers modifiers)) + +(define (x-set-pointer-acceleration display val) + (xlib:change-pointer-control display :acceleration val)) + +(define (x-set-pointer-threshold display val) + (xlib:change-pointer-control display :threshold val)) + +(define (x-pointer-acceleration display) + (lisp:coerce (nth-value 0 (xlib:pointer-control display)) + 'lisp:single-float)) + +(define (x-pointer-threshold display) + (lisp:coerce (nth-value 1 (xlib:pointer-control display)) + 'lisp:single-float)) + +(define-attribute-setter pointer mapping) + +(define (x-set-keyboard-key-click-percent display v) + (xlib:change-keyboard-control display :key-click-percent v)) + +(define (x-set-keyboard-bell-percent display v) + (xlib:change-keyboard-control display :bell-percent v)) + +(define (x-set-keyboard-bell-pitch display v) + (xlib:change-keyboard-control display :bell-pitch v)) + +(define (x-set-keyboard-bell-duration display v) + (xlib:change-keyboard-control display :bell-duration v)) + + +;;; Yes, leds are really counted from 1 rather than 0. + +(define (x-set-keyboard-led display v) + (declare (type integer v)) + (do ((led 1 (1+ led)) + (vv v (lisp:ash vv -1))) + ((> led 32)) + (declare (type fixnum led) (type integer vv)) + (xlib:change-keyboard-control display + :led led + :led-mode (if (lisp:logand vv 1) :on :off)))) + +(define (x-set-keyboard-auto-repeat-mode display v) + (do ((key 0 (1+ key))) + ((>= key (lisp:length v))) + (declare (type fixnum key)) + (xlib:change-keyboard-control display + :key key + :auto-repeat-mode (if (eqv? (the fixnum (lisp:aref v key)) 1) :on :off) + ))) + +(define (x-keyboard-key-click-percent display) + (nth-value 0 (xlib:keyboard-control display))) + +(define (x-keyboard-bell-percent display) + (nth-value 1 (xlib:keyboard-control display))) + +(define (x-keyboard-bell-pitch display) + (nth-value 2 (xlib:keyboard-control display))) + +(define (x-keyboard-bell-duration display) + (nth-value 3 (xlib:keyboard-control display))) + +(define (x-keyboard-led display) + (nth-value 4 (xlib:keyboard-control display))) + +(define (x-keyboard-auto-repeat-mode display) + (nth-value 6 (xlib:keyboard-control display))) + +(define (x-modifier-mapping display) + (lisp:multiple-value-list (xlib:modifier-mapping display))) + +(define (x-set-modifier-mapping display l) + (let ((l1 (cddddr l))) + (xlib:set-modifier-mapping display + :shift (car l) + :lock (cadr l) + :control (caddr l) + :mod1 (cadddr l) + :mod2 (car l1) + :mod3 (cadr l1) + :mod4 (caddr l1) + :mod5 (cadddr l1)))) + +(define (x-keysym-character display keysym state) + (let ((res (xlib:keysym->character display keysym state))) + (if (char? res) (char->integer res) '()))) + +(define (x-keycode-character display keycode state) + (let ((res (xlib:keycode->character display keycode state))) + (if (char? res) (char->integer res) '()))) + +(define-attribute-setter close-down mode) + +(define-attribute-setter access control) + +(define (x-screen-saver display) + (lisp:multiple-value-list (xlib:screen-saver display))) + +(define (x-set-screen-saver display ss) + (xlib:set-screen-saver display (car ss) (cadr ss) (caddr ss) (cadddr ss))) + +(define (slots->keywords slots) + (if (null slots) '() + `(,@(slot->keyword (car slots)) ,@(slots->keywords (cdr slots))))) + +(define (slot->keyword slot) + (let* ((tag (keyword-key slot)) + (val (keyword-val slot))) + (case tag + (:pos `(:x ,(xpoint-x val) :y ,(xpoint-y val))) + (:root-pos `(:root-x ,(xpoint-x val) :root-y ,(xpoint-y val))) + (:size `(:width ,(xsize-w val) :height ,(xsize-h val))) + (:rect `(:x ,(xrect-x val) :y ,(xrect-y val) + :width ,(xrect-w val) :height ,(xrect-h val))) + (:graph-fun `(:major ,(car val) :minor ,(cdr val))) + (:visibility `(:state ,val)) + (:property-state `(:state ,val)) + (:message `(:data ,(car val) :type ,(cadr val) :format ,(caddr val))) + (else `(,tag ,val))))) + +(define (keywords->slots type keywords event) + (let* ((slots (keywords->slots1 type keywords)) + (has-root-xy (memq type '(:key-press :key-release :button-press + :button-release :motion-notify + :enter-notify :leave-notify))) + (has-xy (or has-root-xy + (memq type '(:gravity-notify :reparent-notify)))) + (has-graph-fun (memq type '(:graphics-exposure :no-exposure))) + (has-rect (memq type '(:exposure :graphics-exposure + :configure-notify + :create-notify :configure-request))) + (has-size (memq type '(:resize-request))) + (has-message (memq type '(:client-message)))) + (when has-xy + (push (make-keyword :pos (x-event-pos event)) slots)) + (when has-root-xy + (push (make-keyword :root-pos (x-event-root-pos event)) slots)) + (when has-graph-fun + (push (make-keyword :graph-fun (x-event-graph-fun event)) slots)) + (when has-rect + (push (make-keyword :rect (x-event-rect event)) slots)) + (when has-size + (push (make-keyword :size (x-event-size event)) slots)) + (when has-message + (push (make-keyword :message (x-event-message event)) slots)) + slots)) + +(define (keywords->slots1 type keywords) + (if (null? keywords) + '() + (if (memq (car keywords) + '(:x :y :width :height :root-x :root-y + :major :minor :type :data :format)) + (keywords->slots1 type (cddr keywords)) + (cons (keyword->slot type (car keywords) (cadr keywords)) + (keywords->slots1 type (cddr keywords)))))) + +(define (keyword->slot type slot val) + (if (eq? slot :state) + (case type + (:property-state (make-keyword :property-state val)) + (:visibility (make-keyword :visibility val)) + (else (make-keyword :state val))) + (make-keyword slot val))) + +(define (attrs->keywords attrs) + (if (null attrs) + '() + (nconc (attr->keyword (car attrs)) + (attrs->keywords (cdr attrs))))) + +(define (attr->keyword attr) + (let* ((tag (keyword-key attr)) + (val (keyword-val attr))) + (case tag + (:clip-origin `(:clip-x ,(xpoint-x val) :clip-y ,(xpoint-y val))) + (:dashes `(,tag ,(haskell-list->list/identity val))) + (:tile-origin `(:ts-x ,(xpoint-x val) :ts-y ,(xpoint-y val))) + (:size `(:width ,(xsize-w val) :height ,(xsize-h val))) + (:name `(:name ,(haskell-string->string val))) + (:hot-spot `(:x-hot ,(xpoint-x val) :y-hot ,(xpoint-y val))) + (else `(,tag ,val))))) + +(define (x-mutable-array-create inits) + (list->vector inits)) + +(define (x-mutable-array-lookup a i) + (vector-ref a i)) + +(define (x-mutable-array-update a i x) + (setf (vector-ref a i) x)) + +(define (x-mutable-array-length a) + (vector-length a)) + +(define (get-time-zone) + (nth-value 8 (lisp:get-decoded-time))) + +(define (decode-time time zone) + (multiple-value-bind (sec min hour date mon year week ds-p) + (if zone + (lisp:decode-universal-time time zone) + (lisp:decode-universal-time time)) + (make-h-tuple + (list->haskell-list/identity (list sec min hour date mon year week)) + ds-p))) + +(define (encode-time time zone) + (apply (function lisp:encode-universal-time) + (if (null? zone) time (append time (list zone))))) + +(define (get-run-time) + (/ (lisp:coerce (lisp:get-internal-run-time) 'lisp:single-float) + (lisp:coerce lisp:internal-time-units-per-second 'lisp:single-float))) + +(define (get-elapsed-time) + (/ (lisp:coerce (lisp:get-internal-real-time) 'lisp:single-float) + (lisp:coerce lisp:internal-time-units-per-second 'lisp:single-float))) + +(define (prim.thenio---1 x fn) + (lambda (state) + (declare (ignore state)) + (let ((res (funcall x (box 'state)))) + (format '#t "~A~%" res) + (funcall fn res (box 'state))))) + +(define-attribute-setter wm name) +(define-attribute-setter wm icon-name) diff --git a/progs/lib/X11/xlibprims.hi b/progs/lib/X11/xlibprims.hi new file mode 100644 index 0000000..02d4163 --- /dev/null +++ b/progs/lib/X11/xlibprims.hi @@ -0,0 +1,1465 @@ +-- 4/13/93 add xTestEventMask, xTestStateMask +-- 4/14/93 add xMArrayLength, +-- xGetEventN +-- 4/15/93 change xKeycodeCharacter +-- add xKeysymCharacter +-- add xHandleError +-- add xError +-- 4/27/93 Change Bool to XSwitch in XWinAttribute, XGCAttribute + +interface XLibPrims where + +import XLibTypes( + XDisplay, XScreen, XWindow, XGcontext, XPixmap, + XColormap, XCursor, XFont, XImage, XMaybe, XError, + XBitmap, XKeysymTable, XBitVec, + XPixarray, XByteVec, XAtom, XProperty, + XPixel, XDrawable, XTime, XSwitch, + XWindowPlace, XEventMode, XEventKind, + XWindowVisibility, XWindowStackMode, + XPropertyState, XMapReqType, XGraphFun, + XEvent, XEventType, XEventSlot, XEventMask, + XEventMaskKey, XStateMask, XStateMaskKey, + XWinAttribute,XGCAttribute, XImAttribute, + XGrabAttribute, XArcMode, XCapStyle, + XClipMask, XFillRule, XFillStyle, + XFunction, XJoinStyle, XLineStyle, + XSubwindowMode, XPoint, XSize, XRect, + XArc, XBitmapFormat, XByteOrder, + XPixmapFormat, XVisualInfo, XVisualClass, + XFillContent, XBackingStore, XGravity, + XWindowClass, XMapState, XImageData, + XImageFormat, XImageType, XDrawDirection, + XColor, XInputFocus, XGrabStatus, + XKeysym, XCloseDownMode, XScreenSaver) + +xHandleError :: (XError -> IO a) -> IO a -> IO a +xError :: String -> IO a + +xEventType :: XEvent -> XEventType +xEventWindow :: XEvent -> XWindow +xEventEventWindow :: XEvent -> XWindow +xEventCode :: XEvent -> Int +xEventPos :: XEvent -> XPoint +xEventState :: XEvent -> XStateMask +xEventTime :: XEvent -> XTime +xEventRoot :: XEvent -> XWindow +xEventRootPos :: XEvent -> XPoint +xEventChild :: XEvent -> (XMaybe XWindow) +xEventSameScreenP :: XEvent -> Bool +xEventHintP :: XEvent -> Bool +xEventMode :: XEvent -> XEventMode +xEventKind :: XEvent -> XEventKind +xEventFocusP :: XEvent -> Bool +xEventKeymap :: XEvent -> XBitVec +xEventRequest :: XEvent -> XMapReqType +xEventStart :: XEvent -> Int +xEventCount :: XEvent -> Int +xEventRect :: XEvent -> XRect +xEventDrawable :: XEvent -> XDrawable +xEventXGraphFun :: XEvent -> XGraphFun +xEventPlace :: XEvent -> XWindowPlace +xEventBorderWidth :: XEvent -> Int +xEventAboveSibling :: XEvent -> (XMaybe XWindow) +xEventOverrideRedirectP :: XEvent -> Bool +xEventParent :: XEvent -> XWindow +xEventConfigureP :: XEvent -> Bool +xEventVisibility :: XEvent -> XWindowVisibility +xEventNewP :: XEvent -> Bool +xEventInstalledP :: XEvent -> Bool +xEventStackMode :: XEvent -> XWindowStackMode +xEventValueMask :: XEvent -> Int +xEventSize :: XEvent -> XSize +xEventMessage :: XEvent -> XProperty +xEventPropertyState :: XEvent -> XPropertyState +xEventAtom :: XEvent -> XAtom +xEventSelection :: XEvent -> XAtom +xEventTarget :: XEvent -> XAtom +xEventProperty :: XEvent -> (XMaybe XAtom) +xEventRequestor :: XEvent -> XWindow + +xSetEventMaskKey :: XEventMask -> XEventMaskKey -> XEventMask +xClearEventMaskKey :: XEventMask -> XEventMaskKey -> XEventMask +xTestEventMaskKey :: XEventMask -> XEventMaskKey -> Bool + +xSetStateMaskKey :: XStateMask -> XStateMaskKey -> XStateMask +xClearStateMaskKey :: XStateMask -> XStateMaskKey -> XStateMask +xTestStateMaskKey :: XStateMask -> XStateMaskKey -> Bool + + +-- DISPLAYS + +-- open + +xOpenDisplay :: String -- host:display + -> IO XDisplay + +-- display attributes + +xDisplayAuthorizationData :: XDisplay -> String +xDisplayAuthorizationName :: XDisplay -> String +xDisplayBitmapFormat :: XDisplay -> XBitmapFormat +xDisplayByteOrder :: XDisplay -> XByteOrder +xDisplayDisplay :: XDisplay -> Int +xSetDisplayErrorHandler :: XDisplay -> (XError -> IO ()) -> IO () +xDisplayImageLsbFirstP :: XDisplay -> Bool +xDisplayMaxKeycode :: XDisplay -> Int +xDisplayMaxRequestLength :: XDisplay -> Int +xDisplayMinKeycode :: XDisplay -> Int +xDisplayMotionBufferSize :: XDisplay -> Int +xDisplayPixmapFormats :: XDisplay -> [XPixmapFormat] +xDisplayProtocolMajorVersion :: XDisplay -> Int +xDisplayProtocolMinorVersion :: XDisplay -> Int +xDisplayResourceIdBase :: XDisplay -> Int +xDisplayResourceIdMask :: XDisplay -> Int +xDisplayRoots :: XDisplay -> [XScreen] +xDisplayVendorName :: XDisplay -> String +xDisplayReleaseNumber :: XDisplay -> Int + +-- output buffer + +xDisplayAfterFunction :: XDisplay -> XMaybe (IO ()) +xSetDisplayAfterFunction :: XDisplay -> XMaybe (IO ()) -> IO () +xDisplayForceOutput :: XDisplay -> IO () +xDisplayFinishOutput :: XDisplay -> IO () + +-- close + +xCloseDisplay :: XDisplay -> IO () + +-- SCREENS + +xScreenBackingStores :: XScreen -> XBackingStore +xScreenBlackPixel :: XScreen -> XPixel +xScreenDefaultColormap :: XScreen -> XColormap +xScreenDepths :: XScreen -> [(Int, [XVisualInfo])] +xScreenEventMaskAtOpen :: XScreen -> XEventMask +xScreenSize :: XScreen -> XSize +xScreenMMSize :: XScreen -> XSize +xScreenMaxInstalledMaps :: XScreen -> Int +xScreenMinInstalledMaps :: XScreen -> Int +xScreenRoot :: XScreen -> XWindow +xScreenRootDepth :: XScreen -> Int +xScreenRootVisual :: XScreen -> Int +xScreenSaveUndersP :: XScreen -> Bool +xScreenWhitePixel :: XScreen -> XPixel + +-- WINDOWS AND PIXMAPS + +-- drawables + +xDrawableDisplay :: XDrawable -> XDisplay +xDrawableEqual :: XDrawable -> XDrawable -> Bool +xDrawableId :: XDrawable -> Int + +-- creating windows + +xCreateWindow :: XWindow -- parent + -> XRect -- (x,y,width,height) + -> [XWinAttribute] -- optional arguments + -> IO XWindow + +-- window attributes + +xWindowBorderWidth :: XWindow -> IO Int +xSetWindowBorderWidth :: XWindow -> Int -> IO () + +xDrawableDepth :: XDrawable -> Int + +xDrawableSize :: XDrawable -> IO XSize +xDrawableResize :: XDrawable -> XSize -> IO () + +xWindowPos :: XWindow -> IO XPoint +xWindowMove :: XWindow -> XPoint -> IO () + +xWindowAllEventMasks :: XWindow -> IO XEventMask +xSetWindowBackground :: XWindow -> XFillContent -> IO () + +xWindowBackingPixel :: XWindow -> IO XPixel +xSetWindowBackingPixel :: XWindow -> XPixel -> IO () + +xWindowBackingPlanes :: XWindow -> IO XPixel +xSetWindowBackingPlanes :: XWindow -> XPixel -> IO () + +xWindowBackingStore :: XWindow -> IO XBackingStore +xSetWindowBackingStore :: XWindow -> XBackingStore -> IO () + +xWindowBitGravity :: XWindow -> IO XGravity +xSetWindowBitGravity :: XWindow -> XGravity -> IO () + +xSetWindowBorder :: XWindow -> XFillContent -> IO () + +xWindowClass :: XWindow -> XWindowClass + +xWindowColorMap :: XWindow -> IO (XMaybe XColormap) +xSetWindowColorMap :: XWindow -> XColormap -> IO () +xWindowColormapInstalledP :: XWindow -> IO Bool + +xSetWindowCursor :: XWindow -> (XMaybe XCursor) -> IO () + +xWindowDisplay :: XWindow -> XDisplay + +xWindowDoNotPropagateMask :: XWindow -> IO XEventMask +xSetWindowDoNotPropagateMask :: XWindow -> XEventMask -> IO () + +xWindowEqual :: XWindow -> XWindow -> Bool + +xWindowEventMask :: XWindow -> IO XEventMask +xSetWindowEventMask :: XWindow -> XEventMask -> IO () + +xWindowGravity :: XWindow -> IO XGravity +xSetWindowGravity :: XWindow -> XGravity -> IO () + +xWindowId :: XWindow -> Int + +xWindowMapState :: XWindow -> IO XMapState + +xWindowOverrideRedirect :: XWindow -> IO XSwitch +xSetWindowOverrideRedirect :: XWindow -> XSwitch -> IO () + +xSetWindowPriority :: XWindow -> XWindowStackMode -> IO () + +xWindowSaveUnder :: XWindow -> IO XSwitch +xSetWindowSaveUnder :: XWindow -> XSwitch -> IO () + +xWindowVisual :: XWindow -> Int + +-- stacking order + +xCirculateWindowDown :: XWindow -> IO () +xCirculateWindowUp :: XWindow -> IO () + +-- window hierarchy + +xDrawableRoot :: XDrawable -> IO XWindow +xQueryTree :: XWindow -> IO ([XWindow], -- children + XMaybe XWindow,-- parent + XWindow) -- root + +xReparentWindow :: XWindow -- window + -> XWindow -- parent + -> XPoint -- (x,y) + -> IO () + +xTranslateCoordinates :: XWindow -- source + -> XPoint -- (source-x,source-y) + -> XWindow -- destination + -> IO (XMaybe XPoint) -- (dest-x,dest-y) + +-- mapping windows + +xMapWindow :: XWindow -> IO () +xMapSubwindows :: XWindow -> IO () +xUnmapWindow :: XWindow -> IO () +xUnmapSubwindows :: XWindow -> IO () + +-- destroying windows + +xDestroyWindow :: XWindow -> IO () +xDestroySubwindows :: XWindow -> IO () + +-- pixmaps + +xCreatePixmap :: XSize -- (width,height) + -> Int -- depth + -> XDrawable -- drawable + -> IO XPixmap + +xFreePixmap :: XPixmap -> IO () + +xPixmapDisplay :: XPixmap -> XDisplay +xPixmapEqual :: XPixmap -> XPixmap -> Bool + +-- GRAPHICS CONTEXTS + +xCreateGcontext :: XDrawable -- drawable + -> [XGCAttribute] -- optional arguments + -> IO XGcontext + +xUpdateGcontext :: XGcontext -- old gcontext + -> [XGCAttribute] -- changes + -> IO () -- new gcontext + +xFreeGcontext :: XGcontext -> IO () + +xGcontextDisplay :: XGcontext -> XDisplay +xGcontextEqual :: XGcontext -> XGcontext -> Bool + +xGcontextId :: XGcontext -> Int + +xQueryBestStipple :: XSize -> XDrawable -> XSize +xQueryBestTile :: XSize -> XDrawable -> XSize + +xCopyGcontext :: XGcontext -- source + -> XGcontext -- destination + -> IO () + +-- GRAPHICS OPERATIONS + +xClearArea :: XWindow -- window + -> XRect -- (x,y,width,height) + -> Bool -- exposure-p + -> IO () + +xCopyArea :: XDrawable -- source + -> XGcontext -- gcontext + -> XRect -- (src-x,src-y,w,h) + -> XDrawable -- destination + -> XPoint -- (dest-x,dest-y) + -> IO () + +xCopyPlane :: XDrawable -- source + -> XGcontext -- gcontext + -> XPixel -- plane + -> XRect -- (src-x,src-y,w,h) + -> XDrawable -- destination + -> XPoint -- (dest-x,dest-y) + -> IO () + +xDrawPoint :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x,y) + -> IO () + +xDrawPoints :: XDrawable -- drawable + -> XGcontext -- gcontext + -> [XPoint] -- points + -> IO () + +xDrawLine :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x1,y1) + -> XPoint -- (x2,y2) + -> IO () + +xDrawLines :: XDrawable -- drawable + -> XGcontext -- gcontext + -> [XPoint] -- points + -> Bool -- fill-p + -> IO () + +xDrawSegments :: XDrawable -- drawable + -> XGcontext -- gcontext + -> [(XPoint,XPoint)] -- segments + -> IO () + +xDrawRectangle :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XRect -- (x,y,width,height) + -> Bool -- fill-p + -> IO () + +xDrawRectangles :: XDrawable -- drawable + -> XGcontext -- gcontext + -> [XRect] -- rectangles + -> Bool -- fill-p + -> IO () + +xDrawArc :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XArc -- (x,y,w,h,a1,a2) + -> Bool -- fill-p + -> IO () + +xDrawArcs :: XDrawable -- drawable + -> XGcontext -- gcontext + -> [XArc] -- arcs + -> Bool -- fill-p + -> IO () + +xDrawGlyph :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x,y) + -> Char -- element + -> IO (XMaybe Int) -- width + +xDrawGlyphs :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x,y) + -> String -- sequence + -> IO (XMaybe Int) -- width + +xDrawImageGlyph :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x,y) + -> Char -- element + -> IO (XMaybe Int) -- width + +xDrawImageGlyphs :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XPoint -- (x,y) + -> String -- sequence + -> IO (XMaybe Int) -- width + +-- IMAGES + +xImageBlueMask :: XImage -> XMaybe XPixel +xImageDepth :: XImage -> Int +xImageGreenMask :: XImage -> XMaybe XPixel +xImageSize :: XImage -> XSize +xImageName :: XImage -> String +xSetImageName :: XImage -> String -> IO () +xImageRedMask :: XImage -> XMaybe XPixel +xImageHotSpot :: XImage -> XMaybe XPoint +xSetImageHotSpot :: XImage -> XPoint -> IO () + +-- XY-format images + +xImageXYBitmaps :: XImage -> IO [XBitmap] +xSetImageXYBitmaps :: XImage -> [XBitmap] -> IO () + +-- Z-format images + +xImageZBitsPerPixel :: XImage -> IO Int +xsetImageZBitsPerPixel :: XImage -> Int -> IO () +xImageZPixarray :: XImage -> IO XPixarray +xSetImageZPixarray :: XImage -> XPixarray -> IO () + +-- image functions + +xCreateImage :: [XImAttribute] -> IO XImage +xCopyImage :: XImage -- image + -> XRect -- (x,y,width,height) + -> XImageType -- result-type + -> XImage -- new-image + +xGetImage :: XDrawable -- drawable + -> XRect -- (x,y,width,height) + -> XPixel -- plane-mask + -> XImageFormat -- format + -> XImageType -- result-type + -> IO XImage -- image + +xPutImage :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XImage -- ximage + -> XPoint -- (src-x,src-y) + -> XRect -- (x,y,width,height) + -> IO () + +-- image files + +xReadBitmapFile :: String -- pathname + -> IO XImage + +xWriteBitmapFile :: String -- pathname + -> XImage -> IO () + +-- direct image transfer + +xGetRawImage :: XDrawable -- drawable + -> XRect -- (x,y,width,height) + -> XPixel -- plane-mask + -> XImageFormat -- format + -> IO XImageData -- data + +xPutRawImage :: XDrawable -- drawable + -> XGcontext -- gcontext + -> XImageData -- data + -> Int -- depth + -> XRect -- (x,y,width,height) + -> Int -- left-pad + -> XImageFormat -- format + -> IO () + +-- FONTS + +-- opening fonts + +xOpenFont :: XDisplay -> String -> IO XFont +xCloseFont :: XFont -> IO () +xDiscardFontInfo :: XFont -> IO () + +-- listing fonts + +xFontPath :: XDisplay -> IO [String] +xListFontNames :: XDisplay -> String -- pattern + -> IO [String] +xListFonts :: XDisplay -> String -- pattern + -> IO [XFont] + +-- font attriburtes + +xFontAllCharExistsP :: XFont -> Bool +xFontAscent :: XFont -> Int +xFontDefaultChar :: XFont -> Int +xFontDescent :: XFont -> Int +xFontDirection :: XFont -> XDrawDirection +xFontDisplay :: XFont -> XDisplay +xFontEqual :: XFont -> XFont -> Int +xFontId :: XFont -> Int + +xFontMaxByte1 :: XFont -> Int +xFontMaxByte2 :: XFont -> Int +xFontMaxChar :: XFont -> Int +xFontMinByte1 :: XFont -> Int +xFontMinByte2 :: XFont -> Int +xFontMinChar :: XFont -> Int + +xFontName :: XFont -> String + +xFontMaxCharAscent :: XFont -> Int +xFontMaxCharAttributes :: XFont -> Int +xFontMaxCharDescent :: XFont -> Int +xFontMaxCharLeftBearing :: XFont -> Int +xFontMaxCharRightBearing :: XFont -> Int +xFontMaxCharWidth :: XFont -> Int +xFontMinCharAscent :: XFont -> Int +xFontMinCharAttributes :: XFont -> Int +xFontMinCharDescent :: XFont -> Int +xFontMinCharLeftBearing :: XFont -> Int +xFontMinCharRightBearing :: XFont -> Int +xFontMinCharWidth :: XFont -> Int + +-- char attributes + +xCharAscent :: XFont -> Int -> XMaybe Int +xCharAttributes :: XFont -> Int -> XMaybe Int +xCharDescent :: XFont -> Int -> XMaybe Int +xCharLeftBearing :: XFont -> Int -> XMaybe Int +xCharRightBearing :: XFont -> Int -> XMaybe Int +xCharWidth :: XFont -> Int -> XMaybe Int + +-- querying text size + +xTextWidth :: XFont -- font + -> String -- sequence + -> Int -- width + +-- COLORS + +-- creating colormaps + +xCreateColormap :: XVisualInfo -- visual + -> XWindow -- window + -> Bool -- alloc-p + -> IO XColormap + +xCopyColormapAndFree :: XColormap -> IO XColormap +xFreeColormap :: XColormap -> IO () + +-- installing colormaps + +xInstallColormap :: XColormap -> IO () +xInstalledColormaps :: XWindow -> IO [XColormap] +xUnInstallColormap :: XColormap -> IO () + +-- allocating colors + +xAllocColor :: XColormap -> XColor + -> IO (XPixel, -- pixel + XColor, -- screen-color + XColor) -- exact-color + +xAllocColorCells :: XColormap -- pixel + -> Int -- colors + -> Int -- planes + -> Bool -- contiguous + -> IO ([XPixel], -- pixels + [XPixel]) -- mask + +xAllocColorPlanes :: XColormap -- colormap + -> Int -- colors + -> Int -- reds + -> Int -- greens + -> Int -- blues + -> Bool -- contiguous-p + -> IO ([XPixel], -- pixel + XPixel, -- red-mask + XPixel, -- green-mask + XPixel) -- blue-mask + +xFreeColors :: XColormap -> [XPixel] -- pixels + -> XPixel -- plane-mask + -> IO () + +-- finding colors + +xLookupColor :: XColormap -> String -- name + -> IO (XColor, -- screen-color + XColor) -- exact-color + +xQueryColors :: XColormap -> [XPixel] -- pixels + -> IO [XColor] + +-- changing colors + +xStoreColor :: XColormap -> XPixel -- pixel + -> XColor -- color + -> IO () + +xStoreColors :: XColormap -- colormap + -> [(XPixel, XColor)] -- pixel-colors + -> IO () + +-- colormap attributes + +xColormapDisplay :: XColormap -> XDisplay +xColormapEqual :: XColormap -> XColormap -> Bool + +-- CURSORS + +xCreateCursor :: XPixmap -- source + -> (XMaybe XPixmap) -- mask + -> XPoint -- (x,y) + -> XColor -- foreground + -> XColor -- background + -> IO XCursor + +xCreateGlyphCursor :: (XFont, char) -- (src-font,src-char) + -> (XMaybe (XFont, Char)) -- (mask-font,mask-char) + -> XColor -- foreground + -> XColor -- background + -> IO XCursor + +xFreeCursor :: XCursor -> IO () + +xQueryBestCursor :: XSize -- (width,height) + -> XDisplay -> IO XSize + +xRecolorCursor :: XCursor -> XColor -- foreground + -> XColor -- background + -> IO () + +xCursorDisplay :: XCursor -> XDisplay +xCursorEqual :: XCursor -> XCursor -> Bool + +-- ATOMS, PROPERTIES, AND SELECTIONS + +-- atoms + +xAtomName :: XDisplay -> Int -- atom-id + -> XAtom + +xFindAtom :: XDisplay -> XAtom -- atom-name + -> IO (XMaybe Int) + +xInternAtom :: XDisplay -> XAtom -- atom-name + -> IO (XMaybe Int) + +-- properties + +xChangeProperty :: XWindow -- window + -> XAtom -- property + -> XProperty -- (data,type,format) + -> IO () + +xDeleteProperty :: XWindow -> XAtom -> IO () +xGetProperty :: XWindow -- window + -> XAtom -- property + -> IO XProperty -- (data,type,format) + +xListProperties :: XWindow -> IO [XAtom] +xRotateProperties :: XWindow -- window + -> [XAtom] -- properties + -> Int -- delta + -> IO () + +-- selections + +xConvertSelection :: XAtom -- selection + -> XAtom -- type + -> XWindow -- requester + -> XAtom -- property + -> (XMaybe XTime) -- time + -> IO () + +xSelectionOwner :: XDisplay -- display + -> XAtom -- selection + -> IO (XMaybe XWindow) + +xSetSelectionOwner :: XDisplay -- display + -> XAtom -- selection + -> (XMaybe XTime) -- time + -> XWindow -- owner + -> IO () + +-- EVENT + +-- Wait for the next event + +xGetEvent :: XDisplay -> IO XEvent + +-- managing the event queue + +xQueueEvent :: XDisplay -> XEvent -> Bool -- append-p + -> IO () + +xEventListen :: XDisplay -> IO Int -- # of events in queue + +-- sending events + +xSendEvent :: XWindow -- window + -> XEvent -- event key and slots + -> XEventMask -- event-mask + -> IO () + +-- pointer position + +xGlobalPointerPosition :: XDisplay -> IO XPoint +xPointerPosition :: XWindow -> IO (XMaybe XPoint) +xMotionEvents :: XWindow -> XTime -> XTime -> IO [XPoint] +xWarpPointer :: XWindow -> XPoint -> IO () + +-- keyboard input focus + +xSetInputFocus :: XDisplay -- display + -> XInputFocus -- focus + -> XInputFocus -- revert-to + -> (XMaybe XTime) -- time + -> IO () + +xInputFucus :: XDisplay -> IO (XInputFocus, -- focus + XInputFocus) -- revert-to + +-- grabbing the pointer + +xGrabPointer :: XWindow -- window + -> XEventMask -- event-mask + -> [XGrabAttribute] -- optional attributes + -> XMaybe XTime -- time + -> IO XGrabStatus + +xUngrabPointer :: XDisplay -> XMaybe XTime -> IO () + +xChangeActivePointerGrab :: XDisplay -> XEventMask -- event-mask + -> [XGrabAttribute] -- cursor + -> XMaybe XTime -> IO () + +-- grabbing a button + +xGrabButton :: XWindow -- window + -> Int -- button + -> XEventMask -- event-mask + -> XStateMask -- modifiers + -> [XGrabAttribute] -- optional attributes + -> IO () + +xUngrabButton :: XWindow -> Int -- button + -> XStateMask -- modifiers + -> IO () + +-- grabbing the keyboard + +xGrabKeyboard :: XWindow -- window + -> [XGrabAttribute] -- optional attributes + -> XMaybe XTime -- time + -> IO XGrabStatus + +xUngrabkeyboard :: XDisplay -> XMaybe XTime -> IO () + +-- grabbing a key + +xGrabKey :: XWindow -- window + -> Int -- key + -> XStateMask -- modifiers + -> [XGrabAttribute] -- optional attributes + -> IO () + +xUngrabKey :: XWindow -> Int -> XStateMask -- modifiers + -> IO () + +-- CONTROL FUNCTIONS + +-- grabbing the server + +xGrabServer :: XDisplay -> IO () +xUngrabServer :: XDisplay -> IO () + +-- pointer control + +xSetPointerAcceleration :: XDisplay -> Float -> IO () +xSetPointerThreshold :: XDisplay -> Float -> IO () +xPointerAcceleration :: XDisplay -> IO Float +xPointerThreshold :: XDisplay -> IO Float +xSetPointerMapping :: XDisplay -> [Int] -> IO () +xPointerMapping :: XDisplay -> IO [Int] + +-- keyboard control + +xBell :: XDisplay -> Int -> IO () + +xSetKeyboardKeyClickPercent :: XDisplay -> Int -> IO () +xSetKeyboardBellPercent :: XDisplay -> Int -> IO () +xSetKeyboardBellPitch :: XDisplay -> Int -> IO () +xSetKeyboardBellDuration :: XDisplay -> Int -> IO () +xSetKeyboardLed :: XDisplay -> Integer -> IO () +xSetKeyboardAutoRepeatMode :: XDisplay -> XBitVec -> IO () + +xKeyboardKeyClickPercent :: XDisplay -> IO Int +xKeyboardBellPercent :: XDisplay -> IO Int +xKeyboardBellPitch :: XDisplay -> IO Int +xKeyboardBellDuration :: XDisplay -> IO Int + +xKeyboardLed :: XDisplay -> IO Integer +xKeyboardAutoRepeatMode :: XDisplay -> IO XBitVec + +xModifierMapping :: XDisplay -> IO [[Int]] +xSetModifierMapping :: XDisplay -> [[Int]] -> IO (XMaybe ()) +xQueryKeymap :: XDisplay -> IO XBitVec + +-- keyboard mapping + +xChangeKeyboardMapping :: XDisplay -- display + -> XKeysymTable -- keysyms + -> IO () + +xKeyboardMapping :: XDisplay -- display + -> IO XKeysymTable -- mappings + +xKeycodeKeysym :: XDisplay -- display + -> Int -- keycode + -> Int -- keysym-index + -> IO XKeysym + +xKeysymCharacter :: XDisplay -- display + -> XKeysym -- keysym + -> XStateMask -- state + -> IO (XMaybe Char) + +xKeycodeCharacter :: XDisplay -- display + -> Int -- keycode + -> XStateMask -- state + -> IO (XMaybe Char) + +-- client termination + +xAddToSaveSet :: XWindow -> IO () +xCloseDownMode :: XDisplay -> IO XCloseDownMode +xSetCloseDownMode :: XDisplay -> XCloseDownMode -> IO () +xKillClient :: XDisplay -> Int -> IO () +xKillTemporaryClients :: XDisplay -> IO () +xRemoveFromSaveSet :: XWindow -> IO () + +-- managing host access + +xAccessControl :: XDisplay -> IO Bool +xSetAccessControl :: XDisplay -> Bool -> IO () +xAccessHosts :: XDisplay -> IO [String] +xAddAccessHost :: XDisplay -> String -> IO () +xRemoveAccessHost :: XDisplay -> String -> IO () + +-- screen saver + +xActivateScreenSaver :: XDisplay -> IO () +xResetScreenSaver :: XDisplay -> IO () + +xScreenSaver :: XDisplay -> IO XScreenSaver +xSetScreenSaver :: XDisplay -> XScreenSaver -> IO () + +{-# + + +xHandleError :: LispName("x-handle-error") +xError :: LispName("xlib::x-error") + +xEventType :: LispName("sel-event-type") + +xEventWindow :: LispName ("x-event-window") +xEventEventWindow :: LispName ("x-event-event-window") +xEventCode :: LispName ("x-event-code") +xEventPos :: LispName ("x-event-pos") +xEventState :: LispName ("x-event-state") +xEventTime :: LispName ("x-event-time") +xEventRoot :: LispName ("x-event-root") +xEventRootPos :: LispName ("x-event-root-pos") +xEventChild :: LispName ("x-event-child") +xEventSameScreenP :: LispName ("x-event-same-screen-p") +xEventHintP :: LispName ("x-event-hint-p") +xEventMode :: LispName ("x-event-mode") +xEventKind :: LispName ("x-event-kind") +xEventFocusP :: LispName ("x-event-focus-p") +xEventKeymap :: LispName ("x-event-keymap") +xEventRequest :: LispName ("x-event-request") +xEventStart :: LispName ("x-event-start") +xEventCount :: LispName ("x-event-count") +xEventRect :: LispName ("x-event-rect") +xEventDrawable :: LispName ("x-event-drawable") +xEventXGraphFun :: LispName ("x-event-graph-fun") +xEventPlace :: LispName ("x-event-place") +xEventBorderWidth :: LispName ("x-event-border-width") +xEventAboveSibling :: LispName ("x-event-above-sibling") +xEventOverrideRedirectP :: LispName ("x-event-override-redirect-p") +xEventParent :: LispName ("x-event-parent") +xEventConfigureP :: LispName ("x-event-configure-p") +xEventVisibility :: LispName ("x-event-state") +xEventNewP :: LispName ("x-event-new-p") +xEventInstalledP :: LispName ("x-event-installed-p") +xEventStackMode :: LispName ("x-event-stack-mode") +xEventValueMask :: LispName ("x-event-value-mask") +xEventSize :: LispName ("x-event-size") +xEventMessage :: LispName ("x-event-message") +xEventPropertyState :: LispName ("x-event-state") +xEventAtom :: LispName ("x-event-atom") +xEventSelection :: LispName ("x-event-selection") +xEventTarget :: LispName ("x-event-target") +xEventProperty :: LispName ("x-event-property") +xEventRequestor :: LispName ("x-event-requestor") + + +xSetEventMaskKey :: LispName ("x-set-event-mask-key") +xClearEventMaskKey :: LispName ("x-clear-event-mask-key") +xTestEventMaskKey :: LispName ("x-test-event-mask-key") + +xSetStateMaskKey :: LispName ("x-set-state-mask-key") +xClearStateMaskKey :: LispName ("x-clear-state-mask-key") +xTestStateMaskKey :: LispName ("x-test-state-mask-key") + +-- DISPLAYS + +-- open + +xOpenDisplay :: LispName("x-open-display") + +-- display attributes + +xDisplayAuthorizationData :: LispName("xlib:display-authorization-data") +xDisplayAuthorizationName :: LispName("xlib:display-authorization-name") +xDisplayBitmapFormat :: LispName("xlib:display-bitmap-format") +xDisplayByteOrder :: LispName("xlib:display-byte-order") +xDisplayDisplay :: LispName("xlib:display-display") +xSetDisplayErrorHandler :: LispName("x-set-display-error-handler") +xDisplayImageLsbFirstP :: LispName("xlib:display-image-lsb-first-p") +xDisplayMaxKeycode :: LispName("xlib:display-max-keycode") +xDisplayMaxRequestLength :: LispName("xlib:display-max-request-length") +xDisplayMinKeycode :: LispName("xlib:display-min-keycode") +xDisplayMotionBufferSize :: LispName("xlib:display-motion-buffer-size") +xDisplayPixmapFormats :: LispName("xlib:display-pixmap-formats") +xDisplayProtocolMajorVersion :: LispName("xlib:display-protocol-major-version") +xDisplayProtocolMinorVersion :: LispName("xlib:display-protocol-minor-version") +xDisplayResourceIdBase :: LispName("xlib:display-resource-id-base") +xDisplayResourceIdMask :: LispName("xlib:display-resource-id-mask") +xDisplayRoots :: LispName("xlib:display-roots") +xDisplayVendorName :: LispName("xlib:display-vendor-name") +xDisplayReleaseNumber :: LispName("xlib:display-release-number") + +-- output buffer + +xDisplayAfterFunction :: LispName("xlib:display-after-function") +xSetDisplayAfterFunction :: LispName("x-set-display-after-function") +xDisplayForceOutput :: LispName("xlib:display-force-output") +xDisplayFinishOutput :: LispName("xlib:display-finish-output") + +-- close + +xCloseDisplay :: LispName("xlib:close-display") + +-- SCREENS + +xScreenBackingStores :: LispName("xlib:screen-backing-stores") +xScreenBlackPixel :: LispName("xlib:screen-black-pixel") +xScreenDefaultColormap :: LispName("xlib:screen-default-colormap") +xScreenDepths :: LispName("x-screen-depths") +xScreenEventMaskAtOpen :: LispName("xlib:screen-event-mask-at-open") +xScreenSize :: LispName("x-screen-size") +xScreenMMSize :: LispName("x-screen-mmsize") +xScreenMaxInstalledMaps :: LispName("xlib:screen-max-installed-maps") +xScreenMinInstalledMaps :: LispName("xlib:screen-min-installed-maps") +xScreenRoot :: LispName("xlib:screen-root") +xScreenRootDepth :: LispName("xlib:screen-root-depth") +xScreenRootVisual :: LispName("xlib:screen-root-visual") +xScreenSaveUndersP :: LispName("xlib:screen-save-unders-p") +xScreenWhitePixel :: LispName("xlib:screen-white-pixel") + +-- WINDOWS AND PIXMAPS + +-- drawables + +xDrawableDisplay :: LispName("xlib:drawable-display") +xDrawableEqual :: LispName("xlib:drawable-equal") +xDrawableId :: LispName("xlib:drawable-id") + +-- creating windows + +xCreateWindow :: LispName("x-create-window") + +-- window attributes + +xWindowBorderWidth :: LispName("xlib:drawable-border-width") +xSetWindowBorderWidth :: LispName("x-set-drawable-border-width") + +xDrawableDepth :: LispName("xlib:drawable-depth") + +xDrawableSize :: LispName("x-drawable-size") +xDrawableResize :: LispName("x-drawable-resize") + +xWindowPos :: LispName("x-window-pos") +xWindowMove :: LispName("x-window-move") + +xWindowAllEventMasks :: LispName("xlib:window-all-event-masks") + +xSetWindowBackground :: LispName("x-set-window-background") + +xWindowBackingPixel :: LispName("xlib:window-backing-pixel") +xSetWindowBackingPixel :: LispName("x-set-window-backing-pixel") + +xWindowBackingPlanes :: LispName("xlib:window-backing-planes") +xSetWindowBackingPlanes :: LispName("x-set-window-backing-planes") + +xWindowBackingStore :: LispName("xlib:window-backing-store") +xSetWindowBackingStore :: LispName("x-set-window-backing-store") + +xWindowBitGravity :: LispName("xlib:window-bit-gravity") +xSetWindowBitGravity :: LispName("x-set-window-bit-gravity") + +xSetWindowBorder :: LispName("x-set-window-border") + +xWindowClass :: LispName("xlib:window-class") + +xWindowColorMap :: LispName("xlib:window-colormap") +xSetWindowColorMap :: LispName("x-set-window-colormap") +xWindowColormapInstalledP :: LispName("xlib:window-colormap-installed-p") + +xSetWindowCursor :: LispName("x-set-window-cursor") + +xWindowDisplay :: LispName("xlib:window-display") + +xWindowDoNotPropagateMask :: LispName("xlib:window-do-not-propagate-mask") +xSetWindowDoNotPropagateMask :: LispName("x-set-window-do-not-propagate-mask") + +xWindowEqual :: LispName("xlib:window-equal") + +xWindowEventMask :: LispName("xlib:window-event-mask") +xSetWindowEventMask :: LispName("x-set-window-event-mask") + +xWindowGravity :: LispName("xlib:window-gravity") +xSetWindowGravity :: LispName("x-set-window-gravity") + +xWindowId :: LispName("xlib:window-id") + +xWindowMapState :: LispName("xlib:window-map-state") + +xWindowOverrideRedirect :: LispName("xlib:window-override-redirect") +xSetWindowOverrideRedirect :: LispName("x-set-window-override-redirect") + +xSetWindowPriority :: LispName("x-set-window-priority") + +xWindowSaveUnder :: LispName("xlib:window-save-under") +xSetWindowSaveUnder :: LispName("x-set-window-save-under") +xWindowVisual :: LispName("xlib:window-visual") + +-- stacking order + +xCirculateWindowDown :: LispName("xlib:circulate-window-down") +xCirculateWindowUp :: LispName("xlib:circulate-window-up") + +-- window hierarchy + +xDrawableRoot :: LispName("xlib:drawable-root") +xQueryTree :: LispName("x-query-tree") + +xReparentWindow :: LispName("x-reparent-window") + +xTranslateCoordinates :: LispName("x-translate-coordinates") + +-- mapping windows + +xMapWindow :: LispName("xlib:map-window") +xMapSubwindows :: LispName("xlib:map-subwindows") +xUnmapWindow :: LispName("xlib:unmap-window") +xUnmapSubwindows :: LispName("xlib:unmap-subwindows") + +-- destroying windows + +xDestroyWindow :: LispName("xlib:destroy-window") +xDestroySubwindows :: LispName("xlib:destroy-subwindows") + +-- pixmaps + +xCreatePixmap :: LispName("x-create-pixmap") +xFreePixmap :: LispName("xlib:free-pixmap") +xPixmapDisplay :: LispName("xlib:pixmap-display") +xPixmapEqual :: LispName("xlib:pixmap-equal") + +-- GRAPHICS CONTEXTS + +xCreateGcontext :: LispName("x-create-gcontext") +xUpdateGcontext :: LispName("x-update-gcontext") +xFreeGcontext :: LispName("xlib:free-gcontext") + +xGcontextDisplay :: LispName("xlib:gcontext-display") +xGcontextEqual :: LispName("xlib:gcontext-equal") + +xGcontextId :: LispName("xlib:gcontext-id") + +xQueryBestStipple :: LispName("x-query-best-stipple") +xQueryBestTile :: LispName("x-query-best-tile") + +xCopyGcontext :: LispName("xlib:copy-gcontext") + +-- GRAPHICS OPERATIONS + +xClearArea :: LispName("x-clear-area") +xCopyArea :: LispName("x-copy-area") +xCopyPlane :: LispName("x-copy-plane") +xDrawPoint :: LispName("x-draw-point") +xDrawPoints :: LispName("x-draw-points") +xDrawLine :: LispName("x-draw-line") +xDrawLines :: LispName("x-draw-lines") +xDrawSegments :: LispName("x-draw-segments") +xDrawRectangle :: LispName("x-draw-rectangle") +xDrawRectangles :: LispName("x-draw-rectangles") +xDrawArc :: LispName("x-draw-arc") +xDrawArcs :: LispName("x-draw-arcs") +xDrawGlyph :: LispName("x-draw-glyph") +xDrawGlyphs :: LispName("x-draw-glyphs") +xDrawImageGlyph :: LispName("x-draw-image-glyph") +xDrawImageGlyphs :: LispName("x-draw-image-glyphs") + +-- IMAGES + +xImageBlueMask :: LispName("xlib:image-blue-mask") +xImageDepth :: LispName("xlib:image-depth") +xImageGreenMask :: LispName("xlib:image-green-mask") +xImageSize :: LispName("x-image-size") +xImageName :: LispName("x-image-name") +xSetImageName :: LispName("x-set-image-name") +xImageRedMask :: LispName("xlib:image-red-mask") +xImageHotSpot :: LispName("x-image-hot-spot") +xSetImageHotSpot :: LispName("x-set-image-hot-spot") + +-- XY-format images + +xImageXYBitmaps :: LispName("xlib:image-xy-bitmap-list") +xSetImageXYBitmaps :: LispName("x-set-image-xy-bitmap-list") + +-- Z-format images + +xImageZBitsPerPixel :: LispName("xlib:image-z-bits-per-pixel") +xsetImageZBitsPerPixel :: LispName("x-set-image-z-bits-per-pixel") +xImageZPixarray :: LispName("xlib:image-z-pixarray") +xSetImageZPixarray :: LispName("x-set-image-z-pixarray") + +-- image functions + +xCreateImage :: LispName("x-create-image") +xCopyImage :: LispName("x-copy-image") +xGetImage :: LispName("x-get-image") +xPutImage :: LispName("x-put-image") + +-- image files + +xReadBitmapFile :: LispName("xlib:read-bitmap-file") +xWriteBitmapFile :: LispName("xlib:write-bitmap-file") + +-- direct image transfer + +xGetRawImage :: LispName("x-get-raw-image") +xPutRawImage :: LispName("x-put-raw-image") + +-- FONTS + +-- opening fonts + +xOpenFont :: LispName ("xlib:open-font") +xCloseFont :: LispName ("xlib:close-font") +xDiscardFontInfo :: LispName ("xlib:discard-font-info") + +-- listing fonts + +xFontPath :: LispName ("xlib:font-path") +xListFontNames :: LispName ("xlib:list-font-names") +xListFonts :: LispName ("xlib:list-fonts") + +-- font attriburtes + +xFontAllCharExistsP :: LispName ("xlib:font-all-chars-exist-p") +xFontAscent :: LispName ("xlib:font-ascent") +xFontDefaultChar :: LispName ("xlib:font-default-char") +xFontDescent :: LispName ("xlib:font-descent") +xFontDirection :: LispName ("xlib:font-direction") +xFontDisplay :: LispName ("xlib:font-display") +xFontEqual :: LispName ("xlib:font-equal") +xFontId :: LispName ("xlib:font-id") + +xFontMaxByte1 :: LispName ("xlib:font-max-byte1") +xFontMaxByte2 :: LispName ("xlib:font-max-byte2") +xFontMaxChar :: LispName ("xlib:font-max-char") +xFontMinByte1 :: LispName ("xlib:font-min-byte1") +xFontMinByte2 :: LispName ("xlib:font-min-byte2") +xFontMinChar :: LispName ("xlib:font-min-char") + +xFontName :: LispName ("x-font-name") + +xFontMaxCharAscent :: LispName ("xlib:max-char-ascent") +xFontMaxCharAttributes :: LispName ("xlib:max-char-attributes") +xFontMaxCharDescent :: LispName ("xlib:max-char-descent") +xFontMaxCharLeftBearing :: LispName ("xlib:max-char-left-bearing") +xFontMaxCharRightBearing :: LispName ("xlib:max-char-right-bearing") +xFontMaxCharWidth :: LispName ("xlib:max-char-width") +xFontMinCharAscent :: LispName ("xlib:min-char-ascent") +xFontMinCharAttributes :: LispName ("xlib:min-char-attributes") +xFontMinCharDescent :: LispName ("xlib:min-char-descent") +xFontMinCharLeftBearing :: LispName ("xlib:min-char-left-bearing") +xFontMinCharRightBearing :: LispName ("xlib:min-char-right-bearing") +xFontMinCharWidth :: LispName ("xlib:min-char-width") + +-- char attributes + +xCharAscent :: LispName ("xlib:char-ascent") +xCharAttributes :: LispName ("xlib:char-attributes") +xCharDescent :: LispName ("xlib:char-descent") +xCharLeftBearing :: LispName ("xlib:char-left-bearing") +xCharRightBearing :: LispName ("xlib:char-right-bearing") +xCharWidth :: LispName ("xlib:char-width") + +-- querying text size + +xTextWidth :: LispName ("xlib:text-width") + +-- COLORS + +-- creating colormaps + +xCreateColormap :: LispName ("xlib:create-colormap") +xCopyColormapAndFree :: LispName ("xlib:copy-colormap-and-free") +xFreeColormap :: LispName ("xlib:free-colormap") + +-- installing colormaps + +xInstallColormap :: LispName ("xlib:install-colormap") +xInstalledColormaps :: LispName ("xlib:installed-colormaps") +xUnInstallColormap :: LispName ("xlib:uninstall-colormap") + +-- allocating colors + +xAllocColor :: LispName ("x-alloc-color") +xAllocColorCells :: LispName ("x-alloc-color-cells") +xAllocColorPlanes :: LispName ("x-alloc-color-planes") + +xFreeColors :: LispName ("xlib:free-colors") + +-- finding colors + +xLookupColor :: LispName ("x-lookup-color") +xQueryColors :: LispName ("xlib:query-colors") + +-- changing colors + +xStoreColor :: LispName ("xlib:store-color") +xStoreColors :: LispName ("x-store-colors") + +-- colormap attributes + +xColormapDisplay :: LispName ("xlib:colormap-display") +xColormapEqual :: LispName ("xlib:colormap-equal") + +-- CURSORS + +xCreateCursor :: LispName ("x-create-cursor") +xCreateGlyphCursor :: LispName ("x-create-glyph-cursor") +xFreeCursor :: LispName ("xlib:free-cursor") + +xQueryBestCursor :: LispName ("x-query-best-cursor") +xRecolorCursor :: LispName ("xlib:recolor-cursor") + +xCursorDisplay :: LispName ("xlib:cursor-display") +xCursorEqual :: LispName ("xlib:cursor-equal") + +-- ATOMS, PROPERTIES, AND SELECTIONS + +-- atoms + +xAtomName :: LispName ("xlib:atom-name") +xFindAtom :: LispName ("xlib:find-atom") +xInternAtom :: LispName ("xlib:intern-atom") + +-- properties + +xChangeProperty :: LispName ("x-change-property") +xDeleteProperty :: LispName ("xlib:delete-property") +xGetProperty :: LispName ("x-get-property") +xListProperties :: LispName ("xlib:list-properties") +xRotateProperties :: LispName ("xlib:rotate-properties") + +-- selections + +xConvertSelection :: LispName ("x-convert-selection") +xSelectionOwner :: LispName ("xlib:selection-owner") +xSetSelectionOwner :: LispName ("x-set-selection-owner") + +-- EVENT + +-- Wait for the next event + +xGetEvent :: LispName ("x-get-event") + +-- managing the event queue + +xQueueEvent :: LispName ("x-queue-event") +xEventListen :: LispName ("x-event-listen") + +-- sending events + +xSendEvent :: LispName ("x-send-event") + +-- pointer position + +xGlobalPointerPosition :: LispName ("x-global-pointer-position") +xPointerPosition :: LispName ("x-pointer-position") +xMotionEvents :: LispName ("x-motion-events") +xWarpPointer :: LispName ("x-warp-pointer") + +-- keyboard input focus + +xSetInputFocus :: LispName ("x-set-input-focus") +xInputFucus :: LispName ("x-input-focus") + +-- grabbing the pointer + +xGrabPointer :: LispName ("x-grab-pointer") +xUngrabPointer :: LispName ("x-ungrab-pointer") +xChangeActivePointerGrab :: LispName ("x-change-active-pointer-grab") + +-- grabbing a button + +xGrabButton :: LispName ("x-grab-button") +xUngrabButton :: LispName ("x-ungrab-button") + +-- grabbing the keyboard + +xGrabKeyboard :: LispName ("x-grab-keyboard") +xUngrabkeyboard :: LispName ("x-ungrab-keyboard") + +-- grabbing a key + +xGrabKey :: LispName ("x-grab-key") +xUngrabKey :: LispName ("x-ungrab-key") + +-- CONTROL FUNCTIONS + +-- grabbing the server + +xGrabServer :: LispName ("xlib:grab-server") +xUngrabServer :: LispName ("xlib:ungrab-server") + +-- pointer control + +xSetPointerAcceleration :: LispName ("x-set-pointer-acceleration") +xSetPointerThreshold :: LispName ("x-set-pointer-threshold") +xPointerAcceleration :: LispName ("x-pointer-acceleration") +xPointerThreshold :: LispName ("x-pointer-threshold") +xSetPointerMapping :: LispName ("x-set-pointer-mapping") +xPointerMapping :: LispName ("xlib:pointer-mapping") + +-- keyboard control + +xBell :: LispName ("xlib:bell") + +xSetKeyboardKeyClickPercent :: LispName ("x-set-keyboard-key-click-percent") +xSetKeyboardBellPercent :: LispName ("x-set-keyboard-bell-percent") +xSetKeyboardBellPitch :: LispName ("x-set-keyboard-bell-pitch") +xSetKeyboardBellDuration :: LispName ("x-set-keyboard-bell-duration") +xSetKeyboardLed :: LispName ("x-set-keyboard-led") +xSetKeyboardAutoRepeatMode :: LispName ("x-set-keyboard-auto-repeat-mode") + +xKeyboardKeyClickPercent :: LispName ("x-keyboard-key-click-percent") +xKeyboardBellPercent :: LispName ("x-keyboard-bell-percent") +xKeyboardBellPitch :: LispName ("x-keyboard-bell-pitch") +xKeyboardBellDuration :: LispName ("x-keyboard-bell-duration") +xKeyboardLed :: LispName ("x-keyboard-led") +xKeyboardAutoRepeatMode :: LispName ("x-keyboard-auto-repeat-mode") + +xModifierMapping :: LispName ("x-modifier-mapping") +xSetModifierMapping :: LispName ("x-set-modifier-mapping") +xQueryKeymap :: LispName ("xlib:query-keymap") + +-- keyboard mapping + +xChangeKeyboardMapping :: LispName ("xlib:change-keyboard-mapping") +xKeyboardMapping :: LispName ("xlib:keyboard-mapping") + +xKeycodeKeysym :: LispName ("xlib:keycode->keysym") +xKeysymCharacter :: LispName ("x-keysym-character") +xKeycodeCharacter :: LispName ("x-keycode-character") + +-- client termination + +xAddToSaveSet :: LispName ("xlib:add-to-save-set") +xCloseDownMode :: LispName ("xlib:close-down-mode") +xSetCloseDownMode :: LispName ("x-set-close-down-mode") +xKillClient :: LispName ("xlib:kill-client") +xKillTemporaryClients :: LispName ("xlib:kill-temporary-clients") +xRemoveFromSaveSet :: LispName ("xlib:remove-from-save-set") + +-- managing host access + +xAccessControl :: LispName ("xlib:access-control") +xSetAccessControl :: LispName ("x-set-access-control") +xAccessHosts :: LispName ("xlib:access-hosts") +xAddAccessHost :: LispName ("xlib:add-access-host") +xRemoveAccessHost :: LispName ("xlib:remove-access-host") + +-- screen saver + +xActivateScreenSaver :: LispName ("xlib:activate-screen-saver") +xResetScreenSaver :: LispName ("xlib:reset-screen-saver") +xScreenSaver :: LispName ("x-screen-saver") +xSetScreenSaver :: LispName ("x-set-screen-saver") + +#-} + +data XMArray a + +xMArrayCreate :: [a] -> IO (XMArray a) +xMArrayLookup :: XMArray a -> Int -> IO a +xMArrayUpdate :: XMArray a -> Int -> a -> IO () +xMArrayLength :: XMArray a -> Int + +{-# +xMArrayCreate :: LispName("x-mutable-array-create") +xMArrayLookup :: LispName("x-mutable-array-lookup") +xMArrayUpdate :: LispName("x-mutable-array-update") +xMArrayLength :: LispName("x-mutable-array-length") +#-} + + +xprint :: a -> IO () +{-# +xprint :: LispName ("x-print") +#-} + +-- decoded time format: +-- ([second, minute, hour, date, month, year, day-of-week], +-- daylight-saving-time-p) +-- time format to encode: +-- [second, minute, hour, date, month, year] + +data TimeZone = WestOfGMT Int {-# STRICT #-} + | CurrentZone + +getTime :: IO Integer +getTimeZone :: IO Int +decodeTime :: Integer -> TimeZone -> ([Int], Bool) +encodeTime :: [Int] -> TimeZone -> Integer +getRunTime :: IO Float +getElapsedTime :: IO Float +sleep :: Int -> IO () + +{-# +ImportLispType (TimeZone (WestOfGMT ("number?", "identity", "identity"))) +ImportLispType (TimeZone (CurrentZone ("null?", "'()"))) + +getTime :: LispName("lisp:get-universal-time") +getTimeZone :: LispName("get-time-zone") +decodeTime :: LispName("decode-time") +encodeTime :: LispName("encode-time") +getRunTime :: LispName("get-run-time") +getElapsedTime :: LispName("get-elapsed-time") +sleep :: LispName("lisp:sleep") + +#-} + +xWmName :: XWindow -> IO String +xSetWmName :: XWindow -> String -> IO () + +xWmIconName :: XWindow -> IO String +xSetWmIconName :: XWindow -> String -> IO () + +{-# +xWmName :: LispName ("xlib:wm-name") +xSetWmName :: LispName ("x-set-wm-name") + +xWmIconName :: LispName ("xlib:wm-icon-name") +xSetWmIconName :: LispName ("x-set-wm-icon-name") +#-} diff --git a/progs/lib/X11/xlibprims.hu b/progs/lib/X11/xlibprims.hu new file mode 100644 index 0000000..38138d4 --- /dev/null +++ b/progs/lib/X11/xlibprims.hu @@ -0,0 +1,5 @@ +:output $LIBRARYBIN/ +:stable +:o= all +xlibclx.scm +xlibprims.hi diff --git a/progs/lib/cl/README b/progs/lib/cl/README new file mode 100644 index 0000000..8164257 --- /dev/null +++ b/progs/lib/cl/README @@ -0,0 +1,2 @@ +This directory contains some libraries which allow you to use various +Common Lisp primitives from Haskell. diff --git a/progs/lib/cl/logop-prims.hi b/progs/lib/cl/logop-prims.hi new file mode 100644 index 0000000..2b120bb --- /dev/null +++ b/progs/lib/cl/logop-prims.hi @@ -0,0 +1,78 @@ +-- logop-prims.hi -- interface to logical operations on numbers +-- +-- author : Sandra Loosemore +-- date : 19 June 1993 +-- + +interface LogOpPrims where + +logiorInteger :: Integer -> Integer -> Integer +logxorInteger :: Integer -> Integer -> Integer +logandInteger :: Integer -> Integer -> Integer +logeqvInteger :: Integer -> Integer -> Integer +lognandInteger :: Integer -> Integer -> Integer +lognorInteger :: Integer -> Integer -> Integer +logandc1Integer :: Integer -> Integer -> Integer +logandc2Integer :: Integer -> Integer -> Integer +logorc1Integer :: Integer -> Integer -> Integer +logorc2Integer :: Integer -> Integer -> Integer +lognotInteger :: Integer -> Integer +logtestInteger :: Integer -> Integer -> Integer +logbitpInteger :: Int -> Integer -> Integer +ashInteger :: Integer -> Int -> Integer +logcountInteger :: Integer -> Int +integerLengthInteger :: Integer -> Int + +logiorInt :: Int -> Int -> Int +logxorInt :: Int -> Int -> Int +logandInt :: Int -> Int -> Int +logeqvInt :: Int -> Int -> Int +lognandInt :: Int -> Int -> Int +lognorInt :: Int -> Int -> Int +logandc1Int :: Int -> Int -> Int +logandc2Int :: Int -> Int -> Int +logorc1Int :: Int -> Int -> Int +logorc2Int :: Int -> Int -> Int +lognotInt :: Int -> Int +logtestInt :: Int -> Int -> Int +logbitpInt :: Int -> Int -> Int +ashInt :: Int -> Int -> Int +logcountInt :: Int -> Int +integerLengthInt :: Int -> Int + +{-# +logiorInteger :: LispName("logop.logior-integer"), Complexity(4) +logxorInteger :: LispName("logop.logxor-integer"), Complexity(4) +logandInteger :: LispName("logop.logand-integer"), Complexity(4) +logeqvInteger :: LispName("logop.logeqv-integer"), Complexity(4) +lognandInteger :: LispName("logop.lognand-integer"), Complexity(4) +lognorInteger :: LispName("logop.lognor-integer"), Complexity(4) +logandc1Integer :: LispName("logop.logandc1-integer"), Complexity(4) +logandc2Integer :: LispName("logop.logandc2-integer"), Complexity(4) +logorc1Integer :: LispName("logop.logorc1-integer"), Complexity(4) +logorc2Integer :: LispName("logop.logorc2-integer"), Complexity(4) +lognotInteger :: LispName("logop.lognot-integer"), Complexity(4) +logtestInteger :: LispName("logop.logtest-integer"), Complexity(4) +logbitpInteger :: LispName("logop.logbitp-integer"), Complexity(4) +ashInteger :: LispName("logop.ash-integer"), Complexity(4) +logcountInteger :: LispName("logop.logcount-integer"), Complexity(4) +integerLengthInteger :: LispName("logop.integer-length-integer"), Complexity(4) + +logiorInt :: LispName("logop.logior-int"), Complexity(2) +logxorInt :: LispName("logop.logxor-int"), Complexity(2) +logandInt :: LispName("logop.logand-int"), Complexity(2) +logeqvInt :: LispName("logop.logeqv-int"), Complexity(2) +lognandInt :: LispName("logop.lognand-int"), Complexity(2) +lognorInt :: LispName("logop.lognor-int"), Complexity(2) +logandc1Int :: LispName("logop.logandc1-int"), Complexity(2) +logandc2Int :: LispName("logop.logandc2-int"), Complexity(2) +logorc1Int :: LispName("logop.logorc1-int"), Complexity(2) +logorc2Int :: LispName("logop.logorc2-int"), Complexity(2) +lognotInt :: LispName("logop.lognot-int"), Complexity(2) +logtestInt :: LispName("logop.logtest-int"), Complexity(2) +logbitpInt :: LispName("logop.logbitp-int"), Complexity(2) +ashInt :: LispName("logop.ash-int"), Complexity(2) +logcountInt :: LispName("logop.logcount-int"), Complexity(2) +integerLengthInt :: LispName("logop.integer-length-int"), Complexity(2) +#-} + diff --git a/progs/lib/cl/logop-prims.scm b/progs/lib/cl/logop-prims.scm new file mode 100644 index 0000000..b846836 --- /dev/null +++ b/progs/lib/cl/logop-prims.scm @@ -0,0 +1,81 @@ +;;; logop-prims.scm -- primitives for logical operations on numbers +;;; +;;; author : Sandra Loosemore +;;; date : 19 Jun 1993 +;;; + + +;;; Integer operations +;;; Note that bit counts are still guaranteed to be fixnums.... + +(define-syntax (logop.logior-integer i1 i2) + `(the integer (lisp:logior (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logxor-integer i1 i2) + `(the integer (lisp:logxor (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logand-integer i1 i2) + `(the integer (lisp:logand (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logeqv-integer i1 i2) + `(the integer (lisp:logeqv (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.lognand-integer i1 i2) + `(the integer (lisp:lognand (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.lognor-integer i1 i2) + `(the integer (lisp:lognor (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logandc1-integer i1 i2) + `(the integer (lisp:logandc1 (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logandc2-integer i1 i2) + `(the integer (lisp:logandc2 (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logorc1-integer i1 i2) + `(the integer (lisp:logorc1 (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logorc2-integer i1 i2) + `(the integer (lisp:logorc2 (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.lognot-integer i1) + `(the integer (lisp:lognot (the integer ,i1)))) +(define-syntax (logop.logtest-integer i1 i2) + `(the integer (lisp:logtest (the integer ,i1) (the integer ,i2)))) +(define-syntax (logop.logbitp-integer i1 i2) + `(the integer (lisp:logbitp (the fixnum ,i1) (the integer ,i2)))) +(define-syntax (logop.ash-integer i1 i2) + `(the integer (lisp:ash (the integer ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logcount-integer i1) + `(the fixnum (lisp:logcount (the integer ,i1)))) +(define-syntax (logop.integer-length-integer i1) + `(the fixnum (lisp:integer-length (the integer ,i1)))) + + +;;; Fixnum operations + +(define-syntax (logop.logior-int i1 i2) + `(the fixnum (lisp:logior (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logxor-int i1 i2) + `(the fixnum (lisp:logxor (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logand-int i1 i2) + `(the fixnum (lisp:logand (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logeqv-int i1 i2) + `(the fixnum (lisp:logeqv (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.lognand-int i1 i2) + `(the fixnum (lisp:lognand (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.lognor-int i1 i2) + `(the fixnum (lisp:lognor (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logandc1-int i1 i2) + `(the fixnum (lisp:logandc1 (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logandc2-int i1 i2) + `(the fixnum (lisp:logandc2 (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logorc1-int i1 i2) + `(the fixnum (lisp:logorc1 (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logorc2-int i1 i2) + `(the fixnum (lisp:logorc2 (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.lognot-int i1) + `(the fixnum (lisp:lognot (the fixnum ,i1)))) +(define-syntax (logop.logtest-int i1 i2) + `(the fixnum (lisp:logtest (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logbitp-int i1 i2) + `(the fixnum (lisp:logbitp (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.ash-int i1 i2) + `(the fixnum (lisp:ash (the fixnum ,i1) (the fixnum ,i2)))) +(define-syntax (logop.logcount-int i1) + `(the fixnum (lisp:logcount (the fixnum ,i1)))) +(define-syntax (logop.integer-length-int i1) + `(the fixnum (lisp:integer-length (the fixnum ,i1)))) + + + diff --git a/progs/lib/cl/logop.hs b/progs/lib/cl/logop.hs new file mode 100644 index 0000000..1d0f9ba --- /dev/null +++ b/progs/lib/cl/logop.hs @@ -0,0 +1,63 @@ +-- logop.hs -- logical operations on numbers +-- +-- author : Sandra Loosemore +-- date : 19 June 1993 +-- + +module LogOp where + +import LogOpPrims -- from logop-prims.hi + +class LogOperand a where + logior :: a -> a -> a + logxor :: a -> a -> a + logand :: a -> a -> a + logeqv :: a -> a -> a + lognand :: a -> a -> a + lognor :: a -> a -> a + logandc1 :: a -> a -> a + logandc2 :: a -> a -> a + logorc1 :: a -> a -> a + logorc2 :: a -> a -> a + lognot :: a -> a + logtest :: a -> a -> a + logbitp :: Int -> a -> a + ash :: a -> Int -> a + logcount :: a -> Int + integerLength :: a -> Int + +instance LogOperand Integer where + logior = logiorInteger + logxor = logxorInteger + logand = logandInteger + logeqv = logeqvInteger + lognand = lognandInteger + lognor = lognorInteger + logandc1 = logandc1Integer + logandc2 = logandc2Integer + logorc1 = logorc1Integer + logorc2 = logorc2Integer + lognot = lognotInteger + logtest = logtestInteger + logbitp = logbitpInteger + ash = ashInteger + logcount = logcountInteger + integerLength = integerLengthInteger + +instance LogOperand Int where + logior = logiorInt + logxor = logxorInt + logand = logandInt + logeqv = logeqvInt + lognand = lognandInt + lognor = lognorInt + logandc1 = logandc1Int + logandc2 = logandc2Int + logorc1 = logorc1Int + logorc2 = logorc2Int + lognot = lognotInt + logtest = logtestInt + logbitp = logbitpInt + ash = ashInt + logcount = logcountInt + integerLength = integerLengthInt diff --git a/progs/lib/cl/logop.hu b/progs/lib/cl/logop.hu new file mode 100644 index 0000000..cfe8209 --- /dev/null +++ b/progs/lib/cl/logop.hu @@ -0,0 +1,5 @@ +:output $LIBRARYBIN/ +:o= all +logop.hs +logop-prims.scm +logop-prims.hi diff --git a/progs/lib/cl/maybe.hs b/progs/lib/cl/maybe.hs new file mode 100644 index 0000000..8ce01e5 --- /dev/null +++ b/progs/lib/cl/maybe.hs @@ -0,0 +1,12 @@ +-- maybe.hs -- "maybe" type +-- +-- author : Sandra Loosemore +-- date : 22 June 1993 +-- + +module Maybe where + +data Maybe a = Some a | Null + +{-# ImportLispType (Maybe(Some("identity", "identity", "identity"), + Null("not", "'#f"))) #-} diff --git a/progs/lib/cl/maybe.hu b/progs/lib/cl/maybe.hu new file mode 100644 index 0000000..2115c71 --- /dev/null +++ b/progs/lib/cl/maybe.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +maybe.hs diff --git a/progs/lib/cl/random-prims.hi b/progs/lib/cl/random-prims.hi new file mode 100644 index 0000000..e66d802 --- /dev/null +++ b/progs/lib/cl/random-prims.hi @@ -0,0 +1,20 @@ +-- random-prims.hi -- interface file to random number primitives +-- +-- author : Sandra Loosemore +-- date : 22 June 1993 +-- + + +interface RandomPrims where + +randomInt :: Int -> IO Int +randomInteger :: Integer -> IO Integer +randomFloat :: Float -> IO Float +randomDouble :: Double -> IO Double + +{-# +randomInt :: LispName("lisp:random"), Complexity(5) +randomInteger :: LispName("lisp:random"), Complexity(5) +randomFloat :: LispName("lisp:random"), Complexity(5) +randomDouble :: LispName("lisp:random"), Complexity(5) +#-} diff --git a/progs/lib/cl/random.hs b/progs/lib/cl/random.hs new file mode 100644 index 0000000..93d26e4 --- /dev/null +++ b/progs/lib/cl/random.hs @@ -0,0 +1,21 @@ +-- random.hs -- random number functions +-- +-- author : Sandra Loosemore +-- date : 22 June 1993 +-- + +module Random where + +import RandomPrims -- from random-prims.hi + +class RandomOperand a where + random :: a -> IO a + +instance RandomOperand Int where + random = randomInt +instance RandomOperand Integer where + random = randomInteger +instance RandomOperand Float where + random = randomFloat +instance RandomOperand Double where + random = randomDouble diff --git a/progs/lib/cl/random.hu b/progs/lib/cl/random.hu new file mode 100644 index 0000000..4b8e286 --- /dev/null +++ b/progs/lib/cl/random.hu @@ -0,0 +1,4 @@ +:output $LIBRARYBIN/ +:o= all +random.hs +random-prims.hi diff --git a/progs/lib/hbc/Either.hs b/progs/lib/hbc/Either.hs new file mode 100644 index 0000000..fad5af8 --- /dev/null +++ b/progs/lib/hbc/Either.hs @@ -0,0 +1,2 @@ +module Either(Either(..)) where +data Either a b = Left a | Right b deriving (Eq, Ord, Text, Binary) diff --git a/progs/lib/hbc/Either.hu b/progs/lib/hbc/Either.hu new file mode 100644 index 0000000..3313235 --- /dev/null +++ b/progs/lib/hbc/Either.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Either.hs diff --git a/progs/lib/hbc/Hash.hs b/progs/lib/hbc/Hash.hs new file mode 100644 index 0000000..1f14c6f --- /dev/null +++ b/progs/lib/hbc/Hash.hs @@ -0,0 +1,79 @@ +module Hash where +-- +-- Hash a value. Hashing produces an Int of +-- unspecified range. +-- + +class Hashable a where + hash :: a -> Int + +instance Hashable Char where + hash x = ord x + +instance Hashable Int where + hash x = x + +instance Hashable Integer where + hash x = fromInteger x + +instance Hashable Float where + hash x = truncate x + +instance Hashable Double where + hash x = truncate x + +instance Hashable Bin where + hash x = 0 + +{-instance Hashable File where + hash x = 0 -} + +instance Hashable () where + hash x = 0 + +instance Hashable (a -> b) where + hash x = 0 + +instance Hashable a => Hashable [a] where + hash x = sum (map hash x) + +instance (Hashable a, Hashable b) => Hashable (a,b) where + hash (a,b) = hash a + 3 * hash b + +instance (Hashable a, Hashable b, Hashable c) => Hashable (a,b,c) where + hash (a,b,c) = hash a + 3 * hash b + 5 * hash c + +instance (Hashable a, Hashable b, Hashable c, Hashable d) => Hashable (a,b,c,d) where + hash (a,b,c,d) = hash a + 3 * hash b + 5 * hash c + 7 * hash d + +instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e) => Hashable (a,b,c,d,e) where + hash (a,b,c,d,e) = hash a + hash b + hash c + hash d + hash e + +instance Hashable Bool where + hash False = 0 + hash True = 1 + +instance (Integral a, Hashable a) => Hashable (Ratio a) where + hash x = hash (denominator x) + hash (numerator x) + +instance (RealFloat a, Hashable a) => Hashable (Complex a) where + hash (x :+ y) = hash x + hash y + +instance (Hashable a, Hashable b) => Hashable (Assoc a b) where + hash (x := y) = hash x + hash y + +instance (Ix a) => Hashable (Array a b) where + hash x = 0 -- !!! + +instance Hashable Request where + hash x = 0 -- !! + +instance Hashable Response where + hash x = 0 -- !! + +instance Hashable IOError where + hash x = 0 -- !! + +hashToMax maxhash x = + let h = abs (hash x) + in if h < 0 then 0 else h `rem` maxhash diff --git a/progs/lib/hbc/Hash.hu b/progs/lib/hbc/Hash.hu new file mode 100644 index 0000000..2c23c72 --- /dev/null +++ b/progs/lib/hbc/Hash.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Hash.hs diff --git a/progs/lib/hbc/ListUtil.hs b/progs/lib/hbc/ListUtil.hs new file mode 100644 index 0000000..560920e --- /dev/null +++ b/progs/lib/hbc/ListUtil.hs @@ -0,0 +1,48 @@ +module ListUtil(assoc, concatMap, unfoldr, mapAccuml, union, intersection, chopList, assocDef, lookup, Maybe..) where +import Maybe + +-- Lookup an item in an association list. Apply a function to it if it is found, otherwise return a default value. +assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b +assoc f d [] x = d +assoc f d ((x',y):xys) x | x' == x = f y + | otherwise = assoc f d xys x + +-- Map and concatename results. +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f [] = [] +concatMap f (x:xs) = + case f x of + [] -> concatMap f xs + ys -> ys ++ concatMap f xs + +-- Repeatedly extract (and transform) values until a predicate hold. Return the list of values. +unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b] +unfoldr f p x | p x = [] + | otherwise = y:unfoldr f p x' + where (y, x') = f x + +-- Map, but plumb a state through the map operation. +mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) +mapAccuml f s [] = (s, []) +mapAccuml f s (x:xs) = (s'', y:ys) + where (s', y) = f s x + (s'', ys) = mapAccuml f s' xs + +-- Union of sets as lists. +union :: (Eq a) => [a] -> [a] -> [a] +union xs ys = xs ++ (ys \\ xs) + +-- Intersection of sets as lists. +intersection :: (Eq a) => [a] -> [a] -> [a] +intersection xs ys = [x | x<-xs, x `elem` ys] + +--- Functions derived from those above + +chopList :: ([a] -> (b, [a])) -> [a] -> [b] +chopList f l = unfoldr f null l + +assocDef :: (Eq a) => [(a, b)] -> b -> a -> b +assocDef l d x = assoc id d l x + +lookup :: (Eq a) => [(a, b)] -> a -> Maybe b +lookup l x = assoc Just Nothing l x diff --git a/progs/lib/hbc/ListUtil.hu b/progs/lib/hbc/ListUtil.hu new file mode 100644 index 0000000..7402cb7 --- /dev/null +++ b/progs/lib/hbc/ListUtil.hu @@ -0,0 +1,4 @@ +:output $LIBRARYBIN/ +:o= all +ListUtil.hs +Maybe.hu diff --git a/progs/lib/hbc/Maybe.hs b/progs/lib/hbc/Maybe.hs new file mode 100644 index 0000000..f0ada70 --- /dev/null +++ b/progs/lib/hbc/Maybe.hs @@ -0,0 +1,6 @@ +module Maybe(Maybe(..), thenM) where +-- Maybe together with Just and thenM forms a monad, but is more +-- by accident than by design. +data Maybe a = Nothing | Just a deriving (Eq, Ord, Text, Binary) +Nothing `thenM` _ = Nothing +Just a `thenM` f = f a diff --git a/progs/lib/hbc/Maybe.hu b/progs/lib/hbc/Maybe.hu new file mode 100644 index 0000000..a55b652 --- /dev/null +++ b/progs/lib/hbc/Maybe.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Maybe.hs diff --git a/progs/lib/hbc/Miranda.hs b/progs/lib/hbc/Miranda.hs new file mode 100644 index 0000000..2d863ce --- /dev/null +++ b/progs/lib/hbc/Miranda.hs @@ -0,0 +1,90 @@ +module Miranda(cjustify, lay, layn, limit, ljustify, merge, rep, rjustify, spaces, + {-force,seq,-}sort) where +--import UnsafeDirty +import QSort + +cjustify :: Int -> String -> String +cjustify n s = spaces l ++ s ++ spaces r + where + m = n - length s + l = m `div` 2 + r = m - l + +{- +index :: [a] -> [Int] +index xs = f xs 0 + where f [] n = [] + f (_:xs) n = n : f xs (n+1) +-} + +lay :: [String] -> String +lay = concat . map (++"\n") + +layn :: [String] -> String +layn = concat . zipWith f [1..] + where + f :: Int -> String -> String + f n x = rjustify 4 (show n) ++ ") " ++ x ++ "\n" + +limit :: (Eq a) => [a] -> a +limit (x:y:ys) | x == y = x + | otherwise = limit (y:ys) +limit _ = error "Miranda.limit: bad use" + +ljustify :: Int -> String -> String +ljustify n s = s ++ spaces (n - length s) + +merge :: (Ord a) => [a] -> [a] -> [a] +merge [] ys = ys +merge xs [] = xs +merge xxs@(x:xs) yys@(y:ys) | x <= y = x : merge xs yys + | otherwise = y : merge xxs ys + +rep :: Int -> b -> [b] +rep n x = take n (repeat x) + +rjustify :: Int -> String -> String +rjustify n s = spaces (n - length s) ++ s + +spaces :: Int -> String +spaces 0 = "" +spaces n = ' ' : spaces (n-1) + +------------- + +arctan x = atan x +code c = ord c +converse f a b = flip f a b +decode n = chr n +digit c = isDigit c +e :: (Floating a) => a +e = exp 1 +entier x = floor x +filemode f = error "Miranda.filemode" +--getenv +hd xs = head xs +hugenum :: (Floating a) => a +hugenum = error "hugenum" --!!! +integer x = x == truncate x +letter c = isAlpha c +map2 f xs ys = zipWith f xs ys +--max +max2 x y = max x y +member xs x = x `elem` xs +--min +min2 x y = min x y +mkset xs = nub xs +neg x = negate x +numval :: (Num a) => String -> a +numval cs = read cs +postfix xs x = xs ++ [x] +--read +scan f z l = scanl f z l +--shownum !!! +--showfloat !!! +--showscaled !!! +tinynum :: (Floating a) => a +tinynum = error "tinynum" +undef = error "undefined" +zip2 xs ys = zip xs ys +--zip diff --git a/progs/lib/hbc/Miranda.hu b/progs/lib/hbc/Miranda.hu new file mode 100644 index 0000000..cfa86ed --- /dev/null +++ b/progs/lib/hbc/Miranda.hu @@ -0,0 +1,4 @@ +:output $LIBRARYBIN/ +:o= all +Miranda.hs +QSort.hu diff --git a/progs/lib/hbc/Option.hs b/progs/lib/hbc/Option.hs new file mode 100644 index 0000000..a4b2423 --- /dev/null +++ b/progs/lib/hbc/Option.hs @@ -0,0 +1,3 @@ +module Option(Option(..), thenO) where +import Maybe renaming (Maybe to Option, Nothing to None, Just to Some, thenM to thenO) + diff --git a/progs/lib/hbc/Option.hu b/progs/lib/hbc/Option.hu new file mode 100644 index 0000000..592a0cd --- /dev/null +++ b/progs/lib/hbc/Option.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Option.hs diff --git a/progs/lib/hbc/Pretty.hs b/progs/lib/hbc/Pretty.hs new file mode 100644 index 0000000..ad63dbe --- /dev/null +++ b/progs/lib/hbc/Pretty.hs @@ -0,0 +1,50 @@ +module Pretty(text, separate, nest, pretty, (~.), (^.), IText(..), Context(..)) where +infixr 8 ~. +infixr 8 ^. + +type IText = Context -> [String] +type Context = (Bool,Int,Int,Int) + +text :: String -> IText +text s (v,w,m,m') = [s] + +(~.) :: IText -> IText -> IText +(~.) d1 d2 (v,w,m,m') = + let t = d1 (False,w,m,m') + tn = last t + indent = length tn + sig = if length t == 1 + then m' + indent + else length (dropWhile (==' ') tn) + (l:ls) = d2 (False,w-indent,m,sig) + in init t ++ + [tn ++ l] ++ + map (space indent++) ls + +space :: Int -> String +space n = [' ' | i<-[1..n]] + +(^.) :: IText -> IText -> IText +(^.) d1 d2 (v,w,m,m') = d1 (True,w,m,m') ++ d2 (True,w,m,0) + +separate :: [IText] -> IText +separate [] _ = [""] +separate ds (v,w,m,m') = + let hor = foldr1 (\d1 d2 -> d1 ~. text " " ~. d2) ds + ver = foldr1 (^.) ds + t = hor (v,w,m,m') + in if fits 1 t && fits (w `min` m-m') (head t) + then t + else ver (v,w,m,m') + +fits n xs = length xs <= n `max` 0 --null (drop n xs) + +nest :: Int -> IText -> IText +nest n d (v,w,m,m') = + if v then + map (space n++) (d (v,w-n,m,if m'==0 then 0 else m'+n)) + else + d (v,w,m,m') + +pretty :: Int->Int->IText->String +pretty w m d = concat (map (++"\n") (d (False,w,m,0))) diff --git a/progs/lib/hbc/Printf.hs b/progs/lib/hbc/Printf.hs new file mode 100644 index 0000000..c8291bd --- /dev/null +++ b/progs/lib/hbc/Printf.hs @@ -0,0 +1,150 @@ +-- This code used a function in the lml library (fmtf) that I don't have. +-- If someone makes this work for floats let me know -- jcp +-- +-- A C printf like formatter. +-- Conversion specs: +-- - left adjust +-- num field width +-- . separates width from precision +-- Formatting characters: +-- c Char, Int, Integer +-- d Char, Int, Integer +-- o Char, Int, Integer +-- x Char, Int, Integer +-- u Char, Int, Integer +-- f Float, Double +-- g Float, Double +-- e Float, Double +-- s String +-- +module Printf(UPrintf(..), printf) where + +-- import LMLfmtf + +data UPrintf = UChar Char | + UString String | + UInt Int | + UInteger Integer | + UFloat Float | + UDouble Double + +printf :: String -> [UPrintf] -> String +printf "" [] = "" +printf "" (_:_) = fmterr +printf ('%':_) [] = argerr +printf ('%':cs) us@(_:_) = fmt cs us +printf (c:cs) us = c:printf cs us + +fmt :: String -> [UPrintf] -> String +fmt cs us = + let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us + adjust (pre, str) = + let lstr = length str + lpre = length pre + fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else "" + in if ladj then pre ++ str ++ fill else pre ++ fill ++ str + in + case cs' of + [] -> fmterr + c:cs'' -> + case us' of + [] -> argerr + u:us'' -> + (case c of + 'c' -> adjust ("", [chr (toint u)]) + 'd' -> adjust (fmti u) + 'x' -> adjust ("", fmtu 16 u) + 'o' -> adjust ("", fmtu 8 u) + 'u' -> adjust ("", fmtu 10 u) + '%' -> "%" + 'e' -> adjust (dfmt c prec (todbl u)) + 'f' -> adjust (dfmt c prec (todbl u)) + 'g' -> adjust (dfmt c prec (todbl u)) + 's' -> adjust ("", tostr u) + c -> perror ("bad formatting char " ++ [c]) + ) ++ printf cs'' us'' +unimpl = perror "unimplemented" + +fmti (UInt i) = if i < 0 then + if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i)) + else + ("", itos i) +fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i) +fmti (UChar c) = fmti (UInt (ord c)) +fmti u = baderr + +fmtu b (UInt i) = if i < 0 then + if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i)) + else + itosb b (toInteger i) +fmtu b (UInteger i) = itosb b i +fmtu b (UChar c) = itosb b (toInteger (ord c)) +fmtu b u = baderr + +maxi :: Integer +maxi = (toInteger maxInt + 1) * 2 + +toint (UInt i) = i +toint (UInteger i) = toInt i +toint (UChar c) = ord c +toint u = baderr + +tostr (UString s) = s +tostr u = baderr + +todbl (UDouble d) = d +todbl (UFloat f) = fromRational (toRational f) +todbl u = baderr + +itos n = + if n < 10 then + [chr (ord '0' + toInt n)] + else + let (q, r) = quotRem n 10 in + itos q ++ [chr (ord '0' + toInt r)] + +chars = array (0,15) (zipWith (:=) [0..] "0123456789abcdef") +itosb :: Integer -> Integer -> String +itosb b n = + if n < b then + [chars!n] + else + let (q, r) = quotRem n b in + itosb b q ++ [chars!r] + +stoi :: Int -> String -> (Int, String) +stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '0') cs +stoi a cs = (a, cs) + +getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf]) +getSpecs l z ('-':cs) us = getSpecs True z cs us +getSpecs l z ('0':cs) us = getSpecs l True cs us +getSpecs l z ('*':cs) us = unimpl +getSpecs l z cs@(c:_) us | isDigit c = + let (n, cs') = stoi 0 cs + (p, cs'') = case cs' of + '.':r -> stoi 0 r + _ -> (-1, cs') + in (n, p, l, z, cs'', us) +getSpecs l z cs us = (0, -1, l, z, cs, us) + +-- jcp: I don't know what the lml function fmtf does. Someone needs to +-- rewrite this. + +{- +dfmt c p d = + case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of + '-':cs -> ("-", cs) + cs -> ("" , cs) +-} +dfmt = error "fmtf not implemented" + +perror s = error ("Printf.printf: "++s) +fmterr = perror "formatting string ended prematurely" +argerr = perror "argument list ended prematurely" +baderr = perror "bad argument" + +-- This is needed because standard Haskell does not have toInt + +toInt :: Integral a => a -> Int +toInt x = fromIntegral x diff --git a/progs/lib/hbc/Printf.hu b/progs/lib/hbc/Printf.hu new file mode 100644 index 0000000..d94f5b1 --- /dev/null +++ b/progs/lib/hbc/Printf.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Printf.hs diff --git a/progs/lib/hbc/QSort.hs b/progs/lib/hbc/QSort.hs new file mode 100644 index 0000000..f19eb43 --- /dev/null +++ b/progs/lib/hbc/QSort.hs @@ -0,0 +1,47 @@ +{- + This module implements a sort function using a variation on + quicksort. It is stable, uses no concatenation and compares + only with <=. + + sortLe sorts with a given predicate + sort uses the <= method + + Author: Lennart Augustsson +-} + +module QSort(sortLe, sort) where +sortLe :: (a -> a -> Bool) -> [a] -> [a] +sortLe le l = qsort le l [] + +sort :: (Ord a) => [a] -> [a] +sort l = qsort (<=) l [] + +-- qsort is stable and does not concatenate. +qsort le [] r = r +qsort le [x] r = x:r +qsort le (x:xs) r = qpart le x xs [] [] r + +-- qpart partitions and sorts the sublists +qpart le x [] rlt rge r = + -- rlt and rge are in reverse order and must be sorted with an + -- anti-stable sorting + rqsort le rlt (x:rqsort le rge r) +qpart le x (y:ys) rlt rge r = + if le x y then + qpart le x ys rlt (y:rge) r + else + qpart le x ys (y:rlt) rge r + +-- rqsort is as qsort but anti-stable, i.e. reverses equal elements +rqsort le [] r = r +rqsort le [x] r = x:r +rqsort le (x:xs) r = rqpart le x xs [] [] r + +rqpart le x [] rle rgt r = + qsort le rle (x:qsort le rgt r) +rqpart le x (y:ys) rle rgt r = + if le y x then + rqpart le x ys (y:rle) rgt r + else + rqpart le x ys rle (y:rgt) r + diff --git a/progs/lib/hbc/QSort.hu b/progs/lib/hbc/QSort.hu new file mode 100644 index 0000000..9a07dd1 --- /dev/null +++ b/progs/lib/hbc/QSort.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +QSort.hs diff --git a/progs/lib/hbc/README b/progs/lib/hbc/README new file mode 100644 index 0000000..c51452a --- /dev/null +++ b/progs/lib/hbc/README @@ -0,0 +1,97 @@ +These libraries are adapted from the lml library. Also included are a number +of Common Lisp functions. + +The hbc library contains the following modules and functions: + +* module Either + binary sum data type + data Either a b = Left a | Right b + constructor Left typically used for errors + +* module Option + type for success or failure + data Option a = None | Some a + thenO :: Option a -> (a -> Option b) -> Option b apply a function that may fail + + +* module ListUtil + Various useful functions involving lists that are missing from the Prelude + assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b + 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 + concatMap :: (a -> [b]) -> [a] -> [b] + flattening map (LMLs concmap) + unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b] + unfoldr f p x repeatedly applies f to x until (p x) holds. (f x) should give a list element and a new x + mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) + mapAccuml f s l maps f over l, but also threads the state s though (LMLs mapstate) + union :: (Eq a) => [a] -> [a] -> [a] + unions of two lists + intersection :: (Eq a) => [a] -> [a] -> [a] + intersection of two lists + chopList :: ([a] -> (b, [a])) -> [a] -> [b] + LMLs choplist + assocDef :: (Eq a) => [(a, b)] -> b -> a -> b + LMLs assocdef + lookup :: (Eq a) => [(a, b)] -> a -> Option b + lookup l k looks for the key k in the association list l and returns an optional value + +* module Pretty + John Hughes pretty printing library. + type Context = (Bool, Int, Int, Int) + type IText = Context -> [String] + text :: String -> IText just text + (~.) :: IText -> IText -> IText horizontal composition + (^.) :: IText -> IText -> IText vertical composition + separate :: [IText] -> IText separate by spaces + nest :: Int -> IText -> IText indent + pretty :: Int -> Int -> IText -> String format it + +* module QSort + Sort function using quicksort. + sortLe :: (a -> a -> Bool) -> [a] -> [a] sort le l sorts l with le as less than predicate + sort :: (Ord a) => [a] -> [a] sort l sorts l using the Ord class + +* module Random + Random numbers. + randomInts :: Int -> Int -> [Int] given two seeds gives a list of random Int + randomDoubles :: Int -> Int -> [Double] given two seeds gives a list of random Double + +* module RunDialogue + Test run programs of type Dialogue. + Only a few Requests are implemented, unfortunately not ReadChannel. + run :: Dialogue -> String just run the program, showing the output + runTrace :: Dialogue -> String run the program, showing each Request and Response + +* module Miranda + Functions found in the Miranda(tm) library. + +* module Printf + C printf style formatting. Handles same types as printf in C, but requires the arguments + to be tagged. Useful for formatting of floating point values. + data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double + printf :: String -> [UPrintf] -> String convert arguments in the list according to the formatting string + + +* module Time + Manipulate time values (a Double with seconds since 1970). + -- year mon day hour min sec dec-sec weekday + data Time = Time Int Int Int Int Int Int Double Int + dblToTime :: Double -> Time convert a Double to a Time + timeToDbl :: Time -> Double convert a Time to a Double + timeToString :: Time -> String convert a Time to a readable String + +----- To add: + +Bytes +IO Library +Word oprtations +Time clock stuff +Lisp stuff: symbols + hashtables + strings + + + + + + diff --git a/progs/lib/hbc/Random.hs b/progs/lib/hbc/Random.hs new file mode 100644 index 0000000..269d6af --- /dev/null +++ b/progs/lib/hbc/Random.hs @@ -0,0 +1,52 @@ +{- + This module implements a (good) random number generator. + + The June 1988 (v31 #6) issue of the Communications of the ACM has an + article by Pierre L'Ecuyer called, "Efficient and Portable Combined + Random Number Generators". Here is the Portable Combined Generator of + L'Ecuyer for 32-bit computers. It has a period of roughly 2.30584e18. + + Transliterator: Lennart Augustsson +-} + +module Random(randomInts, randomDoubles) where +-- Use seeds s1 in 1..2147483562 and s2 in 1..2147483398 to generate +-- an infinite list of random Ints. +randomInts :: Int -> Int -> [Int] +randomInts s1 s2 = + if 1 <= s1 && s1 <= 2147483562 then + if 1 <= s2 && s2 <= 2147483398 then + rands s1 s2 + else + error "randomInts: Bad second seed." + else + error "randomInts: Bad first seed." + +rands :: Int -> Int -> [Int] +rands s1 s2 = + let + k = s1 `div` 53668 + s1' = 40014 * (s1 - k * 53668) - k * 12211 + s1'' = if s1' < 0 then s1' + 2147483563 else s1' + + k' = s2 `div` 52774 + s2' = 40692 * (s2 - k' * 52774) - k' * 3791 + s2'' = if s2' < 0 then s2' + 2147483399 else s2' + + z = s1'' - s2'' +{- + z' = if z < 1 then z + 2147483562 else z + + in z' : rands s1'' s2'' +-} +-- Use this instead; it is a little stricter and generates much better code + in if z < 1 then z + 2147483562 : rands s1'' s2'' + else z : rands s1'' s2'' + +-- For those of you who don't have fromInt +fromInt = fromInteger . toInteger + +-- Same values for s1 and s2 as above, generates an infinite +-- list of Doubles uniformly distibuted in (0,1). +randomDoubles :: Int -> Int -> [Double] +randomDoubles s1 s2 = map (\x -> fromInt x * 4.6566130638969828e-10) (randomInts s1 s2) diff --git a/progs/lib/hbc/Random.hu b/progs/lib/hbc/Random.hu new file mode 100644 index 0000000..9fff34e --- /dev/null +++ b/progs/lib/hbc/Random.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Random.hs diff --git a/progs/lib/hbc/Time.hs b/progs/lib/hbc/Time.hs new file mode 100644 index 0000000..29f3441 --- /dev/null +++ b/progs/lib/hbc/Time.hs @@ -0,0 +1,51 @@ +module Time(Time(..), dblToTime, timeToDbl, timeToString) where +-- year mon day hour min sec ... wday +data Time = Time Int Int Int Int Int Int Double Int deriving (Eq, Ord, Text) + +isleap :: Int -> Bool +isleap n = n `rem` 4 == 0 -- good enough for the UNIX time span + +daysin :: Int -> Int +daysin n = if isleap n then 366 else 365 + +monthlen :: Array (Bool, Int) Int +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] ++ + zipWith3 (\ a b c -> (a,b):=c) (repeat True) [1..] [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]) + +-- Time zone offset in minutes +tzOffset = 120 -- Swedish DST + +dblToTime :: Double -> Time +dblToTime d = + let t = truncate d :: Int + offset = tzOffset -- timezone + (days, rem) = (t+offset*60) `quotRem` (60*60*24) + (hour, rem') = rem `quotRem` (60*60) + (min, sec) = rem' `quotRem` 60 + wday = (days+3) `mod` 7 + (year, days')= until (\ (y, d) -> d < daysin y) (\ (y, d) -> (y+1, d - daysin y)) (1970, days) + (mon, day) = until (\ (m, d) -> d <= monthlen!(isleap year, m)) (\ (m, d) -> (m+1, d - monthlen!(isleap year, m))) (1, days') + in Time year mon (day+1) hour min sec (d - fromInt t) wday + +timeToDbl :: Time -> Double +timeToDbl (Time year mon day hour min sec sdec _) = + let year' = year - 1970 + offset = tzOffset -- timezone + days = year' * 365 + (year'+1) `div` 4 + + sum [monthlen!(isleap year, m) | m<-[1..mon-1]] + day - 1 + secs = ((days*24 + hour) * 60 + min - offset) * 60 + sec + in fromInt secs + sdec + +show2 :: Int -> String +show2 x = [chr (x `quot` 10 + ord '0'), chr (x `rem` 10 + ord '0')] + +weekdays = ["Mon","Tue","Wen","Thu","Fri","Sat","Sun"] + +timeToString :: Time -> String +timeToString (Time year mon day hour min sec sdec wday) = + show year ++ "-" ++ show2 mon ++ "-" ++ show2 day ++ " " ++ + show2 hour ++ ":" ++ show2 min ++ ":" ++ show2 sec ++ + tail (take 5 (show sdec)) ++ " " ++ weekdays!!wday + +-- For those of you who don't have fromInt +fromInt = fromInteger . toInteger diff --git a/progs/lib/hbc/Time.hu b/progs/lib/hbc/Time.hu new file mode 100644 index 0000000..01c8f64 --- /dev/null +++ b/progs/lib/hbc/Time.hu @@ -0,0 +1,3 @@ +:output $LIBRARYBIN/ +:o= all +Time.hs diff --git a/progs/prelude/Prelude.hs b/progs/prelude/Prelude.hs new file mode 100644 index 0000000..bf20849 --- /dev/null +++ b/progs/prelude/Prelude.hs @@ -0,0 +1,187 @@ +-- Standard value bindings + +module Prelude ( + PreludeCore.., PreludeRatio.., PreludeComplex.., PreludeList.., + PreludeArray.., PreludeText.., PreludeIO.., + nullBin, isNullBin, appendBin, + (&&), (||), not, otherwise, + minChar, maxChar, ord, chr, + isAscii, isControl, isPrint, isSpace, + isUpper, isLower, isAlpha, isDigit, isAlphanum, + toUpper, toLower, + minInt, maxInt, subtract, gcd, lcm, (^), (^^), + fromIntegral, fromRealFrac, atan2, + fst, snd, id, const, (.), flip, ($), until, asTypeOf, error ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +import PreludePrims + +import PreludeCore +import PreludeList +import PreludeArray +import PreludeRatio +import PreludeComplex +import PreludeText +import PreludeIO + +infixr 9 . +infixr 8 ^, ^^ +infixr 3 && +infixr 2 || +infixr 0 $ + + +-- Binary functions + +nullBin :: Bin +nullBin = primNullBin + +isNullBin :: Bin -> Bool +isNullBin = primIsNullBin + +appendBin :: Bin -> Bin -> Bin +appendBin = primAppendBin + +-- Boolean functions + +(&&), (||) :: Bool -> Bool -> Bool +True && x = x +False && _ = False +True || _ = True +False || x = x + +not :: Bool -> Bool +not True = False +not False = True + +{-# (&&) :: Inline #-} +{-# (||) :: Inline #-} +{-# not :: Inline #-} + + +otherwise :: Bool +otherwise = True + +-- Character functions + +minChar, maxChar :: Char +minChar = '\0' +maxChar = '\255' + +ord :: Char -> Int +ord = primCharToInt + +chr :: Int -> Char +chr = primIntToChar + +isAscii, isControl, isPrint, isSpace :: Char -> Bool +isUpper, isLower, isAlpha, isDigit, isAlphanum :: Char -> Bool + +isAscii c = ord c < 128 +isControl c = c < ' ' || c == '\DEL' +isPrint c = c >= ' ' && c <= '~' +isSpace c = c == ' ' || c == '\t' || c == '\n' || + c == '\r' || c == '\f' || c == '\v' +isUpper c = c >= 'A' && c <= 'Z' +isLower c = c >= 'a' && c <= 'z' +isAlpha c = isUpper c || isLower c +isDigit c = c >= '0' && c <= '9' +isAlphanum c = isAlpha c || isDigit c + + +toUpper, toLower :: Char -> Char +toUpper c | isLower c = chr ((ord c - ord 'a') + ord 'A') + | otherwise = c + +toLower c | isUpper c = chr ((ord c - ord 'A') + ord 'a') + | otherwise = c + +-- Numeric functions + +minInt, maxInt :: Int +minInt = primMinInt +maxInt = primMaxInt + +subtract :: (Num a) => a -> a -> a +subtract = flip (-) + +gcd :: (Integral a) => a -> a -> a +gcd 0 0 = error "gcd{Prelude}: gcd 0 0 is undefined" +gcd x y = gcd' (abs x) (abs y) + where gcd' x 0 = x + gcd' x y = gcd' y (x `rem` y) + +lcm :: (Integral a) => a -> a -> a +lcm _ 0 = 0 +lcm 0 _ = 0 +lcm x y = abs ((x `quot` (gcd x y)) * y) + +(^) :: (Num a, Integral b) => a -> b -> a +x ^ 0 = 1 +x ^ (n+1) = f x n x + where f _ 0 y = y + f x n y = g x n where + g x n | even n = g (x*x) (n `quot` 2) + | otherwise = f x (n-1) (x*y) +_ ^ _ = error "(^){Prelude}: negative exponent" + +(^^) :: (Fractional a, Integral b) => a -> b -> a +x ^^ n = if n >= 0 then x^n else recip (x^(-n)) + +fromIntegral :: (Integral a, Num b) => a -> b +fromIntegral = fromInteger . toInteger + +fromRealFrac :: (RealFrac a, Fractional b) => a -> b +fromRealFrac = fromRational . toRational + +atan2 :: (RealFloat a) => a -> a -> a +atan2 y x = case (signum y, signum x) of + ( 0, 1) -> 0 + ( 1, 0) -> pi/2 + ( 0,-1) -> pi + (-1, 0) -> -pi/2 + ( _, 1) -> atan (y/x) + ( _,-1) -> atan (y/x) + pi + ( 0, 0) -> error "atan2{Prelude}: atan2 of origin" + + +-- Some standard functions: +-- component projections for pairs: +fst :: (a,b) -> a +fst (x,y) = x + +snd :: (a,b) -> b +snd (x,y) = y + +-- identity function +id :: a -> a +id x = x + +-- constant function +const :: a -> b -> a +const x _ = x + +-- function composition +(.) :: (b -> c) -> (a -> b) -> a -> c +f . g = \ x -> f (g x) + +-- flip f takes its (first) two arguments in the reverse order of f. +flip :: (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +-- right-associating infix application operator (useful in continuation- +-- passing style) +($) :: (a -> b) -> a -> b +f $ x = f x + +-- until p f yields the result of applying f until p holds. +until :: (a -> Bool) -> (a -> a) -> a -> a +until p f x | p x = x + | otherwise = until p f (f x) + +-- asTypeOf is a type-restricted version of const. It is usually used +-- as an infix operator, and its typing forces its first argument +-- (which is usually overloaded) to have the same type as the second. +asTypeOf :: a -> a -> a +asTypeOf = const diff --git a/progs/prelude/Prelude.hu b/progs/prelude/Prelude.hu new file mode 100644 index 0000000..1ee32ca --- /dev/null +++ b/progs/prelude/Prelude.hu @@ -0,0 +1,16 @@ +:output $PRELUDEBIN/Prelude +:stable +:prelude +PreludePrims.hu +PreludeArrayPrims.hu +PreludeTuplePrims.hu +PreludeIOPrims.hu +Prelude.hs +PreludeArray.hs +PreludeComplex.hs +PreludeCore.hs +PreludeIO.hs +PreludeList.hs +PreludeRatio.hs +PreludeText.hs +PreludeTuple.hs diff --git a/progs/prelude/PreludeArray.hs b/progs/prelude/PreludeArray.hs new file mode 100644 index 0000000..a501631 --- /dev/null +++ b/progs/prelude/PreludeArray.hs @@ -0,0 +1,201 @@ +module PreludeArray ( Array, Assoc((:=)), array, listArray, (!), bounds, + indices, elems, assocs, accumArray, (//), accum, amap, + ixmap + ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +-- This module uses some simple techniques with updatable vectors to +-- avoid vector copying in loops where single threading is obvious. +-- This is rather fragile and depends on the way the compiler handles +-- strictness. + +import PreludeBltinArray + +infixl 9 ! +infixl 9 // +infix 1 := + +data Assoc a b = a := b deriving (Eq, Ord, Ix, Text, Binary) +data (Ix a) => Array a b = MkArray (a,a) {-#STRICT#-} + (Vector (Box b)) {-#STRICT#-} + deriving () + +array :: (Ix a) => (a,a) -> [Assoc a b] -> Array a b +listArray :: (Ix a) => (a,a) -> [b] -> Array a b +(!) :: (Ix a) => Array a b -> a -> b +bounds :: (Ix a) => Array a b -> (a,a) +indices :: (Ix a) => Array a b -> [a] +elems :: (Ix a) => Array a b -> [b] +assocs :: (Ix a) => Array a b -> [Assoc a b] +accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [Assoc a c] + -> Array a b +(//) :: (Ix a) => Array a b -> [Assoc a b] -> Array a b +accum :: (Ix a) => (b -> c -> b) -> Array a b -> [Assoc a c] + -> Array a b +amap :: (Ix a) => (b -> c) -> Array a b -> Array a c +ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c + -> Array a c + +-- Arrays are a datatype containing a bounds pair and a vector of values. +-- Uninitialized array elements contain an error value. + +-- Primitive vectors now contain only unboxed values. This permits us to +-- treat array indexing as an atomic operation without forcing the element +-- being accessed. The boxing and unboxing of array elements happens +-- explicitly using these operations: + +data Box a = MkBox a +unBox (MkBox x) = x +{-# unBox :: Inline #-} + + +-- Array construction and update using index/value associations share +-- the same helper function. + +array b@(bmin, bmax) ivs = + let size = (index b bmax) + 1 + v = primMakeVector size uninitializedArrayError + in (MkArray b (updateArrayIvs b v ivs)) +{-# array :: Inline #-} + +a@(MkArray b v) // ivs = + let v' = primCopyVector v + in (MkArray b (updateArrayIvs b v' ivs)) +{-# (//) :: Inline #-} + +updateArrayIvs b v ivs = + let g (i := x) next = strict1 (primVectorUpdate v (index b i) (MkBox x)) + next + in foldr g v ivs +{-# updateArrayIvs :: Inline #-} + +uninitializedArrayError = + MkBox (error "(!){PreludeArray}: uninitialized array element.") + + +-- when mapping a list onto an array, be smart and don't do full index +-- computation + +listArray b@(bmin, bmax) vs = + let size = (index b bmax) + 1 + v = primMakeVector size uninitializedArrayError + in (MkArray b (updateArrayVs size v vs)) +{-# listArray :: Inline #-} + +updateArrayVs size v vs = + let g x next j = if (j == size) + then v + else strict1 (primVectorUpdate v j (MkBox x)) + (next (j + 1)) + in foldr g (\ _ -> v) vs 0 +{-# updateArrayVs :: Inline #-} + + +-- Array access + +a@(MkArray b v) ! i = unBox (primVectorSel v (index b i)) +{-# (!) :: Inline #-} + +bounds (MkArray b _) = b + +indices = range . bounds + + +-- Again, when mapping array elements into a list, be smart and don't do +-- the full index computation for every element. + +elems a@(MkArray b@(bmin, bmax) v) = + build (\ c n -> + let size = (index b bmax) + 1 + g j = if (j == size) + then n + else c (unBox (primVectorSel v j)) (g (j + 1)) + -- This strict1 is so size doesn't get inlined and recomputed + -- at every iteration. It should also force the array argument + -- to be strict. + in strict1 size (g 0)) +{-# elems :: Inline #-} + +assocs a@(MkArray b@(bmin, bmax) v) = + build (\ c n -> + let g i next j = let y = unBox (primVectorSel v j) + in c (i := y) (next (j + 1)) + in foldr g (\ _ -> n) (range b) 0) +{-# assocs :: Inline #-} + + +-- accum and accumArray share the same helper function. The difference is +-- that accum makes a copy of an existing array and accumArray creates +-- a new one with all elements initialized to the given value. + +accum f a@(MkArray b v) ivs = + let v' = primCopyVector v + in (MkArray b (accumArrayIvs f b v' ivs)) +{-# accum :: Inline #-} + +accumArray f z b@(bmin, bmax) ivs = + let size = (index b bmax) + 1 + v = primMakeVector size (MkBox z) + in (MkArray b (accumArrayIvs f b v ivs)) +{-# accumArray :: Inline #-} + + +-- This is a bit tricky. We need to force the access to the array element +-- before the update, but not force the thunk that is the value of the +-- array element unless f is strict. + +accumArrayIvs f b v ivs = + let g (i := x) next = + let j = index b i + y = primVectorSel v j + in strict1 + y + (strict1 (primVectorUpdate v j (MkBox (f (unBox y) x))) + next) + in foldr g v ivs +{-# accumArrayIvs :: Inline #-} + + +-- again, be smart and bypass full array indexing on array mapping + +amap f a@(MkArray b@(bmin, bmax) v) = + let size = (index b bmax) + 1 + v' = primMakeVector size uninitializedArrayError + g j = if (j == size) + then v' + else let y = primVectorSel v j + in strict1 (primVectorUpdate v' j (MkBox (f (unBox y)))) + (g (j + 1)) + in (MkArray b (g 0)) +{-# amap :: Inline #-} + + +-- can't bypass the index computation here since f needs it as an argument + +ixmap b f a = array b [i := a ! f i | i <- range b] +{-# ixmap :: Inline #-} + + +-- random other stuff + +instance (Ix a, Eq b) => Eq (Array a b) where + a == a' = assocs a == assocs a' + +instance (Ix a, Ord b) => Ord (Array a b) where + a <= a' = assocs a <= assocs a' + +instance (Ix a, Text a, Text b) => Text (Array a b) where + showsPrec p a = showParen (p > 9) ( + showString "array " . + shows (bounds a) . showChar ' ' . + shows (assocs a) ) + + readsPrec p = readParen (p > 9) + (\r -> [(array b as, u) | ("array",s) <- lex r, + (b,t) <- reads s, + (as,u) <- reads t ] + ++ + [(listArray b xs, u) | ("listArray",s) <- lex r, + (b,t) <- reads s, + (xs,u) <- reads t ]) diff --git a/progs/prelude/PreludeArrayPrims.hi b/progs/prelude/PreludeArrayPrims.hi new file mode 100644 index 0000000..a8529c0 --- /dev/null +++ b/progs/prelude/PreludeArrayPrims.hi @@ -0,0 +1,37 @@ +-- These primitives are used to implement arrays with constant time +-- access. There are destructive update routines for arrays for use +-- internally in functions such as array. These are impure but are +-- marked as pure to keep them out of the top level monad. This should +-- be redone using lambda-var someday. + +interface PreludeBltinArray where + + +data Vector a -- Used to represent vectors with delayed components +data Delay a -- An explicit represenation of a delayed object + + +-- Primitive vectors now always have strict components. This permits us +-- to treat array indexing as an atomic operation without the explicit +-- force on access. + +primVectorSel :: Vector a -> Int -> a +primVectorUpdate :: Vector a -> Int -> a -> a +primMakeVector :: Int -> a -> Vector a +primCopyVector :: Vector a -> Vector a + +-- These functions are used for explicit sequencing of destructive ops + +strict1 :: a -> b -> b +primForce :: Delay a -> a + +{-# +primVectorSel :: LispName("prim.vector-sel"), Complexity(1) +primVectorUpdate :: LispName("prim.vector-update"), Complexity(1) +primMakeVector :: LispName("prim.make-vector"), Complexity(4) +primCopyVector :: LispName("prim.copy-vector"), Complexity(5) +strict1 :: Strictness("S,N"), + LispName("prim.strict1") +primForce :: LispName("prim.force") +#-} + diff --git a/progs/prelude/PreludeArrayPrims.hu b/progs/prelude/PreludeArrayPrims.hu new file mode 100644 index 0000000..62ea8ac --- /dev/null +++ b/progs/prelude/PreludeArrayPrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludeArrayPrims +:stable +:prelude +PreludeArrayPrims.hi diff --git a/progs/prelude/PreludeComplex.hs b/progs/prelude/PreludeComplex.hs new file mode 100644 index 0000000..2044129 --- /dev/null +++ b/progs/prelude/PreludeComplex.hs @@ -0,0 +1,94 @@ +-- Complex Numbers + +module PreludeComplex where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixl 6 :+ + +data (RealFloat a) => Complex a = a {-#STRICT#-} :+ a {-#STRICT #-} + deriving (Eq,Binary,Text) + +instance (RealFloat a) => Num (Complex a) where + (x:+y) + (x':+y') = (x+x') :+ (y+y') + (x:+y) - (x':+y') = (x-x') :+ (y-y') + (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') + negate (x:+y) = negate x :+ negate y + abs z = magnitude z :+ 0 + signum 0 = 0 + signum z@(x:+y) = x/r :+ y/r where r = magnitude z + fromInteger n = fromInteger n :+ 0 + +instance (RealFloat a) => Fractional (Complex a) where + (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d + where x'' = scaleFloat k x' + y'' = scaleFloat k y' + k = - max (exponent x') (exponent y') + d = x'*x'' + y'*y'' + + fromRational a = fromRational a :+ 0 + +instance (RealFloat a) => Floating (Complex a) where + pi = pi :+ 0 + exp (x:+y) = expx * cos y :+ expx * sin y + where expx = exp x + log z = log (magnitude z) :+ phase z + + sqrt 0 = 0 + sqrt z@(x:+y) = u :+ (if y < 0 then -v else v) + where (u,v) = if x < 0 then (v',u') else (u',v') + v' = abs y / (u'*2) + u' = sqrt ((magnitude z + abs x) / 2) + + sin (x:+y) = sin x * cosh y :+ cos x * sinh y + cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y) + tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy)) + where sinx = sin x + cosx = cos x + sinhy = sinh y + coshy = cosh y + + sinh (x:+y) = cos y * sinh x :+ sin y * cosh x + cosh (x:+y) = cos y * cosh x :+ sin y * sinh x + tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx) + where siny = sin y + cosy = cos y + sinhx = sinh x + coshx = cosh x + + asin z@(x:+y) = y':+(-x') + where (x':+y') = log (((-y):+x) + sqrt (1 - z*z)) + acos z@(x:+y) = y'':+(-x'') + where (x'':+y'') = log (z + ((-y'):+x')) + (x':+y') = sqrt (1 - z*z) + atan z@(x:+y) = y':+(-x') + where (x':+y') = log (((1-y):+x) / sqrt (1+z*z)) + + asinh z = log (z + sqrt (1+z*z)) + acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) + atanh z = log ((1+z) / sqrt (1-z*z)) + + +realPart, imagPart :: (RealFloat a) => Complex a -> a +realPart (x:+y) = x +imagPart (x:+y) = y + +conjugate :: (RealFloat a) => Complex a -> Complex a +conjugate (x:+y) = x :+ (-y) + +mkPolar :: (RealFloat a) => a -> a -> Complex a +mkPolar r theta = r * cos theta :+ r * sin theta + +cis :: (RealFloat a) => a -> Complex a +cis theta = cos theta :+ sin theta + +polar :: (RealFloat a) => Complex a -> (a,a) +polar z = (magnitude z, phase z) + +magnitude, phase :: (RealFloat a) => Complex a -> a +magnitude (x:+y) = scaleFloat k + (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2)) + where k = max (exponent x) (exponent y) + mk = - k + +phase (x:+y) = atan2 y x diff --git a/progs/prelude/PreludeCore.hs b/progs/prelude/PreludeCore.hs new file mode 100644 index 0000000..f8a7be2 --- /dev/null +++ b/progs/prelude/PreludeCore.hs @@ -0,0 +1,817 @@ +-- Standard types, classes, and instances + +module PreludeCore ( + Eq((==), (/=)), + Ord((<), (<=), (>=), (>), max, min), + Num((+), (-), (*), negate, abs, signum, fromInteger), + Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger), + Fractional((/), recip, fromRational), + Floating(pi, exp, log, sqrt, (**), logBase, + sin, cos, tan, asin, acos, atan, + sinh, cosh, tanh, asinh, acosh, atanh), + Real(toRational), + RealFrac(properFraction, truncate, round, ceiling, floor), + RealFloat(floatRadix, floatDigits, floatRange, + encodeFloat, decodeFloat, exponent, significand, scaleFloat), + Ix(range, index, inRange), + Enum(enumFrom, enumFromThen, enumFromTo, enumFromThenTo), + Text(readsPrec, showsPrec, readList, showList), ReadS(..), ShowS(..), + Binary(readBin, showBin), +-- List type: [_]((:), []) +-- Tuple types: (_,_), (_,_,_), etc. +-- Trivial type: () + Bool(True, False), + Char, Int, Integer, Float, Double, Bin, + Ratio, Complex((:+)), Assoc((:=)), Array, + String(..), Rational(..) ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +import PreludePrims +import PreludeText +import PreludeRatio(Ratio, Rational(..)) +import PreludeComplex(Complex((:+))) +import PreludeArray(Assoc((:=)), Array) +import PreludeIO({-Request, Response,-} IOError, + Dialogue(..), SuccCont(..), StrCont(..), + StrListCont(..), BinCont(..), FailCont(..)) + +infixr 8 ** +infixl 7 *, /, `quot`, `rem`, `div`, `mod` +infixl 6 +, - +infix 4 ==, /=, <, <=, >=, > + + +infixr 5 : + +data Int = MkInt +data Integer = MkInteger +data Float = MkFloat +data Double = MkDouble +data Char = MkChar +data Bin = MkBin +data List a = a : (List a) | Nil deriving (Eq, Ord) +data Arrow a b = MkArrow a b +data UnitType = UnitConstructor deriving (Eq, Ord, Ix, Enum, Binary) + +-- Equality and Ordered classes + +class Eq a where + (==), (/=) :: a -> a -> Bool + + x /= y = not (x == y) + +class (Eq a) => Ord a where + (<), (<=), (>=), (>):: a -> a -> Bool + max, min :: a -> a -> a + + x < y = x <= y && x /= y + x >= y = y <= x + x > y = y < x + + -- The following default methods are appropriate for partial orders. + -- Note that the second guards in each function can be replaced + -- by "otherwise" and the error cases, eliminated for total orders. + max x y | x >= y = x + | y >= x = y + |otherwise = error "max{PreludeCore}: no ordering relation" + min x y | x <= y = x + | y <= x = y + |otherwise = error "min{PreludeCore}: no ordering relation" + + +-- Numeric classes + +class (Eq a, Text a) => Num a where + (+), (-), (*) :: a -> a -> a + negate :: a -> a + abs, signum :: a -> a + fromInteger :: Integer -> a + + x - y = x + negate y + +class (Num a, Enum a) => Real a where + toRational :: a -> Rational + +class (Real a, Ix a) => Integral a where + quot, rem, div, mod :: a -> a -> a + quotRem, divMod :: a -> a -> (a,a) + even, odd :: a -> Bool + toInteger :: a -> Integer + + n `quot` d = q where (q,r) = quotRem n d + n `rem` d = r where (q,r) = quotRem n d + n `div` d = q where (q,r) = divMod n d + n `mod` d = r where (q,r) = divMod n d + divMod n d = if signum r == - signum d then (q-1, r+d) else qr + where qr@(q,r) = quotRem n d + even n = n `rem` 2 == 0 + odd = not . even + +class (Num a) => Fractional a where + (/) :: a -> a -> a + recip :: a -> a + fromRational :: Rational -> a + + recip x = 1 / x + +class (Fractional a) => Floating a where + pi :: a + exp, log, sqrt :: a -> a + (**), logBase :: a -> a -> a + sin, cos, tan :: a -> a + asin, acos, atan :: a -> a + sinh, cosh, tanh :: a -> a + asinh, acosh, atanh :: a -> a + + x ** y = exp (log x * y) + logBase x y = log y / log x + sqrt x = x ** 0.5 + tan x = sin x / cos x + tanh x = sinh x / cosh x + +class (Real a, Fractional a) => RealFrac a where + properFraction :: (Integral b) => a -> (b,a) + truncate, round :: (Integral b) => a -> b + ceiling, floor :: (Integral b) => a -> b + + truncate x = m where (m,_) = properFraction x + + round x = let (n,r) = properFraction x + m = if r < 0 then n - 1 else n + 1 + in case signum (abs r - 0.5) of + -1 -> n + 0 -> if even n then n else m + 1 -> m + + ceiling x = if r > 0 then n + 1 else n + where (n,r) = properFraction x + + floor x = if r < 0 then n - 1 else n + where (n,r) = properFraction x + +class (RealFrac a, Floating a) => RealFloat a where + floatRadix :: a -> Integer + floatDigits :: a -> Int + floatRange :: a -> (Int,Int) + decodeFloat :: a -> (Integer,Int) + encodeFloat :: Integer -> Int -> a + exponent :: a -> Int + significand :: a -> a + scaleFloat :: Int -> a -> a + + exponent x = if m == 0 then 0 else n + floatDigits x + where (m,n) = decodeFloat x + + significand x = encodeFloat m (- floatDigits x) + where (m,_) = decodeFloat x + + scaleFloat k x = encodeFloat m (n+k) + where (m,n) = decodeFloat x + + +-- Index and Enumeration classes + +class (Ord a, Text a) => Ix a where -- This is a Yale modification + range :: (a,a) -> [a] + index :: (a,a) -> a -> Int + inRange :: (a,a) -> a -> Bool + +class (Ord a) => Enum a where + enumFrom :: a -> [a] -- [n..] + enumFromThen :: a -> a -> [a] -- [n,n'..] + enumFromTo :: a -> a -> [a] -- [n..m] + enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] + + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + +defaultEnumFromTo n m = takeWhile (<= m) (enumFrom n) +defaultEnumFromThenTo n n' m + = takeWhile (if n' >= n then (<= m) else (>= m)) + (enumFromThen n n') +{-# defaultEnumFromTo :: Inline #-} +{-# defaultEnumFromThenTo :: Inline #-} + +-- Text class + +type ReadS a = String -> [(a,String)] +type ShowS = String -> String + +class Text a where + readsPrec :: Int -> ReadS a + showsPrec :: Int -> a -> ShowS + readList :: ReadS [a] + showList :: [a] -> ShowS + + readList = readParen False (\r -> [pr | ("[",s) <- lex r, + pr <- readl s]) + where readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- reads s, + (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, + (x,u) <- reads t, + (xs,v) <- readl' u] + showList [] = showString "[]" + showList (x:xs) + = showChar '[' . shows x . showl xs + where showl [] = showChar ']' + showl (x:xs) = showString ", " . shows x . showl xs + + + +-- Binary class + +class Binary a where + readBin :: Bin -> (a,Bin) + showBin :: a -> Bin -> Bin + + +-- Trivial type + +-- data () = () deriving (Eq, Ord, Ix, Enum, Binary) + +instance Text () where + readsPrec p = readParen False + (\r -> [((),t) | ("(",s) <- lex r, + (")",t) <- lex s ] ) + showsPrec p () = showString "()" + + +-- Binary type + +instance Text Bin where + readsPrec p s = error "readsPrec{PreludeText}: Cannot read Bin." + showsPrec p b = showString "<<Bin>>" + + +-- Boolean type + +data Bool = False | True deriving (Eq, Ord, Ix, Enum, Text, Binary) + + +-- Character type + +instance Eq Char where + (==) = primEqChar + (/=) = primNeqChar + +instance Ord Char where + (<) = primLsChar + (<=) = primLeChar + (>) = primGtChar + (>=) = primGeChar + +instance Ix Char where + range (c,c') = [c..c'] + index b@(c,c') ci + | inRange b ci = ord ci - ord c + | otherwise = error "index{PreludeCore}: Index out of range." + inRange (c,c') ci = ord c <= i && i <= ord c' + where i = ord ci + {-# range :: Inline #-} + +instance Enum Char where + enumFrom = charEnumFrom + enumFromThen = charEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +charEnumFrom c = map chr [ord c .. ord maxChar] +charEnumFromThen c c' = map chr [ord c, ord c' .. ord lastChar] + where lastChar = if c' < c then minChar else maxChar +{-# charEnumFrom :: Inline #-} +{-# charEnumFromThen :: Inline #-} + +instance Text Char where + readsPrec p = readParen False + (\r -> [(c,t) | ('\'':s,t)<- lex r, + (c,_) <- readLitChar s]) + + showsPrec p '\'' = showString "'\\''" + showsPrec p c = showChar '\'' . showLitChar c . showChar '\'' + + readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r, + (l,_) <- readl s ]) + where readl ('"':s) = [("",s)] + readl ('\\':'&':s) = readl s + readl s = [(c:cs,u) | (c ,t) <- readLitChar s, + (cs,u) <- readl t ] + + showList cs = showChar '"' . showl cs + where showl "" = showChar '"' + showl ('"':cs) = showString "\\\"" . showl cs + showl (c:cs) = showLitChar c . showl cs + +type String = [Char] + + +-- Standard Integral types + +instance Eq Int where + (==) = primEqInt + (/=) = primNeqInt + +instance Eq Integer where + (==) = primEqInteger + (/=) = primNeqInteger + +instance Ord Int where + (<) = primLsInt + (<=) = primLeInt + (>) = primGtInt + (>=) = primGeInt + max = primIntMax + min = primIntMin + +instance Ord Integer where + (<) = primLsInteger + (<=) = primLeInteger + (>) = primGtInteger + (>=) = primGeInteger + max = primIntegerMax + min = primIntegerMin + +instance Num Int where + (+) = primPlusInt + (-) = primMinusInt + negate = primNegInt + (*) = primMulInt + abs = primAbsInt + signum = signumReal + fromInteger = primIntegerToInt + +instance Num Integer where + (+) = primPlusInteger + (-) = primMinusInteger + negate = primNegInteger + (*) = primMulInteger + abs = primAbsInteger + signum = signumReal + fromInteger x = x + +signumReal x | x == 0 = 0 + | x > 0 = 1 + | otherwise = -1 + +instance Real Int where + toRational x = toInteger x % 1 + +instance Real Integer where + toRational x = x % 1 + +instance Integral Int where + quotRem = primQuotRemInt + toInteger = primIntToInteger + +instance Integral Integer where + quotRem = primQuotRemInteger + toInteger x = x + +instance Ix Int where + range (m,n) = [m..n] + index b@(m,n) i + | inRange b i = i - m + | otherwise = error "index{PreludeCore}: Index out of range." + inRange (m,n) i = m <= i && i <= n + {-# range :: Inline #-} + +instance Ix Integer where + range (m,n) = [m..n] + index b@(m,n) i + | inRange b i = fromInteger (i - m) + | otherwise = error "index{PreludeCore}: Index out of range." + inRange (m,n) i = m <= i && i <= n + {-# range :: Inline #-} + +instance Enum Int where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +instance Enum Integer where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +numericEnumFrom :: (Real a) => a -> [a] +numericEnumFromThen :: (Real a) => a -> a -> [a] +numericEnumFrom = iterate (+1) +numericEnumFromThen n m = iterate (+(m-n)) n + +{-# numericEnumFrom :: Inline #-} +{-# numericEnumFromThen :: Inline #-} + + +instance Text Int where + readsPrec p = readSigned readDec + showsPrec = showSigned showInt + +instance Text Integer where + readsPrec p = readSigned readDec + showsPrec = showSigned showInt + + +-- Standard Floating types + +instance Eq Float where + (==) = primEqFloat + (/=) = primNeqFloat + +instance Eq Double where + (==) = primEqDouble + (/=) = primNeqDouble + +instance Ord Float where + (<) = primLsFloat + (<=) = primLeFloat + (>) = primGtFloat + (>=) = primGeFloat + max = primFloatMax + min = primFloatMin + +instance Ord Double where + (<) = primLsDouble + (<=) = primLeDouble + (>) = primGtDouble + (>=) = primGeDouble + max = primDoubleMax + min = primDoubleMax + +instance Num Float where + (+) = primPlusFloat + (-) = primMinusFloat + negate = primNegFloat + (*) = primMulFloat + abs = primAbsFloat + signum = signumReal + fromInteger n = encodeFloat n 0 + +instance Num Double where + (+) = primPlusDouble + (-) = primMinusDouble + negate = primNegDouble + (*) = primMulDouble + abs = primAbsDouble + signum = signumReal + fromInteger n = encodeFloat n 0 + +instance Real Float where + toRational = primFloatToRational + +instance Real Double where + toRational = primDoubleToRational + +-- realFloatToRational x = (m%1)*(b%1)^^n +-- where (m,n) = decodeFloat x +-- b = floatRadix x + +instance Fractional Float where + (/) = primDivFloat + fromRational = primRationalToFloat +-- fromRational = rationalToRealFloat + +instance Fractional Double where + (/) = primDivDouble + fromRational = primRationalToDouble +-- fromRational = rationalToRealFloat + +-- rationalToRealFloat x = x' +-- where x' = f e +-- f e = if e' == e then y else f e' +-- where y = encodeFloat (round (x * (1%b)^^e)) e +-- (_,e') = decodeFloat y +-- (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x' +-- / fromInteger (denominator x)) +-- b = floatRadix x' + +instance Floating Float where + pi = primPiFloat + exp = primExpFloat + log = primLogFloat + sqrt = primSqrtFloat + sin = primSinFloat + cos = primCosFloat + tan = primTanFloat + asin = primAsinFloat + acos = primAcosFloat + atan = primAtanFloat + sinh = primSinhFloat + cosh = primCoshFloat + tanh = primTanhFloat + asinh = primAsinhFloat + acosh = primAcoshFloat + atanh = primAtanhFloat + +instance Floating Double where + pi = primPiDouble + exp = primExpDouble + log = primLogDouble + sqrt = primSqrtDouble + sin = primSinDouble + cos = primCosDouble + tan = primTanDouble + asin = primAsinDouble + acos = primAcosDouble + atan = primAtanDouble + sinh = primSinhDouble + cosh = primCoshDouble + tanh = primTanhDouble + asinh = primAsinhDouble + acosh = primAcoshDouble + atanh = primAtanhDouble + + +instance RealFrac Float where + properFraction = floatProperFraction + +instance RealFrac Double where + properFraction = floatProperFraction + +floatProperFraction x + | n >= 0 = (fromInteger m * fromInteger b ^ n, 0) + | otherwise = (fromInteger w, encodeFloat r n) + where (m,n) = decodeFloat x + b = floatRadix x + (w,r) = quotRem m (b^(-n)) + +instance RealFloat Float where + floatRadix _ = primFloatRadix + floatDigits _ = primFloatDigits + floatRange _ = (primFloatMinExp,primFloatMaxExp) + decodeFloat = primDecodeFloat + encodeFloat = primEncodeFloat + +instance RealFloat Double where + floatRadix _ = primDoubleRadix + floatDigits _ = primDoubleDigits + floatRange _ = (primDoubleMinExp,primDoubleMaxExp) + decodeFloat = primDecodeDouble + encodeFloat = primEncodeDouble + +instance Enum Float where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +instance Enum Double where + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromTo = defaultEnumFromTo + enumFromThenTo = defaultEnumFromThenTo + {-# enumFrom :: Inline #-} + {-# enumFromThen :: Inline #-} + {-# enumFromTo :: Inline #-} + {-# enumFromThenTo :: Inline #-} + +instance Text Float where + readsPrec p = readSigned readFloat + showsPrec = showSigned showFloat + +instance Text Double where + readsPrec p = readSigned readFloat + showsPrec = showSigned showFloat + + +-- Lists + +-- data [a] = [] | a : [a] deriving (Eq, Ord, Binary) + +instance (Text a) => Text [a] where + readsPrec p = readList + showsPrec p = showList + + +-- Tuples + +-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Binary) +{- +instance (Text a, Text b) => Text (a,b) where + readsPrec p = readParen False + (\r -> [((x,y), w) | ("(",s) <- lex r, + (x,t) <- reads s, + (",",u) <- lex t, + (y,v) <- reads u, + (")",w) <- lex v ] ) + + showsPrec p (x,y) = showChar '(' . shows x . showChar ',' . + shows y . showChar ')' +-- et cetera +-} + +-- Functions + +instance Text (a -> b) where + readsPrec p s = error "readsPrec{PreludeCore}: Cannot read functions." + showsPrec p f = showString "<<function>>" + +-- Support for class Bin + +instance Binary Int where + showBin i b = primShowBinInt i b + readBin b = primReadBinInt b + +instance Binary Integer where + showBin i b = primShowBinInteger i b + readBin b = primReadBinInteger b + +instance Binary Float where + showBin f b = primShowBinFloat f b + readBin b = primReadBinFloat b + +instance Binary Double where + showBin d b = primShowBinDouble d b + readBin b = primReadBinDouble b + +instance Binary Char where + showBin c b = primShowBinInt (ord c) b + readBin b = (chr i,b') where + (i,b') = primReadBinSmallInt b primMaxChar + +instance (Binary a) => Binary [a] where + showBin l b = showBin (length l :: Int) (sb1 l b) where + sb1 [] b = b + sb1 (h:t) b = showBin h (sb1 t b) + readBin bin = rbl len bin' where + len :: Int + (len,bin') = readBin bin + rbl 0 b = ([],b) + rbl n b = (h:t,b'') where + (h,b') = readBin b + (t,b'') = rbl (n-1) b' + +instance (Ix a, Binary a, Binary b) => Binary (Array a b) where + showBin a = showBin (bounds a) . showBin (elems a) + readBin bin = (listArray b vs, bin'') + where (b,bin') = readBin bin + (vs,bin'') = readBin bin' + +{- +instance (Binary a, Binary b) => Binary (a,b) where + showBin (x,y) = (showBin x) . (showBin y) + readBin b = ((x,y),b'') where + (x,b') = readBin b + (y,b'') = readBin b' + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + showBin (x,y,z) = (showBin x) . (showBin y) . (showBin z) + readBin b = ((x,y,z),b3) where + (x,b1) = readBin b + (y,b2) = readBin b1 + (z,b3) = readBin b2 + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + showBin (a,b,c,d) = (showBin a) . (showBin b) . (showBin c) . (showBin d) + readBin b = ((a1,a2,a3,a4),b4) where + (a1,b1) = readBin b + (a2,b2) = readBin b1 + (a3,b3) = readBin b2 + (a4,b4) = readBin b3 +-} +-- Instances for tuples + +-- This whole section should be handled in the support code. For now, +-- only tuple instances expliticly provided here are available. +-- Currently provided: + +-- 2,3 tuples: all classes (Eq, Ord, Ix, Bin, Text) +-- 4 tuples: Eq, Bin, Text +-- 5, 6 tuples: Text (printing only) + +{- +rangeSize :: (Ix a) => (a,a) -> Int +rangeSize (l,u) = index (l,u) u + 1 + +instance (Eq a1, Eq a2) => Eq (a1,a2) where + (a1,a2) == (z1,z2) = a1==z1 && a2==z2 + +instance (Ord a1, Ord a2) => Ord (a1,a2) where + (a1,a2) <= (z1,z2) = a1<=z1 || a1==z1 && a2<=z2 + (a1,a2) < (z1,z2) = a1<z1 || a1==z1 && a2<z2 + +instance (Ix a1, Ix a2) => Ix (a1,a2) where + range ((l1,l2),(u1,u2)) = [(i1,i2) | i1 <- range(l1,u1), + i2 <- range(l2,u2)] + index ((l1,l2),(u1,u2)) (i1,i2) = + index (l1,u1) i1 * rangeSize (l2,u2) + + index (l2,u2) i2 + inRange ((l1,l2),(u1,u2)) (i1,i2) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 + +{- Apprears in Joe's code. +instance (Text a1, Text a2) => Text (a1,a2) where + readsPrec p = readParen False + (\r0 -> [((a1,a2), w) | ("(",r1) <- lex r0, + (a1,r2) <- reads r1, + (",",r3) <- lex r2, + (a2,r4) <- reads r3, + (")",w) <- lex r4 ]) + + showsPrec p (a1,a2) = showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ')' +-} + +instance (Eq a1, Eq a2, Eq a3) => Eq (a1,a2,a3) where + (a1,a2,a3) == (z1,z2,z3) = a1==z1 && a2==z2 && a3==z3 + +instance (Ord a1, Ord a2, Ord a3) => Ord (a1,a2,a3) where + (a1,a2,a3) <= (z1,z2,z3) = a1<=z1 || a1==z1 && + (a2<=z2 || a2==z2 && + a3<=z3) + (a1,a2,a3) < (z1,z2,z3) = a1<z1 || a1==z1 && + (a2<z2 || a2==z2 && + a3<z3) + + +instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where + range ((l1,l2,l3),(u1,u2,u3)) = + [(i1,i2,i3) | i1 <- range(l1,u1), + i2 <- range(l2,u2), + i3 <- range(l3,u3)] + index ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + (index (l1,u1) i1 * rangeSize (l2,u2) + + index (l2,u2) i2 ) * rangeSize (l3,u3) + + index (l3,u3) i3 + inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && inRange (l3,u3) i3 + + +instance (Text a1, Text a2, Text a3) => Text (a1,a2,a3) where + readsPrec p = readParen False + (\r0 -> [((a1,a2,a3), w) | + ("(",r1) <- lex r0, + (a1,r2) <- reads r1, + (",",r3) <- lex r2, + (a2,r4) <- reads r3, + (",",r5) <- lex r4, + (a3,r6) <- reads r5, + (")",w) <- lex r6 ]) + showsPrec p (a1,a2,a3) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ')' + +instance (Eq a1, Eq a2, Eq a3, Eq a4) => Eq (a1,a2,a3,a4) where + (a1,a2,a3,a4) == (z1,z2,z3,z4) = a1==z1 && a2==z2 && a3==z3 && a4 == z4 + +instance (Text a1, Text a2, Text a3, Text a4) => Text (a1,a2,a3,a4) where + readsPrec p = readParen False + (\r0 -> [((a1,a2,a3,a4), w) | + ("(",r1) <- lex r0, + (a1,r2) <- reads r1, + (",",r3) <- lex r2, + (a2,r4) <- reads r3, + (",",r5) <- lex r4, + (a3,r6) <- reads r5, + (",",r7) <- lex r6, + (a4,r8) <- reads r7, + (")",w) <- lex r8 ]) + showsPrec p (a1,a2,a3,a4) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ',' . + shows a4 . showChar ')' + +instance (Text a1, Text a2, Text a3, Text a4, Text a5) => + Text (a1,a2,a3,a4,a5) where + readsPrec p = error "Read of 5 tuples not implemented" + showsPrec p (a1,a2,a3,a4,a5) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ',' . + shows a4 . showChar ',' . + shows a5 . showChar ')' + +instance (Text a1, Text a2, Text a3, Text a4, Text a5, Text a6) => + Text (a1,a2,a3,a4,a5,a6) where + readsPrec p = error "Read of 6 tuples not implemented" + showsPrec p (a1,a2,a3,a4,a5,a6) = + showChar '(' . shows a1 . showChar ',' . + shows a2 . showChar ',' . + shows a3 . showChar ',' . + shows a4 . showChar ',' . + shows a5 . showChar ',' . + shows a6 . showChar ')' + + +-} diff --git a/progs/prelude/PreludeIO.hs b/progs/prelude/PreludeIO.hs new file mode 100644 index 0000000..6173d8c --- /dev/null +++ b/progs/prelude/PreludeIO.hs @@ -0,0 +1,232 @@ +-- I/O functions and definitions + +module PreludeIO(stdin,stdout,stderr,stdecho,{-Request(..),Response(..),-} + IOError(..),Dialogue(..),IO(..),SystemState,IOResult, + SuccCont(..),StrCont(..), + StrListCont(..),BinCont(..),FailCont(..), + readFile, writeFile, appendFile, readBinFile, + writeBinFile, appendBinFile, deleteFile, statusFile, + readChan, appendChan, readBinChan, appendBinChan, + statusChan, echo, getArgs, getProgName, getEnv, setEnv, + done, exit, abort, print, prints, interact, + thenIO,thenIO_,seqIO,returnIO, doneIO) + where + +import PreludeBltinIO +import PreludeBltinArray(strict1) + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +-- These datatypes are used by the monad. + +type IO a = SystemState -> IOResult a + +data SystemState = SystemState +data IOResult a = IOResult a + +-- Operations in the monad + +-- This definition is needed to allow proper tail recursion of the Lisp +-- code. The use of strict1 forces f1 s (since getState is strict) before +-- the call to f2. The optimizer removed getState and getRes from the +-- generated code. + +{-# thenIO :: Inline #-} +thenIO f1 f2 s = + let g = f1 s + s' = getState g in + strict1 s' (f2 (getRes g) s') + +{-# thenIO_ :: Inline #-} +x `thenIO_` y = x `thenIO` \_ -> y +x `seqIO` y = x `thenIO` \_ -> y + +-- The returnIO function is implemented directly as a primitive. +doneIO = returnIO () + + +-- File and channel names: + +stdin = "stdin" +stdout = "stdout" +stderr = "stderr" +stdecho = "stdecho" + + +-- Requests and responses: + +{- Not used since streams are no longer supported: +data Request = -- file system requests: + ReadFile String + | WriteFile String String + | AppendFile String String + | ReadBinFile String + | WriteBinFile String Bin + | AppendBinFile String Bin + | DeleteFile String + | StatusFile String + -- channel system requests: + | ReadChan String + | AppendChan String String + | ReadBinChan String + | AppendBinChan String Bin + | StatusChan String + -- environment requests: + | Echo Bool + | GetArgs + | GetProgName + | GetEnv String + | SetEnv String String + deriving Text + +data Response = Success + | Str String + | StrList [String] + | Bn Bin + | Failure IOError + deriving Text + +-} + +data IOError = WriteError String + | ReadError String + | SearchError String + | FormatError String + | OtherError String + deriving Text + +-- Continuation-based I/O: + +type Dialogue = IO () +type SuccCont = Dialogue +type StrCont = String -> Dialogue +type StrListCont = [String] -> Dialogue +type BinCont = Bin -> Dialogue +type FailCont = IOError -> Dialogue + +done :: Dialogue +readFile :: String -> FailCont -> StrCont -> Dialogue +writeFile :: String -> String -> FailCont -> SuccCont -> Dialogue +appendFile :: String -> String -> FailCont -> SuccCont -> Dialogue +readBinFile :: String -> FailCont -> BinCont -> Dialogue +writeBinFile :: String -> Bin -> FailCont -> SuccCont -> Dialogue +appendBinFile :: String -> Bin -> FailCont -> SuccCont -> Dialogue +deleteFile :: String -> FailCont -> SuccCont -> Dialogue +statusFile :: String -> FailCont -> StrCont -> Dialogue +readChan :: String -> FailCont -> StrCont -> Dialogue +appendChan :: String -> String -> FailCont -> SuccCont -> Dialogue +readBinChan :: String -> FailCont -> BinCont -> Dialogue +appendBinChan :: String -> Bin -> FailCont -> SuccCont -> Dialogue +statusChan :: String -> FailCont -> StrCont -> Dialogue +echo :: Bool -> FailCont -> SuccCont -> Dialogue +getArgs :: FailCont -> StrListCont -> Dialogue +getProgName :: FailCont -> StrCont -> Dialogue +getEnv :: String -> FailCont -> StrCont -> Dialogue +setEnv :: String -> String -> FailCont -> SuccCont -> Dialogue + +done = returnIO () + +readFile name fail succ = + primReadStringFile name `thenIO` objDispatch fail succ + +writeFile name contents fail succ = + primWriteStringFile name contents `thenIO` succDispatch fail succ + +appendFile name contents fail succ = + primAppendStringFile name contents `thenIO` succDispatch fail succ + +readBinFile name fail succ = + primReadBinFile name `thenIO` objDispatch fail succ + +writeBinFile name contents fail succ = + primWriteBinFile name contents `thenIO` succDispatch fail succ + +appendBinFile name contents fail succ = + primAppendBinFile name contents `thenIO` succDispatch fail succ + +deleteFile name fail succ = + primDeleteFile name `thenIO` succDispatch fail succ + +statusFile name fail succ = + primStatusFile name `thenIO` + (\status -> case status of Succ s -> succ s + Fail msg -> fail (SearchError msg)) + +readChan name fail succ = + if name == stdin then + primReadStdin `thenIO` succ + else + badChan fail name + +appendChan name contents fail succ = + if name == stdout then + primWriteStdout contents `thenIO` succDispatch fail succ + else + badChan fail name + +readBinChan name fail succ = + if name == stdin then + primReadBinStdin `thenIO` objDispatch fail succ + else + badChan fail name + +appendBinChan name contents fail succ = + if name == stdout then + primWriteBinStdout contents `thenIO` succDispatch fail succ + else + badChan fail name + +statusChan name fail succ = + if name == stdin || name == stdout then + succ "0 0" + else + fail (SearchError "Channel not defined") + +echo bool fail succ = + if bool then + succ + else + fail (OtherError "Echo cannot be turned off") + +getArgs fail succ = + succ [""] + +getProgName fail succ = + succ "haskell" + +getEnv name fail succ = + primGetEnv name `thenIO` objDispatch fail succ + +setEnv name val fail succ = + fail (OtherError "setEnv not implemented") + +objDispatch fail succ r = + case r of Succ s -> succ s + Fail msg -> fail (OtherError msg) + +succDispatch fail succ r = + case r of Succ _ -> succ + Fail msg -> fail (OtherError msg) + +badChan f name = f (OtherError ("Improper IO Channel: " ++ name)) + +abort :: FailCont +abort err = done + +exit :: FailCont +exit err = appendChan stderr (msg ++ "\n") abort done + where msg = case err of ReadError s -> s + WriteError s -> s + SearchError s -> s + FormatError s -> s + OtherError s -> s + +print :: (Text a) => a -> Dialogue +print x = appendChan stdout (show x) exit done +prints :: (Text a) => a -> String -> Dialogue +prints x s = appendChan stdout (shows x s) exit done + +interact :: (String -> String) -> Dialogue +interact f = readChan stdin exit + (\x -> appendChan stdout (f x) exit done) + diff --git a/progs/prelude/PreludeIOMonad.hs b/progs/prelude/PreludeIOMonad.hs new file mode 100644 index 0000000..9a45606 --- /dev/null +++ b/progs/prelude/PreludeIOMonad.hs @@ -0,0 +1,60 @@ +module IOMonad (State, IO(..)) where + +import IOMonadPrims + +{- I use data instead of type so that IO can be abstract. For efficiency, + IO can be annotated as a strict constructor. +-} + +type IO a = State -> (State, a) + +data State = State + +-- The rest of this file is unnecessary at the moment since +-- unitIO & bindIO are primitives and we're not using the rest of this + +{- Implemented as a primitives: +bindIO :: IO a -> (a -> IO b) -> IO b +bindIO (IO m) (IO k) = IO (\s0 -> let (s1, a) = m s0 in k a s1) -} + +unitIO :: a -> IO a +unitIO x = IO (\s -> (s, x)) + +-} + +{- Not currently used: +pureIO :: IO a -> a +pureIO (IO m) = let (s, x) = m State in x + +-- execIO executes a program of type IO (). +execIO :: IO () -> State +execIO (IO m) = let (s, x) = m State in s + +infixr 1 =: +infixr 1 ? + +-- assignment +(=:) :: a -> Var a -> IO () +x =: v = IO (\s -> (update v x s, ())) + +-- reader +(?) :: Var a -> (a -> IO b) -> IO b +v ? k = IO (\s -> (s, readVar v s)) `bindIO` k + +-- new +newvar :: IO (Var a) +newvar = IO allocVar + +instance Eq (Var a) where + x == y = eqVar x y +-} + + + + + + + + + + diff --git a/progs/prelude/PreludeIOPrims.hi b/progs/prelude/PreludeIOPrims.hi new file mode 100644 index 0000000..e4c2e74 --- /dev/null +++ b/progs/prelude/PreludeIOPrims.hi @@ -0,0 +1,55 @@ +-- These lisp functions implement the standard Haskell requests + +interface PreludeBltinIO where + +import PreludeCore(String,Bin) +import PreludeIO(SystemState,IOResult,IO) +data IOResponse a = Succ a | Fail String + +{-# Prelude #-} + +primReadStringFile :: String -> IO (IOResponse String) +primWriteStringFile :: String -> String -> IO (IOResponse ()) +primAppendStringFile :: String -> String -> IO (IOResponse ()) +primReadBinFile :: String -> IO (IOResponse Bin) +primWriteBinFile :: String -> Bin -> IO (IOResponse ()) +primAppendBinFile :: String -> Bin -> IO (IOResponse ()) +primDeleteFile :: String -> IO (IOResponse ()) +primStatusFile :: String -> IO (IOResponse String) +primReadStdin :: IO String +primWriteStdout :: String -> IO (IOResponse ()) +primReadBinStdin :: IO (IOResponse Bin) +primWriteBinStdout :: Bin -> IO (IOResponse ()) +primGetEnv :: String -> IO (IOResponse String) + +{-# +primReadStringFile :: LispName("prim.read-string-file") +primWriteStringFile :: LispName("prim.write-string-file"), NoConversion +primAppendStringFile :: LispName("prim.append-string-file"), NoConversion +primReadBinFile :: LispName("prim.read-bin-file") +primWriteBinFile :: LispName("prim.write-bin-file") +primAppendBinFile :: LispName("prim.append-bin-file") +primDeleteFile :: LispName("prim.delete-file") +primStatusFile :: LispName("prim.status-file") +primReadStdin :: LispName("prim.read-string-stdin"), NoConversion +primWriteStdout :: LispName("prim.write-string-stdout"), NoConversion +primReadBinStdin :: LispName("prim.read-bin-stdin") +primWriteBinStdout :: LispName("prim.write-bin-stdout") +primGetEnv :: LispName("prim.getenv") +#-} + +-- Monad prims + +returnIO :: a -> IO a +getState :: IOResult a -> SystemState +getRes :: IOResult a -> a + +{-# +returnIO :: LispName("prim.returnio"), + Strictness("N,S"), NoConversion, Complexity(3) +getState :: LispName("prim.getstate"), + Strictness("S"), NoConversion, Complexity(3) +getRes :: LispName("prim.getres"), + Strictness("S"), NoConversion +#-} + diff --git a/progs/prelude/PreludeIOPrims.hu b/progs/prelude/PreludeIOPrims.hu new file mode 100644 index 0000000..66393c5 --- /dev/null +++ b/progs/prelude/PreludeIOPrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludeIOPrims +:stable +:prelude +PreludeIOPrims.hi diff --git a/progs/prelude/PreludeList.hs b/progs/prelude/PreludeList.hs new file mode 100644 index 0000000..3e445c3 --- /dev/null +++ b/progs/prelude/PreludeList.hs @@ -0,0 +1,585 @@ +-- Standard list functions + +-- build really shouldn't be exported, but what the heck. +-- some of the helper functions in this file shouldn't be +-- exported either! + +module PreludeList (PreludeList.., foldr, build) where + +import PreludePrims(build, foldr) + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixl 9 !! +infix 5 \\ +infixr 5 ++ +infix 4 `elem`, `notElem` + + +-- These are primitives used by the deforestation stuff in the optimizer. +-- the optimizer will turn references to foldr and build into +-- inlineFoldr and inlineBuild, respectively, but doesn't want to +-- necessarily inline all references immediately. + +inlineFoldr :: (a -> b -> b) -> b -> [a] -> b +inlineFoldr f z l = + let foldr' [] = z + foldr' (x:xs) = f x (foldr' xs) + in foldr' l +{-# inlineFoldr :: Inline #-} + + +inlineBuild :: ((a -> [a] -> [a]) -> [b] -> [c]) -> [c] +inlineBuild g = g (:) [] +{-# inlineBuild :: Inline #-} + + +-- head and tail extract the first element and remaining elements, +-- respectively, of a list, which must be non-empty. last and init +-- are the dual functions working from the end of a finite list, +-- rather than the beginning. + +head :: [a] -> a +head (x:_) = x +head [] = error "head{PreludeList}: head []" + +last :: [a] -> a +last [x] = x +last (_:xs) = last xs +last [] = error "last{PreludeList}: last []" + +tail :: [a] -> [a] +tail (_:xs) = xs +tail [] = error "tail{PreludeList}: tail []" + +init :: [a] -> [a] +init [x] = [] +init (x:xs) = x : init xs +init [] = error "init{PreludeList}: init []" + +-- null determines if a list is empty. +null :: [a] -> Bool +null [] = True +null (_:_) = False + + +-- list concatenation (right-associative) + +(++) :: [a] -> [a] -> [a] +xs ++ ys = build (\ c n -> foldr c (foldr c n ys) xs) +{-# (++) :: Inline #-} + + +-- the first occurrence of each element of ys in turn (if any) +-- has been removed from xs. Thus, (xs ++ ys) \\ xs == ys. +(\\) :: (Eq a) => [a] -> [a] -> [a] +(\\) = foldl del + where [] `del` _ = [] + (x:xs) `del` y + | x == y = xs + | otherwise = x : xs `del` y + +-- length returns the length of a finite list as an Int; it is an instance +-- of the more general genericLength, the result type of which may be +-- any kind of number. + +genericLength :: (Num a) => [b] -> a +genericLength l = foldr (\ x n -> 1 + n) 0 l +--genericLength [] = 0 +--genericLength (x:xs) = 1 + genericLength xs +{-# genericLength :: Inline #-} + + +length :: [a] -> Int +length l = foldr (\ x n -> 1 + n) 0 l +--length [] = 0 +--length (x:xs) = 1 + length xs +{-# length :: Inline #-} + +-- List index (subscript) operator, 0-origin +(!!) :: (Integral a) => [b] -> a -> b +l !! i = nth l (fromIntegral i) +{-# (!!) :: Inline #-} + +nth :: [b] -> Int -> b +nth l m = let f x g 0 = x + f x g i = g (i - 1) + fail _ = error "(!!){PreludeList}: index too large" + in foldr f fail l m +{-# nth :: Inline #-} +--nth _ n | n < 0 = error "(!!){PreludeList}: negative index" +--nth [] n = error "(!!){PreludeList}: index too large" +--nth (x:xs) n +-- | n == 0 = x +-- | otherwise = nth xs (n - 1) +--{-# nth :: Strictness("S,S") #-} + +-- map f xs applies f to each element of xs; i.e., map f xs == [f x | x <- xs]. +map :: (a -> b) -> [a] -> [b] +map f xs = build (\ c n -> foldr (\ a b -> c (f a) b) n xs) +--map f [] = [] +--map f (x:xs) = f x : map f xs +{-# map :: Inline #-} + + +-- filter, applied to a predicate and a list, returns the list of those +-- elements that satisfy the predicate; i.e., +-- filter p xs == [x | x <- xs, p x]. +filter :: (a -> Bool) -> [a] -> [a] +filter f xs = build (\ c n -> + foldr (\ a b -> if f a then c a b else b) + n xs) +--filter p = foldr (\x xs -> if p x then x:xs else xs) [] +{-# filter :: Inline #-} + + +-- partition takes a predicate and a list and returns a pair of lists: +-- those elements of the argument list that do and do not satisfy the +-- predicate, respectively; i.e., +-- partition p xs == (filter p xs, filter (not . p) xs). +partition :: (a -> Bool) -> [a] -> ([a],[a]) +partition p = foldr select ([],[]) + where select x (ts,fs) | p x = (x:ts,fs) + | otherwise = (ts,x:fs) +{-# partition :: Inline #-} + + +-- foldl, applied to a binary operator, a starting value (typically the +-- left-identity of the operator), and a list, reduces the list using +-- the binary operator, from left to right: +-- foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn +-- foldl1 is a variant that has no starting value argument, and thus must +-- be applied to non-empty lists. scanl is similar to foldl, but returns +-- a list of successive reduced values from the left: +-- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- Note that last (scanl f z xs) == foldl f z xs. +-- scanl1 is similar, again without the starting element: +-- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] + +foldl :: (a -> b -> a) -> a -> [b] -> a +foldl f z xs = foldr (\ b g a -> g (f a b)) id xs z +--foldl f z [] = z +--foldl f z (x:xs) = foldl f (f z x) xs +{-# foldl :: Inline #-} + +foldl1 :: (a -> a -> a) -> [a] -> a +foldl1 f (x:xs) = foldl f x xs +foldl1 _ [] = error "foldl1{PreludeList}: empty list" +{-# foldl1 :: Inline #-} + +scanl :: (a -> b -> a) -> a -> [b] -> [a] +scanl f q xs = q : (case xs of + [] -> [] + x:xs -> scanl f (f q x) xs) +{-# scanl :: Inline #-} + +scanl1 :: (a -> a -> a) -> [a] -> [a] +scanl1 f (x:xs) = scanl f x xs +scanl1 _ [] = error "scanl1{PreludeList}: empty list" +{-# scanl1 :: Inline #-} + + +-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the +-- above functions. + +--foldr :: (a -> b -> b) -> b -> [a] -> b +--foldr f z [] = z +--foldr f z (x:xs) = f x (foldr f z xs) + + +foldr1 :: (a -> a -> a) -> [a] -> a +foldr1 f [x] = x +foldr1 f (x:xs) = f x (foldr1 f xs) +foldr1 _ [] = error "foldr1{PreludeList}: empty list" +{-# foldr1 :: Inline #-} + + +-- I'm not sure the build/foldr expansion wins. + +scanr :: (a -> b -> b) -> b -> [a] -> [b] +--scanr f q0 l = build (\ c n -> +-- let g x qs@(q:_) = c (f x q) qs +-- in foldr g (c q0 n) l) +scanr f q0 [] = [q0] +scanr f q0 (x:xs) = f x q : qs + where qs@(q:_) = scanr f q0 xs +{-# scanr :: Inline #-} + +scanr1 :: (a -> a -> a) -> [a] -> [a] +scanr1 f [x] = [x] +scanr1 f (x:xs) = f x q : qs + where qs@(q:_) = scanr1 f xs +scanr1 _ [] = error "scanr1{PreludeList}: empty list" +{-# scanr1 :: Inline #-} + + +-- iterate f x returns an infinite list of repeated applications of f to x: +-- iterate f x == [x, f x, f (f x), ...] +iterate :: (a -> a) -> a -> [a] +iterate f x = build (\ c n -> + let iterate' x' = c x' (iterate' (f x')) + in iterate' x) +--iterate f x = x : iterate f (f x) +{-# iterate :: Inline #-} + + +-- repeat x is an infinite list, with x the value of every element. +repeat :: a -> [a] +repeat x = build (\ c n -> let r = c x r in r) +--repeat x = xs where xs = x:xs +{-# repeat :: Inline #-} + +-- cycle ties a finite list into a circular one, or equivalently, +-- the infinite repetition of the original list. It is the identity +-- on infinite lists. + +cycle :: [a] -> [a] +cycle xs = xs' where xs' = xs ++ xs' + + +-- take n, applied to a list xs, returns the prefix of xs of length n, +-- or xs itself if n > length xs. drop n xs returns the suffix of xs +-- after the first n elements, or [] if n > length xs. splitAt n xs +-- is equivalent to (take n xs, drop n xs). + +take :: (Integral a) => a -> [b] -> [b] +take n l = takeInt (fromIntegral n) l +{-# take :: Inline #-} + +takeInt :: Int -> [b] -> [b] +takeInt m l = + build (\ c n -> + let f x g i | i <= 0 = n + | otherwise = c x (g (i - 1)) + in foldr f (\ _ -> n) l m) +--takeInt 0 _ = [] +--takeInt _ [] = [] +--takeInt n l | n > 0 = primTake n l +{-# takeInt :: Inline #-} + + + +-- Writing drop and friends in terms of build/foldr seems to lose +-- way big since they cause an extra traversal of the list tail +-- (except when the calls are being deforested). + +drop :: (Integral a) => a -> [b] -> [b] +drop n l = dropInt (fromIntegral n) l +{-# drop :: Inline #-} +{-# drop :: Strictness("S,S") #-} + + +dropInt :: Int -> [b] -> [b] +dropInt 0 xs = xs +dropInt _ [] = [] +dropInt (n+1) (_:xs) = dropInt n xs +{-# dropInt :: Inline #-} + +splitAt :: (Integral a) => a -> [b] -> ([b],[b]) +splitAt n l = splitAtInt (fromIntegral n) l +{-# splitAt :: Inline #-} + +splitAtInt :: Int -> [b] -> ([b],[b]) +splitAtInt 0 xs = ([],xs) +splitAtInt _ [] = ([],[]) +splitAtInt (n+1) (x:xs) = (x:xs',xs'') where (xs',xs'') = splitAtInt n xs +{-# splitAtInt :: Inline #-} + +-- takeWhile, applied to a predicate p and a list xs, returns the longest +-- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs +-- returns the remaining suffix. Span p xs is equivalent to +-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p. + +takeWhile :: (a -> Bool) -> [a] -> [a] +takeWhile p l = build (\ c n -> foldr (\ a b -> if p a then c a b else n) n l) +--takeWhile p [] = [] +--takeWhile p (x:xs) +-- | p x = x : takeWhile p xs +-- | otherwise = [] +{-# takeWhile :: Inline #-} + + +dropWhile :: (a -> Bool) -> [a] -> [a] +dropWhile p [] = [] +dropWhile p xs@(x:xs') + | p x = dropWhile p xs' + | otherwise = xs +{-# dropWhile :: Inline #-} + +span, break :: (a -> Bool) -> [a] -> ([a],[a]) +span p [] = ([],[]) +span p xs@(x:xs') + | p x = let (ys,zs) = span p xs' in (x:ys,zs) + | otherwise = ([],xs) +break p = span (not . p) + +{-# span :: Inline #-} +{-# break :: Inline #-} + + +-- lines breaks a string up into a list of strings at newline characters. +-- The resulting strings do not contain newlines. Similary, words +-- breaks a string up into a list of words, which were delimited by +-- white space. unlines and unwords are the inverse operations. +-- unlines joins lines with terminating newlines, and unwords joins +-- words with separating spaces. + +lines :: String -> [String] +lines "" = [] +lines s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines s'' + +words :: String -> [String] +words s = case dropWhile isSpace s of + "" -> [] + s' -> w : words s'' + where (w, s'') = break isSpace s' + +unlines :: [String] -> String +unlines = concat . map (++ "\n") +{-# unlines :: Inline #-} + + +unwords :: [String] -> String +unwords [] = "" +unwords ws = foldr1 (\w s -> w ++ ' ':s) ws + +-- nub (meaning "essence") removes duplicate elements from its list argument. +nub :: (Eq a) => [a] -> [a] +nub l = build (\ c n -> + let f x g [] = c x (g [x]) + f x g xs = if elem x xs + then (g xs) + else c x (g (x:xs)) + in foldr f (\ _ -> n) l []) +{-# nub :: Inline #-} +--nub [] = [] +--nub (x:xs) = x : nub (filter (/= x) xs) + +-- reverse xs returns the elements of xs in reverse order. xs must be finite. +reverse :: [a] -> [a] +reverse l = build (\ c n -> + let f x g tail = g (c x tail) + in foldr f id l n) +{-# reverse :: Inline #-} +--reverse x = reverse1 x [] where +-- reverse1 [] a = a +-- reverse1 (x:xs) a = reverse1 xs (x:a) + +-- and returns the conjunction of a Boolean list. For the result to be +-- True, the list must be finite; False, however, results from a False +-- value at a finite index of a finite or infinite list. or is the +-- disjunctive dual of and. +and, or :: [Bool] -> Bool +and = foldr (&&) True +or = foldr (||) False +{-# and :: Inline #-} +{-# or :: Inline #-} + +-- Applied to a predicate and a list, any determines if any element +-- of the list satisfies the predicate. Similarly, for all. +any, all :: (a -> Bool) -> [a] -> Bool +any p = or . map p +all p = and . map p +{-# any :: Inline #-} +{-# all :: Inline #-} + +-- elem is the list membership predicate, usually written in infix form, +-- e.g., x `elem` xs. notElem is the negation. +elem, notElem :: (Eq a) => a -> [a] -> Bool + +elem x ys = foldr (\ y t -> (x == y) || t) False ys +--x `elem` [] = False +--x `elem` (y:ys) = x == y || x `elem` ys +{-# elem :: Inline #-} +notElem x y = not (x `elem` y) + +-- sum and product compute the sum or product of a finite list of numbers. +sum, product :: (Num a) => [a] -> a +sum = foldl (+) 0 +product = foldl (*) 1 +{-# sum :: Inline #-} +{-# product :: Inline #-} + +-- sums and products give a list of running sums or products from +-- a list of numbers. For example, sums [1,2,3] == [0,1,3,6]. +sums, products :: (Num a) => [a] -> [a] +sums = scanl (+) 0 +products = scanl (*) 1 + +-- maximum and minimum return the maximum or minimum value from a list, +-- which must be non-empty, finite, and of an ordered type. +maximum, minimum :: (Ord a) => [a] -> a +maximum = foldl1 max +minimum = foldl1 min +{-# maximum :: Inline #-} +{-# minimum :: Inline #-} + +-- concat, applied to a list of lists, returns their flattened concatenation. +concat :: [[a]] -> [a] +concat xs = build (\ c n -> foldr (\ x y -> foldr c y x) n xs) +--concat [] = [] +--concat (l:ls) = l ++ concat ls +{-# concat :: Inline #-} + + +-- transpose, applied to a list of lists, returns that list with the +-- "rows" and "columns" interchanged. The input need not be rectangular +-- (a list of equal-length lists) to be completely transposable, but can +-- be "triangular": Each successive component list must be not longer +-- than the previous one; any elements outside of the "triangular" +-- transposable region are lost. The input can be infinite in either +-- dimension or both. +transpose :: [[a]] -> [[a]] +transpose = foldr + (\xs xss -> zipWith (:) xs (xss ++ repeat [])) + [] +{-# transpose :: Inline #-} + +-- zip takes two lists and returns a list of corresponding pairs. If one +-- input list is short, excess elements of the longer list are discarded. +-- zip3 takes three lists and returns a list of triples, etc. Versions +-- of zip producing up to septuplets are defined here. + +zip :: [a] -> [b] -> [(a,b)] +zip = zipWith (\a b -> (a,b)) +{-# zip :: Inline #-} + +zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] +zip3 = zipWith3 (\a b c -> (a,b,c)) +{-# zip3 :: Inline #-} + +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] +zip4 = zipWith4 (\a b c d -> (a,b,c,d)) +{-# zip4 :: Inline #-} + +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] +zip5 = zipWith5 (\a b c d e -> (a,b,c,d,e)) +{-# zip5 :: Inline #-} + +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] + -> [(a,b,c,d,e,f)] +zip6 = zipWith6 (\a b c d e f -> (a,b,c,d,e,f)) +{-# zip6 :: Inline #-} + +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] + -> [(a,b,c,d,e,f,g)] +zip7 = zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g)) +{-# zip7 :: Inline #-} + +-- The zipWith family generalises the zip family by zipping with the +-- function given as the first argument, instead of a tupling function. +-- For example, zipWith (+) is applied to two lists to produce the list +-- of corresponding sums. + +zipWith :: (a->b->c) -> [a]->[b]->[c] +zipWith z as bs = + build (\ c' n' -> + let f' a g' (b:bs) = c' (z a b) (g' bs) + f' a g' _ = n' + in foldr f' (\ _ -> n') as bs) +--zipWith z (a:as) (b:bs) = z a b : zipWith z as bs +--zipWith _ _ _ = [] +{-# zipWith :: Inline #-} + +zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith3 z as bs cs = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) = c' (z a b c) (g' bs cs) + f' a g' _ _ = n' + in foldr f' (\ _ _ -> n') as bs cs) +{-# zipWith3 :: Inline #-} +--zipWith3 z (a:as) (b:bs) (c:cs) +-- = z a b c : zipWith3 z as bs cs +--zipWith3 _ _ _ _ = [] + +zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWith4 z as bs cs ds = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) = c' (z a b c d) (g' bs cs ds) + f' a g' _ _ _ = n' + in foldr f' (\ _ _ _ -> n') as bs cs ds) +{-# zipWith4 :: Inline #-} +--zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) +-- = z a b c d : zipWith4 z as bs cs ds +--zipWith4 _ _ _ _ _ = [] + +zipWith5 :: (a->b->c->d->e->f) + -> [a]->[b]->[c]->[d]->[e]->[f] +zipWith5 z as bs cs ds es= + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) (e:es) = + c' (z a b c d e) (g' bs cs ds es) + f' a g' _ _ _ _ = n' + in foldr f' (\ _ _ _ _ -> n') as bs cs ds es) +{-# zipWith5 :: Inline #-} +--zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) +-- = z a b c d e : zipWith5 z as bs cs ds es +--zipWith5 _ _ _ _ _ _ = [] + +zipWith6 :: (a->b->c->d->e->f->g) + -> [a]->[b]->[c]->[d]->[e]->[f]->[g] +zipWith6 z as bs cs ds es fs = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) = + c' (z a b c d e f) (g' bs cs ds es fs) + f' a g' _ _ _ _ _ = n' + in foldr f' (\ _ _ _ _ _ -> n') as bs cs ds es fs) +{-# zipWith6 :: Inline #-} +--zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) +-- = z a b c d e f : zipWith6 z as bs cs ds es fs +--zipWith6 _ _ _ _ _ _ _ = [] + +zipWith7 :: (a->b->c->d->e->f->g->h) + -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] +zipWith7 z as bs cs ds es fs gs = + build (\ c' n' -> + let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) = + c' (z a b c d e f g) (g' bs cs ds es fs gs) + f' a g' _ _ _ _ _ _ = n' + in foldr f' (\ _ _ _ _ _ _ -> n') as bs cs ds es fs gs) +{-# zipWith7 :: Inline #-} +--zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) +-- = z a b c d e f g : zipWith7 z as bs cs ds es fs gs +--zipWith7 _ _ _ _ _ _ _ _ = [] + + +-- unzip transforms a list of pairs into a pair of lists. As with zip, +-- a family of such functions up to septuplets is provided. + +unzip :: [(a,b)] -> ([a],[b]) +unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[]) +{-# unzip :: Inline #-} + + +unzip3 :: [(a,b,c)] -> ([a],[b],[c]) +unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) + ([],[],[]) +{-# unzip3 :: Inline #-} + +unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d]) +unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> + (a:as,b:bs,c:cs,d:ds)) + ([],[],[],[]) +{-# unzip4 :: Inline #-} + +unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e]) +unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> + (a:as,b:bs,c:cs,d:ds,e:es)) + ([],[],[],[],[]) +{-# unzip5 :: Inline #-} + +unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f]) +unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) + ([],[],[],[],[],[]) +{-# unzip6 :: Inline #-} + +unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g]) +unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) + ([],[],[],[],[],[],[]) +{-# unzip7 :: Inline #-} + diff --git a/progs/prelude/PreludeLocal.hs b/progs/prelude/PreludeLocal.hs new file mode 100644 index 0000000..6e52bbf --- /dev/null +++ b/progs/prelude/PreludeLocal.hs @@ -0,0 +1,16 @@ +module PreludeLocal where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixr 5 : + +data Int = MkInt +data Integer = MkInteger +data Float = MkFloat +data Double = MkDouble +data Char = MkChar +data Bin = MkBin +data List a = a : (List a) | Nil +data Arrow a b = MkArrow a b + +data Triv = MkTriv diff --git a/progs/prelude/PreludeLocalIO.hs b/progs/prelude/PreludeLocalIO.hs new file mode 100644 index 0000000..2753071 --- /dev/null +++ b/progs/prelude/PreludeLocalIO.hs @@ -0,0 +1,144 @@ +module PreludeLocalIO where + +import PreludeIOPrims +import PreludeIOMonad + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +data IOResponse a = Succ a | Fail String deriving Text + +exec :: ([Response] -> [Request]) -> IO () +{- +-- Sunderesh's original definition +exec p = case (p bottom) of + [] -> unitIO () + (q:qs) -> processRequest q `bindIO` \r -> + exec (\rs -> tail (p (r:rs))) + +bottom :: a +bottom = error "Should never be evaluated" +-} +-- modified from the existing compiler. no quadratic behavior +-- needs +-- pure :: IO a -> a +-- other alternatives: +-- 1. use reference cells +-- 2. implement exec in Lisp + +exec p = os requests `bindIO` \x -> unitIO () where + requests = p responses + responses = pureIO (os requests) + +os :: [Request] -> IO [Response] +os [] = unitIO [] +os (q:qs) = processRequest q `bindIO` \r -> + os qs `bindIO` \rs -> + unitIO (r:rs) + +processRequest :: Request -> IO Response + +-- This needs to be rewritten in terms of the continuation based defs + +processRequest request = + case request of + +-- File system requests + ReadFile name -> + primReadStringFile name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + WriteFile name contents -> + primWriteStringFile name contents `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + AppendFile name contents -> + primAppendStringFile name contents `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + ReadBinFile name -> + primReadBinFile name `bindIO` \a -> + case a of + Succ s -> unitIO (Bn s) + Fail e -> unitIO (Failure e) + WriteBinFile name bin -> + primWriteBinFile name bin `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + AppendBinFile name bin -> + primAppendBinFile name bin `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + DeleteFile name -> + primDeleteFile name `bindIO` \a -> + case a of + MaybeNot -> Success + Maybe e -> unitIO (Failure e) + StatusFile name -> + primStatusFile name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + +-- Channel system requests + ReadChan name -> + primReadChan name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + AppendChan name string -> + primAppendChan name string `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + ReadBinChan name -> + primReadBinChan name `bindIO` \a -> + case a of + Succ s -> unitIO (Bn s) + Fail e -> unitIO (Failure e) + AppendBinChan name bin -> + primAppendBinChan name bin `bindIO` \a -> + case a of + MaybeNot -> unitIO Success + Maybe e -> unitIO (Failure e) + StatusChan name -> + primStatusChan name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + +-- Environment requests + Echo status -> + primEcho status `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + GetArgs -> + primGetArgs `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + GetProgName -> + primProgArgs `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + GetEnv name -> + primGetEnv name `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + SetEnv name string -> + primGetEnv name string `bindIO` \a -> + case a of + Succ s -> unitIO (Str s) + Fail e -> unitIO (Failure e) + _ -> unitIO (Failure (OtherError "Unrecognized IO Feature")) + +-- Monadic Style IO +-- Channel system requests + diff --git a/progs/prelude/PreludePrims.hi b/progs/prelude/PreludePrims.hi new file mode 100644 index 0000000..737a448 --- /dev/null +++ b/progs/prelude/PreludePrims.hi @@ -0,0 +1,252 @@ +-- interface.scm -- define interface to primitives +-- +-- author : Sandra & John +-- date : 24 Apr 1992 +-- +-- This file declares the interface to the runtime system primitives. +-- The actual definitions for the Lisp functions all appear elsewhere; +-- they all have names like prim.xxx. (They can actually be macros +-- instead of functions since they're never referenced by name.) + +interface PreludePrims where + +{-# Prelude #-} + +import PreludeCore(Int,Integer,Float,Double,Char,Bool) +import PreludeRational(Rational) + +error :: String -> a +primCharToInt :: Char -> Int +primIntToChar :: Int -> Char +primEqChar, primNeqChar, primLeChar, primGtChar, primLsChar, primGeChar + :: Char -> Char -> Bool +primMaxChar :: Int +primEqFloat, primNeqFloat, primLeFloat, primGtFloat, primLsFloat, primGeFloat + :: Float -> Float -> Bool +primFloatMax, primFloatMin :: Float -> Float -> Float +primEqDouble, primNeqDouble, primLeDouble, primGtDouble, + primLsDouble, primGeDouble + :: Double -> Double -> Bool +primDoubleMax, primDoubleMin :: Double -> Double -> Double +primPlusFloat, primMinusFloat, primMulFloat, primDivFloat + :: Float -> Float -> Float +primPlusDouble, primMinusDouble, primMulDouble, primDivDouble + :: Double -> Double -> Double +primNegFloat, primAbsFloat :: Float -> Float +primNegDouble, primAbsDouble :: Double -> Double +primExpFloat, primLogFloat, primSqrtFloat, primSinFloat, primCosFloat, + primTanFloat, primAsinFloat, primAcosFloat, primAtanFloat, primSinhFloat, + primCoshFloat, primTanhFloat, primAsinhFloat, primAcoshFloat, primAtanhFloat + :: Float -> Float +primExpDouble, primLogDouble, primSqrtDouble, primSinDouble, primCosDouble, + primTanDouble, primAsinDouble, primAcosDouble, primAtanDouble, primSinhDouble, + primCoshDouble, primTanhDouble, primAsinhDouble, primAcoshDouble, primAtanhDouble + :: Double -> Double +primPiFloat :: Float +primPiDouble :: Double +primRationalToFloat :: Rational -> Float +primRationalToDouble :: Rational -> Double +primFloatToRational :: Float -> Rational +primDoubleToRational :: Double -> Rational +primFloatDigits :: Int +primFloatRadix :: Integer +primFloatMinExp :: Int +primFloatMaxExp :: Int +primFloatRange :: Float -> (Int, Int) +primDecodeFloat :: Float -> (Integer, Int) +primEncodeFloat :: Integer -> Int -> Float +primDoubleDigits :: Int +primDoubleRadix :: Integer +primDoubleMinExp :: Int +primDoubleMaxExp :: Int +primDoubleRange :: Double -> (Int, Int) +primDecodeDouble :: Double -> (Integer, Int) +primEncodeDouble :: Integer -> Int -> Double +primEqInt, primNeqInt, primLeInt, primGtInt, primLsInt, primGeInt + :: Int -> Int -> Bool +primIntMax, primIntMin :: Int -> Int -> Int +primEqInteger, primNeqInteger, primLeInteger, primGtInteger, + primLsInteger, primGeInteger + :: Integer -> Integer -> Bool +primIntegerMax, primIntegerMin :: Integer -> Integer -> Integer +primPlusInt, primMinusInt, primMulInt :: Int -> Int -> Int +primMinInt,primMaxInt :: Int +primNegInt, primAbsInt :: Int -> Int +primPlusInteger, primMinusInteger, primMulInteger :: Integer -> Integer -> Integer +primNegInteger, primAbsInteger :: Integer -> Integer +primQuotRemInt :: Int -> Int -> (Int, Int) +primQuotRemInteger :: Integer -> Integer -> (Integer, Integer) +primIntegerToInt :: Integer -> Int +primIntToInteger :: Int -> Integer +primNullBin :: Bin +primIsNullBin :: Bin -> Bool +primShowBinInt :: Int -> Bin -> Bin +primShowBinInteger :: Integer -> Bin -> Bin +primShowBinFloat :: Float -> Bin -> Bin +primShowBinDouble :: Double -> Bin -> Bin +primReadBinInt :: Bin -> (Int,Bin) +primReadBinInteger :: Bin -> (Integer,Bin) +primReadBinFloat :: Bin -> (Float,Bin) +primReadBinDouble :: Bin -> (Double,Bin) +primReadBinSmallInt :: Bin -> Int -> (Int,Bin) +primAppendBin :: Bin -> Bin -> Bin + +primStringEq :: [Char] -> [Char] -> Bool + +primAppend :: [a] -> [a] -> [a] +primTake :: Int -> [a] -> [a] + +foldr :: (a -> b -> b) -> b -> [a] -> b +build :: ((a -> [a] -> [a]) -> [b] -> [c]) -> [c] + + + +-- I've assigned complexities for arithmetic primitives as follows: +-- Int and Char comparisons and arithmetic are very cheap (complexity 1). +-- Double and Float comparsions are also cheap, but most implementations +-- need to box the results of floating-point arithmetic so I have given +-- them a complexity of 3. +-- Integer operations need to do an extra bignum check that has a fixed +-- overhead. I assume that actual bignums will be rare and give them +-- all a complexity of 2. + +{-# +error :: LispName("prim.abort") +primCharToInt :: LispName("prim.char-to-int"), Complexity(0),NoConversion +primIntToChar :: LispName("prim.int-to-char"), Complexity(0),NoConversion +primEqChar :: LispName("prim.eq-char"), Complexity(1), NoConversion +primNeqChar:: LispName("prim.not-eq-char"), Complexity(1), NoConversion +primLeChar :: LispName("prim.le-char"), Complexity(1), NoConversion +primGtChar :: LispName("prim.not-le-char"), Complexity(1), NoConversion +primLsChar :: LispName("prim.lt-char"), Complexity(1), NoConversion +primGeChar :: LispName("prim.not-lt-char"), Complexity(1), NoConversion +primMaxChar :: LispName("prim.max-char"), NoConversion +primEqFloat :: LispName("prim.eq-float"), Complexity(1) +primNeqFloat :: LispName("prim.not-eq-float"), Complexity(1) +primLeFloat :: LispName("prim.le-float"), Complexity(1) +primGtFloat :: LispName("prim.not-le-float"), Complexity(1) +primLsFloat :: LispName("prim.lt-float"), Complexity(1) +primGeFloat :: LispName("prim.not-lt-float"), Complexity(1) +primFloatMax :: LispName("prim.float-max"), Complexity(3) +primFloatMin :: LispName("prim.float-min"), Complexity(3) +primEqDouble :: LispName("prim.eq-double"), Complexity(1) +primNeqDouble :: LispName("prim.not-eq-double"), Complexity(1) +primLeDouble :: LispName("prim.le-double"), Complexity(1) +primGtDouble :: LispName("prim.not-le-double"), Complexity(1) +primLsDouble :: LispName("prim.lt-double"), Complexity(1) +primGeDouble :: LispName("prim.not-lt-double"), Complexity(1) +primDoubleMax :: LispName("prim.double-max"), Complexity(3) +primDoubleMin :: LispName("prim.double-min"), Complexity(3) +primPlusFloat :: LispName("prim.plus-float"), Complexity(3) +primMinusFloat :: LispName("prim.minus-float"), Complexity(3) +primMulFloat :: LispName("prim.mul-float"), Complexity(3) +primDivFloat :: LispName("prim.div-float"), Complexity(3) +primPlusDouble :: LispName("prim.plus-double"), Complexity(3) +primMinusDouble :: LispName("prim.minus-double"), Complexity(3) +primMulDouble :: LispName("prim.mul-double"), Complexity(3) +primDivDouble :: LispName("prim.div-double"), Complexity(3) +primNegFloat :: LispName("prim.neg-float"), Complexity(3) +primAbsFloat :: LispName("prim.abs-float"), Complexity(3) +primNegDouble :: LispName("prim.neg-double"), Complexity(3) +primAbsDouble :: LispName("prim.abs-double"), Complexity(3) +primExpFloat :: LispName("prim.exp-float") +primLogFloat :: LispName("prim.log-float") +primSqrtFloat :: LispName("prim.sqrt-float") +primSinFloat :: LispName("prim.sin-float") +primCosFloat :: LispName("prim.cos-float") +primTanFloat :: LispName("prim.tan-float") +primAsinFloat :: LispName("prim.asin-float") +primAcosFloat :: LispName("prim.acos-float") +primAtanFloat :: LispName("prim.atan-float") +primSinhFloat :: LispName("prim.sinh-float") +primCoshFloat :: LispName("prim.cosh-float") +primTanhFloat :: LispName("prim.tanh-float") +primAsinhFloat :: LispName("prim.asinh-float") +primAcoshFloat :: LispName("prim.acosh-float") +primAtanhFloat :: LispName("prim.atanh-float") +primExpDouble :: LispName("prim.exp-double") +primLogDouble :: LispName("prim.log-double") +primSqrtDouble :: LispName("prim.sqrt-double") +primSinDouble :: LispName("prim.sin-double") +primCosDouble :: LispName("prim.cos-double") +primTanDouble :: LispName("prim.tan-double") +primAsinDouble :: LispName("prim.asin-double") +primAcosDouble :: LispName("prim.acos-double") +primAtanDouble :: LispName("prim.atan-double") +primSinhDouble :: LispName("prim.sinh-double") +primCoshDouble :: LispName("prim.cosh-double") +primTanhDouble :: LispName("prim.tanh-double") +primAsinhDouble :: LispName("prim.asinh-double") +primAcoshDouble :: LispName("prim.acosh-double") +primAtanhDouble :: LispName("prim.atanh-double") +primPiFloat :: LispName("prim.pi-float") +primPiDouble :: LispName("prim.pi-double") +primRationalToFloat :: LispName("prim.rational-to-float"), Complexity(3) +primRationalToDouble :: LispName("prim.rational-to-double"), Complexity(3) +primFloatToRational :: LispName("prim.float-to-rational"), Complexity(3) +primDoubleToRational :: LispName("prim.double-to-rational"), Complexity(3) +primFloatDigits :: LispName("prim.float-digits") +primFloatRadix :: LispName("prim.float-radix") +primFloatMinExp :: LispName("prim.float-min-exp") +primFloatMaxExp :: LispName("prim.float-max-exp") +primFloatRange :: LispName("prim.float-range") +primDecodeFloat :: LispName("prim.decode-float") +primEncodeFloat :: LispName("prim.encode-float") +primDoubleDigits :: LispName("prim.double-digits") +primDoubleRadix :: LispName("prim.double-radix") +primDoubleMinExp :: LispName("prim.double-min-exp") +primDoubleMaxExp :: LispName("prim.double-max-exp") +primDoubleRange :: LispName("prim.double-range") +primDecodeDouble :: LispName("prim.decode-double") +primEncodeDouble :: LispName("prim.encode-double") +primEqInt :: LispName("prim.eq-int"), Complexity(1) +primNeqInt:: LispName("prim.not-eq-int"), Complexity(1) +primLeInt :: LispName("prim.le-int"), Complexity(1) +primGtInt :: LispName("prim.not-le-int"), Complexity(1) +primLsInt :: LispName("prim.lt-int"), Complexity(1) +primGeInt :: LispName("prim.not-lt-int"), Complexity(1) +primIntMax :: LispName("prim.int-max"), Complexity(1) +primIntMin :: LispName("prim.int-min"), Complexity(1) +primEqInteger :: LispName("prim.eq-integer"), Complexity(2) +primNeqInteger:: LispName("prim.not-eq-integer"), Complexity(2) +primLeInteger :: LispName("prim.le-integer"), Complexity(2) +primGtInteger :: LispName("prim.not-le-integer"), Complexity(2) +primLsInteger :: LispName("prim.lt-integer"), Complexity(2) +primGeInteger :: LispName("prim.not-lt-integer"), Complexity(2) +primIntegerMax :: LispName("prim.integer-max"), Complexity(2) +primIntegerMin :: LispName("prim.integer-min"), Complexity(2) +primPlusInt :: LispName("prim.plus-int"), Complexity(1) +primMinusInt :: LispName("prim.minus-int"), Complexity(1) +primMulInt :: LispName("prim.mul-int"), Complexity(1) +primMinInt :: LispName("prim.minint") +primMaxInt :: LispName("prim.maxint") +primNegInt :: LispName("prim.neg-int"), Complexity(1) +primAbsInt :: LispName("prim.abs-int"), Complexity(1) +primPlusInteger :: LispName("prim.plus-integer"), Complexity(2) +primMinusInteger :: LispName("prim.minus-integer"), Complexity(2) +primMulInteger :: LispName("prim.mul-integer"), Complexity(2) +primNegInteger :: LispName("prim.neg-integer"), Complexity(2) +primAbsInteger :: LispName("prim.abs-integer"), Complexity(2) +primQuotRemInt :: LispName("prim.div-rem-int") +primQuotRemInteger :: LispName("prim.div-rem-integer") +primIntegerToInt :: LispName("prim.integer-to-int"), Complexity(1) +primIntToInteger :: LispName("prim.int-to-integer"), Complexity(0) +primNullBin :: LispName("prim.nullbin") +primIsNullBin :: LispName("prim.is-null-bin"), Complexity(1) +primShowBinInt :: LispName("prim.show-bin-int"), Complexity(2) +primShowBinInteger :: LispName("prim.show-bin-integer"), Complexity(2) +primShowBinFloat :: LispName("prim.show-bin-float"), Complexity(2) +primShowBinDouble :: LispName("prim.show-bin-double"), Complexity(2) +primReadBinInt :: LispName("prim.read-bin-int") +primReadBinInteger :: LispName("prim.read-bin-integer") +primReadBinFloat :: LispName("prim.read-bin-float") +primReadBinDouble :: LispName("prim.read-bin-double") +primReadBinSmallInt :: LispName("prim.read-bin-small-int") +primAppendBin :: LispName("prim.append-bin") +primStringEq :: LispName("prim.string-eq"), Strictness("S,S"), NoConversion +primAppend :: LispName("prim.append"), Strictness("S,N"), NoConversion +primTake :: LispName("prim.take"), Strictness("S,S"), NoConversion +foldr :: LispName("prim.foldr"), Strictness("N,N,S"), NoConversion +build :: LispName("prim.build"), Strictness("S"), NoConversion + +#-} diff --git a/progs/prelude/PreludePrims.hu b/progs/prelude/PreludePrims.hu new file mode 100644 index 0000000..fd2cdcc --- /dev/null +++ b/progs/prelude/PreludePrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludePrims +:stable +:prelude +PreludePrims.hi diff --git a/progs/prelude/PreludeRatio.hs b/progs/prelude/PreludeRatio.hs new file mode 100644 index 0000000..564558e --- /dev/null +++ b/progs/prelude/PreludeRatio.hs @@ -0,0 +1,98 @@ +-- Standard functions on rational numbers + +module PreludeRatio ( + Ratio, Rational(..), (%), numerator, denominator, approxRational ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +infixl 7 %, :% + +prec = 7 + +data (Integral a) => Ratio a = a {-# STRICT #-} :% a {-# STRICT #-} + deriving (Eq, Binary) + +type Rational = Ratio Integer + +(%) :: (Integral a) => a -> a -> Ratio a +numerator, denominator :: (Integral a) => Ratio a -> a +approxRational :: (RealFrac a) => a -> a -> Rational + + +reduce _ 0 = error "(%){PreludeRatio}: zero denominator" +reduce x y = (x `quot` d) :% (y `quot` d) + where d = gcd x y + + +x % y = reduce (x * signum y) (abs y) + +numerator (x:%y) = x + +denominator (x:%y) = y + + +instance (Integral a) => Ord (Ratio a) where + (x:%y) <= (x':%y') = x * y' <= x' * y + (x:%y) < (x':%y') = x * y' < x' * y + +instance (Integral a) => Num (Ratio a) where + (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y') + (x:%y) * (x':%y') = reduce (x * x') (y * y') + negate (x:%y) = (-x) :% y + abs (x:%y) = abs x :% y + signum (x:%y) = signum x :% 1 + fromInteger x = fromInteger x :% 1 + +instance (Integral a) => Real (Ratio a) where + toRational (x:%y) = toInteger x :% toInteger y + +instance (Integral a) => Fractional (Ratio a) where + (x:%y) / (x':%y') = (x*y') % (y*x') + recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x + fromRational (x:%y) = fromInteger x :% fromInteger y + +instance (Integral a) => RealFrac (Ratio a) where + properFraction (x:%y) = (fromIntegral q, r:%y) + where (q,r) = quotRem x y + +instance (Integral a) => Enum (Ratio a) where + enumFrom = iterate ((+)1) + enumFromThen n m = iterate ((+)(m-n)) n + +instance (Integral a) => Text (Ratio a) where + readsPrec p = readParen (p > prec) + (\r -> [(x%y,u) | (x,s) <- reads r, + ("%",t) <- lex s, + (y,u) <- reads t ]) + + showsPrec p (x:%y) = showParen (p > prec) + (shows x . showString " % " . shows y) + + +-- approxRational, applied to two real fractional numbers x and epsilon, +-- returns the simplest rational number within epsilon of x. A rational +-- number n%d in reduced form is said to be simpler than another n'%d' if +-- abs n <= abs n' && d <= d'. Any real interval contains a unique +-- simplest rational; here, for simplicity, we assume a closed rational +-- interval. If such an interval includes at least one whole number, then +-- the simplest rational is the absolutely least whole number. Otherwise, +-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d +-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of +-- the simplest rational between d'%r' and d%r. + +approxRational x eps = simplest (x-eps) (x+eps) + where simplest x y | y < x = simplest y x + | x == y = xr + | x > 0 = simplest' n d n' d' + | y < 0 = - simplest' (-n') d' (-n) d + | otherwise = 0 :% 1 + where xr@(n:%d) = toRational x + (n':%d') = toRational y + + simplest' n d n' d' -- assumes 0 < n%d < n'%d' + | r == 0 = q :% 1 + | q /= q' = (q+1) :% 1 + | otherwise = (q*n''+d'') :% n'' + where (q,r) = quotRem n d + (q',r') = quotRem n' d' + (n'':%d'') = simplest' d' r' d r diff --git a/progs/prelude/PreludeText.hs b/progs/prelude/PreludeText.hs new file mode 100644 index 0000000..9e4e353 --- /dev/null +++ b/progs/prelude/PreludeText.hs @@ -0,0 +1,260 @@ +module PreludeText ( + reads, shows, show, read, lex, + showChar, showString, readParen, showParen, readLitChar, showLitChar, + readSigned, showSigned, readDec, showInt, readFloat, showFloat ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +reads :: (Text a) => ReadS a +reads = readsPrec 0 + +shows :: (Text a) => a -> ShowS +shows = showsPrec 0 + +read :: (Text a) => String -> a +read s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> x + [] -> error "read{PreludeText}: no parse" + _ -> error "read{PreludeText}: ambiguous parse" + +show :: (Text a) => a -> String +show x = shows x "" + +showChar :: Char -> ShowS +showChar = (:) + +showString :: String -> ShowS +showString = (++) + +showParen :: Bool -> ShowS -> ShowS +showParen b p = if b then showChar '(' . p . showChar ')' else p + +readParen :: Bool -> ReadS a -> ReadS a +readParen b g = if b then mandatory else optional + where optional r = g r ++ mandatory r + mandatory r = [(x,u) | ("(",s) <- lex r, + (x,t) <- optional s, + (")",u) <- lex t ] + +lex :: ReadS String +lex "" = [("","")] +lex (c:s) | isSpace c = lex (dropWhile isSpace s) +lex ('-':'-':s) = case dropWhile (/= '\n') s of + '\n':t -> lex t + _ -> [] -- unterminated end-of-line + -- comment + +lex ('{':'-':s) = lexNest lex s + where + lexNest f ('-':'}':s) = f s + lexNest f ('{':'-':s) = lexNest (lexNest f) s + lexNest f (c:s) = lexNest f s + lexNest _ "" = [] -- unterminated + -- nested comment + +lex ('<':'-':s) = [("<-",s)] +lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s, + ch /= "'" ] +lex ('"':s) = [('"':str, t) | (str,t) <- lexString s] + where + lexString ('"':s) = [("\"",s)] + lexString s = [(ch++str, u) + | (ch,t) <- lexStrItem s, + (str,u) <- lexString t ] + + lexStrItem ('\\':'&':s) = [("\\&",s)] + lexStrItem ('\\':c:s) | isSpace c + = [("\\&",t) | '\\':t <- [dropWhile isSpace s]] + lexStrItem s = lexLitChar s + +lex (c:s) | isSingle c = [([c],s)] + | isSym1 c = [(c:sym,t) | (sym,t) <- [span isSym s]] + | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]] + | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s], + (fe,t) <- lexFracExp s ] + | otherwise = [] -- bad character + where + isSingle c = c `elem` ",;()[]{}_" + isSym1 c = c `elem` "-~" || isSym c + isSym c = c `elem` "!@#$%&*+./<=>?\\^|:" + isIdChar c = isAlphanum c || c `elem` "_'" + + lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s, + (e,u) <- lexExp t ] + lexFracExp s = [("",s)] + + lexExp (e:s) | e `elem` "eE" + = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-", + (ds,u) <- lexDigits t] ++ + [(e:ds,t) | (ds,t) <- lexDigits s] + lexExp s = [("",s)] + +lexDigits :: ReadS String +lexDigits = nonnull isDigit + +nonnull :: (Char -> Bool) -> ReadS String +nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] + +lexLitChar :: ReadS String +lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] + where + lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] + lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] + lexEsc s@(d:_) | isDigit d = lexDigits s + lexEsc ('o':s) = [('o':os, t) | (os,t) <- nonnull isOctDigit s] + lexEsc ('x':s) = [('x':xs, t) | (xs,t) <- nonnull isHexDigit s] + lexEsc s@(c:_) | isUpper c + = case [(mne,s') | mne <- "DEL" : elems asciiTab, + ([],s') <- [match mne s] ] + of (pr:_) -> [pr] + [] -> [] + lexEsc _ = [] +lexLitChar (c:s) = [([c],s)] +lexLitChar "" = [] + +isOctDigit c = c >= '0' && c <= '7' +isHexDigit c = isDigit c || c >= 'A' && c <= 'F' + || c >= 'a' && c <= 'f' + +match :: (Eq a) => [a] -> [a] -> ([a],[a]) +match (x:xs) (y:ys) | x == y = match xs ys +match xs ys = (xs,ys) + +asciiTab = listArray ('\NUL', ' ') + ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", + "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", + "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", + "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", + "SP"] + + + +readLitChar :: ReadS Char +readLitChar ('\\':s) = readEsc s + where + readEsc ('a':s) = [('\a',s)] + readEsc ('b':s) = [('\b',s)] + readEsc ('f':s) = [('\f',s)] + readEsc ('n':s) = [('\n',s)] + readEsc ('r':s) = [('\r',s)] + readEsc ('t':s) = [('\t',s)] + readEsc ('v':s) = [('\v',s)] + readEsc ('\\':s) = [('\\',s)] + readEsc ('"':s) = [('"',s)] + readEsc ('\'':s) = [('\'',s)] + readEsc ('^':c:s) | c >= '@' && c <= '_' + = [(chr (ord c - ord '@'), s)] + readEsc s@(d:_) | isDigit d + = [(chr n, t) | (n,t) <- readDec s] + readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s] + readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s] + readEsc s@(c:_) | isUpper c + = let table = ('\DEL' := "DEL") : assocs asciiTab + in case [(c,s') | (c := mne) <- table, + ([],s') <- [match mne s]] + of (pr:_) -> [pr] + [] -> [] + readEsc _ = [] +readLitChar (c:s) = [(c,s)] + +showLitChar :: Char -> ShowS +showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (ord c)) +showLitChar '\DEL' = showString "\\DEL" +showLitChar '\\' = showString "\\\\" +showLitChar c | c >= ' ' = showChar c +showLitChar '\a' = showString "\\a" +showLitChar '\b' = showString "\\b" +showLitChar '\f' = showString "\\f" +showLitChar '\n' = showString "\\n" +showLitChar '\r' = showString "\\r" +showLitChar '\t' = showString "\\t" +showLitChar '\v' = showString "\\v" +showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO") +showLitChar c = showString ('\\' : asciiTab!c) + +protectEsc p f = f . cont + where cont s@(c:_) | p c = "\\&" ++ s + cont s = s + +readDec, readOct, readHex :: (Integral a) => ReadS a +readDec = readInt 10 isDigit (\d -> ord d - ord '0') +readOct = readInt 8 isOctDigit (\d -> ord d - ord '0') +readHex = readInt 16 isHexDigit hex + where hex d = ord d - (if isDigit d then ord '0' + else ord (if isUpper d then 'A' else 'a') + - 10) + +readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a +readInt radix isDig digToInt s = + [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r) + | (ds,r) <- nonnull isDig s ] + +showInt :: (Integral a) => a -> ShowS +showInt n r = let (n',d) = quotRem n 10 + r' = chr (ord '0' + fromIntegral d) : r + in if n' == 0 then r' else showInt n' r' + +readSigned:: (Real a) => ReadS a -> ReadS a +readSigned readPos = readParen False read' + where read' r = read'' r ++ + [(-x,t) | ("-",s) <- lex r, + (x,t) <- read'' s] + read'' r = [(n,s) | (str,s) <- lex r, + (n,"") <- readPos str] + +showSigned:: (Real a) => (a -> ShowS) -> Int -> a -> ShowS +showSigned showPos p x = if x < 0 then showParen (p > 6) + (showChar '-' . showPos (-x)) + else showPos x + + +-- The functions readFloat and showFloat below use rational arithmetic +-- to insure correct conversion between the floating-point radix and +-- decimal. It is often possible to use a higher-precision floating- +-- point type to obtain the same results. + +readFloat:: (RealFloat a) => ReadS a +readFloat r = [(fromRational ((n%1)*10^^(k-d)), t) | (n,d,s) <- readFix r, + (k,t) <- readExp s] + where readFix r = [(read (ds++ds'), length ds', t) + | (ds,'.':s) <- lexDigits r, + (ds',t) <- lexDigits s ] + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = [(0,s)] + + readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s] + readExp' ('+':s) = readDec s + readExp' s = readDec s + +-- The number of decimal digits m below is chosen to guarantee +-- read (show x) == x. See +-- Matula, D. W. A formalization of floating-point numeric base +-- conversion. IEEE Transactions on Computers C-19, 8 (1970 August), +-- 681-692. + +showFloat:: (RealFloat a) => a -> ShowS +showFloat x = + if x == 0 then showString ("0." ++ take (m-1) (repeat '0')) + else if e >= m-1 || e < 0 then showSci else showFix + where + showFix = showString whole . showChar '.' . showString frac + where (whole,frac) = splitAt (e+1) (show sig) + showSci = showChar d . showChar '.' . showString frac + . showChar 'e' . shows e + where (d:frac) = show sig + (m, sig, e) = if b == 10 then (w, s, n+w-1) + else (m', sig', e' ) + m' = ceiling + (fromIntegral w * log (fromInteger b) / log 10 :: Double) + + 1 + (sig', e') = if sig1 >= 10^m' then (round (t/10), e1+1) + else if sig1 < 10^(m'-1) then (round (t*10), e1-1) + else (sig1, e1 ) + sig1 :: Integer + sig1 = round t + t = s%1 * (b%1)^^n * 10^^(m'-e1-1) + e1 = floor (logBase 10 x) + (s, n) = decodeFloat x + b = floatRadix x + w = floatDigits x diff --git a/progs/prelude/PreludeTuple.hs b/progs/prelude/PreludeTuple.hs new file mode 100644 index 0000000..4f2637a --- /dev/null +++ b/progs/prelude/PreludeTuple.hs @@ -0,0 +1,213 @@ +module PreludeTuple where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +import PreludeTuplePrims + +-- This module contains support routines which handle tuple instances. +-- These are based on a implementation level data type which represents +-- general tuples and a data type to hold the set of dictionaries which +-- are associated with the tuple. + +-- Each of these functions takes the tupledicts as the first argument. +-- Force all of these functions to take strict arguments because they'll +-- never be called with 0-length tuples anyway. + +-- The following primitives operate on tuples. + +-- tupleSize :: TupleDicts -> Int +-- tupleSel :: Tuple -> Int -> Int -> a +-- dictSel :: TupleDicts -> method -> Int -> a +-- listToTuple :: [a] -> Tuple + +-- Eq functions + +tupleEq :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleEq :: Strictness("S,S,S") #-} +tupleEq dicts x y = tupleEq1 0 where + tupleEq1 i | i == size = True + | otherwise = + ((dictSel (cmpEq dicts i)) x' y') && tupleEq1 (i+1) + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +cmpEq x y = x == y + +tupleNeq dicts x y = not (tupleEq dicts x y) + +-- Ord functions + +tupleLe :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleLe :: Strictness("S,S,S") #-} +tupleLe dicts x y = tupleLe1 0 where + tupleLe1 i | i == size = False + | (dictSel (cmpLs dicts i)) x' y' = True + | (dictSel (ordEq dicts i)) x' y' = tupleLe1 (i+1) + | otherwise = False + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +cmpLs x y = x < y + +ordEq :: Ord a => a -> a -> Bool +ordEq x y = x == y + +tupleLeq :: TupleDicts -> Tuple -> Tuple -> Bool +{-# tupleLeq :: Strictness("S,S,S") #-} +tupleLeq dicts x y = tupleLeq1 0 where + tupleLeq1 i | i == size = True + | (dictSel (cmpLs dicts i)) x' y' = True + | (dictSel (ordEq dicts i)) x' y' = tupleLeq1 (i+1) + | otherwise = False + where + x' = tupleSel x i size + y' = tupleSel y i size + size = tupleSize dicts + +tupleGe :: TupleDicts -> Tuple -> Tuple -> Bool +tupleGe d x y = tupleLe d y x + +tupleGeq :: TupleDicts -> Tuple -> Tuple -> Bool +tupleGeq d x y = tupleLeq d y x + +tupleMax,tupleMin :: TupleDicts -> Tuple -> Tuple -> Tuple +tupleMax d x y = if tupleGe d x y then x else y +tupleMin d x y = if tupleLe d x y then x else y + +-- Ix functions + +tupleRange :: TupleDicts -> (Tuple,Tuple) -> [Tuple] +{-# tupleRange :: Strictness("S,S") #-} + +tupleRange dicts (x,y) = map listToTuple (tupleRange' 0) where + tupleRange' i | i == size = [[]] + | otherwise = + [(i1 : i2) | i1 <- r, i2 <- tupleRange' (i+1)] + where + x' = tupleSel x i size + y' = tupleSel y i size + r = (dictSel (range' dicts i)) (x',y') + size = tupleSize dicts + +range' x = range x + +tupleIndex :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Int +{-# tupleIndex :: Strictness("S,S,S") #-} + +tupleIndex dicts (low,high) n = tupleIndex' (size-1) where + size = tupleSize dicts + tupleIndex' i | i == 0 = i' + | otherwise = i' + r' * (tupleIndex' (i-1)) + where + low' = tupleSel low i size + high' = tupleSel high i size + n' = tupleSel n i size + i' = (dictSel (index' dicts i)) (low',high') n' + r' = (dictSel (rangeSize dicts i)) (low',high') + +index' x = index x + +rangeSize :: (Ix a) => (a,a) -> Int +rangeSize (l,u) = index (l,u) u + 1 + +tupleInRange :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Bool +{-# tupleInRange :: Strictness("S,S,S") #-} +tupleInRange dicts (low,high) n = tupleInRange' 0 where + size = tupleSize dicts + tupleInRange' i | i == size = True + | otherwise = (dictSel (inRange' dicts i)) (low',high') n' + && tupleInRange' (i+1) + where + low' = tupleSel low i size + high' = tupleSel high i size + n' = tupleSel n i size + +inRange' x = inRange x + +-- Text functions + +tupleReadsPrec :: TupleDicts -> Int -> ReadS Tuple + +tupleReadsPrec dicts p = readParen False + (\s -> map ( \ (t,w) -> (listToTuple t,w)) + (tRP' s 0)) + where + size = tupleSize dicts + tRP' s i | i == 0 = [(t':t,w) | + ("(",s1) <- lex s, + (t',s2) <- nextItem s1, + (t,w) <- tRP' s2 (i+1)] + | i == size = [([],w) | (")",w) <- lex s] + | otherwise = + [(t':t,w) | + (",",s1) <- lex s, + (t',s2) <- nextItem s1, + (t,w) <- tRP' s2 (i+1)] + where + nextItem s = (dictSel (reads dicts i)) s + +tupleShowsPrec :: TupleDicts -> Int -> Tuple -> ShowS + +tupleShowsPrec dicts p tuple = + showChar '(' . tSP' 0 + where + size = tupleSize dicts + tSP' i | i == (size-1) = + showTup . showChar ')' + | otherwise = + showTup . showChar ',' . tSP' (i+1) + where + showTup = (dictSel (shows dicts i)) (tupleSel tuple i size) + +tupleReadList :: TupleDicts -> ReadS [Tuple] + +tupleReadList dicts = + readParen False (\r -> [pr | ("[",s) <- lex r, + pr <- readl s]) + where readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- tupleReads s, + (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, + (x,u) <- tupleReads t, + (xs,v) <- readl' u] + tupleReads s = tupleReadsPrec dicts 0 s + +tupleShowList :: TupleDicts -> [Tuple] -> ShowS + +tupleShowList dicts [] = showString "[]" +tupleShowList dicts (x:xs) + = showChar '[' . showsTuple x . showl xs + where showl [] = showChar ']' + showl (x:xs) = showString ", " . showsTuple x + . showl xs + showsTuple x = tupleShowsPrec dicts 0 x + +-- Binary functions + +tupleShowBin :: TupleDicts -> Tuple -> Bin -> Bin + +tupleShowBin dicts t bin = tSB' 0 + where + size = tupleSize dicts + tSB' i | i == size = bin + tSB' i | otherwise = + (dictSel (showBin' dicts i)) (tupleSel t i size) (tSB' (i+1)) + +showBin' x = showBin x + +tupleReadBin :: TupleDicts -> Bin -> (Tuple,Bin) + +tupleReadBin dicts bin = (listToTuple t,b) where + size = tupleSize dicts + (t,b) = tRB' bin 0 + tRB' b i | i == size = ([],b) + | otherwise = (t':ts,b') where + (t',b'') = (dictSel (readBin' dicts i)) b + (ts,b') = tRB' b'' (i+1) + +readBin' x = readBin x diff --git a/progs/prelude/PreludeTuplePrims.hi b/progs/prelude/PreludeTuplePrims.hi new file mode 100644 index 0000000..6af0dfd --- /dev/null +++ b/progs/prelude/PreludeTuplePrims.hi @@ -0,0 +1,48 @@ + +-- This is the interface to the primitives used to implement arbitrary +-- sized tuples. + +interface PreludeTuplePrims where + +{-# Prelude #-} + +-- The type checker fiddles around with the call to dictSel to use the +-- dictionary to resolve the overloading of a subexpression. The call +-- dictSel (exp dict i) will typecheck exp and use the ith component of +-- the tupleDict dict to resolve the overloading. No check is made to ensure +-- that the type of the dictionary matches the overloaded class! Beware! + +import PreludeData(Int) + +data Tuple +data TupleDicts + + +tupleSize :: TupleDicts -> Int +tupleSel :: Tuple -> Int -> Int -> a +dictSel :: TupleDicts -> Int -> a +listToTuple :: [a] -> Tuple +-- These are not called by haskell code directly; these are introduced +-- during dictionary conversion by the type checker. +tupleEqDict :: a +tupleOrdDict :: a +tupleIxDict :: a +tupleTextDict :: a +tupleBinaryDict :: a + +{-# +tupleSize :: LispName("prim.tupleSize"), Complexity(1) +tupleSel :: LispName("prim.tupleSel") +dictSel :: LispName("prim.dict-sel") +listToTuple :: LispName("prim.list->tuple"), NoConversion +tupleEqDict :: LispName("prim.tupleEqDict") +tupleOrdDict :: LispName("prim.tupleOrdDict") +tupleIxDict :: LispName("prim.tupleIxDict") +tupleTextDict :: LispName("prim.tupleTextDict") +tupleBinaryDict :: LispName("prim.tupleBinaryDict") + +#-} + + + + diff --git a/progs/prelude/PreludeTuplePrims.hu b/progs/prelude/PreludeTuplePrims.hu new file mode 100644 index 0000000..eaa0385 --- /dev/null +++ b/progs/prelude/PreludeTuplePrims.hu @@ -0,0 +1,4 @@ +:output $PRELUDEBIN/PreludeTuplePrims +:stable +:prelude +PreludeTuplePrims.hi diff --git a/progs/prelude/README b/progs/prelude/README new file mode 100644 index 0000000..2decc21 --- /dev/null +++ b/progs/prelude/README @@ -0,0 +1,12 @@ + +This is the actual prelude used by the Yale system. This contains a many +small changes to the standard prelude, mostly optimizer annotations. +PreludeIO is totally different since we have flushed streams in favor +of the monad. Primitives are defined using the Haskell to Lisp interface. + +Arrays are implemented internally using destructive updates - no array +primitive involves more than one copy operation and lookup is constant +time. + +The data constructors for Complex and Rational are strict. + diff --git a/progs/tutorial/README b/progs/tutorial/README new file mode 100644 index 0000000..defe248 --- /dev/null +++ b/progs/tutorial/README @@ -0,0 +1,12 @@ + +This is the text of the online version of the tutorial. It is set up to +run under Emacs only. Form feeds divide the pages of the tutorial. Emacs +has a special mode just for the tutorial which makes a local copy of each +page for the user to scribble on without disturbing this source. + +It is possible that this could be adapted to the command interface by +breaking it up into one file per page. + +This is still preliminary - we need to work on the text and examples. +Please send comments to haskell-request@cs.yale.edu. + diff --git a/progs/tutorial/tutorial.hs b/progs/tutorial/tutorial.hs new file mode 100644 index 0000000..eb6a78d --- /dev/null +++ b/progs/tutorial/tutorial.hs @@ -0,0 +1,2143 @@ +-- Page 0 Introduction + +This is a programming supplement to `A Gentle Introduction to Haskell' +by Hudak and Fasel. This supplement augments the tutorial by +providing executable Haskell programs which you can run and +experiment with. All program fragments in the tutorial are +found here, as well as other examples not included in the tutorial. + + +Using This Tutorial + +You should have a copy of both the `Gentle Introduction' and the +report itself to make full use of this tutorial. Although the +`Gentle Introduction' is meant to stand by itself, it is often easier +to learn a language through actual use and experimentation than by +reading alone. Once you finish this introduction, we recommend that +you proceed section by section through the `Gentle Introduction' and +after having read each section go back to this online tutorial. You +should wait until you have finished the tutorial before attempting to +read the report. We assume that you are familiar with the basics of +Emacs and that Haskell has been installed at your site. + +This tutorial does not assume any familiarity with Haskell or other +functional languages. However, knowledge of almost-functional +languages such as ML or Scheme is very useful. Throughout the +online component of this tutorial, we try to relate Haskell to +other programming languages and clarify the written tutorial through +additional examples and text. + + +Organization of the Online Tutorial + +This online tutorial is divided into a series of pages. Each page +covers one or more sections in the written tutorial. You can use +special Emacs commands to move back and forth through the pages of the +online tutorial. Each page is a single Haskell program. Comments in +the program contain the text of the online tutorial. You can modify +the program freely (this will not change the underlying tutorial +file!) and ask the system to print the value of expressions defined in +the program. + +At the beginning of each page, the sections covered by the page are +listed. In addition, the start of each individual section is +marked within each page. Emacs commands can take you directly to a +specific page or section in the tutorial. + +To create useful, executable examples of Haskell code, some language +constructs need to be revealed well before they are explained in the +tutorial. We attempt to point these out when they occur. Some +small changes have been made to the examples in the written tutorial; +these are usually cosmetic and should be ignored. Don't feel you have +to understand everything on a page before you move on -- many times +concepts become clearer as you move on and can relate them to other +aspect of the language. + +Each page of the tutorial defines a set of variables. Some of +these are named e1, e2, and so on. These `e' variables are the ones +which are meant for you to evaluate as you go through the tutorial. +Of course you may evaluate any other expressions or variables you wish. + + +The Haskell Report + +While the report is not itself a tutorial on the Haskell language, it +can be an invaluable reference to even a novice user. A very +important feature of Haskell is the prelude. The prelude is a +rather large chunk of Haskell code which is implicitly a part of every +Haskell program. Whenever you see functions used which are not +defined in the current page, these come from the Prelude. Appendix A +of the report lists the entire Prelude; the index has an entry for +every function in the Prelude. Looking at the definitions in the +Prelude is sometimes necessary to fully understand the programs in +this tutorial. + +Another reason to look at the report is to understand the syntax of +Haskell. Appendix B contains the complete syntax for Haskell. The +tutorial treats the syntax very informally; the precise details are +found only in the report. + + +The Yale Haskell System + +This version of the tutorial runs under version Y2.0 of Yale Haskell. +The Yale Haskell system is an interactive programming environment for +the Haskell language. The system is best used in conjunction with the +Emacs editor. Yale Haskell is available free of change via ftp. + + +Using the Compiler + +Yale Haskell runs as a subprocess under Emacs. While many commands +are available to the Yale Haskell user, a single command is the +primary means of communicating with the compiler: C-c e. This command +evaluates and prints an expression in the context of the program on +the screen. Here is what this command does: + +a) You are prompted for an expression in the minibuffer. You can +use M-p or M-n to move through a ring of previous inputs. + +b) If an inferior Haskell process is not running, a buffer named *haskell* +is created and the Haskell compiler is started up. The *haskell* buffer +pops onto your screen. + +c) If the program in the current page of the tutorial has not yet been +compiled or the page has been modified after its most recent +compilation, the entire page is compiled. This may result in a short delay. + +d) If there are no errors in the program, the expression entered in +step a) is compiled in the context of the program. Any value defined +in the current page can be referenced. + +e) If there are no errors in the expression, its value is printed in +the *haskell* buffer. + +There are also a few other commands you can use. C-c i interrupts +the Haskell program. Some tight loops cannot be interrupted; in this +case you will have to kill the Haskell process. C-c q exits the Haskell +process. + + +Emacs Commands Used by the Tutorial + +These commands are specific to the tutorial. The tutorial is entered +using M-x haskell-tutorial and is exited with C-c q. To move among +the pages of the tutorial, use + +C-c C-f -- go forward 1 page +C-c C-b -- go back 1 page +M-x ht-goto-page - goto a specific page of the tutorial +M-x ht-goto-section - goto a specific section of the tutorial + +Each page of the tutorial can be modified without changing the +underlying text of the tutorial. Changes are not saved as you go +between pages. To revert a page to its original form use C-c C-l. + +You can get help regarding the Emacs commands with C-c ?. + +Summary of Emacs commands used by the tutorial: + M-x haskell-tutorial - start the tutorial + C-c C-f - Go to the next page of the tutorial program + C-c C-b - Go back to the previous page of the tutorial program + C-c C-l - Restore the current page to its original form + C-c e - Evaluate a Haskell expression + C-c i - Interrupt a running Haskell program + C-c ? - Shows a help message + M-x ht-goto-page - goto a specific page of the tutorial + M-x ht-goto-section - goto a specific section of the tutorial + + +You are now ready to start the tutorial. Start by reading the `Gentle +Introduction' section 1 then proceed through the online tutorial using +C-c C-f to advance to the next page. You should read about each topic +first before turning to the associated programming example in the +online tutorial. + + +-- Page 1 Section 2 + +-- Section 2 Values, Types, and Other Goodies + +-- Haskell uses `--' to designate end of line comments. We use these +-- throughout the tutorial to place explanatory text in the program. + +-- Remember to use C-c e to evaluate expressions, C-c ? for help. + +-- All Haskell programs must start with a module declaration. Ignore this +-- for now. + +module Test(Bool) where + +-- We will start by defining some identifiers (variables) using equations. +-- You can print out the value of an identifier by typing C-c e and +-- typing the name of the identifier you wish to evaluate. This will +-- compile the entire program, not just the line with the definition +-- you want to see. Not all definitions are very interesting to print out - +-- by convention, we will use variables e1, e2, ... to denote values that +-- are `interesting' to print. + +-- We'll start with some constants as well as their associated type. +-- There are two ways to associate a type with a value: a type declaration +-- and an expression type signature. Here is an equation and a type +-- declaration: + +e1 :: Int -- This is a type declaration for the identifier e1 +e1 = 5 -- This is an equation defining e1 + +-- You can evaluate the expression e1 and watch the system print `5'! Wow! + +-- Remember that C-c e is prompting for an expression. Expressions like +-- e1 or 5 or 1+1 are all valid. However, `e1 = 5' is a definition, +-- not an expression. Trying to evaluate it will result in a syntax error. + +-- The type declaration for e1 is not really necessary but we will try to +-- always provide type declarations for values to help document the program +-- and to ensure that the system infers the same type we do for an expression. +-- If you change the value for e1 to `True', the program will no longer +-- compile due to the type mismatch. + +-- We will briefly mention expression type signatures: these are attached to +-- expressions instead of identifiers. Here are equivalent ways to do +-- the previous definition: + +e2 = 5 :: Int +e3 = (2 :: Int) + (3 :: Int) + +-- The :: has very low precedence in expressions and should usually be placed +-- in parenthesis. + +-- Note that there are two completely separate languages: an expression +-- language for values and a type language for type signatures. The type +-- language is used only in the type declarations previously described and +-- declarations of new types, described later. Haskell uses a +-- uniform syntax so that values resemble their type signature as much as +-- possible. However, you must always be aware of the difference between +-- type expressions and value expressions. + +-- Here are some of the predefined types Haskell provides: +-- type Value Syntax Type Syntax +-- Small integers <digits> Int +e4 :: Int +e4 = 12345 +-- Characters '<character>' Char +e5 :: Char +e5 = 'a' +-- Boolean True, False Bool +e6 :: Bool +e6 = True +-- Floating point <digits.digits> Float +e7 :: Float +e7 = 123.456 +-- We will introduce these types now; there will be much more to say later. +-- Homogenous List [<exp1>,<exp2>,...] [<constituant type>] +e8 :: [Int] +e8 = [1,2,3] +-- Tuple (<exp1>,<exp2>,...) (<exp1-type>,<exp2-type>,...) +e9 :: (Char,Int) +e9 = ('b',4) +-- Functional described later domain type -> range type +succ :: Int -> Int -- a function which takes an Int argument and returns Int +succ x = x + 1 -- test this by evaluating `succ 4' + +-- Here's a few leftover examples from section 2: + +e10 = succ (succ 3) -- you could also evaluate `succ (succ 3)' directly + -- by entering the entire expression to the C-c e + +-- If you want to evaluate something more complex than the `e' variables +-- defined here, it is better to enter a complex expression, such as +-- succ (succ 3), directly than to edit a new definition like e10 into +-- the program. This is because any change to the program will require +-- recompilation of the entire page. The expressions entered to C-c e are +-- compiled separately (and very quickly!). + +-- Uncomment this next line to see a compile time type error. +-- e11 = 'a'+'b' +-- Don't worry about the error message - it will make more sense later. + +-- Proceed to the next page using C-c C-f + +-- Page 2 Section 2.1 + +-- Section 2.1 Polymorphic Types + +module Test(Bool) where + +-- The following line allows us to redefine functions in the standard +-- prelude. Ignore this for now. + +import Prelude hiding (length,head,tail,null) + +-- start with some sample lists to use in test cases + +list1 :: [Int] +list1 = [1,2,3] +list2 :: [Char] -- This is the really a string +list2 = ['a','b','c'] -- This is the same as "abc"; evaluate list2 and see. +list3 :: [[a]] -- The element type of the inner list is unknown +list3 = [[],[],[],[]] -- so this list can't be printed +list4 :: [Int] +list4 = 1:2:3:4:[] -- Exactly the same as [1,2,3,4]; print it and see. + +-- This is the length function. You can test it by evaluating expressions +-- such as `length list1'. Function application is written by +-- simple juxtaposition: `f(x)' in other languages would be `f x' in Haskell. + +length :: [a] -> Int +length [] = 0 +length (x:xs) = 1 + length xs + +-- Function application has the highest precedence, so 1 + length xs is +-- parsed as 1 + (length xs). In general, you have to surround +-- non-atomic arguments to a function with parens. This includes +-- arguments which are also function applications. For example, +-- f g x is the function f applied to arguments g and x, similar to +-- f(g,x) in other languages. However, f (g x) is f applied to (g x), or +-- f(g(x)), which means something quite different! Be especially +-- careful with infix operators: f x+1 y-2 would be parsed as (f x)+(1 y)-2. +-- This is also true on the left of the `=': the parens around (x:xs) are +-- absolutely necessary. length x:xs would be parsed as (length x):xs. + +-- Also be careful with prefix negation, -. The application `f -1' is +-- f-1, not f(-1). Add parens around negative numbers to avoid this +-- problem. + +-- Here are some other list functions: + +head :: [a] -> a -- returns the first element in a list (same as car in lisp) +head (x:xs) = x + +tail :: [a] -> [a] -- removes the first element from a list (same as cdr) +tail (x:xs) = xs + +null :: [a] -> Bool +null [] = True +null (x:xs) = False + +cons :: a -> [a] -> [a] +cons x xs = x:xs + +nil :: [a] +nil = [] + +-- Length could be defined using these functions too. This is +-- not good Haskell style but does illustrate these other list functions. +-- The if - then - else will be discussed later. Haskell programmers feel +-- that the pattern matching style, as used in the previous version of +-- length, is more natural and readable. + +length' :: [a] -> Int -- Note that ' can be part of a name +length' x = if null x then 0 else 1 + length' (tail x) + +-- A test case for length', cons, and nil + +e1 = length' (cons 1 (cons 2 nil)) + +-- We haven't said anything about errors yet. Each of the following +-- examples illustrates a potential runtime or compile time error. The +-- compile time error is commented out so that other examples will compile; +-- you can uncomment them and see what happens. + +-- e2 = cons True False -- Why is this not possible in Haskell? +e3 = tail (tail ['a']) -- What happens if you evaluate this? +e4 = [] -- This is especially mysterious! + +-- This last example, e4, is something hard to explain but is often +-- encountered early by novices. We haven't explained yet how the system +-- prints out the expressions you type in - this will wait until later. +-- However, the problem here is that e4 has the type [a]. The printer for +-- the list datatype is complaining that it needs to know a specific type +-- for the list elements even though the list has no elements! This can +-- be avoided by giving e4 a type such as [Int]. (To further confuse you, +-- try giving e4 the type [Char] and see what happens.) + +-- Page 3 Section 2.2 + +-- Section 2.2 User-Defined Types + +module Test(Bool) where + +-- The type Bool is already defined in the Prelude so there is no +-- need to define it here. + +data Color = Red | Green | Blue | Indigo | Violet deriving Text +-- The `deriving Text' is necessary if you want to print a Color value. + +-- You can now evaluate these expressions. +e1 :: Color +e1 = Red +e2 :: [Color] +e2 = [Red,Blue] + +-- It is very important to keep the expression language and the type +-- language in Haskell separated. The data declaration above defines +-- the type constructor Color. This is a nullary constructor: it takes no +-- arguments. Color is found ONLY in the type language - it can not be +-- part of an expression. e1 = Color is meaningless. (Actually, Color could +-- be both a data constructor and a type constructor but we'll ignore this +-- possibility for now). On the other hand, Red, Blue, and so on are +-- (nullary) data constructors. They can appear in expressions and +-- in patterns (described later). The declaration e1 :: Blue would also +-- be meaningless. Data constructors can be defined ONLY in a data +-- declaration. + +-- In the next example, Point is a type constructor and Pt is a data +-- constructor. Point takes one argument and Pt takes two. A data constructor +-- like Pt is really just an ordinary function except that it can be used in +-- a pattern. Type signatures can not be supplied directly for data +-- constructors; their typing is completely defined by the data declaration. +-- However, data constructors have a signature just like any variable: +-- Pt :: a -> a -> Point a -- Not valid Haskell syntax +-- That is, Pt is a function which takes two arguments with the same +-- arbitrary type and returns a value containing the two argument values. + +data Point a = Pt a a deriving Text + +e3 :: Point Float +e3 = Pt 2.0 3.0 +e4 :: Point Char +e4 = Pt 'a' 'b' +e5 :: Point (Point Int) +e5 = Pt (Pt 1 2) (Pt 3 4) +-- e6 = Pt 'a' True -- This is a typing error + +-- The individual components of a point do not have names. +-- Let's jump ahead a little so that we can write functions using these +-- data types. Data constructors (Red, Blue, ..., and Pt) can be used in +-- patterns. When more than one equation is used to define a function, +-- pattern matching occurs top down. + +-- A function to remove red from a list of colors. + +removeRed :: [Color] -> [Color] +removeRed [] = [] +removeRed (Red:cs) = removeRed cs +removeRed (c:cs) = c : removeRed cs -- c cannot be Red at this point + +e7 :: [Color] +e7 = removeRed [Blue,Red,Green,Red] + +-- Pattern matching is capable of testing equality with a specific color. + +-- All equations defining a function must share a common type. A +-- definition such as: +-- foo Red = 1 +-- foo (Pt x y) = x +-- would result in a type error since the argument to foo cannot be both a +-- Color and a Point. Similarly, the right hand sides must also share a +-- common type; a definition such as +-- foo Red = Blue +-- foo Blue = Pt Red Red +-- would also result in a type error. + +-- Here's a couple of functions defined on points. + +dist :: Point Float -> Point Float -> Float +dist (Pt x1 y1) (Pt x2 y2) = sqrt ((x1-x2)^2 + (y1-y2)^2) + +midpoint :: Point Float -> Point Float -> Point Float +midpoint (Pt x1 y1) (Pt x2 y2) = Pt ((x1+x2)/2) ((y1+y2)/2) + +p1 :: Point Float +p1 = Pt 1.0 1.0 +p2 :: Point Float +p2 = Pt 2.0 2.0 + +e8 :: Float +e8 = dist p1 p2 +e9 :: Point Float +e9 = midpoint p1 p2 + +-- The only way to take apart a point is to pattern match. +-- That is, the two values which constitute a point must be extracted +-- by matching a pattern containing the Pt data constructor. Much +-- more will be said about pattern matching later. + +-- Haskell prints values in the same syntax used in expressions. Thus +-- Pt 1 2 would print as Pt 1 2 (of course, Pt 1 (1+1) would also print +-- as Pt 1 2). + +-- Page 4 Section 2.3 + +-- Section 2.3 Recursive Types + +module Test where + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +-- The following typings are implied by this declaration. As before, +-- this is not valid Haskell syntax. +-- Leaf :: a -> Tree a +-- Branch :: Tree a -> Tree a -> Tree a + +fringe :: Tree a -> [a] +fringe (Leaf x) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +-- The following trees can be used to test functions: + +tree1 :: Tree Int +tree1 = Branch (Leaf 1) (Branch (Branch (Leaf 2) (Leaf 3)) (Leaf 4)) +tree2 :: Tree Int +tree2 = Branch (Branch (Leaf 3) (Leaf 1)) (Branch (Leaf 4) (Leaf 1)) +tree3 :: Tree Int +tree3 = Branch tree1 tree2 + +-- Try evaluating `fringe tree1' and others. + +-- Here's another tree function: + +twist :: Tree a -> Tree a +twist (Branch left right) = Branch right left +twist x = x -- This equation only applies to leaves + +-- Here's a function which compares two trees to see if they have the +-- same shape. Note the signature: the two trees need not contain the +-- same type of values. + +sameShape :: Tree a -> Tree b -> Bool +sameShape (Leaf x) (Leaf y) = True +sameShape (Branch l1 r1) (Branch l2 r2) = sameShape l1 l2 && sameShape r1 r2 +sameShape x y = False -- One is a branch, the other is a leaf + +-- The && function is a boolean AND function. + +-- The entire pattern on the left hand side must match in order for the +-- right hand side to be evaluated. The first clause requires both +-- arguments to be a leaf' otherwise the next equation is tested. +-- The last clause will always match: the final x and y match both +-- leaves and branches. + +-- This compares a tree of integers to a tree of booleans. +e1 = sameShape tree1 (Branch (Leaf True) (Leaf False)) + +-- Page 5 Sections 2.4, 2.5, 2.6 + +-- Section 2.4 Type Synonyms + +module Test(Bool) where + +-- Since type synonyms are part of the type language only, it's hard to +-- write a program which shows what they do. Essentially, they are like +-- macros for the type language. They can be used interchangably with their +-- definition: + +e1 :: String +e1 = "abc" +e2 :: [Char] -- No different than String +e2 = e1 + +-- In the written tutorial the declaration of `Addr' is a data type +-- declaration, not a synonym declaration. This shows that the data +-- type declaration as well as a signature can reference a synonym. + +-- Section 2.5 Built-in Types + +-- Tuples are an easy way of grouping a set of data values. Here are +-- a few tuples. Note the consistancy in notation between the values and +-- types. + +e3 :: (Bool,Int) +e3 = (True,4) +e4 :: (Char,[Int],Char) +e4 = ('a',[1,2,3],'b') + +-- Here's a function which returns the second component of a 3 tuple. +second :: (a,b,c) -> b +second (a,b,c) = b + +-- Try out `second e3' and `second e4' - what happens? +-- Each different size of tuple is a completely distinct type. There is +-- no general way to append two arbitrary tuples or randomly select the +-- i'th component of an arbitrary tuple. Here's a function built using +-- 2-tuples to represent intervals. + +-- Use a type synonym to represent homogenous 2 tuples +type Interval a = (a,a) + +containsInterval :: Interval Int -> Interval Int -> Bool +containsInterval (xmin,xmax) (ymin,ymax) = xmin <= ymin && xmax >= ymax + +p1 :: Interval Int +p1 = (2,3) +p2 :: Interval Int +p2 = (1,4) + +e5 = containsInterval p1 p2 +e6 = containsInterval p2 p1 + +-- Here's a type declaration for a type isomorphic to lists: + +data List a = Nil | Cons a (List a) deriving Text + +-- Except for the notation, this is completely equivalent to ordinary lists +-- in Haskell. + +length' :: List a -> Int +length' Nil = 0 +length' (Cons x y) = 1 + length' y + +e7 = length' (Cons 'a' (Cons 'b' (Cons 'c' Nil))) + +-- It's hard to demonstrate much about the `non-specialness' of built-in +-- types. However, here is a brief summary: + +-- Numbers and characters, such as 1, 2.2, or 'a', are the same as nullary +-- type constructors. + +-- Lists have a special type constructor, [a] instead of List a, and +-- an odd looking data constructor, []. The other data constructor, :, is +-- not `unusual', syntactically speaking. The notation [x,y] is just +-- syntax for x:y:[] and "abc" for 'a' : 'b' : 'c' : []. + +-- Tuples use a special syntax. In a type expression, a 2 tuple containing +-- types a and be would be written (a,b) instead of using a prefix type +-- constructor such as Tuple2 a b. This same notation is used to build +-- tuple values: (1,2) would construct a 2 tuple containing the values 1 and 2. + + +-- Page 6 Sections 2.5.1, 2.5.2 + +module Test(Bool) where + +-- Section 2.5.1 List Comprehensions and Arithmetic Sequences + +-- Warning: brackets in Haskell are used in three different types +-- of expressions: lists, as in [a,b,c], sequences (distinguished by +-- the ..), as in [1..2], and list comprehensions (distinguished by the +-- bar: |), as in [x+1 | x <- xs, x > 1]. + +-- Before list comprehensions, let's start out with sequences: + +e1 :: [Int] +e1 = [1..10] -- Step is 1 +e2 :: [Int] +e2 = [1,3..10] -- Step is 3 - 1 +e3 :: [Int] +e3 = [1,-1..-10] +e4 :: [Char] +e4 = ['a'..'z'] -- This works on chars too + +-- We'll avoid infinite sequences like [1..] for now. If you print one, +-- use C-c i to interrupt the Haskell program. + +-- List comprehensions are very similar to nested loops. They return a +-- list of values generated by the expression inside the loop. The filter +-- expressions are similar to conditionals in the loop. + +-- This function does nothing at all! It just scans through a list and +-- copies it into a new one. + +doNothing :: [a] -> [a] +doNothing l = [x | x <- l] + +-- Adding a filter to the previous function allows only selected elements to +-- be generated. This is similar to what is done in quicksort. + +positives :: [Int] -> [Int] +positives l = [x | x <- l, x > 0] + +e5 = positives [2,-4,5,6,-5,3] + +-- Now the full quicksort function. + +quicksort :: [Char] -> [Char] -- Use Char just to be different! +quicksort [] = [] +quicksort (x:xs) = quicksort [y | y <- xs, y <= x] ++ + [x] ++ + quicksort [y | y <- xs, y > x] + +e6 = quicksort "Why use Haskell?" + +-- Now for some nested loops. Each generator, <-, adds another level of +-- nesting to the loop. Note that the variable introduced by each generator +-- can be used in each following generator; all variables can be used in the +-- generated expression: + +e7 :: [(Int,Int)] +e7 = [(x,y) | x <- [1..5], y <- [x..5]] + +-- Now let's add some guards: (the /= function is `not equal') + +e8 :: [(Int,Int)] +e8 = [(x,y) | x <- [1..7], x /= 5, y <- [x..8] , x*y /= 12] + +-- This is the same as the loop: (going to a psuedo Algol notation) +-- for x := 1 to 7 do +-- if x <> 5 then +-- for y := x to 8 do +-- if x*y <> 12 +-- generate (x,y) + +-- Section 2.5.2 Strings + +e9 = "hello" ++ " world" + +-- Page 7 Sections 3, 3.1 + +module Test(Bool) where +import Prelude hiding (map) + +-- Section 3 Functions + +add :: Int -> Int -> Int +add x y = x+y + +e1 :: Int +e1 = add 1 2 + +-- This Int -> Int is the latter part of the signature of add: +-- add :: Int -> (Int -> Int) + +succ :: Int -> Int +succ = add 1 + +e2 :: Int +e2 = succ 3 + +map :: (a->b) -> [a] -> [b] +map f [] = [] +map f (x:xs) = f x : (map f xs) + +e3 :: [Int] +e3 = map (add 1) [1,2,3] +-- This next definition is the equivalent to e3 +e4 :: [Int] +e4 = map succ [1,2,3] + +-- Heres a more complex example. Define flist to be a list of functions: +flist :: [Int -> Int] +flist = map add [1,2,3] +-- This returns a list of functions which add 1, 2, or 3 to their input. +-- Warning: Haskell should print flist as something like +-- [<<function>>,<<function>>,<<function>>] + + +-- Now, define a function which takes a function and returns its value +-- when applied to the constant 1: +applyTo1 :: (Int -> a) -> a +applyTo1 f = f 1 + +e5 :: [Int] +e5 = map applyTo1 flist -- Apply each function in flist to 1 + +-- If you want to look at how the type inference works, figure out how +-- the signatures of map, applyTo1, and flist combine to yield [Int]. + +-- Section 3.1 Lambda Abstractions + +-- The symbol \ is like `lambda' in lisp or scheme. + +-- Anonymous functions are written as \ arg1 arg2 ... argn -> body +-- Instead of naming every function, you can code it inline with this +-- notation: + +e6 = map (\f -> f 1) flist + +-- Be careful with the syntax here. \x->\y->x+y parses as +-- \ x ->\ y -> x + y. The ->\ is all one token. Use spaces!! + +-- This is identical to e5 except that the applyTo1 function has no name. + +-- Function arguments on the left of an = are the same as lambda on the +-- right: + +add' = \x y -> x+y -- identical to add +succ' = \x -> x+1 -- identical to succ + +-- As with ordinary function, the parameters to anonymous functions +-- can be patterns: + +e7 :: [Int] +e7 = map (\(x,y) -> x+y) [(1,2),(3,4),(5,6)] + +-- Functions defined by more than one equation, like map, cannot +-- be converted to anonymous lambda functions quite as easily - a case +-- statement is also required. This is discussed later. + +-- Page 8 Sections 3.2, 3.2.1, 3.2.2 + +module Test(Bool) where + +import Prelude hiding ((++),(.)) + +-- Section 3.2 Infix operators + +-- Haskell has both identifiers, like x, and operators, like +. +-- These are just two different types of syntax for variables. +-- However, operators are by default used in infix notation. + +-- Briefly, identifiers begin with a letter and may have numbers, _, and ' +-- in them: x, xyz123, x'', xYz'_12a. The case of the first letter +-- distinguishes variables from data constructors (or type variables from +-- type constructors). An operator is a string of symbols, where +-- :!#$%&*+./<=>?@\^| are all symbols. If the first character is : then +-- the operator is a data constructor; otherwise it is an ordinary +-- variable operator. The - and ~ characters may start a symbol but cannot +-- be used after the first character. This allows a*-b to parse as +-- a * - b instead of a *- b. + +-- Operators can be converted to identifiers by enclosing them in parens. +-- This is required in signature declarations. Operators can be defined +-- as well as used in the infix style: + +(++) :: [a] -> [a] -> [a] +[] ++ y = y +(x:xs) ++ y = x : (xs ++ y) + +-- Table 2 (Page 54) of the report is invaluable for sorting out the +-- precedences of the many predefined infix operators. + +e1 = "Foo" ++ "Bar" + +-- This is the same function without operator syntax +appendList :: [a] -> [a] -> [a] +appendList [] y = y +appendList (x:xs) y = x : appendList xs y + +(.) :: (b -> c) -> (a -> b) -> (a -> c) +f . g = \x -> f (g x) + +add1 :: Int -> Int +add1 x = x+1 + +e2 = (add1 . add1) 3 + +-- Section 3.2.1 Sections + +-- Sections are a way of creating unary functions from infix binary +-- functions. When a parenthesized expression starts or ends in an +-- operator, it is a section. Another definition of add1: + +add1' :: Int -> Int +add1' = (+ 1) + +e3 = add1' 4 + +-- Here are a few section examples: + +e4 = map (++ "abc") ["x","y","z"] + +e5 = map ("abc" ++) ["x","y","z"] + + +-- Section 3.2.2 Fixity Declarations + +-- We'll avoid any demonstration of fixity declarations. The Prelude +-- contains numerous examples. + +-- Page 9 Sections 3.3, 3.4, 3.5 +module Test(Bool) where + +import Prelude hiding (take,zip) + +-- Section 3.3 Functions are Non-strict + +-- Observing lazy evaluation can present difficulties. The essential +-- question is `does an expression get evaluated?'. While in theory using a +-- non-terminating computation is the way evaluation issues are examined, +-- we need a more practical approach. The `error' function serves as +-- a bottom value. Evaluating this function prints an error message and +-- halts execution. + +bot = error "Evaluating Bottom" + +e1 :: Bool -- This can be any type at all! +e1 = bot -- evaluate this and see what happens. + +const1 :: a -> Int +const1 x = 1 + +e2 :: Int +e2 = const1 bot -- The bottom is not needed and will thus not be evaluated. + +-- Section 3.4 "Infinite" Data Structures + +-- Data structures are constructed lazily. A constructor like : will not +-- evaluate its arguments until they are demanded. All demands arise from +-- the need to print the result of the computation -- components not needed +-- to compute the printed result will not be evaluated. + +list1 :: [Int] +list1 = (1:bot) + +e3 = head list1 -- doesnt evaluate bot +e4 = tail list1 -- does evaluate bot + +-- Some infinite data structures. Don't print these! If you do, you will +-- need to interrupt the system (C-c i) or kill the Haskell process. + +ones :: [Int] +ones = 1 : ones + +numsFrom :: Int -> [Int] +numsFrom n = n : numsFrom (n+1) + +-- An alternate numsFrom using series notation: + +numsFrom' :: Int -> [Int] +numsFrom' n = [n..] + +squares :: [Int] +squares = map (^2) (numsFrom 0) + +-- Before we start printing anything, we need a function to truncate these +-- infinite lists down to a more manageable size. The `take' function +-- extracts the first k elements of a list: + +take :: Int -> [a] -> [a] +take 0 x = [] -- two base cases: k = 0 +take k [] = [] -- or the list is empty +take k (x:xs) = x : take (k-1) xs + +-- now some printable lists: + +e5 :: [Int] +e5 = take 5 ones + +e6 :: [Int] +e6 = take 5 (numsFrom 10) + +e7 :: [Int] +e7 = take 5 (numsFrom' 0) + +e8 :: [Int] +e8 = take 5 squares + +-- zip is a function which turns two lists into a list of 2 tuples. If +-- the lists are of differing sizes, the result is as long as the +-- shortest list. + +zip (x:xs) (y:ys) = (x,y) : zip xs ys +zip xs ys = [] -- one of the lists is [] + +e9 :: [(Int,Int)] +e9 = zip [1,2,3] [4,5,6] + +e10 :: [(Int,Int)] +e10 = zip [1,2,3] ones + +fib :: [Int] +fib = 1 : 1 : [x+y | (x,y) <- zip fib (tail fib)] + +e11 = take 5 fib + +-- Let's do this without the list comprehension: + +fib' :: [Int] +fib' = 1 : 1 : map (\(x,y) -> x+y) (zip fib (tail fib)) + +-- This could be written even more cleanly using a map function which +-- maps a binary function over two lists at once. This is in the +-- Prelude and is called zipWith. + +fib'' :: [Int] +fib'' = 1 : 1 : zipWith (+) fib (tail fib) + +-- For more examples using infinite structures look in the demo files +-- that come with Yale Haskell. Both the pascal program and the +-- primes program use infinite lists. + +-- Section 3.5 The Error Function + +-- Too late - we already used it! + + +-- Page 10 Sections 4, 4.1, 4.2 + +module Test(Bool) where + +import Prelude hiding (take,(^)) + +-- Section 4 Case Expressions and Pattern Matching + +-- Now for details of pattern matching. We use [Int] instead of [a] +-- since the only value of type [a] is []. + +contrived :: ([Int], Char, (Int, Float), String, Bool) -> Bool +contrived ([], 'b', (1, 2.0), "hi", True) = False +contrived x = True -- add a second equation to avoid runtime errors + +e1 :: Bool +e1 = contrived ([], 'b', (1, 2.0), "hi", True) +e2 :: Bool +e2 = contrived ([1], 'b', (1, 2.0), "hi", True) + +-- Contrived just tests its input against a big constant. + +-- Linearity in pattern matching implies that patterns can only compare +-- values with constants. The following is not valid Haskell: + +-- member x [] = False +-- member x (x:ys) = True -- Invalid since x appears twice +-- member x (y:ys) = member x ys + +f :: [a] -> [a] +f s@(x:xs) = x:s +f _ = [] + +e3 = f "abc" + +-- Another use of _: + +middle :: (a,b,c) -> b +middle (_,x,_) = x + +e4 :: Char +e4 = middle (True, 'a', "123") + +(^) :: Int -> Int -> Int +x ^ 0 = 1 +x ^ (n+1) = x*(x^n) + +e5 :: Int +e5 = 3^3 +e6 :: Int +e6 = 4^(-2) -- Notice the behavior of the + pattern on this one + +-- Section 4.1 Pattern Matching Semantics + +-- Here's an extended example to illustrate the left -> right, top -> bottom +-- semantics of pattern matching. + +foo :: (Int,[Int],Int) -> Int +foo (1,[2],3) = 1 +foo (2,(3:_),3) = 2 +foo (1,_,3) = 3 +foo _ = 4 + +bot = error "Bottom Evaluated" + +e7 = foo (1,[],3) +e8 = foo (1,bot,3) +e9 = foo (1,1:bot,3) +e10 = foo (2,bot,2) +e11 = foo (3,bot,bot) + +-- Now add some guards: + +sign :: Int -> Int +sign x | x > 0 = 1 + | x == 0 = 0 + | x < 0 = -1 + +e12 = sign 3 + +-- The last guard is often `True' to catch all other cases. The identifier +-- `otherwise' is defined as True for use in guards: + +max' :: Int -> Int -> Int +max' x y | x > y = x + | otherwise = y + +-- Guards can refer to any variables bound by pattern matching. When +-- no guard is true, pattern matching resumes at the next equation. Guards +-- may also refer to values bound in an associated where declaration. + + +inOrder :: [Int] -> Bool +inOrder (x1:x2:xs) | x1 <= x2 = True +inOrder _ = False + +e13 = inOrder [1,2,3] +e14 = inOrder [2,1] + +-- Section 4.2 An Example + +take :: Int -> [a] -> [a] +take 0 _ = [] +take _ [] = [] +take (n+1) (x:xs) = x:take n xs + +take' :: Int -> [a] -> [a] +take' _ [] = [] +take' 0 _ = [] +take' (n+1) (x:xs) = x:take' n xs + +e15, e16, e17, e18 :: [Int] +e15 = take 0 bot +e16 = take' 0 bot +e17 = take bot [] +e18 = take' bot [] + +-- Page 11 Sections 4.3, 4.4, 4.5, 4.6 + +module Test(Bool) where + +-- import Prelude hiding (take,Request(..),Response(..)) -- Standard Haskell +import Prelude hiding (take) -- Y2.0-b4 only + +-- Section 4.3 Case Expressions + +-- The function take using a case statement instead of multiple equations + +take :: Int -> [a] -> [a] +take m ys = case (m,ys) of + (0 ,_) -> [] + (_ ,[]) -> [] + (n+1,x:xs) -> x : take n xs + +-- The function take using if then else. We can also eliminate the n+k +-- pattern just for fun. The original version of take is much easier to read! + +take' :: Int -> [a] -> [a] +take' m ys = if m == 0 then [] else + if null ys then [] else + if m > 0 then head ys : take (m-1) (tail ys) + else error "m < 0" + +-- Section 4.4 Lazy Patterns + +-- Before the client-server example, here is a contrived example of lazy +-- patterns. The first version will fail to pattern match whenever the +-- the first argument is []. The second version will always pattern +-- match initially but x will fail if used when the list is []. + +nonlazy :: [Int] -> Bool -> [Int] +nonlazy (x:xs) isNull = if isNull then [] else [x] + +e1 = nonlazy [1,2] False +e2 = nonlazy [] True +e3 = nonlazy [] False + +-- This version will never fail the initial pattern match +lazy :: [Int] -> Bool -> [Int] +lazy ~(x:xs) isNull = if isNull then [] else [x] + +e4 = lazy [1,2] False +e5 = lazy [] True +e6 = lazy [] False + +-- The server - client example is a little hard to demonstrate. We'll avoid +-- the initial version which loops. Here is the version with irrefutable +-- patterns. + +type Response = Int +type Request = Int + +client :: Request -> [Response] -> [Request] +client init ~(resp:resps) = init : client (next resp) resps + +server :: [Request] -> [Response] +server (req : reqs) = process req : server reqs + +-- Next maps the response from the previous request onto the next request +next :: Response -> Request +next resp = resp + +-- Process maps a request to a response +process :: Request -> Response +process req = req+1 + +requests :: [Request] +requests = client 0 responses + +responses :: [Response] +responses = server requests + +e7 = take 5 responses + +-- The lists of requests and responses are infinite - there is no need to +-- check for [] in this program. These lists correspond to streams in other +-- languages. + +-- Here is fib again: + +fib :: [Int] +fib@(1:tfib) = 1 : 1 : [ a+b | (a,b) <- zip fib tfib] + +e8 = take 10 fib + +-- Section 4.5 Lexical Scoping and Nested Forms + +-- One thing that is important to note is that the order of the +-- definitions in a program, let expression, or where clauses is +-- completely arbitrary. Definitions can be arranged 'top down' +-- or `bottom up' without changing the program. + +e9 = let y = 2 :: Float + f x = (x+y)/y + in f 1 + f 2 + +f :: Int -> Int -> String +f x y | y > z = "y > x^2" + | y == z = "y = x^2" + | y < z = "y < x^2" + where + z = x*x + +e10 = f 2 5 +e11 = f 2 4 + +-- Section 4.6 Layout + +-- There's nothing much to demonstrate here. We have been using layout all +-- through the tutorial. The main thing is to be careful line up the +-- first character of each definition. For example, if you +-- change the indentation of the definition of f in e9 you will get a +-- parse error. + +-- Page 12 Section 5 +module Test(Bool) where + +import Prelude hiding (elem) + +-- Section 5 Type Classes + +-- Names in the basic class structure of Haskell cannot be hidden (they are +-- in PreludeCore) so we have to modify the names used in the tutorial. + +-- Here is a new Eq class: + +class Eq' a where + eq :: a -> a -> Bool + +-- Now we can define elem using eq from above: + +elem :: (Eq' a) => a -> [a] -> Bool +x `elem` [] = False +x `elem` (y:ys) = x `eq` y || x `elem` ys + +-- Before this is of any use, we need to admit some types to Eq' + +instance Eq' Int where + x `eq` y = abs (x-y) < 3 -- Let's make this `nearly equal' just for fun + +instance Eq' Float where + x `eq` y = abs (x-y) < 0.1 + +list1 :: [Int] +list1 = [1,5,9,23] + +list2 :: [Float] +list2 = [0.2,5.6,33,12.34] + +e1 = 2 `elem` list1 +e2 = 100 `elem` list1 +e3 = 0.22 `elem` list2 + +-- Watch out! Integers in Haskell are overloaded - without a type signature +-- to designate an integer as an Int, expressions like 3 `eq` 3 will be +-- ambiguous. See 5.5.4 about this problem. + +-- Now to add the tree type: + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +instance (Eq' a) => Eq' (Tree a) where + (Leaf a) `eq` (Leaf b) = a `eq` b + (Branch l1 r1) `eq` (Branch l2 r2) = (l1 `eq` l2) && (r1 `eq` r2) + _ `eq` _ = False + +tree1,tree2 :: Tree Int +tree1 = Branch (Leaf 1) (Leaf 2) +tree2 = Branch (Leaf 2) (Leaf 1) + +e4 = tree1 `eq` tree2 + +-- Now make a new class with Eq' as a super class: + +class (Eq' a) => Ord' a where + lt,le :: a -> a -> Bool -- lt and le are operators in Ord' + x `le` y = x `eq` y || x `lt` y -- This is a default for le + +-- The typing of lt & le is +-- le,lt :: (Ord' a) => a -> a -> Bool +-- This is identical to +-- le,lt :: (Eq' a,Ord' a) => a -> a -> Bool + +-- Make Int an instance of Ord +instance Ord' Int where + x `lt` y = x < y+1 + +i :: Int -- Avoid ambiguity +i = 3 +e5 :: Bool +e5 = i `lt` i + +-- Some constraints on instance declarations: +-- A program can never have more than one instance declaration for +-- a given combination of data type and class. +-- If a type is declared to be a member of a class, it must also be +-- declared in all superclasses of that class. +-- An instance declaration does not need to supply a method for every +-- operator in the class. When a method is not supplied in an +-- instance declaration and no default is present in the class +-- declaration, a runtime error occurs if the method is invoked. +-- You must supply the correct context for an instance declaration -- +-- this context is not inferred automatically. + +-- Section 5.1 Equality and Ordered Classes +-- Section 5.2 Enumeration and Index Classes + +-- No examples are provided for 5.1 or 5.2. The standard Prelude contains +-- many instance declarations which illustrate the Eq, Ord, and Enum classes. + +-- Page 13 Section 5.3 + +module Test(Bool) where + +-- Section 5.3 Text and Binary Classes + +-- This is the slow showTree. The `show' function is part of the +-- Text class and works with all the built-in types. The context `Text a' +-- arises from the call to show for leaf values. + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +showTree :: (Text a) => Tree a -> String +showTree (Leaf x) = show x +showTree (Branch l r) = "<" ++ showTree l ++ "|" ++ showTree r ++ ">" + +tree1 :: Tree Int +tree1 = Branch (Leaf 1) (Branch (Leaf 3) (Leaf 6)) + +e1 = showTree tree1 + +-- Now the improved showTree; shows is already defined for all +-- built in types. + +showsTree :: Text a => Tree a -> String -> String +showsTree (Leaf x) s = shows x s +showsTree (Branch l r) s = '<' : showsTree l ('|' : showsTree r ('>' : s)) + +e2 = showsTree tree1 "" + +-- The final polished version. ShowS is predefined in the Prelude so we +-- don't need it here. + + +showsTree' :: Text a => Tree a -> ShowS +showsTree' (Leaf x) = shows x +showsTree' (Branch l r) = ('<' :) . showsTree' l . ('|' :) . + showsTree' r . ('>' :) + +e3 = showsTree' tree1 "" + + +-- Page 14 This page break is just to keep recompilation from getting too +-- long. The compiler takes a little longer to compile this +-- page than other pages. + +module Test(Bool) where + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +-- Now for the reading function. Again, ReadS is predefined and reads works +-- for all built-in types. The generators in the list comprehensions are +-- patterns: p <- l binds pattern p to successive elements of l which match +-- p. Elements not matching p are skipped. + +readsTree :: (Text a) => ReadS (Tree a) +readsTree ('<':s) = [(Branch l r, u) | (l, '|':t) <- readsTree s, + (r, '>':u) <- readsTree t ] +readsTree s = [(Leaf x,t) | (x,t) <- reads s] + +e4 :: [(Int,String)] +e4 = reads "5 golden rings" + +e5 :: [(Tree Int,String)] +e5 = readsTree "<1|<2|3>>" +e6 :: [(Tree Int,String)] +e6 = readsTree "<1|2" +e7 :: [(Tree Int,String)] +e7 = readsTree "<1|<<2|3>|<4|5>>> junk at end" + +-- Before we do the next readTree, let's play with the lex function. + +e8 :: [(String,String)] +e8 = lex "foo bar bletch" + +-- Here's a function to completely lex a string. This does not handle +-- lexical ambiguity - lex would return more than one possible lexeme +-- when an ambiguity is encountered and the patterns used here would not +-- match. + +lexAll :: String -> [String] +lexAll s = case lex s of + [("",_)] -> [] -- lex returns an empty token if none is found + [(token,rest)] -> token : lexAll rest + +e9 = lexAll "lexAll :: String -> [String]" +e10 = lexAll "<1|<a|3>>" + +-- Finally, the `hard core' reader. This is not sensitive to +-- white space as were the previous versions. + + +readsTree' :: (Text a) => ReadS (Tree a) +readsTree' s = [(Branch l r, x) | ("<", t) <- lex s, + (l, u) <- readsTree' t, + ("|", v) <- lex u, + (r, w) <- readsTree' v, + (">", x) <- lex w ] + ++ + [(Leaf x, t) | (x, t) <- reads s] + +-- When testing this program, you must make sure the input conforms to +-- Haskell lexical syntax. If you remove spaces between | and < or +-- > and > they will lex as a single token. + +e11 :: [(Tree Int,String)] +e11 = readsTree' "<1 | <2 | 3> >" +e12 :: [(Tree Bool,String)] +e12 = readsTree' "<True|False>" + +-- Finally, here is a simple version of read for trees only: + +read' :: (Text a) => String -> (Tree a) +read' s = case (readsTree' s) of + [(tree,"")] -> tree -- Only one parse, no junk at end + [] -> error "Couldn't parse tree" + [_] -> error "Crud after the tree" -- unread chars at end + _ -> error "Ambiguous parse of tree" + +e13 :: Tree Int +e13 = read' "foo" +e14 :: Tree Int +e14 = read' "< 1 | < 2 | 3 > >" +e15 :: Tree Int +e15 = read' "3 xxx" + +-- Page 15 Section 5.4 + +module Test(Bool) where + +-- Section 5.4 Derived Instances + +-- We have actually been using the derived Text instances all along for +-- printing out trees and other structures we have defined. The code +-- in the tutorial for the Eq and Ord instance of Tree is created +-- implicitly by the deriving clause so there is no need to write it +-- here. + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving (Eq,Ord,Text) + +-- Now we can fire up both Eq and Ord functions for trees: + +tree1, tree2, tree3, tree4 :: Tree Int +tree1 = Branch (Leaf 1) (Leaf 3) +tree2 = Branch (Leaf 1) (Leaf 5) +tree3 = Leaf 4 +tree4 = Branch (Branch (Leaf 4) (Leaf 3)) (Leaf 5) + +e1 = tree1 == tree1 +e2 = tree1 == tree2 +e3 = tree1 < tree2 + +quicksort :: Ord a => [a] -> [a] +quicksort [] = [] +quicksort (x:xs) = quicksort [y | y <- xs, y <= x] ++ + [x] ++ + quicksort [y | y <- xs, y > x] + +e4 = quicksort [tree1,tree2,tree3,tree4] + +-- Now for Enum: + +data Day = Sunday | Monday | Tuesday | Wednesday | Thursday | + Friday | Saturday deriving (Text,Eq,Ord,Enum) + +e5 = quicksort [Monday,Saturday,Friday,Sunday] +e6 = [Wednesday .. Friday] +e7 = [Monday, Wednesday ..] +e8 = [Saturday, Friday ..] + + +-- Page 16 Sections 5.5, 5.5.1, 5.5.2, 5.5.3 + +module Test(Bool) where + +-- Section 5.5 Numbers +-- Section 5.5.1 Numeric Class Structure +-- Section 5.5.2 Constructed Numbers + +-- Here's a brief summary of Haskell numeric classes. + +-- Class Num +-- Most general numeric class. Has addition, subtraction, multiplication. +-- Integers can be coerced to any instance of Num with fromInteger. +-- All integer constants are in this class. +-- Instances: Int, Integer, Float, Double, Ratio a, Complex a + +-- Class Real +-- This class contains ordered numbers which can be converted to +-- rationals. +-- Instances: Int, Integer, Float, Double, Ratio a + +-- Class Integral +-- This class deals with integer division. All values in Integral can +-- be mapped onto Integer. +-- Instances: Int, Integer + +-- Class Fractional +-- These are numbers which can be divided. Any rational number can +-- be converted to a fractional. Floating point constants are in +-- this class: 1.2 would be 12/10. +-- Instances: Float, Double, Ratio a + +-- Class Floating +-- This class contains all the standard floating point functions such +-- as sqrt and sin. +-- Instances: Float, Double, Complex a + +-- Class RealFrac +-- These values can be rounded to integers and approximated by rationals. +-- Instances: Float, Double, Ratio a + +-- Class RealFloat +-- These are floating point numbers constructed from a fixed precision +-- mantissa and exponent. +-- Instances: Float, Double + +-- There are only a few sensible combinations of the constructed numerics +-- with built-in types: +-- Ratio Integer (same as Rational): arbitrary precision rationals +-- Ratio Int: limited precision rationals +-- Complex Float: complex numbers with standard precision components +-- Complex Double: complex numbers with double precision components + + +-- The following function works for arbitrary numerics: + +fact :: (Num a) => a -> a +fact 0 = 1 +fact n = n*(fact (n-1)) + +-- Note the behavior when applied to different types of numbers: + +e1 :: Int +e1 = fact 6 +e2 :: Int +e2 = fact 20 -- Yale Haskell may not handle overflow gracefully! +e3 :: Integer +e3 = fact 20 +e4 :: Rational +e4 = fact 6 +e5 :: Float +e5 = fact 6 +e6 :: Complex Float +e6 = fact 6 + +-- Be careful: values like `fact 1.5' will loop! + +-- As a practical matter, Int operations are much faster than Integer +-- operations. Also, overloaded functions can be much slower than non- +-- overloaded functions. Giving a function like fact a precise typing: + +-- fact :: Int -> Int + +-- will yield much faster code. + +-- In general, numeric expressions work as expected. Literals are +-- a little tricky - they are coerced to the appropriate value. A +-- constant like 1 can be used as ANY numeric type. + +e7 :: Float +e7 = sqrt 2 +e8 :: Rational +e8 = ((4%5) * (1%2)) / (3%4) +e9 :: Rational +e9 = 2.2 * (3%11) - 1 +e10 :: Complex Float +e10 = (2 * (3:+3)) / (1.1:+2.0 - 1) +e11 :: Complex Float +e11 = sqrt (-1) +e12 :: Integer +e12 = numerator (4%2) +e13 :: Complex Float +e13 = conjugate (4:+5.2) + +-- A function using pattern matching on complex numbers: + +mag :: (RealFloat a) => Complex a -> a +mag (a:+b) = sqrt (a^2 + b^2) + +e14 :: Float +e14 = mag (1:+1) + +-- Section 5.5.3 Numeric Coercions and Overloaded Literals + +-- The Haskell type system does NOT implicitly coerce values between +-- the different numeric types! Although overloaded constants are +-- coerced when the overloading is resolved, no implicit coercion goes +-- on when values of different types are mixed. For example: + +f :: Float +f = 1.1 +i1 :: Int +i1 = 1 +i2 :: Integer +i2 = 2 + +-- All of these expressions would result in a type error (try them!): + +-- g = i1 + f +-- h = i1 + i2 +-- i3 :: Int +-- i3 = i2 + +-- Appropriate coercions must be introduced by the user to allow +-- the mixing of types in arithmetic expressions. + +e15 :: Float +e15 = f + fromIntegral i1 +e16 :: Integer +e16 = fromIntegral i1 + i2 +e17 :: Int +e17 = i1 + fromInteger i2 -- fromIntegral would have worked too. + +-- Page 17 Section 5.5.4 +module Test(Bool) where + +-- Section 5.5.4 Default Numeric Types + +-- Ambiguous contexts arise frequently in numeric expressions. When an +-- expression which produces a value with a general type, such as +-- `1' (same as `fromInteger 1'; the type is (Num a) => a), with +-- another expression which `consumes' the type, such as `show' or +-- `toInteger', ambiguity arises. This ambiguity can be resolved +-- using expression type signatures, but this gets tedious fast! +-- Assigning a type to the top level of an ambiguous expression does +-- not help: the ambiguity does not propagate to the top level. + +e1 :: String -- This type does not influence the type of the argument to show +e1 = show 1 -- Does this mean to show an Int or a Float or ... +e2 :: String +e2 = show (1 :: Float) +e3 :: String +e3 = show (1 :: Complex Float) + +-- The reason the first example works is that ambiguous numeric types are +-- resolved using defaults. The defaults in effect here are Int and +-- Double. Since Int `fits' in the expression for e1, Int is used. +-- When Int is not valid (due to other context constraints), Double +-- will be tried. + +-- This function defaults the type of the 2's to be Int + +rms :: (Floating a) => a -> a -> a +rms x y = sqrt ((x^2 + y^2) * 0.5) + +-- The C-c e evaluation used to the Haskell system also makes use of +-- defaulting. When you type an expression, the system creates a +-- simple program to print the value of the expression using a function +-- like show. If no type signature for the printed expression is given, +-- defaulting may occur. + +-- One of the reasons for adding type signatures throughout these examples +-- is to avoid unexpected defaulting. Many of the top level signatures are +-- required to avoid ambiguity. + +-- Defaulting can lead to overflow problems when values exceed Int limits. +-- Evaluate a very large integer without a type signature to observe this +-- (unfortunately this may cause a core dump or other unpleasantness). + +-- Notice that defaulting applies only to numeric classes. The +-- show (read "xyz") -- Try this if you want! +-- example uses only class Text so no defaulting occurs. + +-- Ambiguity also arises with polymorphic types. As discussed previously, +-- expressions like [] have a similar problem. + +-- e4 = [] -- Won't work since [] has type [a] and `a' is not known. + +-- Note the difference: even though the lists have no components, the type +-- of component makes a difference in printing. + +e5 = ([] :: [Int]) +e6 = ([] :: [Char]) + +-- Page 18 Sections 6, 6.1, 6.2 + +-- Section 6 Modules + +module Tree ( Tree(Leaf,Branch), fringe ) where +-- Tree(..) would work also + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +fringe :: Tree a -> [a] +fringe (Leaf x) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +-- The Emacs interface to Haskell performs evaluation within the +-- module containing the cursor. To evaluate e1 you must place the +-- cursor in module Main. + +module Main (Tree) where +import Tree ( Tree(Leaf, Branch), fringe) +-- import Tree -- this would be the same thing +e1 :: [Int] +e1 = fringe (Branch (Leaf 1) (Leaf 2)) + +-- This interactive Haskell environment can evaluate expressions in +-- any module. The use of module Main is optional. + +-- Section 6.1 Original Names and Renaming + +module Renamed where +import Tree ( Tree(Leaf,Branch), fringe) + renaming (Leaf to Root, Branch to Twig) + +e2 :: Tree Int +e2 = Twig (Root 1) (Root 2) -- Printing always uses the original names + +-- Section 6.2 Interfaces and Implementations + +-- Yale Haskell allows separate compilation of modules using +-- unit files. These are described in the user's guide. + + +-- Page 19 Sections 6.3, 6.4 + +-- Section 6.3 Abstract Data Types + +-- Since TreeADT does not import Tree it can use the name Tree without +-- any conflict. Each module has its own separate namespace. + +module TreeADT (Tree, leaf, branch, cell, left, + right, isLeaf) where + +data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text + +leaf = Leaf +branch = Branch +cell (Leaf a) = a +left (Branch l r) = l +right (Branch l r) = r +isLeaf (Leaf _) = True +isLeaf _ = False + +module Test where +import TreeADT + +-- Since the constructors for type Tree are hidden, pattern matching +-- cannot be used. + +fringe :: Tree a -> [a] +fringe x = if isLeaf x then [cell x] + else fringe (left x) ++ fringe (right x) + +e1 :: [Int] +e1 = fringe (branch (branch (leaf 3) (leaf 2)) (leaf 1)) + +-- Section 6.4 + + +-- Page 20 Sections 7, 7.1, 7.2, 7.3 + +-- Section 7 Typing Pitfalls + +-- Section 7.1 Let-Bound Polymorphism + +module Test(e2) where + +-- f g = (g 'a',g []) -- This won't typecheck. + +-- Section 7.2 Overloaded Numerals + +-- Overloaded numerics were covered previously - here is one more example. +-- sum is a prelude function which sums the elements of a list. + +average :: (Fractional a) => [a] -> a +average xs = sum xs / fromIntegral (length xs) + +e1 :: Float -- Note that e1 would default to Double instead of Int - + -- this is due to the Fractional context. +e1 = average [1,2,3] + +-- Section 7.3 The Monomorphism Restriction + +-- The monomorphism restriction is usually encountered when functions +-- are defined without parameters. If you remove the signature for sum' +-- the monomorphism restriction will apply. +-- This will generate an error if either: +-- sum' is added to the module export list at the start of this section +-- both sumInt and sumFloat remain in the program. +-- If sum' is not exported and all uses of sum' have the same overloading, +-- there is no type error. + +sum' :: (Num a) => [a] -> a +sum' = foldl (+) 0 -- foldl reduces a list with a binary function + -- 0 is the initial value. + +sumInt :: Int +sumInt = sum' [1,2,3] + +sumFloat :: Float +sumFloat = sum' [1,2,3] + +-- If you use overloaded constants you also may encounter monomorphism: + +x :: Num a => a +x = 1 -- The type of x is Num a => a +y :: Int +y = x -- Uses x as an Int +z :: Integer +z = x -- Uses x as an Integer. A monomorphism will occur of the + -- signature for x is removed. + -- comments to see an error. + +-- Finally, if a value is exported it must not be overloaded unless bound +-- by a function binding. e2 is the only value exported. + +e2 :: Int -- Remove this to get an error. Without this line e1 will + -- be overloaded. +e2 = 1 + +-- To prevent annoying error messages about exported monomorphic variables, +-- most modules in this tutorial do not implicitly export everything - they +-- only export a single value, Bool, which was chosen to keep the export +-- list non-empty (a syntactic restriction!). In Haskell systems without +-- the evaluator used here, a module which does not export any names would +-- be useless. + +-- module Test where -- this would export everything in the module +-- module Test(Bool) -- exports only Bool +-- module Test() -- this is what we really want to do but is not valid. + +-- Page 21 Sections 8, 8.1 + +module Test(Bool) where + +-- Section 8 Input/Output +-- Section 8.1 Introduction to Continuations + +-- Simplify f here to be 1/x. + +data Maybe a = Ok a | Oops String deriving Text + +f :: Float -> Maybe Float +f x = if x == 0 then Oops "Divide by 0" else Ok (1/x) + +-- g is a `safe' call to x. The call to error could be replaced by +-- some explicit value like Oops msg -> 0. + +g x = case f x of + Ok y -> y + Oops msg -> error msg + +e1 = f 0 +e2 = g 0 +e3 = g 1 + +-- Here is the same example using continuations: + +f' :: Float -> (String -> Float) -> Float +f' x c = if x == 0 then c "Divide by 0" + else 1/x + +g' x = f' x error -- calls error on divide by 0 +g'' x = f' x (\s -> 0) -- returns 0 on divide by 0 + +e4 = g' 0 +e5 = g'' 0 + +-- Page 22 Sections 8.2, 8.3 + +module Test where + +-- Section 8.2 Continuation Based I/O + +-- We will skip the program fragments at the start of this section and +-- move directly to the writeFile / readFile example. + +-- Before we can use Haskell I/O, we need to introduce a new Emacs command: +-- C-c r. This command runs a dialogue instead of printing a value. +-- (Actually C-c e creates a dialogue on the fly and runs it in the same +-- manner as C-c r). As with C-c e you are prompted for an expression. +-- In this case, the expression must be of type Dialogue and it is +-- executed by the I/O system. We use d1,d2,... for dialogues to be +-- executed by C-c r. + +-- We make the file name a parameter to allow for easier testing. +-- Don't expect much error handling in exit. + +s1 = "This is a test of Haskell" + +main file = writeFile file s1 exit ( + readFile file exit (\s2 -> + appendChan stdout (if s1==s2 then "contents match" + else "something intervened!") exit + done)) + +d1,d2 :: Dialogue +d1 = main "/tmp/ReadMe" +d2 = main "/dev/null" -- this will read back as the empty string + +-- A simple IO program using $ for readability: ($ is defined in the Prelude) + +d3 = appendChan "stdout" "Type something: " exit $ + readChan "stdin" exit $ \s2 -> + appendChan "stdout" ("You typed " ++ head (lines s2)) exit $ + done + +-- This program suffers from a strictness problem. Strictness deals +-- with when things get evaluated. In this program, the input is not +-- needed until after the "You typed " is printed. Fixing this would +-- require some operation to look at the string before the final +-- appendChan. Here is one possible fix: + +d4 = appendChan "stdout" "Type something: " exit $ + readChan "stdin" exit $ \s2 -> + let str = head (lines s2) in + if str == str then -- This evaluates str + appendChan "stdout" ("You typed " ++ head (lines s2)) exit $ + done + else done + + +-- Section 8.3 Terminal I/O + +-- Since this programming environment runs under Emacs, the issue of +-- echoing does not really apply. However, the synchronization between +-- input and output can be seen in the following example. Since the input +-- comes a line at a time, the X's come in groups between input lines. +-- The cursor will move into the haskell dialogue buffer when the program +-- requests input. Use a ^D to stop the program (^Q^D actually). [Warning: +-- some brain damaged lisps stop not only the Haskell program but also +-- the entire compiler on ^D] + +d5 = readChan stdin exit processInput where + processInput s = loop 1 s + loop n [] = done + loop n (x:xs) | n == 10 = appendChan stdout "X" exit (loop 1 xs) + | True = loop (n+1) xs + +-- For more examples using the I/O system look in the demo programs +-- that come with haskell (in $HASKELL/progs/demo) and the report. + +-- Page 23 Sections 9, 9.1, 9.2 + +module Test(Bool) where + +-- Section 9 Arrays +-- Section 9.1 Index Types + +-- Arrays are built on the class Ix. Here are some quick examples of Ix: + +e1 :: [Int] +e1 = range (0,4) +e2 :: Int +e2 = index (0,4) 2 +low,high :: (Int,Int) +low = (1,1) +high = (3,4) +e3 = range (low,high) +e4 = index (low,high) (3,2) +e5 = inRange (low,high) (4,3) + +-- Section 9.2 Array Creation + +squares :: Array Int Int +squares = array (1,100) [i := i*i | i <- [1..100]] + +-- We can also parameterize this a little: + +squares' :: Int -> Array Int Int +squares' n = array (1,n) [i := i*i | i <- [1..n]] + +e6 :: Int +e6 = squares!6 +e7 :: (Int,Int) +e7 = bounds squares +e8 :: Array Int Int +e8 = squares' 10 + +-- Here is a function which corresponds to `take' for lists. It takes +-- an arbitrary slice out of an array. + +atake :: (Ix a) => Array a b -> (a,a) -> Array a b +atake a (l,u) | inRange (bounds a) l && inRange (bounds a) u = + array (l,u) [i := a!i | i <- range (l,u)] + | otherwise = error "Subarray out of range" + +e9 = atake squares (4,8) + +mkArray :: Ix a => (a -> b) -> (a,a) -> Array a b +mkArray f bnds = array bnds [i := f i | i <- range bnds] + +e10 :: Array Int Int +e10 = mkArray (\i -> i*i) (1,10) + +fibs :: Int -> Array Int Int +fibs n = a where + a = array (0,n) ([0 := 1, 1 := 1] ++ + [i := a!(i-1) + a!(i-2) | i <- [2..n]]) + +e11 = atake (fibs 50) (3,10) + +wavefront :: Int -> Array (Int,Int) Int +wavefront n = a where + a = array ((1,1),(n,n)) + ([(1,j) := 1 | j <- [1..n]] ++ + [(i,1) := 1 | i <- [2..n]] ++ + [(i,j) := a!(i,j-1) + a!(i-1,j-1) + a!(i-1,j) + | i <- [2..n], j <- [2..n]]) + +wave = wavefront 20 +e12 = atake wave ((1,1),(3,3)) +e13 = atake wave ((3,3),(5,5)) + +-- Here are some errors in array operations: + +e14 :: Int +e14 = wave ! (0,0) -- Out of bounds +arr1 :: Array Int Int +arr1 = array (1,10) [1 := 1] -- No value provided for 2..10 +e15,e16 :: Int +e15 = arr1 ! 1 -- works OK +e16 = arr1 ! 2 -- undefined by array + +-- Page 24 Sections 9.3, 9.4 + +module Test(Bool) where + +-- Section 9.3 Accumulation + +hist :: (Ix a, Integral b) => (a,a) -> [a] -> Array a b +hist bnds is = accumArray (+) 0 bnds [i := 1 | i <- is, inRange bnds i] + +e1 :: Array Char Int +e1 = hist ('a','z') "This counts the frequencies of each lowercase letter" + +decades :: (RealFrac a) => a -> a -> [a] -> Array Int Int +decades a b = hist (0,9) . map decade + where + decade x = floor ((x-a) * s) + s = 10 / (b - a) + +test1 :: [Float] +test1 = map sin [0..100] -- take the sine of the 0 - 100 +e2 = decades 0 1 test1 + +-- Section 9.4 Incremental Updates + +swapRows :: (Ix a, Ix b, Enum b) => a -> a -> Array (a,b) c -> Array (a,b) c +swapRows i i' a = a // ([(i,j) := a!(i',j) | j <- [jLo..jHi]] ++ + [(i',j) := a!(i,j) | j <- [jLo..jHi]]) + where ((iLo,jLo),(iHi,jHi)) = bounds a + +arr1 :: Array (Int,Int) (Int,Int) +arr1 = array ((1,1),(5,5)) [(i,j) := (i,j) | (i,j) <- range ((1,1),(5,5))] + +e3 = swapRows 2 3 arr1 + +-- Printing the arrays in more readable form makes the results easier +-- to view. + +-- This is a printer for 2d arrays + +aprint a width = shows (bounds a) . showChar '\n' . showRows lx ly where + showRows r c | r > ux = showChar '\n' + showRows r c | c > uy = showChar '\n' . showRows (r+1) ly + showRows r c = showElt (a!(r,c)) . showRows r (c+1) + showElt e = showString (take width (show e ++ repeat ' ')) . showChar ' ' + ((lx,ly),(ux,uy)) = bounds a + +showArray a w = appendChan stdout (aprint a w "") abort done + +d1 = showArray e3 6 + +swapRows' :: (Ix a, Ix b, Enum b) => a -> a -> Array (a,b) c -> Array (a,b) c +swapRows' i i' a = a // [assoc | j <- [jLo..jHi], + assoc <- [(i,j) := a!(i',j), + (i',j) := a!(i,j)]] + where ((iLo,jLo),(iHi,jHi)) = bounds a + +d2 = showArray (swapRows' 1 5 arr1) 6 + +-- Page 25 Section 9.5 + +module Test(Bool) where + +-- Section 9.5 An example: Matrix Multiplication + +aprint a width = shows (bounds a) . showChar '\n' . showRows lx ly where + showRows r c | r > ux = showChar '\n' + showRows r c | c > uy = showChar '\n' . showRows (r+1) ly + showRows r c = showElt (a!(r,c)) . showRows r (c+1) + showElt e = showString (take width (show e ++ repeat ' ')) . showChar ' ' + ((lx,ly),(ux,uy)) = bounds a + +showArray a w = appendChan stdout (aprint a w "") abort done + +matMult :: (Ix a, Ix b, Ix c, Num d) => + Array (a,b) d -> Array (b,c) d -> Array (a,c) d +matMult x y = + array resultBounds + [(i,j) := sum [x!(i,k) * y!(k,j) | k <- range (lj,uj)] + | i <- range (li,ui), + j <- range (lj',uj')] + where + ((li,lj),(ui,uj)) = bounds x + ((li',lj'),(ui',uj')) = bounds y + resultBounds + | (lj,uj)==(li',ui') = ((li,lj'),(ui,uj')) + | otherwise = error "matMult: incompatible bounds" + +mat1,mat2,mat3,mat4 :: Array (Int,Int) Int +mat1 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 0,(1,0) := 0,(1,1) := 1] +mat2 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 1,(1,0) := 1,(1,1) := 1] +mat3 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 2,(1,0) := 3,(1,1) := 4] +mat4 = array ((0,0),(1,2)) [(0,0) := 1,(0,1) := 2,(0,2) := 3, + (1,0) := 4,(1,1) := 5,(1,2) := 6] + +d1 = showArray (matMult mat1 mat2) 4 +d2 = showArray (matMult mat2 mat3) 4 +d3 = showArray (matMult mat1 mat4) 4 +d4 = showArray (matMult mat4 mat1) 4 + +matMult' :: (Ix a, Ix b, Ix c, Num d) => + Array (a,b) d -> Array (b,c) d -> Array (a,c) d +matMult' x y = + accumArray (+) 0 ((li,lj'),(ui,uj')) + [(i,j) := x!(i,k) * y!(k,j) + | i <- range (li,ui), + j <- range (lj',uj'), + k <- range (lj,uj)] + + where + ((li,lj),(ui,uj)) = bounds x + ((li',lj'),(ui',uj')) = bounds y + resultBounds + | (lj,uj)==(li',ui') = ((li,lj'),(ui,uj')) + | otherwise = error "matMult: incompatible bounds" + +d5 = showArray (matMult mat1 mat2) 4 +d6 = showArray (matMult mat2 mat3) 4 + +genMatMul :: (Ix a, Ix b, Ix c) => + ([f] -> g) -> (d -> e -> f) -> + Array (a,b) d -> Array (b,c) e -> Array (a,c) g +genMatMul f g x y = + array ((li,lj'),(ui,uj')) + [(i,j) := f [(x!(i,k)) `g` (y!(k,j)) | k <- range (lj,uj)] + | i <- range (li,ui), + j <- range (lj',uj')] + where + ((li,lj),(ui,uj)) = bounds x + ((li',lj'),(ui',uj')) = bounds y + resultBounds + | (lj,uj)==(li',ui') = ((li,lj'),(ui,uj')) + | otherwise = error "matMult: incompatible bounds" + +d7 = showArray (genMatMul maximum (-) mat2 mat1) 4 +d8 = showArray (genMatMul and (==) mat1 mat2) 6 +d9 = showArray (genMatMul and (==) mat1 mat1) 6 + +-- Page 26 More about Haskell + +This is the end of the tutorial. If you wish to see more examples of +Haskell programming, Yale Haskell comes with a set of demo programs. +These can be found in $HASKELL/progs/demo. Once you have mastered the +tutorial, both the report and the user manual for Yale Haskell should +be understandable. Many examples of Haskell programming can be found in +the Prelude. The directory $HASKELL/progs/prelude contains the sources +for the Prelude. + +We appreciate any comments you have on this tutorial. Send any comments +to haskell-requests@cs.yale.edu. + + The Yale Haskell Group diff --git a/runtime/README b/runtime/README new file mode 100644 index 0000000..99d113a --- /dev/null +++ b/runtime/README @@ -0,0 +1,8 @@ +This directory contains definitions of things that are used +exclusively in code generated by the Haskell compiler. It contains +implementations of some of the things declared in the prims files for +the prelude, as well as some more generic things that the code +generator knows about. + +Note that some of the files in this directory access some Common Lisp +features directly. diff --git a/runtime/array-prims.scm b/runtime/array-prims.scm new file mode 100644 index 0000000..6b553f5 --- /dev/null +++ b/runtime/array-prims.scm @@ -0,0 +1,55 @@ +;;; array-prims.scm -- array primitives +;;; +;;; author : John & Sandra +;;; date : 14 May 1993 + + +;;; Vector reference, returning unboxed value + +(define-syntax (prim.vector-sel vec i) + `(vector-ref ,vec ,i)) + + +;;; Destructive vector update. All arguments are unboxed. + +(define-syntax (prim.vector-update vec i newval) + `(setf (vector-ref ,vec ,i) ,newval)) + + +;;; Make a vector whose elements are initialized to val (which is boxed). + +(define-syntax (prim.make-vector size val) + `(make-vector ,size ,val)) + + +;;; Copy an existing vector. + +(define-syntax (prim.copy-vector vec) + `(vector-copy ,vec)) + + +;;; Explicit force operation + +(define-syntax (prim.force x) + `(force ,x)) + + +;;; The first parameter is forced first since this prim is declared to +;;; be strict in the first arg. + +(define-syntax (prim.strict1 force-this leave-this) + `(begin + ;; Can't ignore the first argument entirely since doing so + ;; might result in variable-bound-but-not-referenced errors. + ;; Hopefully the Lisp compiler will be smart enough to get + ;; rid of this when appropriate. + ,force-this + ;; Don't generate a stupid (force (delay x)) sequence here if + ;; we don't need to. + ,(if (and (pair? leave-this) + (or (eq? (car leave-this) 'delay) + (eq? (car leave-this) 'box))) + (cadr leave-this) + `(force ,leave-this)))) + + diff --git a/runtime/debug-utils.scm b/runtime/debug-utils.scm new file mode 100644 index 0000000..e5fa971 --- /dev/null +++ b/runtime/debug-utils.scm @@ -0,0 +1,33 @@ + +;;; This has some diagnostic stuff + +;;; This forces all delays in a structure + +(define (force-all x) + (cond ((delay? x) + (force-all (force x))) + ((pair? x) + (force-all (car x)) + (force-all (cdr x))) + ((vector? x) + (dotimes (i (vector-length x)) + (force-all (vector-ref x i))))) + x) + +;;; This forces & removes all delays in a structure. + +(define (remove-delays x) + (cond ((delay? x) + (remove-delays (force x))) + ((pair? x) + (cons (remove-delays (car x)) + (remove-delays (cdr x)))) + ((vector? x) + (list->vector (map (function remove-delays) (vector->list x)))) + (else x))) + +(define (delay? x) + (and (pair? x) + (or (eq? (car x) '#t) + (eq? (car x) '#f)))) + diff --git a/runtime/io-primitives.scm b/runtime/io-primitives.scm new file mode 100644 index 0000000..85bc51b --- /dev/null +++ b/runtime/io-primitives.scm @@ -0,0 +1,178 @@ + +;;; These are the IO primitives used by PreludeIOPrims + +;;; Note: the box in write-string-stdout, write-string-file, and +;;; append-string-file are due to the NoConversion in the .hi file. +;;; The problem is that NoConversion applies to everything, not just +;;; the input arg that the conversion is not needed or. + + +(predefine (notify-input-request)) + +(define *emacs-notified* '#f) +(define *stdin-read* '#f) + +(define (initialize-io-system) + (setf *emacs-notified* '#f) + (setf *stdin-read* '#f)) + +(define (io-success . res) + (make-tagged-data 0 + (if (null? res) + (box 0) + (box (make-haskell-string (car res)))))) + +(define (io-success/bin res) + (make-tagged-data 0 (box res))) + +(define (io-success/lazy res) + (make-tagged-data 0 res)) + +(define (io-failure string) + (make-tagged-data 1 (box (make-haskell-string string)))) + +; primReadStringFile +(define (prim.read-string-file filename) + (if (file-exists? filename) + (let ((str (call-with-input-file filename + (lambda (port) + (port->string port))))) + (io-success str)) + (io-failure (format '#f "File not found: ~A~%" filename)))) + +(define (port->string port) + (call-with-output-string + (lambda (string-port) + (copy-till-eof port string-port)))) + +(define (copy-till-eof in-port out-port) + (do ((ch (read-char in-port) (read-char in-port))) + ((eof-object? ch)) + (write-char ch out-port))) + +; primWriteStringFile +(define (prim.write-string-file filename contents state) + (declare (ignore state)) + (box + (let ((stream (lisp:open (haskell-string->string filename) + :direction :output + :if-exists :overwrite + :if-does-not-exist :create))) + (print-haskell-string contents stream) + (close-output-port stream) + (io-success)))) + +;primAppendStringFile +(define (prim.append-string-file filename contents state) + (declare (ignore state)) + (box + (let ((stream (lisp:open (haskell-string->string filename) + :direction :output + :if-exists :append + :if-does-not-exist '()))) + (cond ((not (eq? stream '())) + (print-haskell-string contents stream) + (close-output-port stream) + (io-success)) + (else + (io-failure "Can't open file")))))) + +; primReadBinFile +(define (prim.read-bin-file name) + (let ((bin (lisp-read name))) + (if (and (pair? bin) (eq? (car bin) ':binary)) + (io-success/bin bin) + (io-failure "Not a bin file")))) + +; primWriteBinFile +(define (prim.write-bin-file name contents) + (let ((stream (lisp:open name :direction :output + :if-exists :overwrite + :if-does-not-exist :create))) + (write (cons ':binary contents) stream) + (close-output-port stream) + (io-success))) + +; primAppendBinFile +(define (prim.append-bin-file name contents) + (let ((bin (lisp-read name))) + (if (and (pair? bin) (eq? (car bin) ':binary)) + (let ((stream (lisp:open name :direction :output :if-exists :overwrite))) + (write (append bin contents) stream) + (io-success)) + (io-failure "Can't open Bin file")))) + +; primDeleteFile +(define (prim.delete-file name) + (if (file-exists? name) + (if (lisp:delete-file name) + (io-success) + (io-failure "Can't delete file")) + (io-failure "File not found"))) + +; primStatusFile +(define (prim.status-file name) + (if (file-exists? name) + (io-success "frw") + (io-failure (format '#f "File ~A not found" name)))) + +;primReadStdin +(define (prim.read-string-stdin state) + (declare (ignore state)) + (cond (*stdin-read* + (haskell-runtime-error "Multiple ReadChan from stdin")) + (else + (setf *stdin-read* '#t) + (delay (read-next-char))))) + +(define (read-next-char) + (when (and *emacs-mode* (not *emacs-notified*)) + (setf *emacs-notified* '#t) + (notify-input-request)) + (let ((ch (read-char))) + (if (eof-object? ch) + '() + (cons (box (char->integer ch)) + (delay (read-next-char)))))) + +; primWriteStdout +(define (prim.write-string-stdout string state) + (declare (ignore state)) + (print-haskell-string string (current-output-port)) + (box (io-success))) + +; primReadBinStdin +(define (prim.read-bin-stdin) + (haskell-runtime-error "ReadBinChan not implemented")) + +; primWriteBinStdout +(define (prim.write-bin-stdout bin) + (declare (ignore bin)) + (haskell-runtime-error "WriteBinChan not implemented")) + +;;; %%% probably bogus +; primGetEnv +(define (prim.getenv name) + (io-success (getenv name))) + +(define (lisp-read file) + (if (not (file-exists? file)) + 'error + (call-with-input-file file + (lambda (port) + (lisp:read port '#f 'error '#f))))) + +(define-integrable (prim.returnio x s) + (declare (ignore s)) + x) + +(define-integrable (prim.getstate x) + (declare (ignore x)) + 'state) + +(define-integrable (prim.getres x) + (force x)) + + + + diff --git a/runtime/prims.scm b/runtime/prims.scm new file mode 100644 index 0000000..797f21b --- /dev/null +++ b/runtime/prims.scm @@ -0,0 +1,595 @@ +;;; prims.scm -- definitions for primitives +;;; +;;; author : Sandra Loosemore +;;; date : 9 Jun 1992 +;;; +;;; WARNING!!! This file contains Common-Lisp specific code. +;;; + + +;;; Helper stuff + +(define-integrable (is-fixnum? x) + (lisp:typep x 'lisp:fixnum)) + +(define-integrable (is-integer? x) + (lisp:typep x 'lisp:integer)) + +(define-integrable (is-single-float? x) + (lisp:typep x 'lisp:single-float)) + +(define-integrable (is-double-float? x) + (lisp:typep x 'lisp:double-float)) + +(define-syntax (the-fixnum x) + `(lisp:the lisp:fixnum ,x)) + +(define-syntax (the-integer x) + `(lisp:the lisp:integer ,x)) + +(define-syntax (the-single-float x) + `(lisp:the lisp:single-float ,x)) + +(define-syntax (the-double-float x) + `(lisp:the lisp:double-float ,x)) + +(define-syntax (make-haskell-tuple2 x y) + `(make-tuple (box ,x) (box ,y))) + +;;; Abort +;;; *** Should probably do something other than just signal an error. + +(define (prim.abort s) + (haskell-runtime-error s)) + +(define (haskell-string->list s) + (if (null? s) + '() + (cons (integer->char (force (car s))) + (haskell-string->list (force (cdr s)))))) + +;;; Char + +(define-syntax (prim.char-to-int c) + `(the-fixnum ,c)) + +(define-syntax (prim.int-to-char i) + `(the-fixnum ,i)) + +(define-syntax (prim.eq-char i1 i2) + `(= (the-fixnum ,i1) (the-fixnum ,i2))) +(define-syntax (prim.not-eq-char i1 i2) + `(not (= (the-fixnum ,i1) (the-fixnum ,i2)))) +(define-syntax (prim.le-char i1 i2) + `(<= (the-fixnum ,i1) (the-fixnum ,i2))) +(define-syntax (prim.not-le-char i1 i2) + `(> (the-fixnum ,i1) (the-fixnum ,i2))) +(define-syntax (prim.not-lt-char i1 i2) + `(>= (the-fixnum ,i1) (the-fixnum ,i2))) +(define-syntax (prim.lt-char i1 i2) + `(< (the-fixnum ,i1) (the-fixnum ,i2))) + +(define-integrable prim.max-char 255) + + +;;; Floating + +(define-syntax (prim.eq-float f1 f2) + `(= (the-single-float ,f1) (the-single-float ,f2))) +(define-syntax (prim.not-eq-float f1 f2) + `(not (= (the-single-float ,f1) (the-single-float ,f2)))) +(define-syntax (prim.le-float f1 f2) + `(<= (the-single-float ,f1) (the-single-float ,f2))) +(define-syntax (prim.not-le-float f1 f2) + `(> (the-single-float ,f1) (the-single-float ,f2))) +(define-syntax (prim.not-lt-float f1 f2) + `(>= (the-single-float ,f1) (the-single-float ,f2))) +(define-syntax (prim.lt-float f1 f2) + `(< (the-single-float ,f1) (the-single-float ,f2))) + +(define-syntax (prim.eq-double f1 f2) + `(= (the-double-float ,f1) (the-double-float ,f2))) +(define-syntax (prim.not-eq-double f1 f2) + `(not (= (the-double-float ,f1) (the-double-float ,f2)))) +(define-syntax (prim.le-double f1 f2) + `(<= (the-double-float ,f1) (the-double-float ,f2))) +(define-syntax (prim.not-le-double f1 f2) + `(> (the-double-float ,f1) (the-double-float ,f2))) +(define-syntax (prim.not-lt-double f1 f2) + `(>= (the-double-float ,f1) (the-double-float ,f2))) +(define-syntax (prim.lt-double f1 f2) + `(< (the-double-float ,f1) (the-double-float ,f2))) + +(define-syntax (prim.float-max f1 f2) + `(the-single-float (max (the-single-float ,f1) (the-single-float ,f2)))) +(define-syntax (prim.float-min f1 f2) + `(the-single-float (min (the-single-float ,f1) (the-single-float ,f2)))) + +(define-syntax (prim.double-max f1 f2) + `(the-double-float (max (the-double-float ,f1) (the-double-float ,f2)))) +(define-syntax (prim.double-min f1 f2) + `(the-double-float (min (the-double-float ,f1) (the-double-float ,f2)))) + +(define-syntax (prim.plus-float f1 f2) + `(the-single-float (+ (the-single-float ,f1) (the-single-float ,f2)))) +(define-syntax (prim.minus-float f1 f2) + `(the-single-float (- (the-single-float ,f1) (the-single-float ,f2)))) +(define-syntax (prim.mul-float f1 f2) + `(the-single-float (* (the-single-float ,f1) (the-single-float ,f2)))) +(define-syntax (prim.div-float f1 f2) + `(the-single-float (/ (the-single-float ,f1) (the-single-float ,f2)))) + +(define-syntax (prim.plus-double f1 f2) + `(the-double-float (+ (the-double-float ,f1) (the-double-float ,f2)))) +(define-syntax (prim.minus-double f1 f2) + `(the-double-float (- (the-double-float ,f1) (the-double-float ,f2)))) +(define-syntax (prim.mul-double f1 f2) + `(the-double-float (* (the-double-float ,f1) (the-double-float ,f2)))) +(define-syntax (prim.div-double f1 f2) + `(the-double-float (/ (the-double-float ,f1) (the-double-float ,f2)))) + + +(define-syntax (prim.neg-float f) + `(the-single-float (- (the-single-float ,f)))) + +(define-syntax (prim.neg-double f) + `(the-double-float (- (the-double-float ,f)))) + +(define-syntax (prim.abs-float f) + `(the-single-float (lisp:abs (the-single-float ,f)))) + +(define-syntax (prim.abs-double f) + `(the-double-float (lisp:abs (the-double-float ,f)))) + + +(define-syntax (prim.exp-float f) + `(the-single-float (lisp:exp (the-single-float ,f)))) +(define-syntax (prim.log-float f) + `(the-single-float (lisp:log (the-single-float ,f)))) +(define-syntax (prim.sqrt-float f) + `(the-single-float (lisp:sqrt (the-single-float ,f)))) +(define-syntax (prim.sin-float f) + `(the-single-float (lisp:sin (the-single-float ,f)))) +(define-syntax (prim.cos-float f) + `(the-single-float (lisp:cos (the-single-float ,f)))) +(define-syntax (prim.tan-float f) + `(the-single-float (lisp:tan (the-single-float ,f)))) +(define-syntax (prim.asin-float f) + `(the-single-float (lisp:asin (the-single-float ,f)))) +(define-syntax (prim.acos-float f) + `(the-single-float (lisp:acos (the-single-float ,f)))) +(define-syntax (prim.atan-float f) + `(the-single-float (lisp:atan (the-single-float ,f)))) +(define-syntax (prim.sinh-float f) + `(the-single-float (lisp:sinh (the-single-float ,f)))) +(define-syntax (prim.cosh-float f) + `(the-single-float (lisp:cosh (the-single-float ,f)))) +(define-syntax (prim.tanh-float f) + `(the-single-float (lisp:tanh (the-single-float ,f)))) +(define-syntax (prim.asinh-float f) + `(the-single-float (lisp:asinh (the-single-float ,f)))) +(define-syntax (prim.acosh-float f) + `(the-single-float (lisp:acosh (the-single-float ,f)))) +(define-syntax (prim.atanh-float f) + `(the-single-float (lisp:atanh (the-single-float ,f)))) + + +(define-syntax (prim.exp-double f) + `(the-double-float (lisp:exp (the-double-float ,f)))) +(define-syntax (prim.log-double f) + `(the-double-float (lisp:log (the-double-float ,f)))) +(define-syntax (prim.sqrt-double f) + `(the-double-float (lisp:sqrt (the-double-float ,f)))) +(define-syntax (prim.sin-double f) + `(the-double-float (lisp:sin (the-double-float ,f)))) +(define-syntax (prim.cos-double f) + `(the-double-float (lisp:cos (the-double-float ,f)))) +(define-syntax (prim.tan-double f) + `(the-double-float (lisp:tan (the-double-float ,f)))) +(define-syntax (prim.asin-double f) + `(the-double-float (lisp:asin (the-double-float ,f)))) +(define-syntax (prim.acos-double f) + `(the-double-float (lisp:acos (the-double-float ,f)))) +(define-syntax (prim.atan-double f) + `(the-double-float (lisp:atan (the-double-float ,f)))) +(define-syntax (prim.sinh-double f) + `(the-double-float (lisp:sinh (the-double-float ,f)))) +(define-syntax (prim.cosh-double f) + `(the-double-float (lisp:cosh (the-double-float ,f)))) +(define-syntax (prim.tanh-double f) + `(the-double-float (lisp:tanh (the-double-float ,f)))) +(define-syntax (prim.asinh-double f) + `(the-double-float (lisp:asinh (the-double-float ,f)))) +(define-syntax (prim.acosh-double f) + `(the-double-float (lisp:acosh (the-double-float ,f)))) +(define-syntax (prim.atanh-double f) + `(the-double-float (lisp:atanh (the-double-float ,f)))) + + +(define-integrable prim.pi-float (lisp:coerce lisp:pi 'lisp:single-float)) + +(define-integrable prim.pi-double (lisp:coerce lisp:pi 'lisp:double-float)) + + +;;; Assumes rationals are represented as a 2-tuple of integers + +(define (prim.rational-to-float x) + (let ((n (tuple-select 2 0 x)) + (d (tuple-select 2 1 x))) + (if (eqv? d 0) + (haskell-runtime-error "Divide by 0.") + (prim.rational-to-float-aux n d)))) + +(define (prim.rational-to-float-aux n d) + (declare (type integer n d)) + (/ (lisp:coerce n 'lisp:single-float) + (lisp:coerce d 'lisp:single-float))) + +(define (prim.rational-to-double x) + (let ((n (tuple-select 2 0 x)) + (d (tuple-select 2 1 x))) + (if (eqv? d 0) + (haskell-runtime-error "Divide by 0.") + (prim.rational-to-double-aux n d)))) + +(define (prim.rational-to-double-aux n d) + (declare (type integer n d)) + (/ (lisp:coerce n 'lisp:double-float) + (lisp:coerce d 'lisp:double-float))) + +(define (prim.float-to-rational x) + (let ((r (lisp:rational (the lisp:single-float x)))) + (declare (type rational r)) + (make-tuple (lisp:numerator r) (lisp:denominator r)))) + +(define (prim.double-to-rational x) + (let ((r (lisp:rational (the lisp:double-float x)))) + (declare (type rational r)) + (make-tuple (lisp:numerator r) (lisp:denominator r)))) + + +(define-integrable prim.float-1 (lisp:coerce 1.0 'lisp:single-float)) +(define-integrable prim.double-1 (lisp:coerce 1.0 'lisp:double-float)) + +(define-integrable prim.float-digits + (lisp:float-digits prim.float-1)) + +(define-integrable prim.double-digits + (lisp:float-digits prim.double-1)) + +(define-integrable prim.float-radix + (lisp:float-radix prim.float-1)) + +(define-integrable prim.double-radix + (lisp:float-radix prim.double-1)) + + +;;; Sometimes least-positive-xxx-float is denormalized. + +(define-integrable prim.float-min-exp + (multiple-value-bind (m e) + (lisp:decode-float + #+lucid lcl:least-positive-normalized-single-float + #-lucid lisp:least-positive-single-float) + (declare (ignore m)) + e)) + +(define-integrable prim.double-min-exp + (multiple-value-bind (m e) + (lisp:decode-float + #+lucid lcl:least-positive-normalized-double-float + #-lucid lisp:least-positive-double-float) + (declare (ignore m)) + e)) + +(define-integrable prim.float-max-exp + (multiple-value-bind (m e) + (lisp:decode-float lisp:most-positive-single-float) + (declare (ignore m)) + e)) + +(define-integrable prim.double-max-exp + (multiple-value-bind (m e) + (lisp:decode-float lisp:most-positive-double-float) + (declare (ignore m)) + e)) + +(define-integrable (prim.float-range x) + (declare (ignore x)) + (make-haskell-tuple2 prim.float-min-exp prim.float-max-exp)) + +(define-integrable (prim.double-range x) + (declare (ignore x)) + (make-haskell-tuple2 prim.double-min-exp prim.double-max-exp)) + + +;;; *** I'm not sure if these are correct. Should the exponent value +;;; *** be taken as the value that lisp:integer-decode-float returns, +;;; *** or as the value that lisp:decode-float returns? (They're +;;; *** not the same because the significand is scaled differently.) +;;; *** I'm guessing that Haskell's model is to use the actual numbers +;;; *** that are in the bit fields + +;;; jcp - I removed this since Haskell requires an integer instead of a +;;; fractional mantissa. My theory is that integer-decode-float returns +;;; what Haskell wants without fiddling (except sign reattachment) + +(define (exponent-adjustment m) + (if (eqv? prim.float-radix 2) + ;; the usual case -- e.g. IEEE floating point + (lisp:integer-length m) + (lisp:ceiling (lisp:log m prim.float-radix)))) + +(define (prim.decode-float f) + (multiple-value-bind (m e s) + (lisp:integer-decode-float (the-single-float f)) + (make-haskell-tuple2 (* (the-integer m) (the-fixnum s)) + (the-fixnum e)))) + +(define (prim.decode-double f) + (multiple-value-bind (m e s) + (lisp:integer-decode-float (the-double-float f)) + (make-haskell-tuple2 (* (the-integer m) (the-fixnum s)) + (the-fixnum e)))) + +(define (prim.encode-float m e) + (lisp:scale-float (lisp:coerce m 'lisp:single-float) (the-fixnum e))) + +(define (prim.encode-double m e) + (lisp:scale-float (lisp:coerce m 'lisp:double-float) (the-fixnum e))) + + +;;; Integral + +(define-syntax (prim.eq-int i1 i2) + `(= (the-fixnum ,i1) (the-fixnum ,i2))) +(define-syntax (prim.not-eq-int i1 i2) + `(not (= (the-fixnum ,i1) (the-fixnum ,i2)))) +(define-syntax (prim.le-int i1 i2) + `(<= (the-fixnum ,i1) (the-fixnum ,i2))) +(define-syntax (prim.not-le-int i1 i2) + `(> (the-fixnum ,i1) (the-fixnum ,i2))) +(define-syntax (prim.not-lt-int i1 i2) + `(>= (the-fixnum ,i1) (the-fixnum ,i2))) +(define-syntax (prim.lt-int i1 i2) + `(< (the-fixnum ,i1) (the-fixnum ,i2))) +(define-syntax (prim.int-max i1 i2) + `(the-fixnum (max (the-fixnum ,i1) (the-fixnum ,i2)))) +(define-syntax (prim.int-min i1 i2) + `(the-fixnum (min (the-fixnum ,i1) (the-fixnum ,i2)))) + +(define-syntax (prim.eq-integer i1 i2) + `(= (the-integer ,i1) (the-integer ,i2))) +(define-syntax (prim.not-eq-integer i1 i2) + `(not (= (the-integer ,i1) (the-integer ,i2)))) +(define-syntax (prim.le-integer i1 i2) + `(<= (the-integer ,i1) (the-integer ,i2))) +(define-syntax (prim.not-le-integer i1 i2) + `(> (the-integer ,i1) (the-integer ,i2))) +(define-syntax (prim.not-lt-integer i1 i2) + `(>= (the-integer ,i1) (the-integer ,i2))) +(define-syntax (prim.lt-integer i1 i2) + `(< (the-integer ,i1) (the-integer ,i2))) +(define-syntax (prim.integer-max i1 i2) + `(the-integer (max (the-integer ,i1) (the-integer ,i2)))) +(define-syntax (prim.integer-min i1 i2) + `(the-integer (min (the-integer ,i1) (the-integer ,i2)))) + + +(define-syntax (prim.plus-int i1 i2) + `(the-fixnum (+ (the-fixnum ,i1) (the-fixnum ,i2)))) +(define-syntax (prim.minus-int i1 i2) + `(the-fixnum (- (the-fixnum ,i1) (the-fixnum ,i2)))) +(define-syntax (prim.mul-int i1 i2) + `(the-fixnum (* (the-fixnum ,i1) (the-fixnum ,i2)))) +(define-syntax (prim.neg-int i) + `(the-fixnum (- (the-fixnum ,i)))) +(define-syntax (prim.abs-int i) + `(the-fixnum (lisp:abs (the-fixnum ,i)))) + +(define-integrable prim.minint lisp:most-negative-fixnum) +(define-integrable prim.maxint lisp:most-positive-fixnum) + +(define-syntax (prim.plus-integer i1 i2) + `(the-integer (+ (the-integer ,i1) (the-integer ,i2)))) +(define-syntax (prim.minus-integer i1 i2) + `(the-integer (- (the-integer ,i1) (the-integer ,i2)))) +(define-syntax (prim.mul-integer i1 i2) + `(the-integer (* (the-integer ,i1) (the-integer ,i2)))) +(define-syntax (prim.neg-integer i) + `(the-integer (- (the-integer ,i)))) +(define-syntax (prim.abs-integer i) + `(the-integer (lisp:abs (the-integer ,i)))) + + +(define (prim.div-rem-int i1 i2) + (multiple-value-bind (q r) + (lisp:truncate (the-fixnum i1) (the-fixnum i2)) + (make-tuple (box (the-fixnum q)) (box (the-fixnum r))))) + +(define (prim.div-rem-integer i1 i2) + (multiple-value-bind (q r) + (lisp:truncate (the-integer i1) (the-integer i2)) + (make-tuple (box (the-integer q)) (box (the-integer r))))) + +(define (prim.integer-to-int i) + (if (is-fixnum? i) + (the-fixnum i) + (haskell-runtime-error "Integer -> Int overflow."))) + +(define-syntax (prim.int-to-integer i) + i) + +;;; Binary + +(define prim.nullbin '()) + +(define (prim.is-null-bin x) + (null? x)) + +(define (prim.show-bin-int i b) + (cons i b)) + +(define (prim.show-bin-integer i b) + (cons i b)) + +(define (prim.show-bin-float f b) + (cons f b)) + +(define (prim.show-bin-double f b) + (cons f b)) + +(define (prim.bin-read-error) + (haskell-runtime-error "Error: attempt to read from an incompatible Bin.")) + +(define (prim.read-bin-int b) + (if (or (null? b) (not (is-fixnum? (car b)))) + (prim.bin-read-error) + (make-haskell-tuple2 (car b) (cdr b)))) + +(define (prim.read-bin-integer b) + (if (or (null? b) (not (is-integer? (car b)))) + (prim.bin-read-error) + (make-haskell-tuple2 (car b) (cdr b)))) + +(define (prim.read-bin-float b) + (if (or (null? b) (not (is-single-float? (car b)))) + (prim.bin-read-error) + (make-haskell-tuple2 (car b) (cdr b)))) + +(define (prim.read-bin-double b) + (if (or (null? b) (not (is-double-float? (car b)))) + (prim.bin-read-error) + (make-haskell-tuple2 (car b) (cdr b)))) + +(define (prim.read-bin-small-int b m) + (if (or (null? b) + (not (is-fixnum? (car b))) + (> (the-fixnum (car b)) (the-fixnum m))) + (prim.bin-read-error) + (make-haskell-tuple2 (car b) (cdr b)))) + +(define (prim.append-bin x y) + (append x y)) + + +;;; String primitives + +;;; Calls to prim.string-eq are generated by the CFN to pattern match +;;; against string constants. So normally one of the arguments will be +;;; a constant string. Treat this case specially to avoid consing up +;;; a haskell string whenever it's called. +;;; This function is strict in both its arguments. + +(define-syntax (prim.string-eq s1 s2) + (cond ((and (pair? s1) + (eq? (car s1) 'make-haskell-string)) + `(prim.string-eq-inline ,(cadr s1) 0 ,(string-length (cadr s1)) ,s2)) + ((and (pair? s2) + (eq? (car s2) 'make-haskell-string)) + `(prim.string-eq-inline ,(cadr s2) 0 ,(string-length (cadr s2)) ,s1)) + (else + `(prim.string-eq-notinline ,s1 ,s2)))) + +(define (prim.string-eq-inline lisp-string i n haskell-string) + (declare (type fixnum i n)) + (cond ((eqv? i n) + ;; Reached end of Lisp string constant -- better be at the end + ;; of the Haskell string, too. + (if (null? haskell-string) '#t '#f)) + ((null? haskell-string) + ;; The Haskell string is too short. + '#f) + ((eqv? (the fixnum (char->integer (string-ref lisp-string i))) + (the fixnum (force (car haskell-string)))) + ;; Next characters match, recurse + (prim.string-eq-inline + lisp-string (the fixnum (+ i 1)) n (force (cdr haskell-string)))) + (else + ;; No match + '#f))) + +(define (prim.string-eq-notinline s1 s2) + (cond ((null? s1) + ;; Reached end of first string. + (if (null? s2) '#t '#f)) + ((null? s2) + ;; Second string too short. + '#f) + ((eqv? (the fixnum (force (car s1))) (the fixnum (force (car s2)))) + (prim.string-eq-notinline (force (cdr s1)) (force (cdr s2)))) + (else + '#f))) + + +;;; List primitives + + +;;; The first argument is strict and the second is a delay. + +(define-syntax (prim.append l1 l2) + (cond ((and (pair? l1) + (eq? (car l1) 'make-haskell-string)) + `(make-haskell-string-tail ,(cadr l1) ,l2)) + ((equal? l1 ''()) + `(force ,l2)) + ((equal? l2 '(box '())) + l1) + ;; *** could also look for + ;; *** (append (cons x (box y)) z) => (cons x (box (append y z))) + ;; *** but I don't think this happens very often anyway + (else + `(prim.append-aux ,l1 ,l2)))) + +(define (prim.append-aux l1 l2) + (cond ((null? l1) + (force l2)) + ((and (forced? l2) (eq? (unbox l2) '())) + ;; Appending nil is identity. + l1) + ((forced? (cdr l1)) + ;; Append eagerly if the tail of the first list argument has + ;; already been forced. + (cons (car l1) + (if (null? (unbox (cdr l1))) + l2 ; don't force this!! + (box (prim.append-aux (unbox (cdr l1)) l2))))) + (else + (cons (car l1) (delay (prim.append-aux (force (cdr l1)) l2)))) + )) + + +;;; Both arguments are forced here. Have to be careful not to call +;;; recursively with an argument of 0. +;;; *** This is no longer used. + +(define (prim.take n l) + (declare (type fixnum n)) + (cond ((not (pair? l)) + '()) + ((eqv? n 1) + ;; Only one element to take. + (cons (car l) (box '()))) + ((forced? (cdr l)) + ;; Take eagerly if the tail of the list has already been forced. + (cons (car l) (box (prim.take (- n 1) (unbox (cdr l)))))) + (else + (cons (car l) (delay (prim.take (- n 1) (force (cdr l)))))) + )) + + +;;; The optimizer gets rid of all first-order calls to these functions. + +(define (prim.foldr k z l) + ;; k and z are nonstrict, l is strict + (if (null? l) + (force z) + (funcall (force k) + (car l) + (delay (prim.foldr k z (force (cdr l))))))) + +(define (prim.build g) + ;; g is strict + (funcall g + (box (function make-cons-constructor)) + (box '()))) diff --git a/runtime/runtime-utils.scm b/runtime/runtime-utils.scm new file mode 100644 index 0000000..f43c930 --- /dev/null +++ b/runtime/runtime-utils.scm @@ -0,0 +1,384 @@ +;;; runtime-utils.scm -- basic runtime support +;;; +;;; author : Sandra Loosemore +;;; date : 9 Jun 1992 +;;; +;;; This file contains definitions (beyond the normal mumble stuff) +;;; that is referenced directly in code built by the code generator. +;;; See backend/codegen.scm. +;;; + + + +;;; (delay form) +;;; returns a delay object with unevaluated "form". + +(define-syntax (delay form) + `(cons '#f (lambda () ,form))) + + +;;; (box form) +;;; returns a delay object with evaluated "form". + +(define-syntax (box form) + (cond ((number? form) + `(quote ,(cons '#t form))) + ((and (pair? form) (eq? (car form) 'quote)) + `(quote ,(cons '#t (cadr form)))) + (else + `(cons '#t ,form)))) + +(define-syntax (unbox form) + `(cdr ,form)) + +(define-syntax (forced? form) + `(car ,form)) + + +;;; (force delay) +;;; return the value of the delay object. + +(define (force delay-object) + (declare (type pair delay-object)) + (if (car delay-object) + (cdr delay-object) + (begin + (let ((result (funcall (cdr delay-object)))) + (setf (car delay-object) '#t) + (setf (cdr delay-object) result))))) + +;;; Inline version of the above. Not good to use everywhere because +;;; of code bloat problems, but handy for helper functions. + +(define-syntax (force-inline delay-object) + (let ((temp1 (gensym)) + (temp2 (gensym))) + `(let ((,temp1 ,delay-object)) + (declare (type pair ,temp1)) + (if (car ,temp1) + (cdr ,temp1) + (let ((,temp2 (funcall (cdr ,temp1)))) + (setf (car ,temp1) '#t) + (setf (cdr ,temp1) ,temp2)))))) + + +;;; (make-curried-fn opt-fn strictness) +;;; The basic idea is to compare the number of arguments received against +;;; the number expected. +;;; If the same, call the optimized entry point opt-fn. +;;; If more, apply the result of calling the optimized entry to the +;;; leftover arguments. +;;; If less, make a closure that accepts the additional arguments. + +(define (make-curried-fn opt-fn strictness) + (lambda args + (curried-fn-body '() args opt-fn strictness))) + +(define (curried-fn-body previous-args args opt-fn strictness) + (multiple-value-bind + (saturated? actual-args leftover-args leftover-strictness) + (process-curried-fn-args strictness args '()) + (setf actual-args (append previous-args actual-args)) + (if saturated? + (if (null? leftover-args) + (apply opt-fn actual-args) + (apply (apply opt-fn actual-args) leftover-args)) + (lambda more-args + (curried-fn-body actual-args more-args opt-fn leftover-strictness))) + )) + +(define (process-curried-fn-args strictness args actual-args) + (cond ((null? strictness) + ;; At least as many arguments as expected. + (values '#t (nreverse actual-args) args strictness)) + ((null? args) + ;; Not enough arguments supplied. + (values '#f (nreverse actual-args) args strictness)) + (else + ;; Process the next argument. + (if (car strictness) + (push (force-inline (car args)) actual-args) + (push (car args) actual-args)) + (process-curried-fn-args (cdr strictness) (cdr args) actual-args)) + )) + + +;;; Special cases of the above. + +(define (make-curried-fn-1-strict opt-fn) + (lambda (arg1 . moreargs) + (setf arg1 (force-inline arg1)) + (if (null? moreargs) + (funcall opt-fn arg1) + (apply (funcall opt-fn arg1) moreargs)))) + +(define (make-curried-fn-1-nonstrict opt-fn) + (lambda (arg1 . moreargs) + (if (null? moreargs) + (funcall opt-fn arg1) + (apply (funcall opt-fn arg1) moreargs)))) + + +;;; Here's a similar helper function used for making data constructors. + +(define (constructor-body previous-args args arity fn) + (declare (type fixnum arity)) + (let ((n (length args))) + (declare (type fixnum n)) + (setf args (append previous-args args)) + (cond ((eqv? n arity) + (apply fn args)) + ((< n arity) + (lambda more-args + (constructor-body args more-args (- arity n) fn))) + (else + (error "Too many arguments supplied to constructor."))))) + + +;;; Special case for cons constructor + +(define (make-cons-constructor . args) + (constructor-body '() args 2 (function cons))) + + +;;; (make-tuple-constructor arity) +;;; return a function that makes an untagged data structure with "arity" +;;; slots. "arity" is a constant. + +(define-integrable *max-predefined-tuple-arity* 10) + +(define (make-tuple-constructor-aux arity) + (cond ((eqv? arity 0) + ;; Actually, should never happen -- this is the unit constructor + 0) + ((eqv? arity 1) + (lambda args + (constructor-body '() args 2 (lambda (x) x)))) + ((eqv? arity 2) + (lambda args + (constructor-body '() args 2 (function cons)))) + (else + (lambda args + (constructor-body '() args arity (function vector)))))) + +(define *predefined-tuple-constructors* + (let ((result '())) + (dotimes (i *max-predefined-tuple-arity*) + (push (make-tuple-constructor-aux i) result)) + (list->vector (nreverse result)))) + +(define-syntax (make-tuple-constructor arity) + (declare (type fixnum arity)) + (if (< arity *max-predefined-tuple-arity*) + `(vector-ref *predefined-tuple-constructors* ,arity) + `(make-tuple-constructor-aux ,arity))) + + +;;; (make-tuple . args) +;;; uncurried version of the above + +(define-syntax (make-tuple . args) + (let ((arity (length args))) + (cond ((eqv? arity 0) + ;; Actually, should never happen -- this is the unit constructor + 0) + ((eqv? arity 1) + (car args)) + ((eqv? arity 2) + `(cons ,@args)) + (else + `(vector ,@args))))) + + +;;; (make-tagged-data-constructor n arity) +;;; return a function that makes a data structure with tag "n" and +;;; "arity" slots. + +(define-integrable *max-predefined-tagged-data-tag* 10) +(define-integrable *max-predefined-tagged-data-arity* 10) + +(define (make-tagged-data-constructor-aux n arity) + (if (eqv? arity 0) + (vector n) + (lambda args + (constructor-body (list n) args arity (function vector))))) + +(define *predefined-tagged-data-constructors* + (let ((result '())) + (dotimes (i *max-predefined-tagged-data-arity*) + (let ((inner-result '())) + (dotimes (j *max-predefined-tagged-data-tag*) + (push (make-tagged-data-constructor-aux j i) inner-result)) + (push (list->vector (nreverse inner-result)) result))) + (list->vector (nreverse result)))) + +(define-syntax (make-tagged-data-constructor n arity) + (declare (type fixnum arity n)) + (if (and (< arity *max-predefined-tagged-data-arity*) + (< n *max-predefined-tagged-data-tag*)) + `(vector-ref (vector-ref *predefined-tagged-data-constructors* ,arity) + ,n) + `(make-tagged-data-constructor-aux ,n ,arity))) + + +;;; (make-tagged-data n . args) +;;; uncurried version of the above + +(define-syntax (make-tagged-data n . args) + `(vector ,n ,@args)) + + +;;; (tuple-select arity i object) +;;; extract component "i" from untagged "object" + +(define-syntax (tuple-select arity i object) + (cond ((eqv? arity 1) + object) + ((eqv? arity 2) + (if (eqv? i 0) + `(car ,object) + `(cdr ,object))) + (else + `(vector-ref (the vector ,object) (the fixnum ,i))))) + + +;;; (tagged-data-select arity i object) +;;; extract component "i" from tagged "object" + +(define-syntax (tagged-data-select arity i object) + (declare (ignore arity)) + `(vector-ref (the vector ,object) (the fixnum ,(1+ i)))) + + +;;; (constructor-number object) +;;; return the tag from "object" + +(define-syntax (constructor-number object) + `(vector-ref (the vector ,object) 0)) + +(define-syntax (funcall-force fn . args) + (let* ((n (length args)) + (junk (assv n '((1 . funcall-force-1) + (2 . funcall-force-2) + (3 . funcall-force-3) + (4 . funcall-force-4))))) + `(,(if junk (cdr junk) 'funcall-force-n) ,fn ,@args))) + +(define (funcall-force-1 fn a1) + (funcall (force-inline fn) a1)) +(define (funcall-force-2 fn a1 a2) + (funcall (force-inline fn) a1 a2)) +(define (funcall-force-3 fn a1 a2 a3) + (funcall (force-inline fn) a1 a2 a3)) +(define (funcall-force-4 fn a1 a2 a3 a4) + (funcall (force-inline fn) a1 a2 a3 a4)) +(define-syntax (funcall-force-n fn . args) + `(funcall (force ,fn) ,@args)) + + +;;; (make-haskell-string string) +;;; Converts a Lisp string lazily to a boxed haskell string (makes +;;; a delay with a magic function). Returns an unboxed result. + +(define (make-haskell-string string) + (declare (type string string)) + (let ((index 1) + (size (string-length string))) + (declare (type fixnum index size)) + (cond ((eqv? size 0) + '()) + ((eqv? size 1) + (cons (box (char->integer (string-ref string 0))) + (box '()))) + (else + (letrec ((next-fn + (lambda () + (let ((ch (char->integer (string-ref string index)))) + (incf index) + (cons (box ch) + (if (eqv? index size) + (box '()) + (cons '#f next-fn))))))) + (cons (box (char->integer (string-ref string 0))) + (cons '#f next-fn)))) + ))) + + +;;; Similar, but accepts an arbitrary tail (which must be a delay object) + +(define (make-haskell-string-tail string tail-delay) + (declare (type string string)) + (let ((index 1) + (size (string-length string))) + (declare (type fixnum index size)) + (cond ((eqv? size 0) + (force-inline tail-delay)) + ((eqv? size 1) + (cons (box (char->integer (string-ref string 0))) + tail-delay)) + (else + (letrec ((next-fn + (lambda () + (let ((ch (char->integer (string-ref string index)))) + (incf index) + (cons (box ch) + (if (eqv? index size) + tail-delay + (cons '#f next-fn))))))) + (cons (box (char->integer (string-ref string 0))) + (cons '#f next-fn)))) + ))) + + +(define (haskell-string->string s) + (let ((length 0)) + (declare (type fixnum length)) + (do ((s s (force (cdr s)))) + ((null? s)) + (setf length (+ length 1))) + (let ((result (make-string length))) + (declare (type string result)) + (do ((s s (unbox (cdr s))) + (i 0 (+ i 1))) + ((null? s)) + (declare (type fixnum i)) + (setf (string-ref result i) (integer->char (force (car s))))) + result))) + + +(define (print-haskell-string s port) + (do ((s1 s (force (cdr s1)))) + ((null? s1)) + (write-char (integer->char (force (car s1))) port))) + +;;; This explicates the value returned by a proc (the IO () type). + +(define (insert-unit-value x) + (declare (ignore x)) + 0) + +;;; These handle list conversions + +(define (haskell-list->list fn l) + (if (null? l) + '() + (cons (funcall fn (force (car l))) + (haskell-list->list fn (force (cdr l)))))) + +(define (list->haskell-list fn l) + (if (null? l) + '() + (cons (box (funcall fn (car l))) + (box (list->haskell-list fn (cdr l)))))) + +(define (haskell-list->list/identity l) + (if (null? l) + '() + (cons (force (car l)) + (haskell-list->list/identity (force (cdr l)))))) + +(define (list->haskell-list/identity l) + (if (null? l) + '() + (cons (box (car l)) + (box (list->haskell-list/identity (cdr l)))))) diff --git a/runtime/runtime.scm b/runtime/runtime.scm new file mode 100644 index 0000000..bd5713e --- /dev/null +++ b/runtime/runtime.scm @@ -0,0 +1,26 @@ +;;; runtime.scm +;;; +;;; author : John +;;; + + +(define-compilation-unit runtime + (source-filename "$Y2/runtime/") + (require global) + (unit runtime-utils + (source-filename "runtime-utils.scm")) + (unit prims + (require runtime-utils) + (source-filename "prims.scm")) + (unit io-primitives + (require runtime-utils) + (source-filename "io-primitives.scm")) + (unit array-prims + (require runtime-utils) + (source-filename "array-prims.scm")) + (unit debug-utils + (require runtime-utils) + (source-filename "debug-utils.scm")) + (unit tuple-prims + (require runtime-utils) + (source-filename "tuple-prims.scm"))) diff --git a/runtime/tuple-prims.scm b/runtime/tuple-prims.scm new file mode 100644 index 0000000..6eb0cbf --- /dev/null +++ b/runtime/tuple-prims.scm @@ -0,0 +1,86 @@ +;; these primitives support arbitrary sized tuples. + +(define (prim.tupleSize x) + (vector-length x)) + +(define (prim.tupleSel tuple i n) + (force + (if (eqv? n 2) + (if (eqv? i 0) + (car tuple) + (cdr tuple)) + (vector-ref tuple i)))) + +(define (prim.list->tuple l) + (let ((l (haskell-list->list/non-strict l))) + (if (null? (cddr l)) + (cons (car l) (cadr l)) + (list->vector l)))) + +(define (haskell-list->list/non-strict l) + (if (null? l) + '() + (cons (car l) + (haskell-list->list/non-strict (force (cdr l)))))) + +(define (prim.dict-sel dicts i) + (force (vector-ref dicts i))) + +;;; These generate dictionaries. + +(define-local-syntax (create-dict dicts vars other-dicts) + `(let ((dict-vector (box (list->vector ,dicts)))) + (make-tuple + ,@(map (lambda (v) + `(delay (funcall (dynamic ,v) dict-vector))) + vars) + ,@(map (lambda (sd) + `(delay (,(car sd) + (map (lambda (d) + (tuple-select ,(cadr sd) ,(caddr sd) (force d))) + ,dicts)))) + other-dicts)))) + +(define prim.tupleEqdict + (lambda dicts + (tupleEqDict/l dicts))) + +(define (tupleEqDict/l dicts) + (create-dict dicts + (|PreludeTuple:tupleEq| |PreludeTuple:tupleNeq|) + ())) + +(define prim.tupleOrdDict + (lambda dicts + (tupleOrdDict/l dicts))) + +(define (tupleOrdDict/l d) + (create-dict d + (|PreludeTuple:tupleLe| |PreludeTuple:tupleLeq| + |PreludeTuple:tupleGe| |PreludeTuple:tupleGeq| + |PreludeTuple:tupleMax| |PreludeTuple:tupleMin|) + ((tupleEqDict/l 7 6)))) + +(define prim.tupleIxDict + (lambda dicts + (create-dict dicts + (|PreludeTuple:tupleRange| |PreludeTuple:tupleIndex| + |PreludeTuple:tupleInRange|) + ((tupleEqDict/l 6 3) (tupleTextDict/l 6 4) (tupleOrdDict/l 6 5))))) + +(define prim.tupleTextDict + (lambda dicts + (tupleTextDict/l dicts))) + +(define (tupleTextDict/l d) + (create-dict d + (|PreludeTuple:tupleReadsPrec| |PreludeTuple:tupleShowsPrec| + |PreludeTuple:tupleReadList| |PreludeTuple:tupleShowList|) + ())) + +(define prim.tupleBinaryDict + (lambda dicts + (create-dict dicts + (|PreludeTuple:tupleReadBin| |PreludeTuple:tupleShowBin|) + ()))) + diff --git a/support/README b/support/README new file mode 100644 index 0000000..6127bc6 --- /dev/null +++ b/support/README @@ -0,0 +1,4 @@ +This directory contains utilities that are layered on top of the basic +mumble support stuff. There should be no T-specific or CL-specific +code in this area. + diff --git a/support/compile.scm b/support/compile.scm new file mode 100644 index 0000000..77e222f --- /dev/null +++ b/support/compile.scm @@ -0,0 +1,447 @@ +;;; compile.scm -- compilation utilities +;;; +;;; author : Sandra Loosemore +;;; date : 24 Oct 1991 +;;; +;;; This file defines a makefile-like compilation system that supports +;;; a hierarchy of dependencies. +;;; The external entry points are define-compilation-unit, load-unit, and +;;; compile-and-load-unit. + + + +;;;===================================================================== +;;; Parsing +;;;===================================================================== + + +;;; Establish global defaults for filenames. + +(define compile.source-filename source-file-type) +(define compile.binary-filename binary-file-type) +(define compile.binary-subdir (string-append lisp-implementation-name "/")) +(define compile.delayed-loads '()) + + +;;; Top level units are stored in this table. +;;; This is really a slight wart on the whole scheme of things; this +;;; is done instead of storing the top-level units in variables because +;;; we were getting unintentional name collisions. + +(define compile.unit-table (make-table)) + +(define-syntax (compile.lookup-unit name) + `(table-entry compile.unit-table ,name)) + +(define (mung-global-units names lexical-units) + (map (lambda (n) + (if (memq n lexical-units) + n + `(compile.lookup-unit ',n))) + names)) + + +;;; Top-level compilation units are defined with define-compilation-unit. +;;; The body can consist of the following clauses: +;;; +;;; (source-filename <filename>) +;;; (binary-filename <filename>) +;;; Specify source and/or binary file names. For nested units, these +;;; are merged with defaults from outer units. If you don't specify +;;; an explicit binary filename, it's inherited from the source file +;;; name. +;;; (require ...) +;;; Specify compile/load dependencies. Arguments are names of other +;;; units/component files; these names have scoping like let*, so a unit +;;; can require previously listed units at the same or outer level. +;;; (unit name ....) +;;; Specifies a nested unit. This can appear multiple times. +;;; If a unit doesn't include any nested units, then it's a leaf +;;; consisting of a single source file. +;;; (load <boolean>) +;;; If supplied and false, the unit isn't loaded unless it is needed +;;; to satisfy a require clause. Used for files containing compilation +;;; support stuff. +;;; (compile <boolean>) +;;; If supplied and false, the unit isn't compiled. Only useful for +;;; leaf nodes. Typically used in combination with (load '#f) to suppress +;;; compilation of stuff only used at compile time. + +(define-syntax (define-compilation-unit name . clauses) + `(begin + (let ((unit ,(compile.process-unit-spec name clauses '#t '()))) + (setf (compile.lookup-unit ',name) unit) + (setf compilation-units (append compilation-units (list unit)))) + ',name)) + + +;;; The basic approach is to turn the compilation unit definition into +;;; a big LET*, and put calls to build the actual unit object inside +;;; of this. +;;; + +(define (compile.process-unit-spec name clauses top-level? lexical-units) + (multiple-value-bind + (source-filename binary-filename require nested-units + load? compile?) + (compile.parse-unit-spec clauses lexical-units) + `(let* ((compile.source-filename ,source-filename) + (compile.binary-filename ,binary-filename) + (compile.unit-require (list ,@require)) + (compile.delayed-loads (append compile.delayed-loads + (compile.select-delayed-loads + compile.unit-require))) + ,@nested-units) + (make compile.unit + (name ',name) + (source-filename compile.source-filename) + (binary-filename compile.binary-filename) + (components (list ,@(map (function car) nested-units))) + (require compile.unit-require) + (top-level? ',top-level?) + (load? ,load?) + (compile? ,compile?) + (delayed-loads compile.delayed-loads))))) + +(define (compile.parse-unit-spec clauses lexical-units) + (let ((source-filename '#f) + (binary-filename '#f) + (require '#f) + (nested-units '()) + (load? ''#t) + (compile? ''#t)) + (dolist (c clauses) + (cond ((not (pair? c)) + (compile.unit-syntax-error c)) + ((eq? (car c) 'source-filename) + (if source-filename + (compile.unit-duplicate-error c) + (setf source-filename (cadr c)))) + ((eq? (car c) 'binary-filename) + (if binary-filename + (compile.unit-duplicate-error c) + (setf binary-filename (cadr c)))) + ((eq? (car c) 'require) + (if require + (compile.unit-duplicate-error c) + (setf require (mung-global-units (cdr c) lexical-units)))) + ((eq? (car c) 'unit) + (push (list (cadr c) + (compile.process-unit-spec (cadr c) (cddr c) + '#f lexical-units)) + nested-units) + (push (cadr c) lexical-units)) + ((eq? (car c) 'load) + (setf load? (cadr c))) + ((eq? (car c) 'compile) + (setf compile? (cadr c))) + (else + (compile.unit-syntax-error c)))) + (values + (if source-filename + `(compile.merge-filenames ,source-filename + compile.source-filename '#f) + 'compile.source-filename) + (if binary-filename + `(compile.merge-filenames ,binary-filename + compile.binary-filename '#f) + (if source-filename + '(compile.merge-filenames compile.binary-filename + compile.source-filename + compile.binary-subdir) + 'compile.binary-filename)) + (or require '()) + (nreverse nested-units) + load? + compile?))) + + +(predefine (error format . args)) + +(define (compile.unit-syntax-error c) + (error "Invalid compilation unit clause ~s." c)) + +(define (compile.unit-duplicate-error c) + (error "Duplicate compilation unit clause ~s." c)) + + + +;;;===================================================================== +;;; Representation and utilities +;;;===================================================================== + +;;; Here are constructors and accessors for unit objects. +;;; Implementationally, the compilation unit has the following slots: +;;; +;;; * The unit name. +;;; * The source file name. +;;; * The binary file name. +;;; * A list of component file/units. +;;; * A list of units/files to require. +;;; * A load timestamp. +;;; * A timestamp to keep track of the newest source file. +;;; * Flags for compile and load. + +(define-struct compile.unit + (predicate compile.unit?) + (slots + (name (type symbol)) + (source-filename (type string)) + (binary-filename (type string)) + (components (type list)) + (require (type list)) + (top-level? (type bool)) + (load? (type bool)) + (compile? (type bool)) + (delayed-loads (type list)) + (load-time (type (maybe integer)) (default '#f)) + (source-time (type (maybe integer)) (default '#f)) + (last-update (type (maybe integer)) (default 0)) + )) + +(define (compile.newer? t1 t2) + (and t1 + t2 + (> t1 t2))) + +(define (compile.select-newest t1 t2) + (if (compile.newer? t1 t2) t1 t2)) + +(define (compile.get-source-time u) + (let ((source-file (compile.unit-source-filename u))) + (if (file-exists? source-file) + (file-write-date source-file) + '#f))) + +(define (compile.get-binary-time u) + (let ((binary-file (compile.unit-binary-filename u))) + (if (file-exists? binary-file) + (file-write-date binary-file) + '#f))) + +(define (compile.load-source u) + (load (compile.unit-source-filename u)) + (setf (compile.unit-load-time u) (current-date))) + +(define (compile.load-binary u) + (load (compile.unit-binary-filename u)) + (setf (compile.unit-load-time u) (current-date))) + +(define (compile.compile-and-load u) + (let ((source-file (compile.unit-source-filename u)) + (binary-file (compile.unit-binary-filename u))) + (compile-file source-file binary-file) + (load binary-file) + (setf (compile.unit-load-time u) (current-date)))) + +(define (compile.do-nothing u) + u) + + +;;;===================================================================== +;;; Runtime support for define-compilation-unit +;;;===================================================================== + +(define (compile.select-delayed-loads require) + (let ((result '())) + (dolist (r require) + (if (not (compile.unit-load? r)) + (push r result))) + (nreverse result))) + +(define (compile.merge-filenames fname1 fname2 add-subdir) + (let ((place1 (filename-place fname1)) + (name1 (filename-name fname1)) + (type1 (filename-type fname1))) + (assemble-filename + (if (string=? place1 "") + (if add-subdir + (string-append (filename-place fname2) add-subdir) + fname2) + place1) + (if (string=? name1 "") fname2 name1) + (if (string=? type1 "") fname2 type1)))) + + + +;;;===================================================================== +;;; Load operation +;;;===================================================================== + +;;; Load-unit and compile-and-load-unit are almost identical. The only +;;; difference is that load-unit will load source files as necessary, while +;;; compile-and-load-unit will compile them and load binaries instead. + +(define (load-unit u) + (compile.update-unit-source-times u '#f (current-date)) + (compile.load-unit-aux u)) + +(define (compile.load-unit-aux u) + (with-compilation-unit () + (compile.load-unit-recursive u '#f))) + +(define (compile-and-load-unit u) + (compile.update-unit-source-times u '#f (current-date)) + (compile.compile-and-load-unit-aux u)) + +(define (compile.compile-and-load-unit-aux u) + (with-compilation-unit () + (compile.load-unit-recursive u '#t))) + + +;;; Load a bunch of compilation units as a group. This is useful because +;;; it can prevent repeated lookups of file timestamps. Basically, the +;;; assumption is that none of the source files will change while the loading +;;; is in progress. +;;; In case of an error, store the units left to be compiled in a global +;;; variable. + +(define remaining-units '()) + +(define (load-unit-list l) + (let ((timestamp (current-date))) + (dolist (u l) + (compile.update-unit-source-times u '#f timestamp)) + (setf remaining-units l) + (dolist (u l) + (compile.load-unit-aux u) + (pop remaining-units)))) + +(define (compile-and-load-unit-list l) + (let ((timestamp (current-date))) + (dolist (u l) + (compile.update-unit-source-times u '#f timestamp)) + (setf remaining-units l) + (dolist (u l) + (compile.compile-and-load-unit-aux u) + (pop remaining-units)))) + + +;;; Walk the compilation unit, updating the source timestamps. + +(define (compile.update-unit-source-times u newest-require timestamp) + (unless (eqv? timestamp (compile.unit-last-update u)) + (setf (compile.unit-last-update u) timestamp) + (dolist (r (compile.unit-require u)) + (if (compile.unit-top-level? r) + (compile.update-unit-source-times r '#f timestamp)) + (setf newest-require + (compile.select-newest newest-require + (compile.unit-source-time r)))) + (let ((components (compile.unit-components u))) + (if (not (null? components)) + (let ((source-time newest-require)) + (dolist (c components) + (compile.update-unit-source-times c newest-require timestamp) + (setf source-time + (compile.select-newest source-time + (compile.unit-source-time c)))) + (setf (compile.unit-source-time u) source-time)) + (setf (compile.unit-source-time u) + (compile.select-newest + newest-require + (compile.get-source-time u))))))) + + +;;; Load a compilation unit. Do this by first loading its require list, +;;; then by recursively loading each of its components, in sequence. +;;; Note that because of the way scoping of units works and the +;;; sequential nature of the load operation, only top-level +;;; units in the require list have to be loaded explicitly. + +(define (compile.load-unit-recursive u compile?) + (let ((components (compile.unit-components u))) + ;; First recursively load dependencies. + ;; No need to update time stamps again here. + (dolist (r (compile.unit-require u)) + (if (compile.unit-top-level? r) + (compile.load-unit-aux r))) + (if (not (null? components)) + ;; Now recursively load subunits. + (dolist (c components) + (unless (not (compile.unit-load? c)) + (compile.load-unit-recursive c compile?))) + ;; For a leaf node, load either source or binary if necessary. + (let ((source-time (compile.unit-source-time u)) + (binary-time (compile.get-binary-time u)) + (load-time (compile.unit-load-time u))) + (cond ((compile.newer? load-time source-time) + ;; The module has been loaded since it was last changed, + ;; but maybe we want to compile it now. + (if (and compile? + (compile.unit-compile? u) + (compile.newer? source-time binary-time)) + (begin + (compile.do-delayed-loads + (compile.unit-delayed-loads u) + compile?) + (compile.compile-and-load u)) + (compile.do-nothing u))) + ((compile.newer? binary-time source-time) + ;; The binary is up-to-date, so load it. + (compile.load-binary u)) + (else + ;; The binary is out-of-date, so either load source or + ;; recompile the binary. + (compile.do-delayed-loads + (compile.unit-delayed-loads u) + compile?) + (if (and compile? (compile.unit-compile? u)) + (compile.compile-and-load u) + (compile.load-source u))) + ))))) + + +(define (compile.do-delayed-loads units compile?) + (dolist (u units) + (compile.load-unit-recursive u compile?))) + + + + +;;;===================================================================== +;;; Extra stuff +;;;===================================================================== + + +;;; Reload a unit without testing to see if any of its dependencies are +;;; out of date. + +(define (reload-unit-source u) + (let ((components (compile.unit-components u))) + (if (not (null? components)) + (dolist (c components) + (reload-unit-source c)) + (compile.load-source u)))) + +(define (reload-unit-binary u) + (let ((components (compile.unit-components u))) + (if (not (null? components)) + (dolist (c components) + (reload-unit-binary c)) + (compile.load-binary u)))) + + +;;; Find a (not necessarily top-level) compilation unit with the given +;;; name. + +(define (find-unit name) + (compile.find-unit-aux name compilation-units)) + +(define (compile.find-unit-aux name units) + (block find-unit-aux + (dolist (u units '#f) + (if (eq? name (compile.unit-name u)) + (return-from find-unit-aux u) + (let* ((components (compile.unit-components u)) + (result (compile.find-unit-aux name components))) + (if result + (return-from find-unit-aux result))))))) + + +;;; Combine the two above: reload a compilation unit. + +(define-syntax (reload name) + `(reload-unit-source + (or (find-unit ',name) + (error "Couldn't find unit named ~s." ',name)))) diff --git a/support/format.scm b/support/format.scm new file mode 100644 index 0000000..c9dbb38 --- /dev/null +++ b/support/format.scm @@ -0,0 +1,683 @@ +;;; format.scm -- format function for Scheme +;;; +;;; author : Sandra Loosemore +;;; date : 29 Oct 1991 +;;; +;;; +;;; This code is adapted from the XP pretty printer originally written +;;; in Common Lisp by Dick Waters. Here is the copyright notice attached +;;; to the original XP source file: +;;; +;;;------------------------------------------------------------------------ +;;; +;;; Copyright 1989,1990 by the Massachusetts Institute of Technology, +;;; Cambridge, Massachusetts. +;;; +;;; Permission to use, copy, modify, and distribute this software and its +;;; documentation for any purpose and without fee is hereby granted, +;;; provided that this copyright and permission notice appear in all +;;; copies and supporting documentation, and that the name of M.I.T. not +;;; be used in advertising or publicity pertaining to distribution of the +;;; software without specific, written prior permission. M.I.T. makes no +;;; representations about the suitability of this software for any +;;; purpose. It is provided "as is" without express or implied warranty. +;;; +;;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +;;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +;;; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +;;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +;;; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +;;; SOFTWARE. +;;; +;;;------------------------------------------------------------------------ +;;; + + +;;; The stream argument can be #f, in which case a string is returned. +;;; If the stream is #t, (current-output-port) is used. +;;; We compile a string argument into a function and call the function. +;;; The only exception is if the string doesn't contain any ~ escapes; +;;; then we can treat it as a literal and just write it to the stream. + +(define (format stream string-or-fn . args) + (cond ((not stream) + (call-with-output-string + (lambda (stream) + (apply (function format) stream string-or-fn args)))) + (else + (if (eq? stream '#t) + (setf stream (current-output-port))) + (when (string? string-or-fn) + (setf string-or-fn (xp.process-format-string string-or-fn))) + (if (string? string-or-fn) + (write-string string-or-fn stream) + (xp.maybe-initiate-xp-printing string-or-fn stream args)) + '#f))) + +(define xp.format-string-cache (make-table)) + +(define (xp.process-format-string string-or-fn) + (cond ((not (string? string-or-fn)) string-or-fn) + ((not xp.format-string-cache) + (xp.maybe-compile-format-string string-or-fn)) + (else + (when (not (table? xp.format-string-cache)) + (setf xp.format-string-cache (make-table))) + (let ((value + (table-entry xp.format-string-cache string-or-fn))) + (when (not value) + (setf value (xp.maybe-compile-format-string string-or-fn)) + (setf (table-entry xp.format-string-cache string-or-fn) + value)) + value)))) + + +(define (xp.maybe-compile-format-string string) + (let ((length (string-length string))) + (or (xp.simple-format-string? string 0 length) + (let ((fn (xp.parse-format-string string 0 length))) + (lambda (xp args) + (funcall fn xp args args)))))) + + +;;; Try to detect format strings without fancy directives, that can be +;;; written with a call to write-string. +;;; Can do simple transformations e.g. ~% => newline, ~~ => ~, etc. + +(define (xp.simple-format-string? s start end) + (let ((twiddle (string-position #\~ s start end))) + (if (not twiddle) + (if (eqv? start 0) + s + (substring s start end)) + (let ((char (string-ref s (1+ twiddle)))) + (cond ((eqv? char #\%) + (let ((tail (xp.simple-format-string? s (+ twiddle 2) end))) + (if tail + (string-append (substring s start twiddle) + (string #\newline) + tail) + '#f))) + ((eqv? char #\~) + (let ((tail (xp.simple-format-string? s (+ twiddle 2) end))) + (if tail + (string-append (substring s start (1+ twiddle)) + tail) + '#f))) + ((eqv? char #\newline) + (let ((tail (xp.simple-format-string? + s + (xp.skip-whitespace s (+ twiddle 2) end) + end))) + (if tail + (string-append (substring s start twiddle) + tail) + '#f))) + (else + '#f)))))) + +(define (warning string-or-fn . args) + (internal-warning (apply (function format) '#f string-or-fn args))) + +(define (error string-or-fn . args) + (internal-error (apply (function format) '#f string-or-fn args))) + + +;;;===================================================================== +;;; Compiled format +;;;===================================================================== + +;;; Note that compiled format strings always print through xp streams even if +;;; they don't have any xp directives in them. As a result, the compiled code +;;; can depend on the fact that the stream being operated on is an xp +;;; stream not an ordinary one. + + +;;; Parse a format string, returning a function to do the printing. +;;; The function is called with three arguments +;;; * the xp stream +;;; * the original argument list +;;; * the argument list tail +;;; It should return the list of leftover, unprocessed arguments. + +(define (xp.parse-format-string string start end) + (cond ((eqv? start end) + (function xp.format-finish)) + ((eqv? (string-ref string start) #\~) + (xp.parse-format-string-dispatch string start end)) + (else + (let* ((next (or (string-position #\~ string start end) end)) + (literal (substring string start next)) + (count (- next start)) + (continue (xp.parse-format-string string next end)) + (newline? (string-position #\newline literal 0 count))) + (if newline? + (lambda (xp args tail) + (xp.write-string+ literal xp 0 count) + (funcall continue xp args tail)) + (lambda (xp args tail) + (xp.write-string++ literal xp 0 count) + (funcall continue xp args tail))))) + )) + +(define (xp.format-finish xp args tail) + (declare (ignore xp args)) + tail) + + +;;; Functions for handling individual format specifiers are installed +;;; in this table. They are called with these arguments: +;;; * the format string +;;; * the index of the next character +;;; * the index of the end of the format string +;;; * the list of parameters for the format specification +;;; * a boolean indicating whether the colon modifier was present +;;; * a boolean indicating whether the atsign modifier was present +;;; The handler is responsible for calling xp.parse-format-string to parse +;;; the rest of the format string, and returning a function. (This has +;;; to be done by the individual handlers because some of them need to +;;; scan the format string for matching delimiters, etc.) + +;;; *** This probably isn't right, we assume characters can be compared +;;; *** with EQ? and used as table keys. + +(define xp.fn-table (make-table)) + +(define (define-format char function) + (setf (table-entry xp.fn-table (char-upcase char)) function) + (setf (table-entry xp.fn-table (char-downcase char)) function)) + +;;; Parse a ~ sequence from the format string and dispatch to the +;;; appropriate handler. + +(define (xp.parse-format-string-dispatch string start end) + (multiple-value-bind (next params colon? atsign? char) + (xp.parse-format-descriptor string start end) + (let ((fn (table-entry xp.fn-table char))) + (if fn + (funcall fn string next end params colon? atsign?) + (error "Unrecognized format escape ~~~a." char))))) + +(define (xp.parse-format-descriptor string start end) + (multiple-value-bind (params start) + (xp.parse-format-parameters string start end) + (let ((colon? '#f) + (atsign? '#f) + (char '#f)) + (block parse-format-descriptor + (do () + ((xp.check-for-incomplete-format-string string start end)) + (setf char (string-ref string start)) + (incf start) + (cond ((eqv? char #\:) + (setf colon? '#t)) + ((eqv? char #\@) + (setf atsign? '#t)) + (else + (return-from parse-format-descriptor + (values start params colon? atsign? char))) + )))))) + + +;;; *** The stuff for V and # format parameters is disabled because +;;; *** it makes the handler functions hairier. It's rarely used anyway, +;;; *** and you can get the same effect by consing up a format string +;;; *** on the fly if you really need to. + +(define (xp.parse-format-parameters string start end) + (let ((params '()) + (char '#f)) + (incf start) ; skip ~ + (block parse-format-parameters + (do () + ((xp.check-for-incomplete-format-string string start end)) + (setf char (string-ref string start)) + (cond ((char-numeric? char) + (multiple-value-bind (next value) + (xp.parse-format-number string start end 0) + (setf start next) + (push value params))) + ((eqv? char #\') + (push (string-ref string (1+ start)) params) + (setf start (+ start 2))) + ((or (eqv? char #\v) (eqv? char #\V)) + (error "V format parameter not supported.") ;*** + (push 'value params) + (setf start (+ start 1))) + ((eqv? char #\#) + (error "# format parameter not supported.") ;*** + (push 'count params) + (setf start (+ start 1))) + ((eqv? char #\,) + (push '#f params)) + (else + (return-from parse-format-parameters + (values (nreverse params) start)))) + (if (eqv? (string-ref string start) #\,) + (incf start)))))) + +(define (xp.parse-format-number string start end value) + (xp.check-for-incomplete-format-string string start end) + (let* ((char (string-ref string start)) + (weight (string-position char "0123456789" 0 10))) + (if weight + (xp.parse-format-number string (1+ start) end (+ (* value 10) weight)) + (values start value)))) + +(define (xp.check-for-incomplete-format-string string start end) + (if (eqv? start end) + (error "Incomplete format string ~s." string) + '#f)) + + +;;; *** All of these format handlers probably ought to do more checking +;;; *** for the right number of parameters and not having colon? and +;;; *** atsign? supplied when they are not allowed. + +;;; ~A and ~S are the basic format directives. + +(define (xp.format-a string start end params colon? atsign?) + (xp.format-a-s-helper string start end params colon? atsign? '#f)) +(define-format #\a (function xp.format-a)) + +(define (xp.format-s string start end params colon? atsign?) + (xp.format-a-s-helper string start end params colon? atsign? '#t)) +(define-format #\s (function xp.format-s)) + +(define (xp.format-a-s-helper string start end params colon? atsign? escape?) + (declare (ignore colon? atsign?)) ;*** + (let ((continuation (xp.parse-format-string string start end))) + (if (null? params) + ;; Do the simple, common case. + (lambda (xp args tail) + (dynamic-let ((*print-escape* escape?)) + (xp.write+ (car tail) xp)) + (funcall continuation xp args (cdr tail))) + ;; Do the hard case. + (let* ((mincol (or (and (not (null? params)) (pop params)) 0)) + (colinc (or (and (not (null? params)) (pop params)) 1)) + (minpad (or (and (not (null? params)) (pop params)) 0)) + (padchar (or (and (not (null? params)) (pop params)) #\space))) + (declare (ignore mincol colinc minpad padchar)) ;*** +;;; *** I'm confused. It seems like we have to print this to a string +;;; *** and then write the string to the XP stream along with the padding +;;; *** But won't switching to a new stream mess up circularity detection, +;;; *** indentation, etc? + (error "Unimplemented format option ~s!" string)) + ))) + + +;;; ~W -> write + +(define (xp.format-w string start end params colon? atsign?) + (declare (ignore params)) + (let ((continuation (xp.parse-format-string string start end))) + (cond ((and (not colon?) (not atsign?)) + (lambda (xp args tail) + (xp.write+ (car tail) xp) + (funcall continuation xp args (cdr tail)))) + ((and colon? (not atsign?)) + (lambda (xp args tail) + (dynamic-let ((*print-pretty* '#t)) + (xp.write+ (car tail) xp)) + (funcall continuation xp args (cdr tail)))) + ((and (not colon?) atsign?) + (lambda (xp args tail) + (dynamic-let ((*print-level* '#f) + (*print-length* '#f)) + (xp.write+ (car tail) xp)) + (funcall continuation xp args (cdr tail)))) + ((and colon? atsign?) + (lambda (xp args tail) + (dynamic-let ((*print-level* '#f) + (*print-length* '#f) + (*print-pretty* '#t)) + (xp.write+ (car tail) xp)) + (funcall continuation xp args (cdr tail)))) + ))) +(define-format #\w (function xp.format-w)) + + +;;; Here are the directives for printing integers, ~D and friends. + +(define (xp.format-d string start end params colon? atsign?) + (xp.format-d-b-o-x-helper string start end params colon? atsign? 10)) +(define-format #\d (function xp.format-d)) + +(define (xp.format-b string start end params colon? atsign?) + (xp.format-d-b-o-x-helper string start end params colon? atsign? 2)) +(define-format #\b (function xp.format-b)) + +(define (xp.format-o string start end params colon? atsign?) + (xp.format-d-b-o-x-helper string start end params colon? atsign? 8)) +(define-format #\o (function xp.format-o)) + +(define (xp.format-x string start end params colon? atsign?) + (xp.format-d-b-o-x-helper string start end params colon? atsign? 16)) +(define-format #\x (function xp.format-x)) + +(define (xp.format-d-b-o-x-helper string start end params colon? atsign? radix) + (let ((continuation (xp.parse-format-string string start end))) + (if (and (null? params) (not colon?) (not atsign?)) + ;; Do the simple, common case. + (lambda (xp args tail) + (dynamic-let ((*print-escape* '#f) + (*print-radix* '#f) + (*print-base* radix)) + (xp.write+ (car tail) xp)) + (funcall continuation xp args (cdr tail))) + ;; Do the hard case. + (let* ((mincol (or (and (not (null? params)) (pop params)) 0)) + (padchar (or (and (not (null? params)) (pop params)) #\space)) + (commachar (or (and (not (null? params)) (pop params)) #\,)) + (commaint (or (and (not (null? params)) (pop params)) 3))) + (declare (ignore mincol padchar commachar commaint)) ;*** + ;; *** I'm too lazy to do this right now. + (error "Unimplemented format option ~s!" string))))) + + +(define (xp.format-r string start end params colon? atsign?) + (if (not (null? params)) + (xp.format-d-b-o-x-helper string start end (cdr params) + colon? atsign? (car params)) + ;; *** The colon? and atsign? modifiers do weird things like + ;; *** printing roman numerals. I'm too lazy to do this until/unless + ;; *** we have a real need for it. + (error "Unimplemented format option ~s!" string))) +(define-format #\r (function xp.format-r)) + + +;;; ~P -> plurals + +(define (xp.format-p string start end params colon? atsign?) + (declare (ignore params)) + (let ((continuation (xp.parse-format-string string start end))) + (cond ((and (not colon?) (not atsign?)) + (lambda (xp args tail) + (if (not (eqv? (car tail) 1)) + (xp.write-char++ #\s xp)) + (funcall continuation xp args (cdr tail)))) + ((and colon? (not atsign?)) + (lambda (xp args tail) + (setf tail (xp.back-up 1 args tail)) + (if (not (eqv? (car tail) 1)) + (xp.write-char++ #\s xp)) + (funcall continuation xp args (cdr tail)))) + ((and (not colon?) atsign?) + (lambda (xp args tail) + (if (eqv? (car tail) 1) + (xp.write-char++ #\y xp) + (begin + (xp.write-char++ #\i xp) + (xp.write-char++ #\e xp) + (xp.write-char++ #\s xp))) + (funcall continuation xp args (cdr tail)))) + ((and colon? atsign?) + (lambda (xp args tail) + (setf tail (xp.back-up 1 args tail)) + (if (eqv? (car tail) 1) + (xp.write-char++ #\y xp) + (begin + (xp.write-char++ #\i xp) + (xp.write-char++ #\e xp) + (xp.write-char++ #\s xp))) + (funcall continuation xp args (cdr tail))))))) +(define-format #\p (function xp.format-p)) + + +;;; ~C -> character + +(define (xp.format-c string start end params colon? atsign?) + (declare (ignore params)) + (let ((continuation (xp.parse-format-string string start end))) + (cond ((and (not colon?) (not atsign?)) + (lambda (xp args tail) + (xp.write-char++ (car tail) xp) + (funcall continuation xp args (cdr tail)))) + ((and (not colon?) atsign?) + (lambda (xp args tail) + (dynamic-let ((*print-escape* '#t)) + (xp.write+ (car tail) xp) + (funcall continuation xp args (cdr tail))))) + (else + ;; *** I don't know how to get at the character names. + (error "Unimplemented format option ~s!" string))))) +(define-format #\c (function xp.format-c)) + + + +;;; Newline directives, ~% and ~& + +(define (xp.format-percent string start end params colon? atsign?) + (xp.format-newline-helper string start end params colon? atsign? + 'unconditional)) +(define-format #\% (function xp.format-percent)) + +(define (xp.format-ampersand string start end params colon? atsign?) + (xp.format-newline-helper string start end params colon? atsign? + 'fresh)) +(define-format #\& (function xp.format-ampersand)) + +(define (xp.format-newline-helper string start end params colon? atsign? kind) + (declare (ignore colon? atsign?)) + (let ((continuation (xp.parse-format-string string start end)) + (n (or (and (not (null? params)) (pop params)) 1))) + (if (eqv? n 1) + (lambda (xp args tail) + (xp.pprint-newline+ kind xp) + (funcall continuation xp args tail)) + (lambda (xp args tail) + (xp.pprint-newline+ kind xp) + (dotimes (i (1- n)) + (xp.pprint-newline+ 'unconditional xp)) + (funcall continuation xp args tail)) + ))) + + +;;; ~_, Conditional newline + +(define (xp.format-underbar string start end params colon? atsign?) + (declare (ignore params)) + (let ((continuation (xp.parse-format-string string start end)) + (kind (if colon? + (if atsign? 'mandatory 'fill) + (if atsign? 'miser 'linear)))) + (lambda (xp args tail) + (xp.pprint-newline+ kind xp) + (funcall continuation xp args tail)))) +(define-format #\_ (function xp.format-underbar)) + + +;;; Random character printing directives, ~| and ~~ + +;;; *** commented out because #\page is not standard scheme +; (define (xp.format-bar string start end params colon? atsign?) +; (xp.format-char-helper string start end params colon? atsign? #\page)) +; (define-format #\| (function xp.format-bar)) + +(define (xp.format-twiddle string start end params colon? atsign?) + (xp.format-char-helper string start end params colon? atsign? #\~)) +(define-format #\~ (function xp.format-twiddle)) + +(define (xp.format-char-helper string start end params colon? atsign? char) + (declare (ignore colon? atsign?)) + (let ((continuation (xp.parse-format-string string start end)) + (n (or (and (not (null? params)) (pop params)) 1))) + (if (eqv? n 1) + (lambda (xp args tail) + (xp.write-char++ char xp) + (funcall continuation xp args tail)) + (lambda (xp args tail) + (dotimes (i n) + (xp.write-char++ char xp)) + (funcall continuation xp args tail))))) + + + +;;; ~<newline> directive (ignore whitespace in format string) + +(define (xp.format-newline string start end params colon? atsign?) + (declare (ignore params)) + (let ((newline? '#f) + (skip? '#f)) + (cond ((and (not colon?) (not atsign?)) ; skip both newline and whitespace + (setf skip? '#t)) + ((and colon? (not atsign?))) ; skip newline, leave whitespace + ((and (not colon?) atsign?) ; do newline, skip whitespace + (setf newline? '#t) + (setf skip? '#t)) + (else + (error "~:@<newline> not allowed."))) + (if skip? + (setf start (xp.skip-whitespace string start end))) + (let ((continuation (xp.parse-format-string string start end))) + (if newline? + (lambda (xp args tail) + (xp.pprint-newline+ 'unconditional xp) + (funcall continuation xp args tail)) + continuation)))) +(define-format #\newline (function xp.format-newline)) + +(define (xp.skip-whitespace string start end) + (if (eqv? start end) + start + (let ((char (string-ref string start))) + (if (and (char-whitespace? char) + (not (eqv? char #\newline))) + (xp.skip-whitespace string (1+ start) end) + start)))) + + + +;;; ~T -> tab + +(define (xp.format-t string start end params colon? atsign?) + (let* ((continuation (xp.parse-format-string string start end)) + (colnum (or (and (not (null? params)) (pop params)) 1)) + (colinc (or (and (not (null? params)) (pop params)) 1)) + (kind (if colon? + (if atsign? 'section-relative 'section) + (if atsign? 'line-relative 'line)))) + (lambda (xp args tail) + (xp.pprint-tab+ kind colnum colinc xp) + (funcall continuation xp args tail)))) +(define-format #\t (function xp.format-t)) + + +;;; ~I -> indent + +(define (xp.format-i string start end params colon? atsign?) + (declare (ignore atsign?)) + (let ((continuation (xp.parse-format-string string start end)) + (kind (if colon? 'current 'block)) + (n (or (and (not (null? params)) (pop params)) 0))) + (lambda (xp args tail) + (pprint-indent kind n) + (funcall continuation xp args tail)))) +(define-format #\i (function xp.format-i)) + + +;;; ~* -> skip or back up over arguments + +(define (xp.format-star string start end params colon? atsign?) + (let ((continuation (xp.parse-format-string string start end)) + (n (or (and (not (null? params)) (pop params)) 1))) + (cond ((and (not colon?) (not atsign?)) + (lambda (xp args tail) + (funcall continuation xp args (list-tail tail n)))) + ((and colon? (not atsign?)) + (lambda (xp args tail) + (funcall continuation xp args (xp.back-up n args tail)))) + ((and (not colon?) atsign?) + (lambda (xp args tail) + (declare (ignore tail)) + (funcall continuation xp args (list-tail args n)))) + (else + (error "~:@* not allowed."))))) +(define-format #\* (function xp.format-star)) + +(define (xp.back-up n head tail) + (if (eq? (list-tail head n) tail) + head + (xp.back-up n (cdr head) tail))) + + +;;; ~? -> indirection +;;; Normally uses two arguments, a string and a list. +;;; With @, only uses a string, takes arguments from the tail. + +(define (xp.format-question string start end params colon? atsign?) + (declare (ignore params colon?)) + (let ((continuation (xp.parse-format-string string start end))) + (if atsign? + (lambda (xp args tail) + (setf tail (apply (function format) xp (car tail) (cdr tail))) + (funcall continuation xp args tail)) + (lambda (xp args tail) + (apply (function format) xp (car tail) (cadr tail)) + (funcall continuation xp args (cddr tail)))))) +(define-format #\? (function xp.format-question)) + + +;;; ~(...~) -> case conversion. + +(define *xp.format-paren-next* '#f) + +(define (xp.format-paren string start end params colon? atsign?) + (declare (ignore params)) + (let* ((handler (dynamic-let ((*xp.format-paren-next* '#t)) + (let ((result (xp.parse-format-string + string start end))) + (if (eq? (dynamic *xp.format-paren-next*) '#t) + (error "~( directive has no matching ~).")) + (setf start (dynamic *xp.format-paren-next*)) + result))) + (continuation (xp.parse-format-string string start end)) + (mode (if colon? + (if atsign? 'up 'cap1) + (if atsign? 'cap0 'down)))) + (lambda (xp args tail) + (xp.push-char-mode xp mode) + (setf tail (funcall handler xp args tail)) + (xp.pop-char-mode xp) + (funcall continuation xp args tail)))) +(define-format #\( (function xp.format-paren)) + +(define (xp.format-paren-end string start end params colon? atsign?) + (declare (ignore string end params colon? atsign?)) + (if (not (dynamic *xp.format-paren-next*)) + (error "~) directive has no matching ~(.")) + (setf (dynamic *xp.format-paren-next*) start) + (function xp.format-finish)) +(define-format #\) (function xp.format-paren-end)) + +;;; ~F -> fixed-width *** unimplemented +;;; ~E -> e-notation *** unimplemented +;;; ~G -> general float *** unimplemented +;;; ~$ -> dollars float *** unimplemented +;;; ~[...~] -> conditional *** unimplemented +;;; ~{...~} -> iteration *** unimplemented +;;; ~<...~> -> justification *** unimplemented +;;; ~; -> clause seperator *** unimplemented +;;; ~^ -> up and out *** unimplemented +;;; ~/.../ -> hook *** unimplemented + +(define (xp.unimplemented-format string start end params colon? atsign?) + (declare (ignore start end params colon? atsign?)) + (error "Unimplemented format directive in ~s." string)) + +(define-format #\f (function xp.unimplemented-format)) +(define-format #\e (function xp.unimplemented-format)) +(define-format #\g (function xp.unimplemented-format)) +(define-format #\$ (function xp.unimplemented-format)) +(define-format #\[ (function xp.unimplemented-format)) +(define-format #\] (function xp.unimplemented-format)) +(define-format #\{ (function xp.unimplemented-format)) +(define-format #\} (function xp.unimplemented-format)) +(define-format #\< (function xp.unimplemented-format)) +(define-format #\> (function xp.unimplemented-format)) +(define-format #\; (function xp.unimplemented-format)) +(define-format #\^ (function xp.unimplemented-format)) +(define-format #\/ (function xp.unimplemented-format)) + diff --git a/support/mumble.txt b/support/mumble.txt new file mode 100644 index 0000000..0ca2f40 --- /dev/null +++ b/support/mumble.txt @@ -0,0 +1,840 @@ +Syntax +------ + +(quote x) + +(function name) + You must use this to reference a global function, as in CL. (There + isn't a local function namespace.) + +(lambda lambda-list . body) + Equivalent to #'(lambda ...) in Common Lisp. + The lambda-list can be dotted, as in Scheme. CL lambda-list keywords + are not supported. + +function call + Order of evaluation is unspecified, as in Scheme. + You have to use FUNCALL if the function is bound with let. + +(funcall function . args) + As in Common Lisp, but might be a macro. (The function is guaranteed + to be a true function, not a symbol.) + +(apply procedure . args) + As in Common Lisp/Scheme. + +(map procedure . lists) + As in Scheme. Equivalent to MAPCAR in CL. + +(for-each procedure . lists) + As in Scheme. Equivalent to MAPC in CL. + +(every procedure . lists) +(some procedure . lists) +(notany procedure . lists) +(notevery procedure . lists) + As in CL, but only work on lists. + +(procedure? object) + As in Scheme, but can return an arbitrary truth value instead of just #t. + Note that we never use symbols or quoted lambda expressions as functions. + +(if test then . maybe-else) +(when test . body) +(unless test . body) + +(cond . tests) + As in Scheme, but the = syntax isn't supported. When no test is true, the + result is undefined. + +(case value . cases) + As in Scheme. + Stylistically, use this only when the case labels are symbols. + +(and . expressions) +(or . expressions) + +(not value) + As in Scheme but can return an arbitrary truth value instead of #t. + +(set! variable value) + As in Scheme; this doesn't return a useful value. Use setf instead. + +(setf place value) + Similar to SETF in Common Lisp. Returns value. + See define-setf below. Places that are macro calls are expanded + if they don't have their own setter. + Here is a list of the built-in setters: + dynamic + car + cdr + list-ref + string-ref + vector-ref + table-entry + +(let bindings . body) +(let* bindings . body) +(letrec bindings . body) + Note that each binding clause must be a list of the form (var init); + you can't just supply var or (var) as in Common Lisp. Also remember + that the order of evaluation for the init-forms is not specified for + let/letrec. + The Scheme named LET construct is not supported. + +(flet bindings . body) +(labels bindings . body) + As in Common Lisp. + +(dynamic-let bindings . body) +(dynamic name) + As in Eulisp. Dynamic-let is equivalent to bind in T, or LET in + Common Lisp with all of the variables declared special. As a matter + of style, use dynamic to reference the value rather than just the name. + +(begin . body) + Like PROGN in Common Lisp. + +(block name . body) +(return-from name result) + The intersection of the Eulisp and Common Lisp definitions. The "name" + may be bound as a lexical variable, but you should only refer to it + inside a return-from. + Don't depend on named functions (etc) establishing implicit blocks, + as they do in CL. + +(do bindings-and-steppers (end-test . results) . body) + As in Scheme. It doesn't necessarily establish an implicit BLOCK + as in CL so you can't RETURN from the loop. + +(dolist (variable init . maybe-result) . body) +(dotimes (variable init . maybe-result) . body) + As in CL, except you can't RETURN from the loop. + +(values . values) +(multiple-value-bind variables values-expression . body) + As in Common Lisp, except that the values-expression must explicitly + return multiple values. + +(let/cc variable . body) + As in EuLisp. This is the same as catch in T. The continuation + has dynamic extent within the body. + You call the continuation with an arbitrary number of arguments, which + are the multiple values to be returned. + +(unwind-protect protected-form . body) + +(declare ...) + Similar to Common Lisp declare. Declarations are allowed only in the + standard places that Common Lisp permits (in particular, at the + beginning of binding forms). For now, only the following declarations + are permitted: + + (ignore . variables) + (ignorable . variables) + (type type-spec . variables) -- see info on type-specs below. + + + + +Definitions +----------- + +(define pattern . value) + As in Scheme. + +(define-integrable pattern . value) + Like DEFINE, but also tells the compiler to try to inline the value. + +(define-syntax (name . lambda-list) . body) + Similar to the equivalent T functionality. The lambda-list does not + support destructuring, as does Common Lisp's DEFMACRO. + The macro definition is made both when the file is loaded and when it + is compiled. + +(define-local-syntax (name . lambda-list) . body) + Again, similar to the T functionality. In Common Lisp, equivalent to + a DEFMACRO wrapped in (eval-when (compile) ...). + +(define-setf getter-name setter-name) + Similar to the short form of DEFSETF in Common Lisp, except that the + calling convention for the setter differs: the value is passed as the + first argument rather than as the last. The setter must return this + value. + +(predefine pattern) + This is a forward definition for a function or variable. It doesn't + actually make a definition; its purpose is to try to get rid of compiler + warnings about calls to functions that haven't been defined yet. It can + be a no-op if the underlying Lisp system doesn't provide any way to do + this. + +(redefine pattern . value) + Like DEFINE, but hints to the compiler not to complain if this + function/variable was previously defined somewhere else. + +(redefine-syntax (name . lambda-list) . body) + Like DEFINE-SYNTAX, but hints to the compiler not to complain if this + macro was previously defined somewhere else. + + +Equivalence +----------- + +(eq? x1 x2) +(eqv? x1 x2) +(equal? x1 x2) + As in Scheme but can return an arbitrary truth value instead of #t. + Note that equal? is not the same as EQUAL in CL because it descends vectors. + eqv? is different from the T equiv? because it doesn't descent strings. + + +Lists +----- + +(pair? x) + As in Scheme but can return an arbitrary truth value instead of #t. + +(cons x y) +(list . values) +(make-list length . maybe-init) + +(cxxxxr x) + +(null? x) +(list? x) + As in Scheme but can return an arbitrary truth value instead of #t. + Note that this is a check for a proper (null-terminated) list, not + like LISTP in CL. + +(length x) +(append list . more-lists) +(nconc list . more-lists) + +(reverse x) +(nreverse x) + +(list-tail list n) + Like NTHCDR in Common Lisp. + +(list-ref list n) + Like NTH in Common Lisp. + +(last list) +(butlast list) + As in Common Lisp. + +(memq object list) +(memv object list) +(member object list) + +(assq object list) +(assv object list) +(assoc object list) + +(push item place) +(pop place) + As in Common Lisp. + +(list-copy list) + + +Symbols +------- + +(symbol? object) +(symbol->string object) +(string->symbol object) +(gensym . maybe-prefix) +(gensym? object) + +(symbol-append . symbols) + + +Characters +---------- + +(char? object) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(char=? c1 c2) +(char<? c1 c2) +(char>? c1 c2) +(char<=? c1 c2) +(char>=? c1 c2) + As in Scheme, except that they can return an arbitrary truth value + instead of just #t. + +(char-ci=? c1 c2) +(char-ci<? c1 c2) +(char-ci>? c1 c2) +(char-ci<=? c1 c2) +(char-ci>=? c1 c2) + As in Scheme, except that they can return an arbitrary truth value + instead of just #t. + +(char-alphabetic? c) +(char-numeric? c) +(char-whitespace? c) +(char-upper-case? c) +(char-lower-case? c) + +(char->integer c) +(integer->char n) + +(char-upcase c) +(char-downcase c) + +(char-name c) + As in Common Lisp. + +(char->digit c . maybe-radix) + Returns nil or the "weight" of the character as a fixnum in the given + radix (defaults to 10). + + +Strings +------- + +(string? object) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(make-string length . maybe-init) + +(string char . more-chars) + +(string-length string) +(string-ref string index) + +(string=? s1 s2) +(string<? s1 s2) +(string>? s1 s2) +(string<=? s1 s2) +(string>=? s1 s2) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(string-ci=? s1 s2) +(string-ci<? s1 s2) +(string-ci>? s1 s2) +(string-ci<=? s1 s2) +(string-ci>=? s1 s2) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(substring string start end) +(string-append string . more-strings) + +(string->list string) +(list->string list) + +(string-copy string) + +(string-upcase string) +(string-downcase string) + + +Vectors +------- + +(vector? object) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(make-vector length . maybe-init) +(vector object . more-objects) + +(vector-length vector) +(vector-ref vector index) +(vector->list vector) +(list->vector list) + +(vector-copy vector) + + +Numbers +------- + +(number? object) + As in Scheme, but can return an arbitrary truth value instead of just #t. + +(integer? object) +(rational? object) +(float? object) + These test the representation of a number, not its mathematical + properties. They're equivalent to the CL integerp, rationalp, and floatp + predicates. We ignore complex numbers for now. + +(exact->inexact number) + Convert an exact-rational to a float. + +(= x1 x2) +(< x1 x2) +(> x1 x2) +(<= x1 x2) +(>= x1 x2) + As in Scheme, except they can return an arbitrary truth value. + They're restricted to being binary operators because that's all + that's supported in T. + +(zero? x) +(positive? x) +(negative? x) + As in Scheme, except they can return an arbitrary truth value. + +(min number . more-numbers) +(max number . more-numbers) + +(+ . numbers) +(* . numbers) +(- n1 . more-numbers) +(/ n1 . more-numbers) + As in Scheme. + +(quotient n1 n2) +(remainder n1 n2) +(modulo n1 n2) + quotient rounds towards zero. + remainder has the sign of the second argument, modulo has the sign of + the first argument. + +(floor x) +(ceiling x) +(truncate x) +(round x) + As in Scheme. These return a number of the same type as the argument. + +(floor->exact x) +(ceiling->exact x) +(truncate->exact x) +(round->exact x) + Like the above, but return an exact-integer result. Borrowed from + MIT Scheme. + +(1+ n) +(1- n) +(incf place . maybe-delta) +(decf place . maybe-delta) + As in Common Lisp. + +(number->string number . maybe-radix) +(string->number string . maybe-radix) + As in Scheme. + +(expt base power) + As in Common Lisp. [our only use is when both args are integers] + + +Tables +------ + +(table? object) +(make-table) +(table-entry table key) +(table-for-each proc table) +(copy-table table) + More or less as in T. For now we only bother with tables that use + eq? as the comparison function -- mostly symbols are used as keys. + + +I/O +--- + +(call-with-input-file string proc) +(call-with-output-file string proc) + As in Scheme. The proc is called with one argument, the port. + +(call-with-input-string string proc) +(call-with-output-string proc) + Similar, but for reading/writing to a string stream string. + Call-with-output-string returns the string. + +(input-port? object) +(output-port? object) + As in Scheme, but can return an arbitrary truth value. + +(current-input-port) +(current-output-port) + +(open-input-file filename) +(open-output-file filename) + +(close-input-port port) +(close-output-port port) + +(read . maybe-port) +(read-char . maybe-port) +(peek-char . maybe-port) +(read-line . maybe-port) + +(eof-object? object) + + +Printer +------- + +(internal-write object port) +(internal-output-width port) +(internal-output-position port) +(internal-write-char char port) +(internal-write-string string port start end) +(internal-newline port) +(internal-fresh-line port) +(internal-finish-output port) +(internal-force-output port) +(internal-clear-output port) +(internal-write-to-string object) +(internal-warning string) +(internal-error string) + These are all internal hooks. Don't use them directly if you can + avoid it. + +(write object . maybe-stream) +(print object . maybe-stream) +(prin1 object . maybe-stream) +(princ object . maybe-stream) +(pprint object . maybe-stream) +(prin1-to-string object) +(princ-to-string object) +(write-char char . maybe-stream) +(write-string string . maybe-stream-start-end) +(write-line string . maybe-stream-start-end) +(terpri . maybe-stream) +(fresh-line . maybe-stream) +(finish-output . maybe-stream) +(force-output . maybe-stream) +(clear-output . maybe-stream) + These are the standard Common Lisp print functions. All of them + accept either a port or an XP stream as a stream argument. + +(display object . maybe-stream) + Same as princ; for Scheme compatibility. +(newline object . maybe-stream) + Same as terpri; for Scheme compatibility. + + +*print-escape* +*print-shared* +*print-circle* +*print-pretty* +*print-level* +*print-length* + These are the standard Common Lisp printer control variables. The + functions listed above obey them. + +*print-base* +*print-radix* +*print-case* +*print-readably* + These are more standard Common Lisp printer control variables, but + support for them hasn't been implemented yet. Maybe some day. + +*print-dispatch* + This is the hook for user customization of the printer. Its value is a + function that is passed an object as an argument, and returns another + function that takes a stream and the object as arguments. + +*print-structure* + If true, use standard structure printing syntax (overriding any special + print function for the structure type). + +*print-structure-slots* + If true, recursively print structure slots when using standard structure + printing syntax; otherwise just print the structure type name. + + +(standard-print-dispatch object) + This function is the initial value of *print-dispatch*. + +*print-right-margin* +*print-miser-width* +*print-lines* +*default-right-margin* +*last-abbreviated-printing* + These are the XP pretty-printer control variables. For more information + about the pretty-printer, read the XP document. + +(pprint-newline kind . maybe-stream) + The kind argument can be one of LINEAR, FILL, MISER, or MANDATORY. + +(pprint-logical-block (stream-symbol list . more-options) . body) + This is a macro. The body should contain code for printing a logical + block to the stream stream-symbol. + + The format of the options is (stream-symbol list prefix suffix per-line?). + + The list argument can be used with the pprint-pop macro. + + The prefix is a string that is printed as the initial prefix of the logical + block. If per-line? is true, then the prefix is printed on every line. + The suffix is a string that is printed at the end of the logical block. + + You can use this macro even when not pretty-printing, to get support + for *print-length* and *print-level*. In that case, you should have + the body forms put out only a minimal amount of whitespace. + +(pprint-pop) + Returns the next item from the list specified to an enclosing + pprint-logical-block. Checks for circular list tails and *print-length* + abbreviation. + +(pprint-exit-if-list-exhausted) + Can be used inside pprint-logical-block to see if the list is empty. + Causes the block to be exited if so. + +(pprint-indent relative-to n . maybe-stream) + Specify the indentation level to use for a logical block. + The relative-to argument can be either BLOCK or CURRENT. + +(pprint-tab kind colnum colinc . maybe-stream) + Specify tabbing. The kind argument can be one of LINE, SECTION, + LINE-RELATIVE, or SECTION-RELATIVE. + +(pprint-fill stream list . maybe-colon-atsign) +(pprint-linear stream list . maybe-colon-atsign) +(pprint-tabular stream list . maybe-colon-atsign-tabsize) + Pretty-print list to the stream in the given style. + + +(format stream string-or-fn . args) + The standard Common Lisp format, except that some of the more esoteric + directives are unimplemented. (Specifically, watch out for specifying + field widths or using # or V parameters; most of the numeric formatting + options are unimplemented, as are complicated directives like ~{...~}.) + + The stream parameter can be #f to output to a string, or #t to output + to the (current-output-port). + + The string-or-fn argument can be a function as well as a string containing + embedded directives. The function is applied to the stream and the args. + +(warning string-or-fn . args) +(error string-or-fn . args) + + + +System Interface +---------------- + +(macroexpand-1 form . maybe-env) +(macroexpand form . maybe-env) + As in Common Lisp. Since we don't have lexical macros and don't allow + syntax to be shadowed by local bindings, you can omit the environment + argument. These functions are provided mostly for debugging purposes. + +(eval form . maybe-compile) + As in Common Lisp. If the optional argument is supplied and is true, + try to compile the code in memory, not interpret it. + +(load filename) + +*code-quality* + A number between 0 and 3. 0 = minimal compilation, 1 = for debugging, + 2 = low safety, high speed, fast compilation, 3 = go all out. + +(compile-file source-filename . maybe-binary-filename) + +(with-compilation-unit options . forms) + This is the ANSI CL macro. We don't use any options. + +(filename-place filename) +(filename-name filename) +(filename-type filename) + We use a rather simplistic file system model. Filenames are strings + with place (or directory), name, and type components. These functions + pick apart filename strings. You shouldn't have to mess with string + operations on the components directly. + +(assemble-filename place-filename name-filename type-filename) + Build a new filename by combining the appropriate parts of the argument + filenames. + +source-file-type +binary-file-type + These constants hold appropriate default types for source and + compiled files. By convention, source-file-type is ".scm" but + the binary-file-type depends on the underlying Lisp system. + +(file-exists? filename) + Returns true if the file exists. + +(file-write-date filename) +(current-date) + Dates are represented as integers relative to an arbitrary base. These + functions are mostly useful for recording timestamps. + +(get-run-time) + Return run time as a floating-point number relative to an arbitrary base. + Useful for doing timings. + +(getenv name) + Explicitly expand an environment variable. (Environment variables that + appear as filename prefixes are expanded automagically by the functions + that open files.) + +(cd filename) + Change the current directory. + + +(exit) + Go away. + + +Reader Support +-------------- + +' => quote +` => backquote; also , and ,@ +#t and #f + + +Random Stuff +------------ + +lisp-implementation-name + returns a string identifying the underlying lisp implementation; e.g. + "lucid", "t", etc. + +(identify-system) + return a longer string indentifying the lisp version and machine type. + +left-to-right-evaluation + True if the underlying Lisp always evaluates function arguments + left-to-right; false otherwise. + +(gc-messages onoff) + Turn garbage collection messages on/off, if possible. + +(identity x) + The identity function. + + + +Type specifiers +--------------- + +t +procedure +pair +null +list, (list element-type) +symbol +char +string +vector +number +integer +rational +float +fixnum, int +table, (table key-type value-type) +(enum . values) +(tuple . component-types) +bool +alist, (alist key-type value-type) +(maybe type) +struct +type-descriptor +slot-descriptor + These are the standard type specifiers. + +the + As in Common Lisp. +subtype? + Equivalent to CL subtypep +is-type? + Equivalent to CL typep +typecase + As in Common Lisp, also recognizes "else" clause. + + + +Structures +---------- + +(struct? object) + Returns true if the object is a struct. +(struct-type-descriptor object) + Returns the type descriptor of a struct object. + +name, slots, parent-type, printer + Slots of type-descriptor object. + +(td-name td) +(td-slots td) +(td-parent-type td) +(td-printer td) + Accessors for type-descriptors. + +name, type, default, getter + Slots of slot-descriptor object. + +(sd-name sd) +(sd-type sd) +(sd-default sd) +(sd-getter sd) + Accessors for slot-descriptors. +(sd-getter-function sd) + Returns a function which can be used to access a slot (as opposed to + the symbol that names the function). + +(lookup-type-descriptor type-name) +(lookup-slot-descriptor type-name slot-name) + Name to descriptor mappings. + + +(make type . initializers) + The type must name a struct type; it is not evaluated. + The initializers are of the form (slot-name value-form). + +(struct-slot type slot object) + Generalized slot access. Type and slot are symbols. If both are + quoted, can be used with SETF. + +(with-slots type slot-names object . body) + Binds the specified slots of object to local variables with the + same names. Bindings are read-only. Type is not evaluated. + +(update-slots type object . initializers) + Modifies the slots of object. Syntax of initializers is as for make. + Type is not evaluated. + +(define-struct name + (include parent-type-name) + (type-template subtype-of-type-descriptor) + (prefix prefix-symbol) + (predicate predicate-name) + (slots + (slot-name + (type type) + (default init-form) + (bit #t) + (read-only? #t) + (uninitialized? #t)) + ...)) + + Defines name as a subtype of struct with the given slots. + All fields are optional. + + Include specifies the immediate supertype. All accessors on the supertype + work on the newly defined type. It defaults to struct. + + Type-template specifies the metaclass. It can be used to attach + additional information to the type descriptor. It defaults to + type-descriptor. + + Prefix can be used to specify an alternate prefix for accessors. The + default is name-. + + Predicate can be used to create a predicate function. The default is + not to create one. + + If no default is specified for a slot, it's expected to have an + explicit initializer supplied with MAKE. You'll get a compilation + warning otherwise, unless you specify the uninitialized? option instead. + + Bit is a hint for optimizing internal representation. + + Read-only? says not to create a SETFer for the slot. + + +(define-struct-printer struct-name printer-function) + Specifies a printer function to use when *print-structure* is false. + diff --git a/support/pprint.scm b/support/pprint.scm new file mode 100644 index 0000000..9b28ec8 --- /dev/null +++ b/support/pprint.scm @@ -0,0 +1,1788 @@ +;;; pprint.scm -- xp pretty-printer in Scheme +;;; +;;; author : Sandra Loosemore +;;; date : 29 Oct 1991 +;;; +;;; +;;; This code is adapted from the XP pretty printer originally written +;;; in Common Lisp by Dick Waters. Here is the copyright notice attached +;;; to the original XP source file: +;;; +;;;------------------------------------------------------------------------ +;;; +;;; Copyright 1989,1990 by the Massachusetts Institute of Technology, +;;; Cambridge, Massachusetts. +;;; +;;; Permission to use, copy, modify, and distribute this software and its +;;; documentation for any purpose and without fee is hereby granted, +;;; provided that this copyright and permission notice appear in all +;;; copies and supporting documentation, and that the name of M.I.T. not +;;; be used in advertising or publicity pertaining to distribution of the +;;; software without specific, written prior permission. M.I.T. makes no +;;; representations about the suitability of this software for any +;;; purpose. It is provided "as is" without express or implied warranty. +;;; +;;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +;;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +;;; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +;;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +;;; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +;;; SOFTWARE. +;;; +;;;------------------------------------------------------------------------ +;;; + + +;;;===================================================================== +;;; Variables +;;;===================================================================== + + +;;; External variables. These may be specially bound by user code. + +(define *print-escape* '#t) +(define *print-circle* '#f) +(define *print-level* '#f) +(define *print-length* '#f) +(define *print-base* 10) +(define *print-radix* '#f) + + +(define *print-shared* '#f) +(define *print-pretty* '#f) +(define *print-right-margin* '#f) +(define *print-miser-width* 40) +(define *print-lines* '#f) +(define *default-right-margin* 70) +(define *last-abbreviated-printing* + (lambda maybe-stream + (declare (ignore maybe-stream)) + '#f)) + +(define *print-dispatch* '#f) ; initialized later +(define *print-structure* '#f) +(define *print-structure-slots* '#t) + + +;;; *** These variables aren't really supported, but they should be. + +(define *print-readably* '#f) +(define *print-case* 'upcase) + + + +;;; Internal variables. These are all specially rebound when we initiate +;;; printing to an XP stream. + +(define *xp.current-level* 0) +(define *xp.current-length* 0) +(define *xp.abbreviation-happened* '#f) +(define *xp.locating-circularities* '#f) +(define *xp.parents* '()) +(define *xp.circularity-hash-table* '#f) +(define *xp.line-limit-abbreviation-exit* + (lambda values + (declare (ignore values)) + (error "No line limit abbreviation exit in this extent."))) + + + +;;;===================================================================== +;;; Dispatching +;;;===================================================================== + +;;; Since Scheme doesn't have type specifiers or named structures, +;;; the dispatch mechanism defined for the Common Lisp XP won't work +;;; very well. A more general alternative might be to maintain a +;;; sorted list of <priority predicate printer> tuples, but having to +;;; try each of these in sequence could get very slow. +;;; +;;; What I've decided to to instead is to have the value of +;;; *print-dispatch* be a user-defined dispatcher +;;; function: given an object, it should return a function to print it, +;;; or #f. In the latter case, the object is printed in some default +;;; way. +;;; +;;; The standard dispatcher function is defined towards the bottom +;;; of this file. If you are writing your own dispatcher, you should +;;; probably call this function as the fall-through case. + +(define (xp.get-printer object) + (funcall (dynamic *print-dispatch*) object)) + + +;;;===================================================================== +;;; Internal data structures +;;;===================================================================== + +(define-integrable xp.block-stack-entry-size 1) +(define-integrable xp.prefix-stack-entry-size 5) +(define-integrable xp.queue-entry-size 7) +(define-integrable xp.buffer-entry-size 1) +(define-integrable xp.prefix-entry-size 1) +(define-integrable xp.suffix-entry-size 1) + +(define-integrable xp.block-stack-min-size (* 35 xp.block-stack-entry-size)) +(define-integrable xp.prefix-stack-min-size (* 30 xp.prefix-stack-entry-size)) +(define-integrable xp.queue-min-size (* 75 xp.queue-entry-size)) +(define-integrable xp.buffer-min-size 256) +(define-integrable xp.prefix-min-size 256) +(define-integrable xp.suffix-min-size 256) + + +;;; The xp stream structure. +;;; Fields without defaults are initialized by xp.initialize-xp, below. + +(define-struct xp + (prefix xp.) + (predicate xp.xp-structure-p) + (slots + (base-stream (type t) (default '#f)) + (linel (type fixnum) (default 0)) + (line-limit (type (maybe fixnum)) (default '#f)) + (line-no (type fixnum) (default 0)) + (char-mode (type (enum #f up down cap0 cap1 capw)) (default '#f)) + (char-mode-counter (type fixnum) (default 0)) + ;; number of logical blocks at qright that are started but not ended. + (depth-in-blocks (type fixnum) (default 0)) + ;; This stack is pushed and popped in accordance with the way blocks + ;; are nested at the moment they are entered into the queue. + (block-stack (type vector) (default (make-vector xp.block-stack-min-size))) + ;; Pointer into block-stack vector. + (block-stack-ptr (type fixnum) (default 0)) + ;; This is a string that builds up the line images that will be printed out. + (buffer (type string) (default (make-string xp.buffer-min-size))) + ;; The output character position of the first character in the buffer; + ;; nonzero only if a partial line has been output. + (charpos (type fixnum) (default 0)) + ;; The index in the buffer where the next character is to be inserted. + (buffer-ptr (type fixnum) (default 0)) + ;; This is used in computing total lengths. It is changed to reflect + ;; all shifting and insertion of prefixes so that total length computes + ;; things as they would be if they were all on one line. + (buffer-offset (type fixnum) (default 0)) + ;; The queue of action descriptors. The value is a vector. + (queue (type vector) (default (make-vector xp.queue-min-size))) + ;; Index of next queue entry to dequeue. + (qleft (type fixnum) (default 0)) + ;; Index of last entry queued; queue is empty when (> qleft qright). + (qright (type fixnum) (default 0)) + ;; This stores the prefix that should be used at the start of the line. + (prefix (type string) (default (make-string xp.buffer-min-size))) + ;; This stack is pushed and popped in accordance with the way blocks + ;; are nested at the moment things are taken off the queue and printed. + (prefix-stack (type vector) (default (make-vector xp.prefix-stack-min-size))) + ;; Index into prefix-stack. + (prefix-stack-ptr (type fixnum) (default 0)) + ;; This stores the suffixes that have to be pritned to close of the + ;; current open blocks. For convenience in popping, the whole suffix + ;; is stored in reverse order. + (suffix (type string) (default (make-string xp.buffer-min-size))) + )) + + +(define (xp.make-xp-structure) + (make xp)) + + +;;; Positions within the buffer are kept in three ways: +;;; * Buffer position (eg BUFFER-PTR) +;;; * Line position (eg (+ BUFFER-PTR CHARPOS)). +;;; Indentations are stored in this form. +;;; * Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET)) +;;; Positions are stored in this form. + +(define-local-syntax (xp.lp<-bp xp . maybe-ptr) + (let ((ptr (if (not (null? maybe-ptr)) + (car maybe-ptr) + `(xp.buffer-ptr ,xp)))) + `(+ ,ptr (xp.charpos ,xp)))) + +(define-local-syntax (xp.tp<-bp xp) + `(+ (xp.buffer-ptr ,xp) (xp.buffer-offset ,xp))) + +(define-local-syntax (xp.bp<-lp xp ptr) + `(- ,ptr (xp.charpos ,xp))) + +(define-local-syntax (xp.bp<-tp xp ptr) + `(- ,ptr (xp.buffer-offset ,xp))) + +(define-local-syntax (xp.lp<-tp xp ptr) + `(xp.lp<-bp ,xp (xp.bp<-tp ,xp ,ptr))) + + +;;; Define some macros for growing the various stacks in the xp-structure. + +(define-local-syntax (xp.check-block-stack-size xp ptr) + `(setf (xp.block-stack ,xp) + (xp.grow-vector (xp.block-stack ,xp) ,ptr xp.block-stack-entry-size))) + +(define-local-syntax (xp.check-prefix-size xp ptr) + `(setf (xp.prefix ,xp) + (xp.grow-string (xp.prefix ,xp) ,ptr xp.prefix-entry-size))) + +(define-local-syntax (xp.check-prefix-stack-size xp ptr) + `(setf (xp.prefix-stack ,xp) + (xp.grow-vector (xp.prefix-stack ,xp) ,ptr xp.prefix-stack-entry-size))) + +(define-local-syntax (xp.check-queue-size xp ptr) + `(setf (xp.queue ,xp) + (xp.grow-vector (xp.queue ,xp) ,ptr xp.queue-entry-size))) + +(define-local-syntax (xp.check-buffer-size xp ptr) + `(setf (xp.buffer ,xp) + (xp.grow-string (xp.buffer ,xp) ,ptr xp.buffer-entry-size))) + +(define-local-syntax (xp.check-suffix-size xp ptr) + `(setf (xp.suffix ,xp) + (xp.grow-string (xp.suffix ,xp) ,ptr xp.suffix-entry-size))) + +(define (xp.grow-vector old ptr entry-size) + (let ((end (vector-length old))) + (if (> ptr (- end entry-size)) + (let ((new (make-vector (+ ptr 50)))) + (dotimes (i end) + (setf (vector-ref new i) (vector-ref old i))) + new) + old))) + +(define (xp.grow-string old ptr entry-size) + (let ((end (string-length old))) + (if (> ptr (- end entry-size)) + (let ((new (make-string (+ ptr 50)))) + (dotimes (i end) + (setf (string-ref new i) (string-ref old i))) + new) + old))) + + + +;;; Things for manipulating the block stack. + +(define-local-syntax (xp.section-start xp) + `(vector-ref (xp.block-stack ,xp) (xp.block-stack-ptr ,xp))) + +(define (xp.push-block-stack xp) + (incf (xp.block-stack-ptr xp) xp.block-stack-entry-size) + (xp.check-block-stack-size xp (xp.block-stack-ptr xp))) + +(define (xp.pop-block-stack xp) + (decf (xp.block-stack-ptr xp) xp.block-stack-entry-size)) + + +;;; Prefix stack manipulations + +(define-local-syntax (xp.prefix-ptr xp) + `(vector-ref (xp.prefix-stack ,xp) (xp.prefix-stack-ptr ,xp))) +(define-local-syntax (xp.suffix-ptr xp) + `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 1))) +(define-local-syntax (non-blank-prefix-ptr xp) + `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 2))) +(define-local-syntax (initial-prefix-ptr xp) + `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 3))) +(define-local-syntax (xp.section-start-line xp) + `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 4))) + +(define (xp.push-prefix-stack xp) + (let ((old-prefix 0) + (old-suffix 0) + (old-non-blank 0)) + (when (not (negative? (xp.prefix-stack-ptr xp))) + (setf old-prefix (xp.prefix-ptr xp)) + (setf old-suffix (xp.suffix-ptr xp)) + (setf old-non-blank (non-blank-prefix-ptr xp))) + (incf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size) + (xp.check-prefix-stack-size xp (xp.prefix-stack-ptr xp)) + (setf (xp.prefix-ptr xp) old-prefix) + (setf (xp.suffix-ptr xp) old-suffix) + (setf (non-blank-prefix-ptr xp) old-non-blank))) + +(define (xp.pop-prefix-stack xp) + (decf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size)) + + +;;; The queue entries have several parts: +;;; QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK +;;; QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH +;;; or :BLOCK/:CURRENT +;;; QPOS total position corresponding to this entry +;;; QDEPTH depth in blocks of this entry. +;;; QEND offset to entry marking end of section this entry starts. +;; (NIL until known.) +;;; Only :start-block and non-literal :newline entries can start sections. +;;; QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known). +;;; QARG for :IND indentation delta +;;; for :START-BLOCK suffix in the block if any. +;;; or if per-line-prefix then cons of suffix and +;;; per-line-prefix. +;;; for :END-BLOCK suffix for the block if any. + +(define-local-syntax (xp.qtype xp index) + `(vector-ref (xp.queue ,xp) ,index)) +(define-local-syntax (xp.qkind xp index) + `(vector-ref (xp.queue ,xp) (1+ ,index))) +(define-local-syntax (xp.qpos xp index) + `(vector-ref (xp.queue ,xp) (+ ,index 2))) +(define-local-syntax (xp.qdepth xp index) + `(vector-ref (xp.queue ,xp) (+ ,index 3))) +(define-local-syntax (xp.qend xp index) + `(vector-ref (xp.queue ,xp) (+ ,index 4))) +(define-local-syntax (xp.qoffset xp index) + `(vector-ref (xp.queue ,xp) (+ ,index 5))) +(define-local-syntax (xp.qarg xp index) + `(vector-ref (xp.queue ,xp) (+ ,index 6))) + +;;; we shift the queue over rather than using a circular queue because +;;; that works out to be a lot faster in practice. Note, short printout +;;; does not ever cause a shift, and even in long printout, the queue is +;;; shifted left for free every time it happens to empty out. + +(define (xp.enqueue xp type kind . maybe-arg) + (incf (xp.qright xp) xp.queue-entry-size) + (when (> (xp.qright xp) (- xp.queue-min-size xp.queue-entry-size)) + (vector-replace (xp.queue xp) (xp.queue xp) 0 (xp.qleft xp) (xp.qright xp)) + (setf (xp.qright xp) (- (xp.qright xp) (xp.qleft xp))) + (setf (xp.qleft xp) 0)) + (xp.check-queue-size xp (xp.qright xp)) + (setf (xp.qtype xp (xp.qright xp)) type) + (setf (xp.qkind xp (xp.qright xp)) kind) + (setf (xp.qpos xp (xp.qright xp)) (xp.tp<-bp xp)) + (setf (xp.qdepth xp (xp.qright xp)) (xp.depth-in-blocks xp)) + (setf (xp.qend xp (xp.qright xp)) '#f) + (setf (xp.qoffset xp (xp.qright xp)) '#f) + (setf (xp.qarg xp (xp.qright xp)) (car maybe-arg))) + +(define-local-syntax (xp.qnext index) `(+ ,index xp.queue-entry-size)) + + + +;;; Print routine for xp structures +;;; *** this is broken, it uses unimplemented format options. + +(define *xp.describe-xp-streams-fully* '#f) + +(define (xp.describe-xp xp . maybe-stream) + (let ((s (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (format s "#<XP stream ") + (if (not (xp.base-stream xp)) + (format s "not currently in use") + (begin + (format s "outputting to ~S" (xp.base-stream xp)) + (format s "~&buffer= ~S" + (substring (xp.buffer xp) 0 (max (xp.buffer-ptr xp) 0))) + (if (not (dynamic *xp.describe-xp-streams-fully*)) + (format s " ...") + (begin + (format s "~& pos _123456789_123456789_123456789_123456789") + (format s "~&depth-in-blocks= ~D linel= ~D line-no= ~D line-limit= ~D" + (xp.depth-in-blocks xp) (xp.linel xp) + (xp.line-no xp) (xp.line-limit xp)) + (when (or (xp.char-mode xp) (not (zero? (xp.char-mode-counter xp)))) + (format s "~&char-mode= ~S char-mode-counter= ~D" + (xp.char-mode xp) (xp.char-mode-counter xp))) + (unless (negative? (xp.block-stack-ptr xp)) + (format s "~§ion-start") + (do ((save (xp.block-stack-ptr xp))) + ((negative? (xp.block-stack-ptr xp)) + (setf (xp.block-stack-ptr xp) save)) + (format s " ~D" (xp.section-start xp)) + (xp.pop-block-stack xp))) + (format s "~&linel= ~D charpos= ~D buffer-ptr= ~D buffer-offset= ~D" + (xp.linel xp) (xp.charpos xp) + (xp.buffer-ptr xp) (xp.buffer-offset xp)) + (unless (negative? (xp.prefix-stack-ptr xp)) + (format s "~&prefix= ~S" + (substring (xp.prefix xp) 0 (max (xp.prefix-ptr xp) 0))) + (format s "~&suffix= ~S" + (substring (xp.suffix xp) 0 (max (xp.suffix-ptr xp) 0)))) + (unless (> (xp.qleft xp) (xp.qright xp)) + (format s "~&ptr type kind pos depth end offset arg") + (do ((p (xp.qleft xp) (xp.qnext p))) + ((> p (xp.qright xp))) + (format s "~&~4A~13A~15A~4A~6A~4A~7A~A" + (/ (- p (xp.qleft xp)) xp.queue-entry-size) + (xp.qtype xp p) + (if (memq (xp.qtype xp p) '(newline ind)) + (xp.qkind xp p) + "") + (xp.bp<-tp xp (xp.qpos xp p)) + (xp.qdepth xp p) + (if (not (memq (xp.qtype xp p) + '(newline start-block))) + "" + (and (xp.qend xp p) + (/ (- (+ p (xp.qend xp p)) (xp.qleft xp)) + xp.queue-entry-size))) + (if (not (eq? (xp.qtype xp p) 'start-block)) + "" + (and (xp.qoffset xp p) + (/ (- (+ p (xp.qoffset xp p)) (xp.qleft xp)) + xp.queue-entry-size))) + (if (not (memq (xp.qtype xp p) + '(ind start-block end-block))) + "" + (xp.qarg xp p))))) + (unless (negative? (xp.prefix-stack-ptr xp)) + (format s "~&initial-prefix-ptr prefix-ptr suffix-ptr non-blank start-line") + (do ((save (xp.prefix-stack-ptr xp))) + ((negative? (xp.prefix-stack-ptr xp)) + (setf (xp.prefix-stack-ptr xp) save)) + (format s "~& ~19A~11A~11A~10A~A" + (initial-prefix-ptr xp) + (xp.prefix-ptr xp) + (xp.suffix-ptr xp) + (non-blank-prefix-ptr xp) + (xp.section-start-line xp)) + (xp.pop-prefix-stack xp))))))) + (format s ">"))) + + + +;;; Allocation of XP structures + +;;; This maintains a list of XP structures. We save them +;;; so that we don't have to create new ones all of the time. +;;; We have separate objects so that many can be in use at once +;;; (e.g. for printing to multiple streams). + +(define xp.free-xps '()) + +(define (xp.get-pretty-print-stream stream) + (xp.initialize-xp + (if (not (null? xp.free-xps)) + (pop xp.free-xps) + (xp.make-xp-structure)) + stream)) + + +;;; If you call this, the xp-stream gets efficiently recycled. + +(define (xp.free-pretty-print-stream xp) + (setf (xp.base-stream xp) '#f) + (if (not (memq xp xp.free-xps)) + (push xp xp.free-xps))) + + +;;; This is called to initialize things when you start pretty printing. + +(define (xp.initialize-xp xp stream) + (setf (xp.base-stream xp) stream) + (setf (xp.linel xp) + (max 0 + (cond ((dynamic *print-right-margin*)) + ((internal-output-width stream)) + (else (dynamic *default-right-margin*))))) + (setf (xp.line-limit xp) (dynamic *print-lines*)) + (setf (xp.line-no xp) 1) + (setf (xp.char-mode xp) '#f) + (setf (xp.char-mode-counter xp) 0) + (setf (xp.depth-in-blocks xp) 0) + (setf (xp.block-stack-ptr xp) 0) + (setf (xp.charpos xp) (or (internal-output-position stream) 0)) + (setf (xp.section-start xp) 0) + (setf (xp.buffer-ptr xp) 0) + (setf (xp.buffer-offset xp) (xp.charpos xp)) + (setf (xp.qleft xp) 0) + (setf (xp.qright xp) (- xp.queue-entry-size)) + (setf (xp.prefix-stack-ptr xp) (- xp.prefix-stack-entry-size)) + xp) + + + +;;; The char-mode stuff is a bit tricky. +;;; one can be in one of the following modes: +;;; NIL no changes to characters output. +;;; :UP CHAR-UPCASE used. +;;; :DOWN CHAR-DOWNCASE used. +;;; :CAP0 capitalize next alphanumeric letter then switch to :DOWN. +;;; :CAP1 capitalize next alphanumeric letter then switch to :CAPW +;;; :CAPW downcase letters. When a word break letter found, switch to :CAP1. +;;; It is possible for ~(~) to be nested in a format string, but note that +;;; each mode specifies what should happen to every letter. Therefore, inner +;;; nested modes never have any effect. You can just ignore them. + +(define (xp.push-char-mode xp new-mode) + (if (zero? (xp.char-mode-counter xp)) + (setf (xp.char-mode xp) new-mode)) + (incf (xp.char-mode-counter xp))) + +(define (xp.pop-char-mode xp) + (decf (xp.char-mode-counter xp)) + (if (zero? (xp.char-mode-counter xp)) + (setf (xp.char-mode xp) '#f))) + + +;;; Assumes is only called when char-mode is non-nil + +(define (xp.handle-char-mode xp char) + (case (xp.char-mode xp) + ((CAP0) + (cond ((not (or (char-alphabetic? char) (char-numeric? char))) char) + (else (setf (xp.char-mode xp) 'DOWN) (char-upcase char)))) + ((CAP1) + (cond ((not (or (char-alphabetic? char) (char-numeric? char))) char) + (else (setf (xp.char-mode xp) 'CAPW) (char-upcase char)))) + ((CAPW) + (cond ((or (char-alphabetic? char) (char-numeric? char)) + (char-downcase char)) + (else (setf (xp.char-mode xp) 'CAP1) char))) + ((UP) + (char-upcase char)) + (else + (char-downcase char)))) ;DOWN + + +;;; All characters output are passed through the handler above. However, +;;; it must be noted that on-each-line prefixes are only processed in the +;;; context of the first place they appear. They stay the same later no +;;; matter what. Also non-literal newlines do not count as word breaks. + +;;; This handles the basic outputting of characters. note + suffix means that +;;; the stream is known to be an XP stream, all inputs are mandatory, and no +;;; error checking has to be done. Suffix ++ additionally means that the +;;; output is guaranteed not to contain a newline char. + +(define (xp.write-char+ char xp) + (if (eqv? char #\newline) + (xp.pprint-newline+ 'unconditional xp) + (xp.write-char++ char xp))) + +(define (xp.write-string+ mystring xp start end) + (let ((next-newline (string-position #\newline mystring start end))) + (if next-newline + (begin + (xp.write-string++ mystring xp start next-newline) + (xp.pprint-newline+ 'unconditional xp) + (xp.write-string+ mystring xp (1+ next-newline) end)) + (xp.write-string++ mystring xp start end)))) + + +;;; note this checks (> BUFFER-PTR LINEL) instead of (> (xp.lp<-bp) LINEL) +;;; this is important so that when things are longer than a line they +;;; end up getting printed in chunks of size LINEL. + +(define (xp.write-char++ char xp) + (when (> (xp.buffer-ptr xp) (xp.linel xp)) + (xp.force-some-output xp)) + (let ((new-buffer-end (1+ (xp.buffer-ptr xp)))) + (xp.check-buffer-size xp new-buffer-end) + (if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char))) + (setf (string-ref (xp.buffer xp) (xp.buffer-ptr xp)) char) + (setf (xp.buffer-ptr xp) new-buffer-end))) + +(define (xp.force-some-output xp) + (xp.attempt-to-output xp '#f '#f) + (when (> (xp.buffer-ptr xp) (xp.linel xp)) ;only if printing off end of line + (xp.attempt-to-output xp '#t '#t))) + +(define (xp.write-string++ mystring xp start end) + (when (> (xp.buffer-ptr xp) (xp.linel xp)) + (xp.force-some-output xp)) + (xp.write-string+++ mystring xp start end)) + + +;;; never forces output; therefore safe to call from within xp.output-line. + +(define (xp.write-string+++ mystring xp start end) + (let ((new-buffer-end (+ (xp.buffer-ptr xp) (- end start)))) + (xp.check-buffer-size xp new-buffer-end) + (do ((buffer (xp.buffer xp)) + (i (xp.buffer-ptr xp) (1+ i)) + (j start (1+ j))) + ((= j end)) + (let ((char (string-ref mystring j))) + (if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char))) + (setf (string-ref buffer i) char))) + (setf (xp.buffer-ptr xp) new-buffer-end))) + + +(define (xp.pprint-tab+ kind colnum colinc xp) + (let ((indented? '#f) + (relative? '#f)) + (case kind + ((section) (setf indented? '#t)) + ((line-relative) (setf relative? '#t)) + ((section-relative) (setf indented? '#t) (setf relative? '#t))) + (let* ((current + (if (not indented?) + (xp.lp<-bp xp) + (- (xp.tp<-bp xp) (xp.section-start xp)))) + (new + (if (zero? colinc) + (if relative? (+ current colnum) (max colnum current)) + (cond (relative? + (* colinc + (quotient (+ current colnum colinc -1) colinc))) + ((> colnum current) colnum) + (else + (+ colnum + (* colinc + (quotient (+ current (- colnum) colinc) + colinc))))))) + (end (- new current))) + (when (positive? end) + (if (xp.char-mode xp) (xp.handle-char-mode xp #\space)) + (let ((end (+ (xp.buffer-ptr xp) end))) + (xp.check-buffer-size xp end) + (string-fill (xp.buffer xp) #\space (xp.buffer-ptr xp) end) + (setf (xp.buffer-ptr xp) end)))))) + + +;;; note following is smallest number >= x that is a multiple of colinc +;;; (* colinc (quotient (+ x (1- colinc)) colinc)) + + +(define (xp.pprint-newline+ kind xp) + (xp.enqueue xp 'newline kind) + (do ((ptr (xp.qleft xp) (xp.qnext ptr))) ;find sections we are ending + ((not (< ptr (xp.qright xp)))) ;all but last + (when (and (not (xp.qend xp ptr)) + (not (> (xp.depth-in-blocks xp) (xp.qdepth xp ptr))) + (memq (xp.qtype xp ptr) '(newline start-block))) + (setf (xp.qend xp ptr) (- (xp.qright xp) ptr)))) + (setf (xp.section-start xp) (xp.tp<-bp xp)) + (when (and (memq kind '(fresh unconditional)) (xp.char-mode xp)) + (xp.handle-char-mode xp #\newline)) + (when (memq kind '(fresh unconditional mandatory)) + (xp.attempt-to-output xp '#t '#f))) + + +(define (xp.start-block xp prefix-string on-each-line? suffix-string) + (xp.write-prefix-suffix prefix-string xp) + (if (and (xp.char-mode xp) on-each-line?) + (setf prefix-string + (substring (xp.buffer xp) + (- (xp.buffer-ptr xp) (string-length prefix-string)) + (xp.buffer-ptr xp)))) + (xp.push-block-stack xp) + (xp.enqueue xp 'start-block '#f + (if on-each-line? (cons suffix-string prefix-string) suffix-string)) + (incf (xp.depth-in-blocks xp)) ;must be after enqueue + (setf (xp.section-start xp) (xp.tp<-bp xp))) + + +(define (xp.end-block xp suffix) + (unless (and (dynamic *xp.abbreviation-happened*) + (eqv? (dynamic *xp.abbreviation-happened*) + (dynamic *print-lines*))) + (xp.write-prefix-suffix suffix xp) + (decf (xp.depth-in-blocks xp)) + (xp.enqueue xp 'end-block '#f suffix) + (block foundit + (do ((ptr (xp.qleft xp) (xp.qnext ptr))) ;look for start of block we are ending + ((not (< ptr (xp.qright xp)))) ;all but last + (when (and (= (xp.depth-in-blocks xp) (xp.qdepth xp ptr)) + (eq? (xp.qtype xp ptr) 'start-block) + (not (xp.qoffset xp ptr))) + (setf (xp.qoffset xp ptr) (- (xp.qright xp) ptr)) + (return-from foundit '#f))) ;can only be 1 + ) + (xp.pop-block-stack xp))) + +(define (xp.write-prefix-suffix mystring xp) + (when mystring + (xp.write-string++ mystring xp 0 (string-length mystring)))) + +(define (xp.pprint-indent+ kind n xp) + (xp.enqueue xp 'ind kind n)) + + +;;; attempt-to-output scans the queue looking for things it can do. +;;; it keeps outputting things until the queue is empty, or it finds +;;; a place where it cannot make a decision yet. +;;; If flush-out? is T and force-newlines? is NIL then the buffer, +;;; prefix-stack, and queue will be in an inconsistent state after the call. +;;; You better not call it this way except as the last act of outputting. + + +(define-local-syntax (xp.maybe-too-large xp Qentry) + `(let ((limit (xp.linel ,xp))) + (when (eqv? (xp.line-limit ,xp) (xp.line-no ,xp)) ;prevents suffix overflow + (decf limit 2) ;3 for " .." minus 1 for space (heuristic) + (when (not (negative? (xp.prefix-stack-ptr ,xp))) + (decf limit (xp.suffix-ptr ,xp)))) + (cond ((xp.qend ,xp ,Qentry) + (> (xp.lp<-tp ,xp (xp.qpos ,xp (+ ,Qentry (xp.qend ,xp ,Qentry)))) limit)) + ((or force-newlines? (> (xp.lp<-bp ,xp) limit)) + '#t) + (else ;wait until later to decide. + (return-from attempt-to-output '#f))))) + +(define-local-syntax (xp.misering? xp) + `(and (dynamic *print-miser-width*) + (<= (- (xp.linel ,xp) (initial-prefix-ptr ,xp)) + (dynamic *print-miser-width*)))) + +(define (xp.attempt-to-output xp force-newlines? flush-out?) + (block attempt-to-output + (do () + ((> (xp.qleft xp) (xp.qright xp)) + (setf (xp.qleft xp) 0) + (setf (xp.qright xp) (- xp.queue-entry-size))) ;saves shifting + (case (xp.qtype xp (xp.qleft xp)) + ((ind) + (unless (xp.misering? xp) + (xp.set-indentation-prefix + xp + (case (xp.qkind xp (xp.qleft xp)) + ((block) + (+ (initial-prefix-ptr xp) (xp.qarg xp (xp.qleft xp)))) + (else ; current + (+ (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp))) + (xp.qarg xp (xp.qleft xp))))))) + (setf (xp.qleft xp) (xp.qnext (xp.qleft xp)))) + ((start-block) + (cond ((xp.maybe-too-large xp (xp.qleft xp)) + (xp.push-prefix-stack xp) + (setf (initial-prefix-ptr xp) (xp.prefix-ptr xp)) + (xp.set-indentation-prefix + xp (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp)))) + (let ((arg (xp.qarg xp (xp.qleft xp)))) + (when (pair? arg) (xp.set-prefix xp (cdr arg))) + (setf (initial-prefix-ptr xp) (xp.prefix-ptr xp)) + (cond ((not (list? arg)) (xp.set-suffix xp arg)) + ((car arg) (xp.set-suffix xp (car arg))))) + (setf (xp.section-start-line xp) (xp.line-no xp))) + (else (incf (xp.qleft xp) (xp.qoffset xp (xp.qleft xp))))) + (setf (xp.qleft xp) (xp.qnext (xp.qleft xp)))) + ((end-block) + (xp.pop-prefix-stack xp) + (setf (xp.qleft xp) (xp.qnext (xp.qleft xp)))) + (else ; newline + (when (case (xp.qkind xp (xp.qleft xp)) + ((fresh) (not (zero? (xp.lp<-bp xp)))) + ((miser) (xp.misering? xp)) + ((fill) (or (xp.misering? xp) + (> (xp.line-no xp) (xp.section-start-line xp)) + (xp.maybe-too-large xp (xp.qleft xp)))) + (else '#t)) ;(linear unconditional mandatory) + (xp.output-line xp (xp.qleft xp)) + (xp.setup-for-next-line xp (xp.qleft xp))) + (setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))))) + (when flush-out? (xp.flush xp))) + + +;;; this can only be called last! + +(define (xp.flush xp) + (unless (dynamic *xp.locating-circularities*) + (internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 (xp.buffer-ptr xp))) + (incf (xp.buffer-offset xp) (xp.buffer-ptr xp)) + (incf (xp.charpos xp) (xp.buffer-ptr xp)) + (setf (xp.buffer-ptr xp) 0)) + + +;;; This prints out a line of stuff. + +(define (xp.output-line xp Qentry) + (let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry))) + (last-non-blank (string-position-not-from-end + #\space (xp.buffer xp) 0 out-point)) + (end (cond ((memq (xp.qkind xp Qentry) '(fresh unconditional)) + out-point) + (last-non-blank (1+ last-non-blank)) + (else 0))) + (line-limit-exit (and (xp.line-limit xp) + (not (> (xp.line-limit xp) (xp.line-no xp)))))) + (when line-limit-exit + (setf (xp.buffer-ptr xp) end) ;truncate pending output. + (xp.write-string+++ " .." xp 0 3) + (string-nreverse (xp.suffix xp) 0 (xp.suffix-ptr xp)) + (xp.write-string+++ (xp.suffix xp) xp 0 (xp.suffix-ptr xp)) + (setf (xp.qleft xp) (xp.qnext (xp.qright xp))) + (setf (dynamic *xp.abbreviation-happened*) (dynamic *print-lines*)) + (funcall (dynamic *xp.line-limit-abbreviation-exit*) '#t)) + (incf (xp.line-no xp)) + (unless (dynamic *xp.locating-circularities*) + (internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 end) + (newline (xp.base-stream xp))))) + +(define (xp.setup-for-next-line xp Qentry) + (let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry))) + (prefix-end + (cond ((memq (xp.qkind xp Qentry) '(unconditional fresh)) + (non-blank-prefix-ptr xp)) + (else (xp.prefix-ptr xp)))) + (change (- prefix-end out-point))) + (setf (xp.charpos xp) 0) + (when (positive? change) ;almost never happens + (xp.check-buffer-size xp (+ (xp.buffer-ptr xp) change))) + (string-replace (xp.buffer xp) (xp.buffer xp) + prefix-end out-point (xp.buffer-ptr xp)) + (string-replace (xp.buffer xp) (xp.prefix xp) 0 0 prefix-end) + (incf (xp.buffer-ptr xp) change) + (decf (xp.buffer-offset xp) change) + (when (not (memq (xp.qkind xp Qentry) '(unconditional fresh))) + (setf (xp.section-start-line xp) (xp.line-no xp))))) + +(define (xp.set-indentation-prefix xp new-position) + (let ((new-ind (max (non-blank-prefix-ptr xp) new-position))) + (setf (xp.prefix-ptr xp) (initial-prefix-ptr xp)) + (xp.check-prefix-size xp new-ind) + (when (> new-ind (xp.prefix-ptr xp)) + (string-fill (xp.prefix xp) #\space (xp.prefix-ptr xp) new-ind)) + (setf (xp.prefix-ptr xp) new-ind))) + +(define (xp.set-prefix xp prefix-string) + (let ((end (string-length prefix-string))) + (string-replace (xp.prefix xp) prefix-string + (- (xp.prefix-ptr xp) end) 0 end)) + (setf (non-blank-prefix-ptr xp) (xp.prefix-ptr xp))) + +(define (xp.set-suffix xp suffix-string) + (let* ((end (string-length suffix-string)) + (new-end (+ (xp.suffix-ptr xp) end))) + (xp.check-suffix-size xp new-end) + (do ((i (1- new-end) (1- i)) + (j 0 (1+ j))) + ((= j end)) + (setf (string-ref (xp.suffix xp) i) (string-ref suffix-string j))) + (setf (xp.suffix-ptr xp) new-end))) + + +;;;===================================================================== +;;; Basic interface functions +;;;===================================================================== + +;;; The internal functions in this file +;;; use the '+' forms of these functions directly (which is faster) because, +;;; they do not need error checking of fancy stream coercion. The '++' forms +;;; additionally assume the thing being output does not contain a newline. + +(define (write object . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (cond ((xp.xp-structure-p stream) + (xp.write+ object stream)) + ((xp.get-printer object) + (xp.initiate-xp-printing + (lambda (s o) (xp.write+ o s)) + stream + object)) + (else + (internal-write object stream))))) + +(define (xp.maybe-initiate-xp-printing fn stream . args) + (if (xp.xp-structure-p stream) + (apply fn stream args) + (apply (function xp.initiate-xp-printing) fn stream args))) + +(define (xp.initiate-xp-printing fn stream . args) + (dynamic-let ((*xp.abbreviation-happened* + '#f) + (*xp.locating-circularities* + (if (dynamic *print-circle*) + 0 + '#f)) + (*xp.circularity-hash-table* + (if (dynamic *print-circle*) + (make-table) + '#f)) + (*xp.parents* + (if (not (dynamic *print-shared*)) + (list '#f) + '())) ;*** is this right? + (*xp.current-level* + 0) + (*xp.current-length* + 0)) + (let ((result (xp.xp-print fn stream args))) + (when (dynamic *xp.abbreviation-happened*) + (setf args (list-copy args)) + (setf (dynamic *last-abbreviated-printing*) + (lambda maybe-stream + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + stream))) + (apply (function xp.maybe-initiate-xp-printing) + fn stream args))))) + result))) + +(define (xp.xp-print fn stream args) + (let ((result (xp.do-xp-printing fn stream args))) + (when (dynamic *xp.locating-circularities*) + (setf (dynamic *xp.locating-circularities*) '#f) + (setf (dynamic *xp.abbreviation-happened*) '#f) + (setf (dynamic *xp.parents*) '()) + (setf result (xp.do-xp-printing fn stream args))) + result)) + +(define (xp.do-xp-printing fn stream args) + (let ((xp (xp.get-pretty-print-stream stream)) + (result '#f)) + (dynamic-let ((*xp.current-level* 0)) + (let/cc catch + (dynamic-let ((*xp.line-limit-abbreviation-exit* catch)) + (xp.start-block xp '#f '#f '#f) + (setf result (apply fn xp args)) + (xp.end-block xp '#f))) + (when (and (dynamic *xp.locating-circularities*) + (zero? (dynamic *xp.locating-circularities*)) ;No circularities. + (= (xp.line-no xp) 1) ;Didn't suppress line. + (zero? (xp.buffer-offset xp))) ;Didn't suppress partial line. + (setf (dynamic *xp.locating-circularities*) '#f)) ;print what you have got. + (when (let/cc catch + (dynamic-let ((*xp.line-limit-abbreviation-exit* catch)) + (xp.attempt-to-output xp '#f '#t) + '#f)) + (xp.attempt-to-output xp '#t '#t)) + (xp.free-pretty-print-stream xp) + result))) + + +(define (xp.write+ object xp) + (dynamic-let ((*xp.parents* (dynamic *xp.parents*))) + (unless (and (dynamic *xp.circularity-hash-table*) + (eq? (xp.circularity-process xp object '#f) 'subsequent)) + (when (and (dynamic *xp.circularity-hash-table*) (pair? object)) + ;; Must do this to avoid additional circularity detection by + ;; pprint-logical-block; otherwise you get stuff like #1=#1#. + (setf object (cons (car object) (cdr object)))) + (funcall (or (xp.get-printer object) (function xp.print-default)) + object + xp)) + object)) + + + +(define (xp.print-default object xp) + (let ((stuff (internal-write-to-string object))) + (xp.write-string+ stuff xp 0 (string-length stuff)))) + + +;;; It is vital that this function be called EXACTLY once for each occurrence +;;; of each thing in something being printed. +;;; Returns nil if printing should just continue on. +;;; Either it is not a duplicate, or we are in the first pass and do not +;;; know. +;;; returns :FIRST if object is first occurrence of a DUPLICATE. +;;; (This can only be returned on a second pass.) +;;; After an initial code (printed by this routine on the second pass) +;;; printing should continue on for the object. +;;; returns :SUBSEQUENT if second or later occurrence. +;;; Printing is all taken care of by this routine. + +;;; Note many (maybe most) lisp implementations have characters and small +;;; numbers represented in a single word so that the are always eq when +;;; they are equal and the reader takes care of properly sharing them +;;; (just as it does with symbols). Therefore, we do not want circularity +;;; processing applied to them. However, some kinds of numbers +;;; (e.g., bignums) undoubtedly are complex structures that the reader +;;; does not share. However, they cannot have circular pointers in them +;;; and it is therefore probably a waste to do circularity checking on them. +;;; In any case, it is not clear that it easy to tell exactly what kinds of +;;; numbers a given implementation is going to have the reader +;;; automatically share. + +(define (xp.circularity-process xp object interior-cdr?) + (unless (or (number? object) + (char? object) + (and (symbol? object) (not (gensym? object)))) + (let ((id (table-entry (dynamic *xp.circularity-hash-table*) object))) + (if (dynamic *xp.locating-circularities*) + ;; This is the first pass. + (cond ((not id) ;never seen before + (when (not (null? (dynamic *xp.parents*))) + (push object (dynamic *xp.parents*))) + (setf (table-entry (dynamic *xp.circularity-hash-table*) object) + 0) + '#f) + ((zero? id) ;possible second occurrence + (cond ((or (null? (dynamic *xp.parents*)) + (memq object (dynamic *xp.parents*))) + (setf (table-entry + (dynamic *xp.circularity-hash-table*) object) + (incf (dynamic *xp.locating-circularities*))) + 'subsequent) + (else '#f))) + (else 'subsequent));third or later occurrence + ;; This is the second pass. + (cond ((or (not id) ;never seen before (note ~@* etc. conses) + (zero? id));no duplicates + '#f) + ((positive? id) ; first occurrence + (cond (interior-cdr? + (decf (dynamic *xp.current-level*)) + (xp.write-string++ ". #" xp 0 3)) + (else (xp.write-char++ #\# xp))) + (xp.print-integer id xp) + (xp.write-char++ #\= xp) + (setf (table-entry (dynamic *xp.circularity-hash-table*) object) + (- id)) + 'first) + (else + (if interior-cdr? + (xp.write-string++ ". #" xp 0 3) + (xp.write-char++ #\# xp)) + (xp.print-integer(- id) xp) + (xp.write-char++ #\# xp) + 'subsequent)))))) + + +;;; Here are all the standard Common Lisp printing functions. + +(define (print object . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (dynamic-let ((*print-escape* '#t)) + (terpri stream) + (write object stream) + (write-char #\space stream) + object))) + +(define (prin1 object . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (dynamic-let ((*print-escape* '#t)) + (write object stream) + object))) + +(define (princ object . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (dynamic-let ((*print-escape* '#f)) + (write object stream) + object))) + +(define (display object . maybe-stream) + (apply (function princ) object maybe-stream)) + + +(define (pprint object . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (dynamic-let ((*print-escape* '#t) + (*print-pretty* '#t)) + (terpri stream) + (write object stream) + (values)))) + +(define (prin1-to-string object) + (call-with-output-string + (lambda (stream) + (dynamic-let ((*print-escape* '#t)) + (write object stream))))) + +(define (princ-to-string object) + (call-with-output-string + (lambda (stream) + (dynamic-let ((*print-escape* '#f)) + (write object stream))))) + + + +(define (write-char char . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (if (xp.xp-structure-p stream) + (xp.write-char+ char stream) + (internal-write-char char stream)) + char)) + +(define (write-string mystring . maybe-stream-start-end) + (let* ((stream (if (not (null? maybe-stream-start-end)) + (car maybe-stream-start-end) + (current-output-port))) + (start (if (not (null? (cdr maybe-stream-start-end))) + (cadr maybe-stream-start-end) + 0)) + (end (if (not (null? (cddr maybe-stream-start-end))) + (caddr maybe-stream-start-end) + (string-length mystring)))) + (if (xp.xp-structure-p stream) + (xp.write-string+ mystring stream start end) + (internal-write-string mystring stream start end)) + mystring)) + +(define (write-line mystring . maybe-stream-start-end) + (let* ((stream (if (not (null? maybe-stream-start-end)) + (car maybe-stream-start-end) + (current-output-port))) + (start (if (not (null? (cdr maybe-stream-start-end))) + (cadr maybe-stream-start-end) + 0)) + (end (if (not (null? (cddr maybe-stream-start-end))) + (caddr maybe-stream-start-end) + (string-length mystring)))) + (if (xp.xp-structure-p stream) + (begin + (xp.write-string+ mystring stream start end) + (xp.pprint-newline+ 'unconditional stream)) + (begin + (internal-write-string mystring stream start end) + (internal-newline stream))) + mystring)) + +(define (terpri . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (if (xp.xp-structure-p stream) + (xp.pprint-newline+ 'unconditional stream) + (internal-newline stream)) + '#f)) + +(define (newline . maybe-stream) + (apply (function terpri) maybe-stream)) + + +;;; This has to violate the XP data abstraction and fool with internal +;;; stuff, in order to find out the right info to return as the result. + +(define (fresh-line . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (cond ((xp.xp-structure-p stream) + (xp.attempt-to-output stream '#t '#t) ;ok because we want newline + (when (not (zero? (xp.lp<-bp stream))) + (xp.pprint-newline+ 'fresh stream) + '#t)) + (else + (internal-fresh-line stream))))) + + +;;; Each of these causes the stream to be pessimistic and insert +;;; newlines wherever it might have to, when forcing the partial output +;;; out. This is so that things will be in a consistent state if +;;; output continues to the stream later. + +(define (finish-output . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (if (xp.xp-structure-p stream) + (xp.attempt-to-output stream '#t '#t) + (internal-finish-output stream)) + '#f)) + +(define (force-output . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (if (xp.xp-structure-p stream) + (xp.attempt-to-output stream '#t '#t) + (internal-force-output stream)) + '#f)) + +(define (clear-output . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (if (xp.xp-structure-p stream) + (dynamic-let ((*xp.locating-circularities* 0)) ;hack to prevent visible output + (xp.attempt-to-output stream '#t '#t) + (internal-clear-output stream))) + '#f)) + + + + +;;;===================================================================== +;;; Functional interface to dynamic formatting +;;;===================================================================== + +;;; The internal functions in this file, and the (formatter "...") expansions +;;; use the '+' forms of these functions directly (which is faster) because, +;;; they do not need error checking or fancy stream coercion. The '++' forms +;;; additionally assume the thing being output does not contain a newline. + +(define-syntax (pprint-logical-block stream-symbol-stuff . body) + (let* ((stream-symbol (car stream-symbol-stuff)) + (mylist (cadr stream-symbol-stuff)) + (rest (cddr stream-symbol-stuff)) + (prefix (if (not (null? rest)) (pop rest) "")) + (suffix (if (not (null? rest)) (pop rest) "")) + (per-line? (if (not (null? rest)) (pop rest) '#f))) + `(xp.maybe-initiate-xp-printing + (lambda (,stream-symbol) + (let ((+l ,mylist) + (+p ,prefix) + (+s ,suffix) + (+x ,stream-symbol)) + (xp.pprint-logical-block+ (+x +l +p +s ,per-line? '#t '#f) + ,@body + '#f))) + ,stream-symbol))) + + +;;; Assumes var and args must be variables. Other arguments must be literals +;;; or variables. + +(define-syntax (xp.pprint-logical-block+ stuff . body) + (let* ((var (pop stuff)) + (args (pop stuff)) + (prefix (pop stuff)) + (suffix (pop stuff)) + (per-line? (pop stuff))) + `(unless (xp.check-abbreviation ,var ,args) + (dynamic-let ((*xp.current-level* (1+ (dynamic *xp.current-level*))) + (*xp.current-length* -1) + (*xp.parents* (dynamic *xp.parents*))) + (block logical-block + (if (dynamic *print-pretty*) + (xp.start-block ,var ,prefix ,per-line? ,suffix) + (xp.write-prefix-suffix ,prefix ,var)) + (unwind-protect + (begin ,@body) + (if (dynamic *print-pretty*) + (xp.end-block ,var ,suffix) + (xp.write-prefix-suffix ,suffix ,var)))))) + )) + +(define (xp.check-abbreviation xp object) + (cond ((and (dynamic *print-level*) + (>= (dynamic *xp.current-level*) + (dynamic *print-level*))) + (xp.write-char++ #\# XP) + (setf (dynamic *xp.abbreviation-happened*) '#t) + '#t) + ((and (dynamic *xp.circularity-hash-table*) + (eq? (xp.circularity-process xp object '#f) 'subsequent)) + '#t) + (else '#f))) + + +(define-syntax (pprint-pop) + `(xp.pprint-pop+ +l +x)) + +(define-syntax (xp.pprint-pop+ args xp) + `(if (xp.pprint-pop-check+ ,args ,xp) + (return-from logical-block '#f) + (if (null? ,args) '() (pop ,args)))) + +(define (xp.pprint-pop-check+ args xp) + (incf (dynamic *xp.current-length*)) + (cond ((not (or (pair? args) (null? args))) + ;; must be first to supersede length abbreviation + (xp.write-string++ ". " xp 0 2) + (xp.write+ args xp) + '#t) + ((and (dynamic *print-length*) + (not (< *xp.current-length* (dynamic *print-length*)))) + ;; must supersede circularity check + (xp.write-string++ "..." xp 0 3) + (setf (dynamic *xp.abbreviation-happened*) '#t) + '#t) + ((and (dynamic *xp.circularity-hash-table*) + (not (zero? *xp.current-length*))) + (case (xp.circularity-process xp args '#t) + ((first) + (xp.write+ (cons (car args) (cdr args)) xp) '#t) + ((subsequent) + '#t) + (else + '#f))) + (else + '#f))) + +(define-syntax (pprint-exit-if-list-exhausted) + `(xp.pprint-exit-if-list-exhausted+ +l)) + +(define-syntax (xp.pprint-exit-if-list-exhausted+ mylist) + `(if (null? ,mylist) (return-from logical-block '#f))) + + +(define (pprint-newline kind . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (when (not (memq kind '(linear miser fill mandatory))) + (error "Invalid KIND argument ~A to PPRINT-NEWLINE" kind)) + (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*)) + (xp.pprint-newline+ kind stream)) + '#f)) + +(define (pprint-indent relative-to n . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (when (not (memq relative-to '(block current))) + (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to)) + (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*)) + (xp.pprint-indent+ relative-to n stream)) + '#f)) + +(define (pprint-tab kind colnum colinc . maybe-stream) + (let ((stream (if (not (null? maybe-stream)) + (car maybe-stream) + (current-output-port)))) + (when (not (memq kind '(line section line-relative section-relative))) + (error "Invalid KIND argument ~A to PPRINT-TAB" kind)) + (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*)) + (xp.pprint-tab+ kind colnum colinc stream)) + '#f)) + + + + +;;;===================================================================== +;;; Standard print dispatch function +;;;===================================================================== + + +(define (xp.print-null object xp) + (declare (ignore object)) + (xp.write-string+ "()" xp 0 2)) + +(define (xp.print-true object xp) + (declare (ignore object)) + (xp.write-string+ "#t" xp 0 2)) + +(define (xp.print-false object xp) + (declare (ignore object)) + (xp.write-string+ "#f" xp 0 2)) + +(define (xp.print-symbol object xp) + (if (dynamic *print-escape*) + (xp.print-default object xp) + (let ((mystring (symbol->string object))) + (xp.write-string+ mystring xp 0 (string-length mystring))))) + +(define (xp.print-number object xp) + (if (and (integer? object) + (eqv? (dynamic *print-base*) 10) + (not (dynamic *print-radix*))) + (begin + (when (negative? object) + (xp.write-char++ #\- xp) + (setf object (- object))) + (xp.print-integer object xp)) + (xp.print-default object xp))) + +(define (xp.print-integer n xp) + (let ((quot (quotient n 10)) + (rem (remainder n 10))) + (unless (zero? quot) + (xp.print-integer quot xp)) + (xp.write-char++ (string-ref "0123456789" rem) xp))) + +(define (xp.print-string object xp) + (if (dynamic *print-escape*) + (begin + (xp.write-char++ #\" xp) + (do ((i 0 (1+ i)) + (n (string-length object))) + ((= i n)) + (let ((c (string-ref object i))) + (if (or (char=? c #\") (char=? c #\\)) + (xp.write-char++ #\\ xp)) + (xp.write-char++ c xp))) + (xp.write-char++ #\" xp)) + (xp.write-string+ object xp 0 (string-length object)))) + +(define (xp.print-character object xp) + (if (dynamic *print-escape*) + (let ((name (char-name object))) + (xp.write-char++ #\# xp) + (xp.write-char++ #\\ xp) + (if name + (xp.write-string++ name xp 0 (string-length name)) + (xp.write-char++ object xp))) + (xp.write-char+ object xp))) + +(define (xp.print-vector object xp) + (let* ((pretty? (dynamic *print-pretty*)) + (end (vector-length object))) + (pprint-logical-block (xp '() "#(" ")") + (do ((i 0 (1+ i))) + ((eqv? i end) '#f) + (when (not (eqv? i 0)) + (xp.write-char++ #\space xp) + (if pretty? + (xp.pprint-newline+ 'fill xp))) + (pprint-pop) + (xp.write+ (vector-ref object i) xp) + )))) + +(define (xp.print-table object xp) + (let ((pretty? (dynamic *print-pretty*))) + (pprint-logical-block (xp '() "#<Table" ">") + (table-for-each + (lambda (key value) + (xp.write-char++ #\space xp) + (if pretty? + (xp.pprint-newline+ 'fill xp)) + (pprint-pop) + (xp.write+ (cons key value) xp)) + object)))) + +(define (xp.print-pair object xp) + (if (dynamic *print-pretty*) + (xp.pretty-print-list object xp) + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (do () + ((null? object) '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (when (not (null? object)) (xp.write-char++ #\space xp)))))) + +(define (xp.print-struct object xp) + (if (dynamic *print-structure*) + (print-structure-default object xp) + (funcall (get-structure-printer (struct-type-descriptor object)) + object xp))) + +(define (get-structure-printer td) + (or (td-printer td) + (if (eq? (td-name td) 'struct) + (function print-structure-default) + (get-structure-printer (td-parent-type td))))) + + + +(define (print-structure-default object xp) + (let* ((td (struct-type-descriptor object)) + (slots (td-slots td)) + (pretty? (dynamic *print-pretty*))) + (pprint-logical-block (xp '() "#<Struct " ">") + (prin1 (td-name td) xp) + (when (dynamic *print-structure-slots*) + (dolist (s slots) + (write-char #\space xp) + (if pretty? (pprint-newline 'fill xp)) + (pprint-pop) + (prin1 (sd-name s) xp) + (write-char #\space xp) + (write (funcall (sd-getter-function s) object) xp))) + ))) + + +;;; This table can't be initialized until after all the functions +;;; have been defined. + +(define *standard-print-dispatch-table* + (list (cons (function null?) (function xp.print-null)) + (cons (lambda (x) (eq? x '#t)) (function xp.print-true)) + (cons (function not) (function xp.print-false)) + (cons (function symbol?) (function xp.print-symbol)) + (cons (function number?) (function xp.print-number)) + (cons (function pair?) (function xp.print-pair)) + (cons (function string?) (function xp.print-string)) + (cons (function char?) (function xp.print-character)) + (cons (function struct?) (function xp.print-struct)) + (cons (function vector?) (function xp.print-vector)) + (cons (function table?) (function xp.print-table)))) + +(define (standard-print-dispatch object) + (standard-print-dispatch-aux + object (dynamic *standard-print-dispatch-table*))) + +(define (standard-print-dispatch-aux object table) + (cond ((null? table) (function xp.print-default)) + ((funcall (car (car table)) object) + (cdr (car table))) + (else + (standard-print-dispatch-aux object (cdr table))))) + +(setf (dynamic *print-dispatch*) (function standard-print-dispatch)) + + + +;;;===================================================================== +;;; Pretty printing formats for code +;;;===================================================================== + + +;;; The standard prettyprinters for lists dispatch off the CAR of the list. + +(define *xp.pair-dispatch-table* (make-table)) + +(define (xp.pretty-print-list object xp) + (funcall (or (table-entry (dynamic *xp.pair-dispatch-table*) (car object)) + (if (symbol? (car object)) (function xp.fn-call) '#f) + (lambda (object xp) + (pprint-fill xp object))) + object + xp)) + + +;;; Must use pprint-logical-block (no +) in the following three, because they +;;; are exported functions. +;;; *** Note that the argument order on these is backwards; that's the +;;; *** way it is in Common Lisp.... + +(define (pprint-linear s object . moreargs) + (let* ((colon? (if (not (null? moreargs)) (pop moreargs) '#t)) + (atsign? (if (not (null? moreargs)) (pop moreargs) '#f))) + (declare (ignore atsign?)) + (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (do () ('#f) + (xp.write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (xp.write-char++ #\space s) + (xp.pprint-newline+ 'linear s))))) + +(define (pprint-fill s object . moreargs) + (let* ((colon? (if (not (null? moreargs)) (pop moreargs) '#t)) + (atsign? (if (not (null? moreargs)) (pop moreargs) '#f))) + (declare (ignore atsign?)) + (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (do () ('#f) + (xp.write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (xp.write-char++ #\space s) + (xp.pprint-newline+ 'fill s))))) + +(define (pprint-tabular s object . moreargs) + (let* ((colon? (if (not (null? moreargs)) (pop moreargs) '#t)) + (atsign? (if (not (null? moreargs)) (pop moreargs) '#f)) + (tabsize (or (and (not (null? moreargs)) (pop moreargs)) 16))) + (declare (ignore atsign?)) + (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (do () ('#f) + (xp.write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (xp.write-char++ #\space s) + (xp.pprint-tab+ 'section-relative 0 tabsize s) + (xp.pprint-newline+ 'fill s))))) + + +(define (xp.fn-call object xp) + ;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-indent+ 'current 0 xp) + (xp.pprint-newline+ 'miser xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + + +;;; Although idiosyncratic, I have found this very useful to avoid large +;;; indentations when printing out code. + +(define (xp.alternative-fn-call object xp) + (if (> (string-length (symbol->string (car object))) 12) + ;; (formatter "~:<~1I~@{~W~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.pprint-indent+ 'block 1 xp) + (when (not (null? object)) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + (xp.fn-call object xp))) + + +(define (xp.bind-list object xp . args) + (declare (ignore args)) + ;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (when (not (null? object)) + (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f))))) + +(define (xp.fbind-list object xp . args) + (declare (ignore args)) + ;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (when (not (null? object)) + (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.block-like (xp.pprint-pop+ object xp) xp))))) + + +(define (xp.block-like object xp . args) + (declare (ignore args)) + ;; (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.pprint-indent+ 'block 1 xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'miser xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + + +(define (xp.print-fancy-fn-call object xp template) + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-indent+ 'current 1 xp) + (do ((i 0 (1+ i)) + (in-first-section '#t)) + ((null? object) '#f) + (xp.write-char++ #\space xp) + (when (eqv? i (car template)) + (xp.pprint-indent+ 'block (cadr template) xp) + (setf template (cddr template)) + (setf in-first-section '#f)) + (pprint-newline (cond ((zero? i) 'miser) + (in-first-section 'fill) + (else 'linear)) + xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + +(define (xp.let-print object xp) + ;; (formatter "~:<~1I~W~^ ~@_~/xp:xp.bind-list/~^~@{ ~_~W~^~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.pprint-indent+ 'block 1 xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'miser xp) + (xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f) + (xp.pprint-exit-if-list-exhausted+ object) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + +(define (xp.flet-print object xp) + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.pprint-indent+ 'block 1 xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'miser xp) + (xp.fbind-list (xp.pprint-pop+ object xp) xp '#f '#f) + (xp.pprint-exit-if-list-exhausted+ object) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + +(define (xp.cond-print object xp) + ;; (formatter "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-indent+ 'current 0 xp) + (xp.pprint-newline+ 'miser xp) + (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f)))) + +(define (xp.do-print object xp) + ;; (formatter "~:<~W~^ ~:I~@_~/xp:xp.bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-indent+ 'current 0 xp) + (xp.pprint-newline+ 'miser xp) + (xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f) + (xp.write-char++ #\space xp) + (xp.pprint-indent+ 'block 1 xp) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp)))) + +(define (xp.mvb-print object xp) + (xp.print-fancy-fn-call object xp '(1 3 2 1))) + +(define (xp.setf-print object xp) + ;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") + (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (xp.pprint-exit-if-list-exhausted+ object) + (xp.write-char++ #\space xp) + (xp.pprint-indent+ 'current 0 xp) + (xp.pprint-newline+ 'miser xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (do () + ((null? object) '#f) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'fill xp) + (xp.write+ (xp.pprint-pop+ object xp) xp) + (when (not (null? object)) + (xp.write-char++ #\space xp) + (xp.pprint-newline+ 'linear xp) + (xp.write+ (xp.pprint-pop+ object xp) xp))))) + +(define (xp.quote-print object xp) + (if (and (pair? (cdr object)) (null? (cddr object))) + (begin + (xp.write-char++ #\' xp) + (xp.write+ (cadr object) xp)) + (pprint-fill xp object))) + +(define (xp.up-print object xp) + (xp.print-fancy-fn-call object xp '(0 3 1 1))) + + +;;; Install printers for built-in macros and special forms into the +;;; standard dispatch table. + +(define-local-syntax (define-printer symbol function) + `(setf (table-entry (dynamic *xp.pair-dispatch-table*) ',symbol) + (function ,function))) + + +;;; *** Missing support for backquote here. + +(define-printer quote xp.quote-print) +(define-printer lambda xp.block-like) +(define-printer when xp.block-like) +(define-printer unless xp.block-like) +(define-printer cond xp.cond-print) +(define-printer case xp.block-like) +(define-printer setf xp.setf-print) +(define-printer set! xp.setf-print) +(define-printer let xp.let-print) +(define-printer let* xp.let-print) +(define-printer letrec xp.let-print) +(define-printer flet xp.flet-print) +(define-printer labels xp.flet-print) +(define-printer dynamic-let xp.let-print) +(define-printer block xp.block-like) +(define-printer do xp.do-print) +(define-printer dolist xp.block-like) +(define-printer dotimes xp.block-like) +(define-printer multiple-value-bind xp.mvb-print) +(define-printer let/cc xp.block-like) +(define-printer unwind-protect xp.up-print) +(define-printer define xp.block-like) +(define-printer define-syntax xp.block-like) +(define-printer define-local-syntax xp.block-like) +(define-printer pprint-logical-block xp.block-like) +(define-printer xp.pprint-logical-block+ xp.block-like) + +;;; Here are some hacks for struct macros. + +(define-printer update-slots xp.mvb-print) +(define-printer make xp.block-like) diff --git a/support/support.scm b/support/support.scm new file mode 100644 index 0000000..bdecc4f --- /dev/null +++ b/support/support.scm @@ -0,0 +1,35 @@ +;;; support.scm -- load support files shared by all systems +;;; +;;; author : Sandra Loosemore +;;; date : 28 Oct 1991 +;;; +;;; + + +;;; Keep track of all compilation units defined. +;;; This has to go here and not in compile.scm because we don't want this +;;; list reinitialized every time that file is loaded. + +(define compilation-units '()) + + +;;; Load this file first; it defines the basic compilation system support. +;;; It doesn't matter if this ends up loading source because we'll compile +;;; and reload it below. + +(load "$Y2/support/compile.scm") + + +;;; Define a real compilation unit for shared support files. + +(define-compilation-unit support + (source-filename "$Y2/support/") + (unit compile (source-filename "compile.scm")) + (unit utils (source-filename "utils.scm")) + (unit xp + (unit pprint (source-filename "pprint.scm")) + (unit format (source-filename "format.scm") + (require pprint))) + ) + + diff --git a/support/system.scm b/support/system.scm new file mode 100644 index 0000000..ac03b10 --- /dev/null +++ b/support/system.scm @@ -0,0 +1,51 @@ +;;; system.scm -- haskell system setup +;;; +;;; author : Sandra Loosemore +;;; date : 22 Nov 1991 +;;; +;;; This file loads in the compilation unit definition files for all +;;; of the components of the haskell system. +;;; +;;; (The compilation unit facility is defined in support/shared/compile.scm.) + + +;;; First load the files containing module definitions. +;;; *** Add more files to the end of this list. + +(load "$Y2/support/support") +(load "$Y2/ast/ast") +(load "$Y2/top/top") +(load "$Y2/util/haskell-utils") +(load "$Y2/printers/printers") +(load "$Y2/parser/parser") +(load "$Y2/import-export/ie.scm") +(load "$Y2/tdecl/tdecl.scm") +(load "$Y2/derived/derived.scm") +(load "$Y2/prec/prec.scm") +(load "$Y2/depend/depend.scm") +(load "$Y2/type/type.scm") +(load "$Y2/cfn/cfn.scm") +(load "$Y2/flic/flic.scm") +(load "$Y2/backend/backend.scm") +(load "$Y2/runtime/runtime.scm") +(load "$Y2/csys/csys") +(load "$Y2/command-interface/command-interface") + +;;; Define some functions to actually do the work. The compilation unit +;;; facility has conveniently kept a list of all of the unit definitions, +;;; so we can just rip through them in sequence. + +(define (compile-haskell) + (compile-and-load-unit-list compilation-units)) + +(define (recompile-haskell) + (unless (null? remaining-units) + (compile-and-load-unit-list remaining-units))) + + +(define (load-haskell) + (load-unit-list compilation-units)) + +(define (reload-haskell) + (unless (null? remaining-units) + (load-unit-list remaining-units))) diff --git a/support/utils.scm b/support/utils.scm new file mode 100644 index 0000000..ab93f6b --- /dev/null +++ b/support/utils.scm @@ -0,0 +1,408 @@ +;;; utils.scm -- utility functions +;;; +;;; author : Sandra Loosemore +;;; date : 18 Nov 1991 +;;; +;;; This file contains miscellaneous functions that are generally useful. +;;; If you find some missing feature from the base language, this is +;;; a good place to put it. Common Lisp-style sequence functions are +;;; an example of the sort of thing found here. + + +;;;===================================================================== +;;; Sequence functions +;;;===================================================================== + +(define (vector-replace to-vec from-vec to start end) + (declare (type fixnum to start end) + (type vector to-vec from-vec)) + (if (and (eq? to-vec from-vec) + (> to start)) + ;; Right shift in place + (do ((from (1- end) (1- from)) + (to (1- (+ to (- end start))))) + ((< from start) to-vec) + (declare (type fixnum from to)) + (setf (vector-ref to-vec to) (vector-ref from-vec from)) + (decf to)) + ;; Normal case, left-to-right + (do ((from start (1+ from))) + ((= from end) to-vec) + (declare (type fixnum from)) + (setf (vector-ref to-vec to) (vector-ref from-vec from)) + (incf to)))) + +(define (string-replace to-vec from-vec to start end) + (declare (type fixnum to start end) + (type string to-vec from-vec)) + (if (and (eq? to-vec from-vec) + (> to start)) + ;; Right shift in place + (do ((from (1- end) (1- from)) + (to (1- (+ to (- end start))))) + ((< from start) to-vec) + (declare (type fixnum from to)) + (setf (string-ref to-vec to) (string-ref from-vec from)) + (decf to)) + ;; Normal case, left-to-right + (do ((from start (1+ from))) + ((= from end) to-vec) + (declare (type fixnum from)) + (setf (string-ref to-vec to) (string-ref from-vec from)) + (incf to)))) + +(define (string-fill string c start end) + (declare (type fixnum start end) + (type string string) + (type char c)) + (do ((i start (1+ i))) + ((= i end) string) + (declare (type fixnum i)) + (setf (string-ref string i) c))) + +(define (string-position c string start end) + (declare (type fixnum start end) + (type string string) + (type char c)) + (cond ((= start end) '#f) + ((char=? (string-ref string start) c) start) + (else + (string-position c string (1+ start) end)))) + +(define (string-position-not-from-end c string start end) + (declare (type fixnum start end) + (type string string) + (type char c)) + (cond ((= start end) '#f) + ((not (char=? (string-ref string (setf end (1- end))) c)) + end) + (else + (string-position-not-from-end c string start end)))) + +(define (string-nreverse string start end) + (declare (type fixnum start end) + (type string string)) + (do ((i start (1+ i)) + (j (1- end) (1- j))) + ((not (< i j)) string) + (declare (type fixnum i j)) + (let ((c (string-ref string i))) + (setf (string-ref string i) (string-ref string j)) + (setf (string-ref string j) c)))) + + +(define (string-starts? s1 s2) ; true is s1 begins s2 + (and (>= (string-length s2) (string-length s1)) + (string=? s1 (substring s2 0 (string-length s1))))) + + +;;;===================================================================== +;;; Table utilities +;;;===================================================================== + + +(define (table->list table) + (let ((l '())) + (table-for-each + (lambda (key val) (push (cons key val) l)) table) + l)) + +(define (list->table l) + (let ((table (make-table))) + (dolist (p l) + (setf (table-entry table (car p)) (cdr p))) + table)) + + + +;;;===================================================================== +;;; Tuple utilities +;;;===================================================================== + +;;; For future compatibility with a typed language, define 2 tuples with +;;; a few functions: (maybe add 3 tuples someday!) + +(define-integrable (tuple x y) + (cons x y)) + +(define-integrable (tuple-2-1 x) (car x)) ; Flic-like notation +(define-integrable (tuple-2-2 x) (cdr x)) + +(define (map-tuple-2-1 f l) + (map (lambda (x) (tuple (funcall f (tuple-2-1 x)) (tuple-2-2 x))) l)) + +(define (map-tuple-2-2 f l) + (map (lambda (x) (tuple (tuple-2-1 x) (funcall f (tuple-2-2 x)))) l)) + + +;;;===================================================================== +;;; List utilities +;;;===================================================================== + +;;; This does an assq using the second half of the tuple as the key. + +(define (rassq x l) + (if (null? l) + '#f + (if (eq? x (tuple-2-2 (car l))) + (car l) + (rassq x (cdr l))))) + +;;; This is an assoc with an explicit test + +(define (assoc/test test-fn x l) + (if (null? l) + '#f + (if (funcall test-fn x (tuple-2-1 (car l))) + (car l) + (assoc/test test-fn x (cdr l))))) + + + + +;;; Stupid position function works only on lists, uses eqv? + +(define (position item list) + (position-aux item list 0)) + +(define (position-aux item list index) + (declare (type fixnum index)) + (cond ((null? list) + '#f) + ((eqv? item (car list)) + index) + (else + (position-aux item (cdr list) (1+ index))) + )) + + +;;; Destructive delete-if function + +(define (list-delete-if f l) + (list-delete-if-aux f l l '#f)) + +(define (list-delete-if-aux f head next last) + (cond ((null? next) + ;; No more elements. + head) + ((not (funcall f (car next))) + ;; Leave this element and do the next. + (list-delete-if-aux f head (cdr next) next)) + (last + ;; Delete element from middle of list. + (setf (cdr last) (cdr next)) + (list-delete-if-aux f head (cdr next) last)) + (else + ;; Delete element from head of list. + (list-delete-if-aux f (cdr next) (cdr next) last)))) + + +;;; Same as the haskell function + +(define (concat lists) + (if (null? lists) + '() + (append (car lists) (concat (cdr lists))))) + + +;;; This is a quick & dirty list sort function. + +(define (sort-list l compare-fn) + (if (or (null? l) (null? (cdr l))) + l + (insert-sorted compare-fn (car l) (sort-list (cdr l) compare-fn)))) + +(define (insert-sorted compare-fn e l) + (if (null? l) + (list e) + (if (funcall compare-fn e (car l)) + (cons e l) + (cons (car l) (insert-sorted compare-fn e (cdr l)))))) + +(define (find-duplicates l) + (cond ((null? l) + '()) + ((memq (car l) (cdr l)) + (cons (car l) + (find-duplicates (cdr l)))) + (else (find-duplicates (cdr l))))) + +;;; A simple & slow topsort routine. +;;; Input: A list of lists. Each list is a object consed onto the +;;; list of objects it preceeds. +;;; Output: Two values: SORTED / CYCLIC & a list of either sorted objects +;;; or a set of components containing the cycle. + +(define (topsort l) + (let ((changed? '#t) + (sorted '()) + (next '())) + (do () ((not changed?) + (if (null? next) + (values 'sorted (nreverse sorted)) + (values 'cyclic (map (function car) next)))) + (setf changed? '#f) + (setf next '()) + (dolist (x l) + (cond ((topsort-aux (cdr x) sorted) + (push (car x) sorted) + (setf changed? '#t)) + (else + (push x next)))) + (setf l next)))) + + +;;; Returns true if x doesn't contain any elements that aren't in sorted. +;;; equivalent to (null? (set-intersection x sorted)), but doesn't cons +;;; and doesn't traverse the whole list in the failure case. + +(define (topsort-aux x sorted) + (cond ((null? x) + '#t) + ((memq (car x) sorted) + (topsort-aux (cdr x) sorted)) + (else + '#f))) + +(define (set-intersection s1 s2) + (if (null? s1) + '() + (let ((rest (set-intersection (cdr s1) s2))) + (if (memq (car s1) s2) + (cons (car s1) rest) + rest)))) + +;;; remove s2 elements from s1 + +(define (set-difference s1 s2) + (if (null? s1) + '() + (let ((rest (set-difference (cdr s1) s2))) + (if (memq (car s1) s2) + rest + (cons (car s1) rest))))) + + +(define (set-union s1 s2) + (if (null? s2) + s1 + (if (memq (car s2) s1) + (set-union s1 (cdr s2)) + (cons (car s2) (set-union s1 (cdr s2)))))) + + +;;; Destructive list splitter + +(define (split-list list n) + (declare (type fixnum n)) + (let ((tail1 (list-tail list (1- n)))) + (if (null? tail1) + (values list '()) + (let ((tail2 (cdr tail1))) + (setf (cdr tail1) '()) + (values list tail2))))) + + +;;; Some string utils + +(define (mem-string s l) + (and (not (null? l)) (or (string=? s (car l)) + (mem-string s (cdr l))))) + +(define (ass-string k l) + (cond ((null? l) + '#f) + ((string=? k (caar l)) + (car l)) + (else + (ass-string k (cdr l))))) + + +;;;===================================================================== +;;; Syntax extensions +;;;===================================================================== + +;;; The mlet macro combines let* and multiple-value-bind into a single +;;; syntax. + +(define-syntax (mlet binders . body) + (mlet-body binders body)) + +(define (mlet-body binders body) + (if (null? binders) + `(begin ,@body) + (let* ((b (car binders)) + (var (car b)) + (init (cadr b)) + (inner-body (mlet-body (cdr binders) body))) + (if (pair? var) + (multiple-value-bind (new-vars ignore-decl) + (remove-underlines var) + `(multiple-value-bind ,new-vars + ,init ,@ignore-decl ,inner-body)) + `(let ((,var ,init)) ,inner-body))))) + +(define (remove-underlines vars) + (if (null? vars) + (values '() '()) + (multiple-value-bind (rest ignore-decl) (remove-underlines (cdr vars)) + (if (not (eq? (car vars) '_)) + (values (cons (car vars) rest) ignore-decl) + (let ((var (gensym))) + (values (cons var rest) + `((declare (ignore ,var)) ,@ignore-decl))))))) + + + + +;;;===================================================================== +;;; Other utilities +;;;===================================================================== + +(define (add-extension name ext) + (assemble-filename (filename-place name) (filename-name name) ext)) + +(define (time-execution thunk) + (let* ((start-time (get-run-time)) + (res (funcall thunk)) + (end-time (get-run-time))) + (values res (- end-time start-time)))) + +(define (pprint-flatten code . maybe-port) + (pprint-flatten-aux + code + (if (null? maybe-port) (current-output-port) (car maybe-port)))) + +(define (pprint-flatten-aux code port) + (if (and (pair? code) + (eq? (car code) 'begin)) + (dolist (c (cdr code)) + (pprint-flatten-aux c port)) + (pprint*-aux code port))) + +(define (print-flatten code port) + (if (and (pair? code) + (eq? (car code) 'begin)) + (dolist (c (cdr code)) + (print-flatten c port)) + (begin + (internal-write code port) + (internal-newline port)))) + + +;;; Like pprint, but print newline after instead of before. + +(define (pprint* object . maybe-port) + (pprint*-aux + object + (if (null? maybe-port) (current-output-port) (car maybe-port)))) + +(define (pprint*-aux object port) + (dynamic-let ((*print-pretty* '#t)) + (prin1 object port)) + (terpri port)) + +;;; This reads stuff from a string. (Better error checks needed!) + +(define (read-lisp-object str) + (call-with-input-string str (lambda (port) (read port)))) diff --git a/tdecl/README b/tdecl/README new file mode 100644 index 0000000..62e6b0a --- /dev/null +++ b/tdecl/README @@ -0,0 +1,2 @@ +This directory contains code to convert type-related declarations to +definition form. diff --git a/tdecl/alg-syn.scm b/tdecl/alg-syn.scm new file mode 100644 index 0000000..b128486 --- /dev/null +++ b/tdecl/alg-syn.scm @@ -0,0 +1,228 @@ + +;;; Description: Convert algdata & synonym from ast to definition form. +;;; Lots of error checking. + +;;; Algdata: +;;; Errors detected: +;;; Types & classes (deriving & context) resolved +;;; context tyvars must be parameters +;;; all parameter tyvars must be referenced +;;; only parameter tyvars must be referenced + +(define (algdata->def data-decl) + (remember-context data-decl + (with-slots data-decl (context simple constrs deriving annotations) data-decl + (let* ((def (tycon-def simple)) + (tyvars (simple-tyvar-list simple)) + (enum? '#t) + (tag 0) + (derived-classes '()) + (tyvars-referenced '()) + (all-con-vars '()) + (all-strict? (process-alg-strictness-annotation annotations)) + (constr-defs + (map (lambda (constr) + (with-slots constr (constructor types) constr + (let ((constr-def (con-ref-con constructor)) + (c-arity (length types)) + (con-vars '()) + (all-types '()) + (strictness '())) + (when (not (eqv? c-arity 0)) + (setf enum? '#f)) + (dolist (type types) + (let* ((ty (tuple-2-1 type)) + (anns (tuple-2-2 type)) + (tyvars1 (resolve-type ty))) + (push ty all-types) + (push (get-constr-strictness anns all-strict?) + strictness) + (dolist (v tyvars1) + (if (not (memq v tyvars)) + (signal-bad-algdata-tyvar v))) + (setf con-vars (append tyvars1 tyvars-referenced)) + (setf tyvars-referenced + (append tyvars1 tyvars-referenced)))) + (push (tuple constr con-vars) all-con-vars) + (update-slots con constr-def + (arity c-arity) + (types (reverse all-types)) + (tag tag) + (alg def) + (infix? (con-ref-infix? constructor)) + (slot-strict? (reverse strictness))) + (incf tag) + constr-def))) + constrs))) + (dolist (class deriving) + (if (eq? (class-ref-name class) '|Printers|) + (setf (class-ref-class class) *printer-class*) + (resolve-class class)) + (when (not (eq? (class-ref-class class) *undefined-def*)) + (push (class-ref-class class) derived-classes))) + (when (not (null? constrs)) + (dolist (tyvar tyvars) + (when (not (memq tyvar tyvars-referenced)) + (signal-unreferenced-tyvar-arg tyvar)))) + (resolve-signature-aux tyvars context) + ;; This computes a signature for the datatype as a whole. + (let ((gtype (ast->gtype context simple))) + ;; This sets the signatures for the constructors + (dolist (con constr-defs) + (let* ((con-type (**arrow-type/l (append (con-types con) + (list simple)))) + (con-context (restrict-context + context (tuple-2-2 (assq con all-con-vars)))) + (con-signature (ast->gtype con-context con-type))) + (setf (con-signature con) con-signature))) + (update-slots algdata def + (n-constr (length constrs)) + (constrs constr-defs) + (context context) + (tyvars tyvars) + (signature gtype) + (classes '()) + (enum? enum?) + (tuple? (and (not (null? constrs)) (null? (cdr constrs)))) + (real-tuple? '#f) + (deriving derived-classes) + )) + (process-alg-annotations def) + def)))) + + +(define (process-alg-strictness-annotation anns) + (let ((res '#f)) + (dolist (a anns) + (if (and (annotation-value? a) + (eq? (annotation-value-name a) '|STRICT|) + (null? (annotation-value-args a))) + (setf res '#t) + (signal-unknown-annotation a))) + res)) + +(define (get-constr-strictness anns all-strict?) + (let ((res all-strict?)) + (dolist (a anns) + (cond ((annotation-value? a) + (if (and (eq? (annotation-value-name a) '|STRICT|) + (null? (annotation-value-args a))) + (setf res '#t) + (signal-unknown-annotation a))) + (else (signal-unknown-annotation a)))) + res)) + +(define (process-alg-annotations alg) + (dolist (a (module-annotations *module*)) + (when (and (annotation-value? a) + (or (eq? (annotation-value-name a) '|ImportLispType|) + (eq? (annotation-value-name a) '|ExportLispType|)) + (assq (def-name alg) (car (annotation-value-args a)))) + (if (eq? (annotation-value-name a) '|ImportLispType|) + (setf (algdata-implemented-by-lisp? alg) '#t) + (setf (algdata-export-to-lisp? alg) '#t)) + (let ((constrs (tuple-2-2 (assq (def-name alg) + (car (annotation-value-args a)))))) + (dolist (c constrs) + (process-annotated-constr + alg + (lookup-alg-constr (tuple-2-1 c) (algdata-constrs alg)) + (tuple-2-2 c))))))) + +(define (lookup-alg-constr name constrs) + (if (null? constrs) + (fatal-error 'bad-constr-name "Constructor ~A not in algdata~%" + name) + (if (eq? name (def-name (car constrs))) + (car constrs) + (lookup-alg-constr name (cdr constrs))))) + +(define (process-annotated-constr alg con lisp-fns) + ;; For nullary tuples, allow a single annotation to represent a constant + ;; and generate the test function by default. + (when (and (eqv? (con-arity con) 0) + lisp-fns + (null? (cdr lisp-fns))) + (push `(lambda (x) (eq? x ,(car lisp-fns))) lisp-fns)) + ;; Insert an implicit test function for tuples (never used anyway!) + (when (and (algdata-tuple? alg) + (eqv? (+ 1 (con-arity con)) (length lisp-fns))) + (push '(lambda (x) '#t) lisp-fns)) + (when (or (not (null? (con-lisp-fns con))) + (not (eqv? (length lisp-fns) (+ 2 (con-arity con))))) + (fatal-error 'bad-constr-annotation + "Bad annotation for ~A in ~A~%" con alg)) + (setf (con-lisp-fns con) lisp-fns)) + +(define (signal-unknown-annotation a) + (recoverable-error 'bad-annotation "Bad or misplaced annotation: ~A%" + a)) + +(define (restrict-context context vars) + (if (null? context) + '() + (let ((rest (restrict-context (cdr context) vars))) + (if (memq (context-tyvar (car context)) vars) + (cons (car context) rest) + rest)))) + +(define (signal-bad-algdata-tyvar tyvar) + (phase-error 'bad-algdata-tyvar + "~a is referenced on the right-hand side of a data type declaration,~%~ + but is not bound as a type variable." + tyvar)) + +(define (signal-unreferenced-tyvar-arg tyvar) + (phase-error 'unreferenced-tyvar-arg + "~a is bound as a type variable in a data type declaration,~%~ + but is not referenced on the right-hand side." + tyvar)) + +;;; Synonyms + +;;; Errors detected: + +(define (synonym->def synonym-decl) + (remember-context synonym-decl + (with-slots synonym-decl (simple body) synonym-decl + (let* ((def (tycon-def simple)) + (tyvars (simple-tyvar-list simple)) + (tyvars-referenced (resolve-type body))) + (dolist (v tyvars) + (if (not (memq v tyvars-referenced)) + (signal-unreferenced-synonym-arg v))) + (dolist (v tyvars-referenced) + (if (not (memq v tyvars)) + (signal-bad-synonym-tyvar v))) + (update-slots synonym def + (args tyvars) + (body body)) + (push (cons def (gather-synonyms body '())) *synonym-refs*) + def)))) + +(define (signal-bad-synonym-tyvar tyvar) + (phase-error 'bad-synonym-tyvar + "~a is referenced on the right-hand side of a type synonym declaration,~%~ + but is not bound as a type variable." + tyvar)) + +(define (signal-unreferenced-synonym-arg tyvar) + (haskell-warning 'unreferenced-synonym-arg + "~a is bound as a type variable in a type synonym declaration,~%~ + but is not referenced on the right-hand side." + tyvar)) + +(define (gather-synonyms type acc) + (cond ((tyvar? type) + acc) + ((and (synonym? (tycon-def type)) + (eq? *unit* (def-unit (tycon-def type)))) + (gather-synonyms/list (tycon-args type) + (cons (tycon-def type) acc))) + (else + (gather-synonyms/list (tycon-args type) acc)))) + +(define (gather-synonyms/list types acc) + (if (null? types) + acc + (gather-synonyms/list (cdr types) (gather-synonyms (car types) acc)))) diff --git a/tdecl/class.scm b/tdecl/class.scm new file mode 100644 index 0000000..c95bbc2 --- /dev/null +++ b/tdecl/class.scm @@ -0,0 +1,258 @@ +;;; Before classes are converted, the super class relation is computed. +;;; This sets up the super and super* field of each class and +;;; checks for the following errors: +;;; Wrong tyvar in context +;;; cyclic class structure +;;; Non-class in context + +(define (compute-super-classes modules) + (let ((all-classes '())) + (walk-modules modules + (lambda () + (dolist (c (module-classes *module*)) + (remember-context c + (with-slots class-decl (super-classes class class-var) c + (let* ((def (class-ref-class class)) + (local-ctxts '()) + (super '())) + (dolist (context super-classes) + (with-slots context (class tyvar) context + (when (not (eq? class-var tyvar)) + (signal-super-class-tyvar-error class class-var tyvar)) + (resolve-class class) + (let ((super-def (class-ref-class class))) + (when (not (eq? super-def *undefined-def*)) + (push super-def super) + (when (eq? *unit* (def-unit super-def)) + (push super-def local-ctxts)))))) + (update-slots class def + (super super) + (tyvar class-var)) + (push (cons def local-ctxts) all-classes))))))) + (multiple-value-bind (status sorted) (topsort all-classes) + (when (eq? status 'cyclic) + (signal-cyclic-class-structure sorted)) + (dolist (c sorted) + (let* ((super (class-super c)) + (super* super)) + (dolist (s super) + (setf super* (set-union super* (class-super* s))) + (setf (class-super* c) super*))))))) + +(define (signal-super-class-tyvar-error class class-var tyvar) + (recoverable-error 'super-class-tyvar-error + "The context for class ~A must only refer to type variable ~A.~%~ + Type variable ~A cannot be used here." + (class-ref-name class) class-var tyvar)) + +(define (signal-cyclic-class-structure classes) + (fatal-error 'cyclic-class-structure + "There is a cycle in the superclass relation involving these classes:~%~a" + classes)) + + +;;; This sets up the following fields in the class entry: +;;; instances '() +;;; defaults = ast for defaults +;;; kind +;;; methods +;;; signatures +;;; method-vars +;;; selectors +;;; Each method is initialized with +;;; class +;;; signature +;;; type +;;; Errors detected: +;;; signature doesnt reference class + +(define (class->def class-decl) + (remember-context class-decl + (let* ((class (class-ref-class (class-decl-class class-decl))) + (decls (class-decl-decls class-decl))) + (setf (class-instances class) '()) + (setf (class-kind class) (find-class-kind class)) + (init-methods class decls) ; sets up defaults, method signatures + (setf (class-n-methods class) (length (class-method-vars class))) + (setf (class-dict-size class) + (+ (class-n-methods class) (length (class-super* class)))) + class))) + +(define (find-class-kind class) + (cond ((not (module-prelude? *module*)) + 'other) + ((memq class + (list (core-symbol "Eq") (core-symbol "Ord") + (core-symbol "Text") (core-symbol "Binary") + (core-symbol "Ix") (core-symbol "Enum"))) + 'Standard) + ((memq class + (list (core-symbol "Num") (core-symbol "Real") + (core-symbol "Integral") (core-symbol "Fractional") + (core-symbol "Floating") (core-symbol "RealFrac") + (core-symbol "RealFloat"))) + 'Numeric) + (else + 'other))) + +(define (init-methods class decls) + (let* ((tyvar (class-tyvar class)) + (class-context (**context (**class/def class) tyvar))) + (dolist (decl decls) + (remember-context decl + (cond ((is-type? 'signdecl decl) + (let* ((signature (signdecl-signature decl)) + (vars (resolve-signature signature))) + (when (not (memq tyvar vars)) + (signal-class-sig-ignores-type signature)) + ;; Note: signature does not include defined class yet + (dolist (context (signature-context signature)) + (when (eq? tyvar (context-tyvar context)) + (signal-method-constrains-class-tyvar context))) + (setf signature (rename-class-sig-vars signature tyvar)) + (let ((gtype (ast->gtype (cons class-context + (signature-context signature)) + (signature-type signature)))) + (dolist (var-ref (signdecl-vars decl)) + (let ((var (var-ref-var var-ref))) + (setf (var-type var) gtype) + (setf (method-var-method-signature var) signature)))))) + (else ; decl must be a default definition + (let ((vars (collect-pattern-vars (valdef-lhs decl)))) + (dolist (var-ref vars) + (resolve-var var-ref) + (let* ((method-name (var-ref-name var-ref)) + (method-var (var-ref-var var-ref))) + (when (not (eq? method-var *undefined-def*)) + (if (and (method-var? method-var) + (eq? (method-var-class method-var) class)) + (let ((default-var + (make-new-var + (string-append + "default-" + (symbol->string (def-name method-var)))))) + (setf (var-ref-var var-ref) default-var) + (setf (var-ref-name var-ref) (def-name default-var)) + (when (not (eq? (method-var-default method-var) '#f)) + (signal-multiple-definition-of-default method-name)) + (setf (method-var-default method-var) default-var) + (let* ((sig (method-var-method-signature method-var)) + (context (cons class-context + (signature-context sig))) + (new-sig (**signature context + (signature-type sig)))) + (add-new-module-signature default-var new-sig))) + (signal-default-not-in-class method-var class))))) + (add-new-module-decl decl)))))))) + +(define (signal-class-sig-ignores-type signature) + (phase-error 'class-sig-ignores-type + "The method signature ~a does not reference the overloaded type." + signature)) + + +;;; *** I don't understand this message. + +(define (signal-method-constrains-class-tyvar context) + (phase-error 'method-constrains-class-tyvar + "Individual methods may not further constrain a class: ~A" context)) + + +;;; *** I don't understand this message. + +(define (signal-multiple-definition-of-default method-name) + (phase-error 'multiple-definition-of-default + "More that one default for ~A." + method-name)) + + +;;; *** I don't understand this message. + +(define (signal-default-not-in-class method-var class) + (phase-error 'default-not-in-class + "~A is not a method in class ~A." + method-var class)) + + +(define (create-selector-functions class) + (let ((res '())) + (dolist (c (cons class (class-super* class))) + (dolist (m (class-method-vars c)) + (let* ((var (make-new-var + (string-append "sel-" + (symbol->string (def-name class)) + "/" + (symbol->string (def-name m))))) + (sel-body (create-selector-code class m))) + (setf (var-selector-fn? var) '#t) + (push (tuple m var) res) + (when (not (eq? (module-type *module*) 'interface)) + (add-new-module-def var sel-body))))) + res)) + +(define (create-selector-code c m) + (let ((var (create-local-definition '|d|))) + (setf (var-force-strict? var) '#t) + (let ((body (create-selector-code-1 c m (**var/def var)))) + (**lambda/pat (list (**var-pat/def var)) body)))) + +(define (create-selector-code-1 class method d) + (let ((mcl (method-var-class method))) + (cond ((eq? mcl class) + (**dsel/method class method d)) + (else + (**dsel/method mcl method (**dsel/dict class mcl d)))))) + +;;; The following code is for the alpha conversion of method +;;; signatures. The class tyvar is unchanged; all others are renamed. +;;; This is needed because all method types are combined to form the +;;; dictionary signature and aliasing among different tyvars should be +;;; prevented. + +(define (rename-class-sig-vars signature tyvar) + (mlet (((new-context env1) + (rename-context-vars (signature-context signature) + (list (tuple tyvar tyvar)))) + ((new-type _) + (rename-type-vars (signature-type signature) env1))) + (**signature new-context new-type))) + +(define (rename-context-vars contexts env) + (if (null? contexts) + (values '() env) + (mlet (((new-tyvar env1) + (rename-sig-tyvar (context-tyvar (car contexts)) env)) + ((rest env2) + (rename-context-vars (cdr contexts) env1))) + (values (cons (**context (context-class (car contexts)) new-tyvar) rest) + env2)))) + +(define (rename-type-vars type env) + (if (tyvar? type) + (mlet (((tyvar env1) + (rename-sig-tyvar (tyvar-name type) env))) + (values (**tyvar tyvar) env1)) + (mlet (((new-types env1) (rename-type-vars/l (tycon-args type) env))) + (values (**tycon/def (tycon-def type) new-types) env1)))) + +(define (rename-type-vars/l types env) + (if (null? types) + (values '() env) + (mlet (((type1 env1) (rename-type-vars (car types) env)) + ((new-types env2) (rename-type-vars/l (cdr types) env1))) + (values (cons type1 new-types) env2)))) + +(define (rename-sig-tyvar tyvar env) + (let ((res (assq tyvar env))) + (if (eq? res '#f) + (let ((new-tyvar (gentyvar (symbol->string tyvar)))) + (values new-tyvar (cons (tuple tyvar new-tyvar) env))) + (values (tuple-2-2 res) env)))) + +(define *tyvar-counter* 0) + +;;; This generates a new interned tyvar name + +(define (gentyvar root) + (incf *tyvar-counter*) + (string->symbol (format '#f "~A-~A" root *tyvar-counter*))) diff --git a/tdecl/instance.scm b/tdecl/instance.scm new file mode 100644 index 0000000..1866339 --- /dev/null +++ b/tdecl/instance.scm @@ -0,0 +1,296 @@ +;;; tdecl/instance.scm + +;;; Convert an instance decl to a definition + +;;; The treatment of instances is more complex than the treatment of other +;;; type definitions due to the possibility of derived instances. +;;; Here's the plan: +;;; a) instance-decls are converted to instance structures. The type +;;; information is verified but the decls are unchanged. +;;; b) All instances are linked into the associated classes. +;;; c) Derived instances are generated. +;;; d) Instance dictionaries are generated from the decls in the instances. +;;; + +;;; Instances-decl to instance definition conversion +;;; Errors detected: +;;; Class must be a class +;;; Data type must be an alg +;;; Tyvars must be distinct +;;; Correct number of tyvars +;;; Context applies only to tyvars in simple +;;; C-T restriction + +;;; Needs work for interface files. + +(define (instance->def inst-decl) + (recover-errors '#f + (remember-context inst-decl + (with-slots instance-decl (context class simple decls) inst-decl + (resolve-type simple) + (resolve-class class) + (let ((alg-def (tycon-def simple)) + (class-def (class-ref-class class))) + (when (not (algdata? (tycon-def simple))) + (signal-datatype-required (tycon-def simple))) + (let ((tyvars (simple-tyvar-list simple))) + (resolve-signature-aux tyvars context) + (when (and (not (eq? *module-name* (def-module alg-def))) + (not (eq? *module-name* (def-module class-def)))) + (signal-c-t-rule-violation class-def alg-def)) + (let ((old-inst (lookup-instance alg-def class-def))) + (when (and (not (eq? old-inst '#f)) + (not (instance-special? old-inst))) + (signal-multiple-instance class-def alg-def)) + (let ((inst (new-instance class-def alg-def tyvars))) + (setf (instance-context inst) context) + (setf (instance-decls inst) decls) + (setf (instance-ok? inst) '#t) + inst)))))))) + +(define (signal-datatype-required def) + (phase-error 'datatype-required + "The synonym type ~a cannot be declared as an instance." + (def-name def))) + +(define (signal-c-t-rule-violation class-def alg-def) + (phase-error 'c-t-rule-violation + "Instance declaration does not appear in the same module as either~%~ + the class ~a or type ~a." + class-def alg-def)) + +(define (signal-multiple-instance class-def alg-def) + (phase-error 'multiple-instance + "The type ~a has already been declared to be an instance of class ~a." + alg-def class-def)) + +;;; This generates the dictionary for each instance and makes a few final +;;; integrity checks in the instance context. This happens after derived +;;; instances are inserted. + +(define (expand-instance-decls inst) + (when (instance-ok? inst) + (check-inst-type inst) + (with-slots instance (class algdata dictionary decls context tyvars) inst + (let ((simple (**tycon/def algdata (map (function **tyvar) tyvars)))) + (setf (instance-gcontext inst) + (gtype-context (ast->gtype/inst context simple))) + (with-slots class (super* method-vars) class + ;; Before computing signatures uniquify tyvar names to prevent + ;; collision with method tyvar names + (let ((new-tyvars (map (lambda (tyvar) (tuple tyvar (gentyvar "tv"))) + (instance-tyvars inst)))) + (setf (instance-tyvars inst) (map (function tuple-2-2) new-tyvars)) + (setf (instance-context inst) + (map (lambda (c) + (**context (context-class c) + (tuple-2-2 (assq (context-tyvar c) new-tyvars)))) + (instance-context inst)))) + ;; Now walk over the decls & rename each method with a unique name + ;; generated by combining the class, type, and method. Watch for + ;; multiple defs of methods and add defaults after all decls have + ;; been scanned. + (let ((methods-used '()) + (new-instance-vars (map (lambda (m) + (tuple m (method-def-var m inst))) + method-vars))) + (dolist (decl decls) + (setf methods-used + (process-instance-decl decl new-instance-vars methods-used))) + ;; now add defaults when needed + (dolist (m-v new-instance-vars) + (let* ((method-var (tuple-2-1 m-v)) + (definition-var (tuple-2-2 m-v)) + (signature (generate-method-signature inst method-var '#t))) + (if (memq method-var methods-used) + (add-new-module-signature definition-var signature) + (let ((method-body + (if (eq? (method-var-default method-var) '#f) + (**abort (format '#f + "No method declared for method ~A in instance ~A(~A)." + method-var class algdata)) + (**var/def (method-var-default method-var))))) + (add-new-module-def definition-var method-body) + (add-new-module-signature definition-var signature))))) + (setf (instance-methods inst) new-instance-vars) + (add-new-module-def dictionary + (**tuple/l (append (map (lambda (m-v) + (dict-method-ref + (tuple-2-1 m-v) (tuple-2-2 m-v) inst)) + new-instance-vars) + (map (lambda (c) + (get-class-dict algdata c)) + super*)))) + (let ((dict-sig (generate-dictionary-signature inst))) + (add-new-module-signature dictionary dict-sig)) + (setf (instance-decls inst) '()))))))) + +(define (dict-method-ref method-var inst-var inst) + (if (null? (signature-context (method-var-method-signature method-var))) + (**var/def inst-var) + (let* ((sig (generate-method-signature inst method-var '#f)) + (ctxt (signature-context sig)) + (ty (signature-type sig))) + (make overloaded-var-ref + (sig (ast->gtype ctxt ty)) + (var inst-var))))) + +(define (get-class-dict algdata class) + (let ((inst (lookup-instance algdata class))) + (if (eq? inst '#f) + (**abort "Missing super class") + (**var/def (instance-dictionary inst))))) + +(define (process-instance-decl decl new-instance-vars methods-used) + (if (valdef? decl) + (rename-instance-decl decl new-instance-vars methods-used) + (begin + (dolist (a (annotation-decls-annotations decl)) + (cond ((annotation-value? a) + (recoverable-error 'misplaced-annotation + "Misplaced annotation: ~A~%" a)) + (else + (dolist (name (annotation-decl-names a)) + (attach-method-annotation + name (annotation-decl-annotations a) new-instance-vars))))) + methods-used))) + +(define (attach-method-annotation name annotations vars) + (cond ((null? vars) + (signal-no-method name)) + ((eq? name (def-name (tuple-2-1 (car vars)))) + (setf (var-annotations (tuple-2-2 (car vars))) + (append annotations (var-annotations (tuple-2-2 (car vars)))))) + (else (attach-method-annotation name annotations (cdr vars))))) + +(define (signal-no-method name) + (recoverable-error 'no-method "~A is not a method in this class.~%" + name)) + +(define (rename-instance-decl decl new-instance-vars methods-used) + (let ((decl-vars (collect-pattern-vars (valdef-lhs decl)))) + (dolist (var decl-vars) + (resolve-var var) + (let ((method (var-ref-var var))) + (when (not (eq? method *undefined-def*)) + (let ((m-v (assq method new-instance-vars))) + (cond ((memq method methods-used) + (signal-multiple-instance-def method)) + ((eq? m-v '#f) + (signal-not-in-class method)) + (else + (setf (var-ref-name var) (def-name (tuple-2-2 m-v))) + (setf (var-ref-var var) (tuple-2-2 m-v)) + (push (tuple-2-1 m-v) methods-used))))))) + (add-new-module-decl decl) + methods-used)) + +(define (signal-multiple-instance-def method) + (phase-error 'multiple-instance-def + "The instance declaration has multiple definitions of the method ~a." + method)) + +(define (signal-not-in-class method) + (phase-error 'not-in-class + "The instance declaration includes a definition for ~a,~%~ + which is not one of the methods for this class." + method)) + + +(define (method-def-var method-var inst) + (make-new-var + (string-append "i-" + (symbol->string (print-name (instance-class inst))) "-" + (symbol->string (print-name (instance-algdata inst))) "-" + (symbol->string (def-name method-var))))) + +(define (generate-method-signature inst method-var keep-method-context?) + (let* ((simple-type (make-instance-type inst)) + (class-context (instance-context inst)) + (class-tyvar (class-tyvar (instance-class inst))) + (signature (method-var-method-signature method-var))) + (make signature + (context (if keep-method-context? + (append class-context (signature-context signature)) + class-context)) + (type (substitute-tyvar (signature-type signature) class-tyvar + simple-type))))) + +(define (make-instance-type inst) + (**tycon/def (instance-algdata inst) + (map (function **tyvar) (instance-tyvars inst)))) + +(define (generate-dictionary-signature inst) + (**signature (sort-inst-context-by-tyvar + (instance-context inst) (instance-tyvars inst)) + (generate-dictionary-type inst (make-instance-type inst)))) + +(define (sort-inst-context-by-tyvar ctxt tyvars) + (concat (map (lambda (tyvar) + (extract-single-context tyvar ctxt)) tyvars))) + +(define (extract-single-context tyvar ctxt) + (if (null? ctxt) + '() + (let ((rest (extract-single-context tyvar (cdr ctxt)))) + (if (eq? tyvar (context-tyvar (car ctxt))) + (cons (car ctxt) rest) + rest)))) + +(define (generate-dictionary-type inst simple) + (let* ((class (instance-class inst)) + (algdata (instance-algdata inst)) + (tyvar (class-tyvar class))) + (**tuple-type/l (append (map (lambda (method-var) + ;; This ignores the context associated + ;; with a method + (let ((sig (method-var-method-signature + method-var))) + (substitute-tyvar (signature-type sig) + tyvar + simple))) + (class-method-vars class)) + (map (lambda (super-class) + (generate-dictionary-type + (lookup-instance algdata super-class) + simple)) + (class-super* class)))))) + +;;; Checks performed here: +;;; Instance context must include the following: +;;; Context associated with data type +;;; Context associated with instances for each super class +;;; All super class instances must exist + +(define (check-inst-type inst) + (let* ((class (instance-class inst)) + (algdata (instance-algdata inst)) + (inst-context (instance-gcontext inst)) + (alg-context (gtype-context (algdata-signature algdata)))) + (when (not (full-context-implies? inst-context alg-context)) + (signal-instance-context-needs-alg-context algdata)) + (dolist (super-c (class-super class)) + (let ((super-inst (lookup-instance algdata super-c))) + (cond ((eq? super-inst '#f) + (signal-no-super-class-instance class algdata super-c)) + (else + (when (not (full-context-implies? + inst-context (instance-context super-inst))) + (signal-instance-context-insufficient-for-super + class algdata super-c)))))) + )) + +(define (signal-instance-context-needs-alg-context algdata) + (phase-error 'instance-context-needs-alg-context + "The instance context needs to include context defined for data type ~A." + algdata)) + +(define (signal-no-super-class-instance class algdata super-c) + (fatal-error 'no-super-class-instance + "The instance ~A(~A) requires that the instance ~A(~A) be provided." + class algdata super-c algdata)) + +(define (signal-instance-context-insufficient-for-super class algdata super-c) + (phase-error 'instance-context-insufficient-for-super + "Instance ~A(~A) does not imply super class ~A instance context." + class algdata super-c)) diff --git a/tdecl/tdecl-utils.scm b/tdecl/tdecl-utils.scm new file mode 100644 index 0000000..0009eeb --- /dev/null +++ b/tdecl/tdecl-utils.scm @@ -0,0 +1,16 @@ +;;; This file contains routines which generate the code for the +;;; dictionaries used in the class system. + +(define (make-sel-node size i) + (**lambda '(x) + (if (eqv? size 1) + (**var 'x) + (**sel (tuple-constructor size) (**var 'x) i)))) + +(define (make-compose f1 f2) + (**lambda '(x) + (**app f1 (**app f2 (**var 'x))))) + +(define (make-new-var name) ; name is a string + (create-definition *module* (string->symbol name) 'var)) + diff --git a/tdecl/tdecl.scm b/tdecl/tdecl.scm new file mode 100644 index 0000000..227171e --- /dev/null +++ b/tdecl/tdecl.scm @@ -0,0 +1,18 @@ +;;; -- compilation unit definition for type declaration analysis +;;; +;;; author : John +;;; + +(define-compilation-unit tdecl + (source-filename "$Y2/tdecl/") + (require global) + (unit type-declaration-analysis + (source-filename "type-declaration-analysis.scm")) + (unit tdecl-utils + (source-filename "tdecl-utils.scm")) + (unit alg-syn + (source-filename "alg-syn.scm")) + (unit class + (source-filename "class.scm")) + (unit instance + (source-filename "instance.scm"))) diff --git a/tdecl/type-declaration-analysis.scm b/tdecl/type-declaration-analysis.scm new file mode 100644 index 0000000..bffcb23 --- /dev/null +++ b/tdecl/type-declaration-analysis.scm @@ -0,0 +1,72 @@ +;;; This processes type declarations (data, type, instance, class) +;;; Static errors in type declarations are detected and type decls +;;; are replaced by type definitions. All code (class and instance +;;; definitions) is moved to the module decls. + +(define *synonym-refs* '()) + +(predefine (add-derived-instances modules)) ; in derived/derived-instances.scm + +(define (process-type-declarations modules) +;;; Convert data & type decls to definitions + (let ((interface? (eq? (module-type (car modules)) 'interface))) + (setf *synonym-refs* '()) + (walk-modules modules + (lambda () + (setf (module-alg-defs *module*) + (map (function algdata->def) (module-algdatas *module*))) + (setf (module-synonym-defs *module*) + (map (function synonym->def) (module-synonyms *module*))) + (when (not interface?) + (dolist (ty (default-decl-types (module-default *module*))) + (resolve-type ty)))) + ;; A test to see that ty is in Num and is a monotype is needed here. + ) + (multiple-value-bind (ty vals) (topsort *synonym-refs*) + (when (eq? ty 'cyclic) (signal-recursive-synonyms vals))) + ;; Build the class heirarchy + (compute-super-classes modules) + ;; Convert class declarations and instance declarations to definitions. + (walk-modules modules + (lambda () + (setf (module-class-defs *module*) + (map (function class->def) (module-classes *module*))))) + (walk-modules modules + (lambda () + (dolist (class (module-class-defs *module*)) + (setf (class-selectors class) (create-selector-functions class))))) + (walk-modules modules + (lambda () + (setf (module-instance-defs *module*) '()) + (dolist (inst-decl (module-instances *module*)) + (let ((inst (instance->def inst-decl))) + (when (not (eq? inst '#f)) + (push inst (module-instance-defs *module*))))))) + (add-derived-instances modules) + (walk-modules modules + (lambda () + (dolist (inst (module-instance-defs *module*)) + (expand-instance-decls inst)))) + (when (not interface?) + (walk-modules modules + (lambda () + (dolist (ty (default-decl-types (module-default *module*))) + (resolve-type ty))))) + )) + + +(define (signal-recursive-synonyms vals) + (fatal-error 'recursive-synonyms + "There is a cycle in type synonym definitions involving these types:~%~a" + vals)) + +(define (add-new-module-decl decl) + (setf (module-decls *module*) (cons decl (module-decls *module*)))) + +(define (add-new-module-def var value) + (add-new-module-decl + (**define var '() value))) + +(define (add-new-module-signature var signature) + (add-new-module-decl + (**signdecl/def (list var) signature))) diff --git a/top/README b/top/README new file mode 100644 index 0000000..6657292 --- /dev/null +++ b/top/README @@ -0,0 +1,12 @@ +This directory contains the top level of the compiler. +Files found here: + +phases - the top level calls to the compiler phases; compilation init code +errors - general error handlers +globals - global variable definitions +core-symbols - defines core symbols +system-init - code to run once after the compiler is loaded. +driver - top level functions which drive the compiler. There are called + from the command interface or directly from the user. + + diff --git a/top/core-definitions.scm b/top/core-definitions.scm new file mode 100644 index 0000000..e86b355 --- /dev/null +++ b/top/core-definitions.scm @@ -0,0 +1,149 @@ +;;; This file defines core symbols - those in PreludeCore and +;;; other Prelude symbols used in compilation. + +;;; This part is constructed from the export table of PreludeCore +;;; by 'top/prelude-core-syms' and has been pasted in here. + + +(DEFINE *haskell-prelude-vars* + '((CLASSES "Num" + "Integral" + "Eq" + "Text" + "Fractional" + "RealFloat" + "RealFrac" + "Enum" + "Ix" + "Floating" + "Ord" + "Real" + "Binary") + (METHODS "fromInteger" + "signum" + "abs" + "negate" + "*" + "-" + "+" + "toInteger" + "odd" + "even" + "divMod" + "quotRem" + "mod" + "div" + "rem" + "quot" + "/=" + "==" + "showList" + "readList" + "showsPrec" + "readsPrec" + "fromRational" + "recip" + "/" + "scaleFloat" + "significand" + "exponent" + "encodeFloat" + "decodeFloat" + "floatRange" + "floatDigits" + "floatRadix" + "floor" + "ceiling" + "round" + "truncate" + "properFraction" + "enumFromThenTo" + "enumFromTo" + "enumFromThen" + "enumFrom" + "inRange" + "index" + "range" + "atanh" + "acosh" + "asinh" + "tanh" + "cosh" + "sinh" + "atan" + "acos" + "asin" + "tan" + "cos" + "sin" + "logBase" + "**" + "sqrt" + "log" + "exp" + "pi" + "min" + "max" + ">" + ">=" + "<=" + "<" + "toRational" + "showBin" + "readBin") + (TYPES "Char" + "Complex" + "Integer" + "Double" + "Bin" + "Array" + "Float" + "Bool" + "Int" + "Assoc" + "Ratio" + "SystemState" + "IOResult") + (CONSTRUCTORS ":+" "True" "False" ":=" ":") + (SYNONYMS "ShowS" "ReadS" "String" "Rational" "IO") + (VALUES))) + +;;; Non PreludeCore stuff + +;;; This table defines all symbols in the core used internally by the +;;; compiler. + +(define *haskell-noncore-vars* '( + (types + "List" + "Arrow" + "Request" + "Response" + "UnitType" + "TupleDicts") + (constructors + "MkFloat" + "MkDouble" + "MkChar" + "MkInteger" + "MkInt" + "Nil" + "UnitConstructor") + (values + "&&" "||" "primPlusInt" + "++" "take" "drop" "." "showChar" "shows" "showString" + "showParen" "lex" "readParen" "reads" + "primShowBinInt" "primReadBinSmallInt" + "error" + "primIntegerToInt" "primIntToInteger" + "primRationalToFloat" "primRationalToDouble" + "primNegInt" "primNegInteger" "primNegFloat" "primNegDouble" + "foldr" "build" "inlineFoldr" "inlineBuild" + "primAppend" "primStringEq" + "dictSel" "tupleEqDict" "tupleOrdDict" "tupleIxDict" + "tupleTextDict" "tupleBinaryDict"))) + + + + + diff --git a/top/core-init.scm b/top/core-init.scm new file mode 100644 index 0000000..7ba9fa1 --- /dev/null +++ b/top/core-init.scm @@ -0,0 +1,14 @@ + + +(define *core-symbols* '()) +(define *prelude-core-symbols* '()) + +; expands into lots of (define *core-??* '()) + +(define-core-variables) + +(define (init-core-symbols) + (setf *core-symbols* (make-table)) + (setf *prelude-core-symbols* (make-table)) + (create-core-globals)) + diff --git a/top/core-symbols.scm b/top/core-symbols.scm new file mode 100644 index 0000000..f43de93 --- /dev/null +++ b/top/core-symbols.scm @@ -0,0 +1,126 @@ +;;; This defines all core symbols. + +;;; Core symbols are stored in global variables. The core-symbol +;;; macro just turns a string into a variable name. + +(define-syntax (core-symbol str) + (make-core-symbol-name str)) + +(define (make-core-symbol-name str) + (string->symbol (string-append "*core-" str "*"))) + +(define (symbol->core-var name) + (make-core-symbol-name (symbol->string name))) + +(define (get-core-var-names vars type) + (let ((res (assq type vars))) + (if (eq? res '#f) + '() + (map (function string->symbol) (tuple-2-2 res))))) + +;;; This is just used to create a define for each var without a +;;; value. + +(define-syntax (define-core-variables) + `(begin + ,@(define-core-variables-1 *haskell-prelude-vars*) + ,@(define-core-variables-1 *haskell-noncore-vars*))) + +(define (define-core-variables-1 vars) + (concat (map (lambda (ty) + (map (function init-core-symbol) + (get-core-var-names vars ty))) + '(classes methods types constructors synonyms values)))) + +(define (init-core-symbol sym) + `(define ,(symbol->core-var sym) '())) + +(define-syntax (create-core-globals) + `(begin + (begin ,@(create-core-defs *haskell-prelude-vars* '#t)) + (begin ,@(create-core-defs *haskell-noncore-vars* '#f)))) + +(define (create-core-defs defs prelude-core?) + `(,@(map (lambda (x) (define-core-value x prelude-core?)) + (get-core-var-names defs 'values)) + ,@(map (lambda (x) (define-core-method x prelude-core?)) + (get-core-var-names defs 'methods)) + ,@(map (lambda (x) (define-core-synonym x prelude-core?)) + (get-core-var-names defs 'synonyms)) + ,@(map (lambda (x) (define-core-class x prelude-core?)) + (get-core-var-names defs 'classes)) + ,@(map (lambda (x) (define-core-type x prelude-core?)) + (get-core-var-names defs 'types)) + ,@(map (lambda (x) (define-core-constr x prelude-core?)) + (get-core-var-names defs 'constructors)))) + + +(define (define-core-value name pc?) + `(setf ,(symbol->core-var name) + (make-core-value-definition ',name ',pc?))) + +(define (make-core-value-definition name pc?) + (install-core-sym + (make var (name name) (module '|*Core|) (unit '|*Core|)) + name + pc?)) + +(define (define-core-method name pc?) + `(setf ,(symbol->core-var name) + (make-core-method-definition ',name ',pc?))) + +(define (make-core-method-definition name pc?) + (install-core-sym + (make method-var (name name) (module '|*Core|) (unit '|*Core|)) + name + pc?)) + +(define (define-core-class name pc?) + `(setf ,(symbol->core-var name) + (make-core-class-definition ',name ',pc?))) + +(define (make-core-class-definition name pc?) + (install-core-sym + (make class (name name) (module '|*Core|) (unit '|*Core|)) + name + pc?)) + +(define (define-core-synonym name pc?) + `(setf ,(symbol->core-var name) + (make-core-synonym-definition ',name ',pc?))) + +(define (make-core-synonym-definition name pc?) + (install-core-sym + (make synonym (name name) (module '|*Core|) (unit '|*Core|)) + name + pc?)) + +(define (define-core-type name pc?) + `(setf ,(symbol->core-var name) + (make-core-type-definition ',name ',pc?))) + +(define (make-core-type-definition name pc?) + (install-core-sym + (make algdata (name name) (module '|*Core|) (unit '|*Core|)) + name + pc?)) + +(define (define-core-constr name pc?) + `(setf ,(symbol->core-var name) + (make-core-constr-definition ',name ',pc?))) + +(define (make-core-constr-definition name pc?) + (setf name (add-con-prefix/symbol name)) + (install-core-sym + (make con (name name) (module '|*Core|) (unit '|*Core|)) + name + pc?)) + +(define (install-core-sym def name preludecore?) + (setf (def-core? def) '#t) + (when preludecore? + (setf (def-prelude? def) '#t)) + (setf (table-entry (dynamic *core-symbols*) name) def) + (when preludecore? + (setf (table-entry (dynamic *prelude-core-symbols*) name) def)) + def) diff --git a/top/errors.scm b/top/errors.scm new file mode 100644 index 0000000..06a2f66 --- /dev/null +++ b/top/errors.scm @@ -0,0 +1,119 @@ +;;; This file contains general error handling routines. + +;;; This is the general error handler. It has three arguments: an +;;; id, error type, and an error message. The message is a list of +;;; format, arglist combinations. + +;;; The error types are: +;;; warning -> control returns and compilation proceeds +;;; The message may be suppressed +;;; recoverable -> control returns and compilation proceeds +;;; phase -> control returns but compilation is aborted +;;; after the phase in *abort-point*. +;;; fatal -> control goes back to the top level +;;; internal -> enters the break loop or does a fatal error + +;;; Two globals control error behavior: +;;; *break-on-error?* enter the break loop on any error +;;; *never-break?* never enter the break loop, even for internal errors. + +;;; The global *error-output-port* controls where errors are printer. + +;;; The strategy here is to first write a banner message based on the id and +;;; type, write out the messages, and then take action depending on the type. + +(define *in-error-handler?* '#f) + +(define (haskell-error id type messages) + (format *error-output-port* "~&[~A] ~A in phase ~A:~%" + id (err-type->banner type) (dynamic *phase*)) + (dolist (m messages) + (apply (function format) *error-output-port* m) + (fresh-line *error-output-port*)) + (maybe-show-context (dynamic *context*)) + (if (dynamic *in-error-handler?*) + (error "Recursive error in haskell-error.") + (begin + (dynamic-let ((*in-error-handler?* '#t)) + (cond (*break-on-error?* + (haskell-breakpoint)) + ((eq? type 'internal) + (if *never-break?* + (abort-compilation) + (haskell-breakpoint))) + ((eq? type 'fatal) + (abort-compilation)) + ((eq? type 'phase) + (halt-compilation)))) + (when (and (memq type '(recoverable phase)) + (dynamic *recoverable-error-handler*)) + (funcall (dynamic *recoverable-error-handler*))) + 'ok))) + +(define (err-type->banner err-type) + (cond ((eq? err-type 'warning) + "Warning") + ((eq? err-type 'recoverable) + "Recoverable error") + ((eq? err-type 'phase) + "Phase error") + ((eq? err-type 'fatal) + "Fatal error") + ((eq? err-type 'internal) + "Internal-error") + (else "???"))) + +(define (maybe-show-context context) + (when context + (with-slots source-pointer (line file) (ast-node-line-number context) + (fresh-line *error-output-port*) + (format *error-output-port* "Error occurred at line ~A in file ~A.~%" + line (filename-name file))))) + +;;; A few entry points into the error system. +;;; As a matter of convention, there should be a signaling function defined +;;; for each specific error condition that calls one of these functions. +;;; Error messages should be complete sentences with proper punctuation +;;; and capitalization. The signaling function should use the message +;;; to report the error and not do any printing of its own. + +(define (fatal-error id . msg) + (haskell-error id 'fatal (list msg))) + +(define (haskell-warning id . msg) + (haskell-error id 'warning (list msg))) + +(define (recoverable-error id . msg) + (haskell-error id 'recoverable (list msg))) + +(define (compiler-error id . msg) + (haskell-error id 'internal (list msg))) + +(define (phase-error id . msg) + (haskell-error id 'phase (list msg))) + +;;; This function puts the compiler into the lisp breakloop. this may +;;; want to fiddle the programming envoronment someday. + +(define (haskell-breakpoint) + (error "Haskell breakpoint.")) + + +;;; This deals with error at runtime + +(define (haskell-runtime-error msg) + (format '#t "~&Haskell runtime abort.~%~A~%" msg) + (funcall (dynamic *runtime-abort*))) + +;; Some common error handlers + +(define (signal-unknown-file-type filename) + (fatal-error 'unknown-file-type + "The filename ~a has an unknown file type." + filename)) + +(define (signal-file-not-found filename) + (fatal-error 'file-not-found + "The file ~a doesn't exist." + filename)) + diff --git a/top/globals.scm b/top/globals.scm new file mode 100644 index 0000000..eba139b --- /dev/null +++ b/top/globals.scm @@ -0,0 +1,75 @@ +;;; These are global variables used throughout the compiler. + +;;; Configuration stuff + +(define *prelude-unit-filename* "$PRELUDE/Prelude.hu") + +(define *haskell-compiler-version* "Y2.0.5") +(define *haskell-compiler-update* "") + + +;;; Control over the init process +(define *haskell-initialized?* '#f) + +;;; Error control +(define *break-on-error?* '#f) +(define *never-break?* '#f) + +(define *runtime-abort* '()) + +(define *recoverable-error-handler* '()) +(define *error-output-port* '()) ; initialized later + +(define *context* '#f) ; ast node being compiled. + +(define *unit* '()) + +(define *standard-module-default* '()) + +(define *undefined-def* '()) +(define *printer-class* '()) +(define *printers* '(phase-time)) + +(define *all-printers* + '(phase-time time compiling loading reading extension + parse import type-decl scope depend + type cfn depend2 + flic optimize optimize-extra strictness codegen codegen-flic + dumper dump-stat)) + +;;; Global context stuff +;;; ***This variable is actually only used by the parser. + +(define *current-file* '()) + +(define *printed-tyvars* '()) + + +;;; Used by the symbol table routines + +(define *modules* '()) ; maps module name -> module structure +(define *module* '()) ; current module +(define *module-name* '()) +(define *symbol-table* '()) ; part of the current module +(define *inverted-symbol-table* '()) ; maps def -> localname +(define *fixity-table* '()) ; name -> fixity +(define *suffix-table* '()) ; name -> int (for uniquifying names) + +(define *special-parse-for-type-macros* '#f) + +;;; These are for diagnostic purposes only + +(define *big-let* '()) + +(define *show-end-of-phase* '#f) + +;;; This is used to configure error messages & responses. + +(define *emacs-mode* '#f) + +;;; This is used to stash the Prelude symbol environment + +(define *prelude-symbol-table* '()) +(define *prelude-fixity-table* '()) +(define *prelude-inverted-symbol-table* '()) + diff --git a/top/has-macros.scm b/top/has-macros.scm new file mode 100644 index 0000000..2c75730 --- /dev/null +++ b/top/has-macros.scm @@ -0,0 +1,57 @@ +;;; General macros for the Haskell compiler + +(define-syntax (remember-context exp . body) + (let ((temp (gensym))) + `(let ((,temp ,exp)) + (dynamic-let ((*context* (if (ast-node-line-number ,temp) + ,temp + (dynamic *context*)))) + ,@body)))) + +(define-syntax (maybe-remember-context exp . body) + (let ((temp (gensym))) + `(let ((,temp ,exp)) + (if (ast-node-line-number ,temp) + (dynamic-let ((*context* ,temp)) ,@body) + (begin ,@body))))) + +(define-syntax (recover-errors error-value . body) + (let ((local-handler (gensym))) + `(let/cc ,local-handler + (dynamic-let ((*recoverable-error-handler* + (lambda () (funcall ,local-handler ,error-value)))) + ,@body)))) + +;;; This is for iterating a list of contexts over a list of types. + +(define-syntax (do-contexts cbinder tbinder . body) + (let ((cvar (car cbinder)) + (cinit (cadr cbinder)) + (tvar (car tbinder)) + (tinit (cadr tbinder)) + (cv (gensym)) + (tv (gensym))) + `(do ((,cv ,cinit (cdr ,cv)) + (,tv ,tinit (cdr ,tv))) + ((null? ,cv)) + (let ((,tvar (car ,tv))) + (dolist (,cvar (car ,cv)) + ,@body))))) + +;; dolist for 2 lists at once. + +(define-syntax (dolist2 a1 a2 . body) + (let ((a1var (car a1)) + (a1init (cadr a1)) + (a2var (car a2)) + (a2init (cadr a2)) + (a1l (gensym)) + (a2l (gensym))) + `(do ((,a1l ,a1init (cdr ,a1l)) + (,a2l ,a2init (cdr ,a2l))) + ((null? ,a1l)) + (let ((,a1var (car ,a1l)) + (,a2var (car ,a2l))) + ,@body)))) + +
\ No newline at end of file diff --git a/top/has-utils.scm b/top/has-utils.scm new file mode 100644 index 0000000..62a0c3f --- /dev/null +++ b/top/has-utils.scm @@ -0,0 +1,21 @@ +;;; These utilities are specific to the Haskell language. + +(define (add-con-prefix str) ; should be in some utility file + (string-append ";" str)) + +(define (remove-con-prefix string) + (substring string 1 (string-length string))) + +(define (has-con-prefix? string) + (char=? (string-ref string 0) '#\;)) + +(define (add-con-prefix/symbol sym) + (string->symbol (add-con-prefix (symbol->string sym)))) + +(define (remove-con-prefix/symbol sym) + (string->symbol (remove-con-prefix (symbol->string sym)))) + +(define (has-con-prefix/symbol? sym) + (has-con-prefix? (symbol->string sym))) + + diff --git a/top/phases.scm b/top/phases.scm new file mode 100644 index 0000000..706c541 --- /dev/null +++ b/top/phases.scm @@ -0,0 +1,226 @@ + +;;; This is the top-level phase structure of the compiler. + +;;; Compilation phase support + +(define *phase* '#f) +(define *abort-phase* '#f) ; abort when this phase completes +(define *abort-compilation* + (lambda () + (error "No error continuation defined here!"))) + +(define *module-asts* '()) ; a global only for debugging purposes + +;;; Later add the printing and timing stuff here + +(define-local-syntax (phase-body phase-name body printer) + `(dynamic-let ((*phase* ',phase-name)) + (when (memq ',phase-name (dynamic *printers*)) + (format '#t "~%Phase ~a:~%" ',phase-name) + (force-output)) + (let* ((phase-start-time (get-run-time)) + (result ,body) + (current-time (get-run-time))) + (when (eq? (dynamic *abort-phase*) ',phase-name) + (abort-compilation)) + ,@(if (eq? printer '#f) + '() + `((when (memq ',phase-name (dynamic *printers*)) + (funcall ,printer result) + (force-output)))) + (when (memq 'phase-time *printers*) + (let ((elapsed-time (- current-time phase-start-time))) + (format '#t "~&~A complete: ~A seconds~%" + ',phase-name elapsed-time) + (force-output))) + result))) + + + +;;; Returns 2 values: module ast's and lisp code. + +(define (compile-haskell-files files) + (dynamic-let ((*abort-phase* '#f)) + (let ((all-mods (haskell-parse-files files)) + (interface-mods '()) + (regular-mods '())) + (dolist (m all-mods) + (if (eq? (module-type m) 'interface) + (push m interface-mods) + (push m regular-mods))) + (dynamic-let ((*unit* (module-name (car all-mods)))) + (values + all-mods + `(begin + ,(if interface-mods + (compile-interface-modules (nreverse interface-mods)) + '#f) + ,(if regular-mods + (compile-modules (nreverse regular-mods)) + '#f)) + ))))) + + + +(define (compile-modules mods) + (dynamic-let ((*context* '#f) + (*recoverable-error-handler* '#f) + (*abort-phase* '#f) + (*unique-name-counter* 1) + (*suffix-table* (make-table))) + (haskell-import-export mods '#f) + (haskell-process-type-declarations mods) + (haskell-scope mods) + (let ((big-let (haskell-dependency-analysis mods))) + (cond ((not (void? big-let)) + (haskell-type-check big-let mods) + (setf big-let (haskell-cfn big-let)) + (setf big-let (haskell-dependency-reanalysis big-let)) + (setf big-let (haskell-ast-to-flic big-let)) + (setf big-let (haskell-optimize big-let)) + (setf big-let (haskell-strictness big-let)) + (haskell-codegen big-let mods)) + (else + ''#f) + )))) + + +(define (modules->lisp-code modules) + (dynamic-let ((*unit* (module-name (car modules)))) + (compile-modules modules))) + + +(predefine (notify-error)) ; in command-interface/command-utils.scm + +(define (abort-compilation) + (notify-error) + (funcall (dynamic *abort-compilation*))) + +(define (halt-compilation) + (setf (dynamic *abort-phase*) (dynamic *phase*))) + + +;;; Here are the actual phase bodies + +(predefine (parse-files files)) + +(define (haskell-parse-files filenames) + (phase-body parse + (let ((mods (parse-files filenames))) + mods) + #f)) + +(predefine (import-export modules)) ; in import-export/import-export.scm +(predefine (import-export/interface modules)) + +(define (haskell-import-export modules interface?) + (phase-body import + (if interface? + (import-export/interface modules) + (import-export modules)) + #f)) + + +(predefine (process-type-declarations modules)) + ; in tdecl/type-declaration-analysis.scm + +(define (haskell-process-type-declarations modules) + (phase-body type-decl + (begin + (process-type-declarations modules)) + #f)) + + +(predefine (scope-modules x)) ; in prec/scope.scm +(predefine (print-full-module x . maybe-stream)) ; in the printers + +(define (haskell-scope modules) + (phase-body scope + (scope-modules modules) + (lambda (result) + (declare (ignore result)) + (dolist (m modules) (print-full-module m))) + )) + + +(predefine (do-dependency-analysis x)) ; in depend/dependency-analysis.scm + +(define (haskell-dependency-analysis modules) + (phase-body depend + (do-dependency-analysis modules) + (function pprint*))) + + +(predefine (do-haskell-type-check big-let mods)) + +(define (haskell-type-check big-let modules) + (phase-body type + (do-haskell-type-check big-let modules) + #f)) + +(predefine (cfn-ast x)) ; in cfn/main.scm + +(define (haskell-cfn big-let) + (phase-body cfn + (cfn-ast big-let) + (function pprint*))) + + +(predefine (analyze-dependency-top x)) ; in depend/dependency-analysis.scm + +(define (haskell-dependency-reanalysis big-let) + (phase-body depend2 + (begin + (analyze-dependency-top big-let) + big-let) + (function pprint*))) + + +(predefine (ast-to-flic x)) ; in flic/ast-to-flic.scm + +(define (haskell-ast-to-flic big-let) + (phase-body flic + (ast-to-flic big-let) + (function pprint*))) + + +(predefine (optimize-top x)) ; in backend/optimize.scm + +(define (haskell-optimize big-let) + (phase-body optimize + (optimize-top big-let) + (function pprint*))) + +(predefine (strictness-analysis-top x)) ; in backend/strictness.scm +(predefine (strictness-analysis-printer x)) + +(define (haskell-strictness big-let) + (phase-body strictness + (strictness-analysis-top big-let) + (function strictness-analysis-printer))) + + +(predefine (codegen-top x)) ; in backend/codegen.scm +(predefine (codegen-exported-types x)) ; " +(predefine (codegen-prim-entries x)) ; ditto + +(define (haskell-codegen big-let mods) + (phase-body codegen + `(begin + ,(codegen-exported-types mods) + ,(codegen-top big-let)) + #f)) + + +;;; This is for interface modules. + +(predefine (haskell-codegen/interface mods)) + +(define (compile-interface-modules mods) + (dynamic-let ((*context* '#f) + (*recoverable-error-handler* '#f) + (*abort-phase* '#f)) + (haskell-import-export mods '#t) + (haskell-process-type-declarations mods) + (haskell-scope mods) + (haskell-codegen/interface mods))) diff --git a/top/prelude-core-syms.scm b/top/prelude-core-syms.scm new file mode 100644 index 0000000..ddae21f --- /dev/null +++ b/top/prelude-core-syms.scm @@ -0,0 +1,57 @@ +;;; This should be used to create core symbols for every name exported +;;; by PreludeCore. This only needs to run when the Prelude definition +;;; changes. + +(define (def->name-string x) + (symbol->string (def-name x))) + + +(define (generate-prelude-core-symbols) + (initialize-compilation) + (load-compilation-unit *prelude-unit-filename* '#t '#f '#f '#f) + (let* ((core (table-entry *modules* '|PreludeCore|)) + (export-table (module-export-table core)) + (vars '()) + (classes '()) + (types '()) + (constrs '()) + (syns '()) + (methods '())) + (table-for-each + (lambda (k v) + (declare (ignore k)) + (let ((def (tuple-2-2 (car v)))) + (cond ((var? def) + (push (def->name-string def) vars)) + ((synonym? def) + (push (def->name-string def) syns)) + ((algdata? def) + (push (def->name-string def) types) + (dolist (x (cdr v)) + (push (remove-con-prefix (def->name-string (tuple-2-2 x))) + constrs))) + ((class? def) + (push (def->name-string def) classes) + (dolist (x (cdr v)) + (push (def->name-string (tuple-2-2 x)) + methods))) + (else (error "? strange def"))))) + export-table) + (call-with-output-file "/tmp/prelude-syms" + (lambda (port) + (pprint `(define *haskell-prelude-vars* + '((classes ,@classes) + (methods ,@methods) + (types ,@types) + (constructors ,@constrs) + (synonyms ,@syns) + (values ,@vars))) + port))))) + + + +(define (create-prelude-init-code defs) + (let* ((name (def-name def)) + (sym-name (make-core-symbol-name name))) + `(define sym-name '()))) + diff --git a/top/symbol-table.scm b/top/symbol-table.scm new file mode 100644 index 0000000..499bfb8 --- /dev/null +++ b/top/symbol-table.scm @@ -0,0 +1,412 @@ +;;; These routines deal with the global symbol table. The symbol table +;;; is represented in two stages: a module table which maps module names +;;; onto module structures and local tables within each module which +;;; map names (symbols) to definitions. + +;;; The following functions deal with the module table (*modules*): + +;;; (initialize-module-table) - this clears out all modules from the +;;; symbol table. Every compilation should start with this. +;;; (add-module-to-module-table module) - this takes a module ast, +;;; either from a .exp file or previous compilation with the same +;;; incarnation of the compiler and adds it to the set of `known' +;;; modules. Incomplete module ast's in the process of compilation +;;; are also added to this table. + + +(define (initialize-module-table) + (setf *modules* (make-table))) + +(define (add-module-to-symbol-table module) + (let* ((name (module-name module)) + (old-module (table-entry *modules* name))) + (when (not (eq? old-module '#f)) + (if (eq? *unit* (module-unit old-module)) + (signal-module-double-definition name) + (signal-module-already-defined name))) + (setf (table-entry *modules* name) module))) + +(define (remove-module-from-symbol-table module) + (let ((name (module-name module))) + (setf (table-entry *modules* name) '#f))) + +(define (locate-module name) + (table-entry *modules* name)) + +;;; (walk-modules fn mod-list) - this calls fn for each module in the +;;; mod-list. It also binds the global variable *module* to the +;;; current module, *symbol-table* to the local symbol +;;; table. The fixity table is also placed in a global. + +(define (walk-modules mods fn) + (dolist (mod mods) + (dynamic-let ((*module* mod) + (*module-name* (module-name mod)) + (*symbol-table* (module-symbol-table mod)) + (*fixity-table* (module-fixity-table mod)) + (*inverted-symbol-table* (module-inverted-symbol-table mod))) + (funcall fn)))) + +;;; create-definition makes a new definition object + +(define (create-definition module name type) + (cond ((module-prelude? module) + (let ((def (table-entry *core-symbols* name))) + (cond ((eq? def '#f) + (create-definition/non-core module name type)) + (else + (setf (def-unit def) *unit*) + (setf (def-module def) (module-name module)) + ;; *** Should any other properties be reinitialized here? + (cond ((or (eq? type 'var) (eq? type 'method-var)) + (setf (var-fixity def) '#f) + (setf (var-signature def) '#f)) + ((eq? type 'con) + (setf (con-fixity def) '#f))) + def)))) + (else (create-definition/non-core module name type)))) + +;(define (create-definition/non-core module name type) +; (create-definition/new module name type) +; (let* ((interface (module-interface-module module)) +; (old-def (table-entry (module-symbol-table interface) name))) +; (if (eq? old-def '#f) +; (create-definition/new module name type) +; (cond ((eq? type 'var) +; (unless (var? old-def) +; (def-conflict module name type old-def)) +; (setf (var-interface-type old-def) (var-type old-def))) +; ((eq? type 'con) +; (unless (con? old-def) +; (def-conflict module name type old-def))) +; ((eq? type 'synonym) +; (unless (synonym? old-def) +; (def-conflict module name type old-def))) +; ((eq? type 'algdata) +; (unless (algdata? old-def) +; (def-conflict module name type old-def))) +; ((eq? type 'class) +; (unless (class? old-def) +; (def-conflict module name type old-def))) +; ((eq? type 'method-var) +; (unless (method-var? old-def) +; (def-conflict module name type old-def))))) +; (setf (def-unit old-def) *unit*) +; old-def))) +; +;(define (def-conflict module name type def) +; (phase-error 'interface-conflict +; "The ~A ~A in module ~A was defined as a ~A in an interface." +; (cond ((var? def) "variable") +; ((class? def) "class") +; ((algdata? def) "data type") +; ((synonym? def) "synonym") +; ((con? def) "constructor") +; (else "widgit")) +; name (module-name module) type)) + +(define (create-definition/non-core module name type) + (let ((mname (module-name module))) + (when (eq? (module-type *module*) 'interface) + (mlet (((mod name1) (rename-interface-symbol name))) + (setf mname mod) + (setf name name1))) + (create-definition/inner mname name type))) + +(define (create-definition/inner mname name type) + (cond ((eq? type 'var) + (make var (name name) (module mname) (unit *unit*))) + ((eq? type 'con) + (make con (name name) (module mname) (unit *unit*))) + ((eq? type 'synonym) + (make synonym (name name) (module mname) (unit *unit*))) + ((eq? type 'algdata) + (make algdata (name name) (module mname) (unit *unit*))) + ((eq? type 'class) + (make class (name name) (module mname) (unit *unit*))) + ((eq? type 'method-var) + (make method-var (name name) (module mname) (unit *unit*))) + (else + (error "Bad type argument ~s." type)))) + + +(define (create-top-definition name type) + (let ((def (create-definition *module* name type))) + (insert-top-definition name def) + def)) + +;;; Interfaces have a special table which resolves imports in the +;;; interface. Given a name in an interface module this returns the +;;; corresponding full name: a (module,original-name) pair. Symbols not +;;; imported are assumed to be defined in the interface. + +(define (rename-interface-symbol name) + (let ((res (assq name (module-interface-imports *module*)))) + (if (eq? res '#f) + (values *module-name* name) + (values (tuple-2-1 (tuple-2-2 res)) + (tuple-2-2 (tuple-2-2 res)))))) + +;;; This creates a locally defined var node. + +(define (create-local-definition name) + (let ((var (make var (name name) (module *module-name*) (unit *unit*)))) + (setf (var-fixity var) (table-entry *fixity-table* name)) + var)) + + +;;; This function creates a new variable. +;;; The "root" may be either a symbol or a string. +;;; *unit* defines the home module of the variable. + +;;; *** Maybe it would be possible to hack this so that it doesn't +;;; *** create any symbol at all until the name is demanded by something, +;;; *** but that seems like a rather sweeping change. + +(define (create-temp-var root) + (let* ((name (gensym (if (symbol? root) (symbol->string root) root))) + (module *unit*)) + (make var (name name) (module module) (unit *unit*)))) + + +;;; The following routines install top level definitions into the symbol +;;; table. + +(predefine (signal-multiple-name-conflict name old-local-name def)) + ; in import-export/ie-errors.scm + +(define (insert-top-definition name def) + (let ((old-definition (resolve-toplevel-name name))) + (cond ((eq? old-definition '#f) + (when (not (def-prelude? def)) + (setf (table-entry *symbol-table* name) def)) + (when (and (var? def) (not (eq? (var-fixity def) '#f))) + (setf (table-entry *fixity-table* name) + (var-fixity def))) + (when (and (con? def) (not (eq? (con-fixity def) '#f))) + (setf (table-entry *fixity-table* name) + (con-fixity def))) + (when (not (def-prelude? def)) + (if (eq? (local-name def) '#f) + (setf (table-entry *inverted-symbol-table* def) name) + (signal-multiple-name-conflict name (local-name def) def)))) + ((eq? old-definition def) + 'OK) + ((def-prelude? old-definition) + (signal-core-redefinition name)) + ((and (module-uses-standard-prelude? *module*) + (table-entry *prelude-symbol-table* name)) + (if (eq? (def-module def) *module-name*) + (signal-prelude-redefinition name) + (signal-prelude-reimport name (def-module def)))) + ((eq? (def-module def) *module-name*) + (signal-multiple-definition-in-module name *module-name*)) + ((eq? (def-module old-definition) *module-name*) + (signal-redefinition-by-imported-symbol name *module-name*)) + (else + (signal-multiple-import name *module-name*))))) + +;;; Gets the fixity of a name. + +(define (get-local-fixity name) + (table-entry *fixity-table* name)) + +;;; These routines support general scoping issues. Only vars have local +;;; definitions - all other names are resolved from the global symbol table. + +;;; This is used when the name must be in the top symbols. + +(define (fetch-top-def name type) + (let ((def (resolve-toplevel-name name))) + (cond ((eq? def '#f) + (cond ((eq? (module-type *module*) 'interface) + (mlet (((mod name1) (rename-interface-symbol name))) + (if (eq? mod *module-name*) + (undefined-topsym name) + (let ((new-def (create-definition/inner + mod name1 type))) + (insert-top-definition name1 new-def) + (cond ((algdata? new-def) + (setf (algdata-n-constr new-def) 0) + (setf (algdata-constrs new-def) '()) + (setf (algdata-context new-def) '()) + (setf (algdata-tyvars new-def) '()) + (setf (algdata-classes new-def) '#f) + (setf (algdata-enum? new-def) '#f) + (setf (algdata-tuple? new-def) '#f) + (setf (algdata-real-tuple? new-def) '#f) + (setf (algdata-deriving new-def) '())) + ((class? new-def) + (setf (class-method-vars new-def) '()) + (setf (class-super new-def) '()) + (setf (class-super* new-def) '()) + (setf (class-tyvar new-def) '|a|) + (setf (class-instances new-def) '()) + (setf (class-kind new-def) 'other) + (setf (class-n-methods new-def) 0) + (setf (class-dict-size new-def) 0) + (setf (class-selectors new-def) '()))) + new-def)))) + (else + (undefined-topsym name)))) + (else def)))) + +(define (undefined-topsym name) + (signal-undefined-symbol name) + *undefined-def*) + + +(define (resolve-toplevel-name name) + (let ((pc (table-entry *prelude-core-symbols* name))) + (cond ((not (eq? pc '#f)) + pc) + ((module-uses-standard-prelude? *module*) + (let ((res (table-entry *prelude-symbol-table* name))) + (if (eq? res '#f) + (resolve-toplevel-name-1 name) + res))) + (else + (resolve-toplevel-name-1 name))))) + +(define (resolve-toplevel-name-1 name) + (cond ((eq? (module-inherited-env *module*) '#f) + (table-entry *symbol-table* name)) + (else + (let ((res (search-inherited-tables + name (module-inherited-env *module*)))) + (if (eq? res '#f) + (table-entry *symbol-table* name) + res))))) + +(define (search-inherited-tables name mod) + (if (eq? mod '#f) + '#f + (let ((res (table-entry (module-symbol-table mod) name))) + (if (eq? res '#f) + (search-inherited-tables name (module-inherited-env mod)) + res)))) + +;;; Con-ref's are special in that the naming convention (;Name) ensures +;;; that if a def is found it must be a con. + +(define (resolve-con con-ref) + (when (eq? (con-ref-con con-ref) *undefined-def*) + (remember-context con-ref + (let ((def (fetch-top-def (con-ref-name con-ref) 'con))) + (setf (con-ref-con con-ref) def))))) + +(define (resolve-class class-ref) + (when (eq? (class-ref-class class-ref) *undefined-def*) + (remember-context class-ref + (let ((def (fetch-top-def (class-ref-name class-ref) 'class))) + (when (not (class? def)) + (signal-class-name-required def (class-ref-name class-ref))) + (setf (class-ref-class class-ref) def))))) + + +(define (resolve-tycon tycon) + (when (eq? (tycon-def tycon) *undefined-def*) + (remember-context tycon + (let ((def (fetch-top-def (tycon-name tycon) 'algdata))) + (when (class? def) + (signal-tycon-name-required (tycon-name tycon))) + (setf (tycon-def tycon) def))))) + + +;;; This should be used after the local environment has been searched. +;;; Other routines dealing with variable scoping are elsewhere. + +(define (resolve-var var-ref) + (when (eq? (var-ref-var var-ref) *undefined-def*) + (remember-context var-ref + (let ((def (fetch-top-def (var-ref-name var-ref) 'var))) + (setf (var-ref-var var-ref) def))))) + + +;;; *** The inverted-symbol-table is the only table in the whole +;;; *** system that is not keyed off of symbols. If this is a problem, +;;; *** things that use it could probably be rewritten to do something +;;; *** else, like store an a-list on the def itself. + +;;; This does not need to consult the inherited-env flag because when this +;;; is used in extensions only new symbols get inserted. + +(define (local-name def) + (cond ((def-prelude? def) + (def-name def)) + ((module-uses-standard-prelude? *module*) + (let ((res (table-entry *prelude-inverted-symbol-table* def))) + (if (eq? res '#f) + (table-entry *inverted-symbol-table* def) + res))) + (else + (table-entry *inverted-symbol-table* def)))) + +(define (print-name x) + (let ((res (local-name x))) + (if (eq? res '#f) + (def-name x) + res))) + + +;;; Error signalling routines. + +(define (signal-module-double-definition name) + (fatal-error 'module-double-definition + "Module ~s is defined more than once." + name)) + +(define (signal-module-already-defined name) + (fatal-error 'module-already-defined + "Module ~a is defined more than once in the current unit." + name)) + +(define (signal-multiple-definition-in-module name modname) + (if (eq? (module-type *module*) 'extension) + (phase-error 'cant-redefine-in-extension + "An extension for module ~A cannot redefine the symbol ~A" + modname name) + (phase-error 'multiple-definition-in-module + "There is more than one definition for the name ~a in module ~a." + name modname))) + +(define (signal-redefinition-by-imported-symbol name modname) + (phase-error 'redefinition-by-imported-symbol + "The name ~a is defined in module ~a, and cannot be imported." + name modname)) + +(define (signal-core-redefinition name) + (phase-error 'prelude-redefinition + "The name ~a is defined in the prelude core and cannot be redefined." + name)) + +(define (signal-prelude-redefinition name) + (phase-error 'prelude-redefinition + "The name ~a is defined in the prelude.~%You must hide it if you wish to use this name." + name)) + +(define (signal-prelude-reimport name modname) + (phase-error 'prelude-redefinition + "The name ~a is both imported from ~A and defined in the prelude.~%" + name modname)) + +(define (signal-multiple-import name modname) + (phase-error 'multiple-import + "The name ~a is imported into module ~a multiple times." + name modname)) + +(define (signal-undefined-symbol name) + (phase-error 'undefined-symbol + "The name ~A is undefined." + name)) + +(define (signal-class-name-required name def) + (phase-error 'class-name-required + "The name ~A defines a ~A, but a class name is required." + name + (if (synonym? def) "synonym" "data type"))) + +(define (signal-tycon-name-required name) + (phase-error 'tycon-required + "The name ~A defines a class, but a type constructor name is required." + name)) diff --git a/top/system-init.scm b/top/system-init.scm new file mode 100644 index 0000000..4c06cb5 --- /dev/null +++ b/top/system-init.scm @@ -0,0 +1,41 @@ + +(define (initialize-haskell-system) + (when (not *haskell-initialized?*) + (initialize-haskell-system/forced)) + 'haskell-ready) + +(predefine (**tycon/def def args)) ; in util/constructors.scm +(predefine (init-cse-structs)) ; in csys/dump-cse.scm + +(define (initialize-haskell-system/forced) + (setf *haskell-initialized?* '#t) + (setf *error-output-port* (current-output-port)) + (init-core-symbols) + (init-tuples) + (setf *standard-module-default* + (make default-decl + (types (list + (**tycon/def (core-symbol "Int") '()) + (**tycon/def (core-symbol "Double") '()))))) + (setf *undefined-def* + (make def + (name '*undefined*) + (unit '*undefined*) + (module '*undefined*))) + (setf *printer-class* + (make class + (name '|Printers|) + (module '|*Core|) (unit '|*Core|))) + (init-cse-structs)) + +;;; This should be called in the system restart code generated by a +;;; disk save + +(define (load-init-files) + (load-init-file "$HASKELL/.yhaskell") + (load-init-file "~/.yhaskell")) + +(define (load-init-file name) + (when (file-exists? name) + (load name))) + diff --git a/top/top.scm b/top/top.scm new file mode 100644 index 0000000..1a63923 --- /dev/null +++ b/top/top.scm @@ -0,0 +1,46 @@ +;;; top.scm -- compilation unit definition for the top level + +;;; Global includes the ast definitions and all global data structures +;;; used in the compiler. + +(define-compilation-unit global + (source-filename "$Y2/top/") + (require ast) + (unit has-utils + (source-filename "has-utils.scm")) + (unit core-definitions + (require has-utils) + (source-filename "core-definitions.scm")) + (unit core-symbols + (require core-definitions) + (source-filename "core-symbols.scm")) + (unit core-init + (require core-symbols) + (source-filename "core-init.scm")) + (unit globals + (require core-init) + (source-filename "globals.scm")) + (unit has-macros + (source-filename "has-macros.scm")) + ) + + +;;; These files do not need to be required by other units + +(define-compilation-unit top-level + (source-filename "$Y2/top/") + (require global) + (unit phases + (source-filename "phases.scm")) + (unit system-init + (source-filename "system-init.scm")) + (unit errors + (source-filename "errors.scm")) + (unit tuple + (source-filename "tuple.scm")) + (unit symbol-table + (source-filename "symbol-table.scm")) + ) + + + diff --git a/top/tuple.scm b/top/tuple.scm new file mode 100644 index 0000000..b736ee2 --- /dev/null +++ b/top/tuple.scm @@ -0,0 +1,87 @@ +;;; This file creates type definitions for tuples of arbitrary size. + +(define *tuple-definitions* '()) + +(define (init-tuples) + (setf *tuple-definitions* '())) + +(define (tuple-tycon k) + (let ((tycon (assq k *tuple-definitions*))) + (if (eq? tycon '#f) + (new-tuple-tycon k) + (tuple-2-2 tycon)))) + +(define (tuple-constructor k) + (car (algdata-constrs (tuple-tycon k)))) + +(define (is-tuple-constructor? x) + (and (con? x) (is-tuple-tycon? (con-alg x)))) + +(define (is-tuple-tycon? x) + (and (algdata? x) (algdata-real-tuple? x))) + +(define (tuple-constructor-arity x) + (con-arity x)) + +(predefine (ast->gtype c t)) ; in util/type-utils.scm +(predefine (**arrow-type/l args)) ; in util/constructors.scm +(predefine (**tyvar x)) ; in util/constructors.scm + +(define (new-tuple-tycon k) + (cond ((eqv? k 0) + (core-symbol "UnitType")) + (else + (let* ((name (string->symbol (format '#f "Tuple~A" k))) + (cname (string->symbol (format '#f ";MkTuple~A" k))) + (dummy-vars (gen-dummy-names k)) + (algdata (make algdata + (name name) + (module '*core*) + (unit '*core*) + (exported? '#t) + (arity k) + (n-constr 1) + (context '()) + (tyvars dummy-vars) + (classes '()) ;; filled in later + (enum? '#f) + (tuple? '#t) + (real-tuple? '#t) + (deriving '()))) + (constr (make con + (name cname) + (module '*core*) + (unit '*core*) + (exported? '#t) + (arity k) + (types (map (function **tyvar) dummy-vars)) + (tag 0) + (alg algdata) + (slot-strict? '()) + (infix? '#f))) + (tyvars (map (function **tyvar) dummy-vars)) + (tuple-type (**tycon/def algdata tyvars))) + (dotimes (i k) + (push '#f (con-slot-strict? constr))) + (setf (algdata-signature algdata) + (ast->gtype '() tuple-type)) + (setf (con-signature constr) + (ast->gtype '() (**arrow-type/l + (append tyvars (list tuple-type))))) + (setf (algdata-constrs algdata) + (list constr)) + (push (tuple k algdata) *tuple-definitions*) + algdata)))) + +(define (gen-dummy-names n) + (gen-dummy-names-1 n '())) + +(define (gen-dummy-names-1 n l) + (if (eqv? n 0) + l + (gen-dummy-names-1 (1- n) + (cons (string->symbol (format '#f "a~A" n)) l)))) + + + + diff --git a/type/README b/type/README new file mode 100644 index 0000000..dc40c55 --- /dev/null +++ b/type/README @@ -0,0 +1 @@ +This directory contains the type inference phase. diff --git a/type/default.scm b/type/default.scm new file mode 100644 index 0000000..529f4f8 --- /dev/null +++ b/type/default.scm @@ -0,0 +1,47 @@ +;;; This handles the default rule. + +(define (maybe-default-ambiguous-tyvar type def module) + (let ((classes (ntyvar-context type))) + (and (not (null? classes)) ; this happens only during cleanup after an error + (let ((non-standard? '#f) + (numeric? '#f)) + (dolist (class classes) + (cond ((eq? (class-kind class) 'numeric) + (setf numeric? '#t)) + ((not (eq? (class-kind class) 'standard)) + (setf non-standard? '#t)))) + (cond ((or non-standard? (not numeric?)) + (remember-context def + (phase-error 'Non-defaultable-ambiguous-context +"An ambiguous context, ~A, cannot be defaulted.~%Ambiguity in call to ~A~%" + classes def)) + '#f) + (else + (find-default-type type classes classes + (tuple-2-2 (assq module *default-decls*))))))))) + +(define (find-default-type tyvar classes all-classes defaults) + (cond ((null? defaults) + (phase-error 'no-default-applies + "Ambiguous context: ~A~%No default applies.~%" + all-classes) + '#f) + ((null? classes) + (instantiate-tyvar tyvar (car defaults)) + '#t) + ((type-in-class? (car defaults) (car classes)) + (find-default-type tyvar (cdr classes) all-classes defaults)) + (else + (find-default-type tyvar all-classes all-classes (cdr defaults))))) + +(define (type-in-class? ntype class) + (let* ((ntype (expand-ntype-synonym ntype)) + (alg (ntycon-tycon ntype)) + (inst (lookup-instance alg class))) + (if (eq? inst '#f) + '#f + (let ((res '#t)) + (do-contexts (c (instance-context inst)) (ty (ntycon-args ntype)) + (when (not (type-in-class? ty c)) + (setf res '#f))) + res)))) diff --git a/type/dictionary.scm b/type/dictionary.scm new file mode 100644 index 0000000..0a0260e --- /dev/null +++ b/type/dictionary.scm @@ -0,0 +1,229 @@ + +;;; type/dictionary.scm + +;;; This function supports dictionary conversion. It creates lambda +;;; variables to bind to the dictionary args needed by the context. +;;; The actual conversion to lambda is done in the cfn. Each tyvar in +;;; the context has an associated mapping from class to dictionary +;;; variable. This mapping depends on the decl containing the placeholder +;;; since different recursive decls share common tyvars. The mapping is +;;; two levels: decl -> class -> var. + +;;; Due to language restrictions this valdef must be a simple variable +;;; definition. + +(define (dictionary-conversion/definition valdef tyvars) + (let* ((var (decl-var valdef)) + (type (var-type var)) + (context (gtype-context type)) + (dict-param-vars '())) + (dolist (c context) + (let ((tyvar (car tyvars)) + (dparams '())) + (when (not (null? c)) + (dolist (class c) + (let ((var (create-temp-var + (string-append "d_" + (symbol->string (def-name class)))))) + (setf (var-force-strict? var) '#t) + (push (tuple class var) dparams) + (push var dict-param-vars))) + (push (tuple valdef dparams) (ntyvar-dict-params tyvar))) + (setf tyvars (cdr tyvars)))) + (setf (valdef-dictionary-args valdef) (nreverse dict-param-vars)))) + +;;; These routines deal with dict-var processing. + +;;; This discharges the tyvars associated with dictionaries. The dict-vars +;;; to be processed at the next level are returned. + +(define (process-placeholders placeholders deferred decls) + (if (null? placeholders) + deferred + (let ((d1 (process-placeholder (car placeholders) deferred decls))) + (process-placeholders (cdr placeholders) d1 decls)))) + +;;; This processes a placeholder. The following cases arise: +;;; a) the variable has already been processed (no placeholders remain) - +;;; ignore it. placeholders may contain duplicates so this is likely. +;;; b) the type variable is from an outer type environment (in ng-list) +;;; and should just be passed up to the next level (added to old-placeholders) +;;; c) the type variable is associated with a dictionary parameter +;;; d) the type variable is instantiated to a type constructor +;;; e) the type variable is ambiguous (none of the above) + +(define (process-placeholder p deferred decls) + (let* ((tyvar (placeholder-tyvar p)) + (type (prune tyvar))) + (cond ((ntycon? type) + (process-instantiated-tyvar + (expand-ntype-synonym type) p deferred decls)) + ((non-generic? type) + (cons p deferred)) + ((not (null? (ntyvar-dict-params type))) + (if (dict-placeholder? p) + (placeholder->dict-param p (ntyvar-dict-params type) decls) + (placeholder->method p (ntyvar-dict-params type) decls)) + deferred) + (else + ;; Since default types are monotypes, no new vars will + ;; be added to old-placeholders + (when (maybe-default-ambiguous-tyvar + type (placeholder-overloaded-var p) + (valdef-module (car (placeholder-enclosing-decls p)))) + (process-placeholder p deferred decls)) + deferred)))) + +;;; The type variable is associated with a dictionary parameter. The only +;;; complication here is that the class needed may not be directly available - +;;; it may need to be obtained from the super classes of the parameter +;;; dictionaries. + +(define (placeholder->dict-param p param-vars decls) + (let ((class (dict-placeholder-class p)) + (edecls (dict-placeholder-enclosing-decls p))) + (setf (placeholder-exp p) + (dict-reference-code class (locate-params param-vars edecls decls))))) + +(define (dict-reference-code class param-vars) + (let ((var (assq class param-vars))) + (if (not (eq? var '#f)) + (**var/def (tuple-2-2 var)) + (search-superclasses class param-vars)))) + +(define (locate-params param-vars enclosing-decls decls) + (if (null? (cdr param-vars)) + (tuple-2-2 (car param-vars)) + (let ((decl (search-enclosing-decls enclosing-decls decls))) + (tuple-2-2 (assq decl param-vars))))) + +;;; This finds the first dictionary containing the needed class in its +;;; super classes and generates a selector to get the needed dictionary. + +(define (search-superclasses class param-vars) + (let ((pclass (tuple-2-1 (car param-vars)))) + (if (memq class (class-super* pclass)) + (**dsel/dict pclass class (**var/def (tuple-2-2 (car param-vars)))) + (search-superclasses class (cdr param-vars))))) + +(define (placeholder->method p param-vars decls) + (let* ((method (method-placeholder-method p)) + (class (method-var-class method)) + (edecls (placeholder-enclosing-decls p)) + (params (locate-params param-vars edecls decls))) + (setf (placeholder-exp p) + (method-reference-code method class params)))) + +(define (method-reference-code m c param-vars) + (let ((pclass (tuple-2-1 (car param-vars)))) + (if (or (eq? c pclass) + (memq c (class-super* pclass))) + (let* ((msel (assq m (class-selectors pclass))) + (mvar (tuple-2-2 msel))) + (**app (**var/def mvar) (**var/def (tuple-2-2 (car param-vars))))) + (method-reference-code m c (cdr param-vars))))) + +;;; This is for tyvars instantiated to a tycon. A reference to the +;;; appropriate dictionary is generated. This reference must be recursively +;;; dictionary converted since dictionaries may need subdictionaries +;;; when referenced. + +(define (process-instantiated-tyvar tycon p deferred decls) + (let* ((alg (ntycon-tycon tycon)) + (edecls (placeholder-enclosing-decls p)) + (var (placeholder-overloaded-var p)) + (class (if (dict-placeholder? p) + (dict-placeholder-class p) + (method-var-class (method-placeholder-method p)))) + (instance (lookup-instance alg class))) + (if (dict-placeholder? p) + (mlet (((code def1) + (generate-dict-ref instance tycon deferred decls edecls var))) + (setf (placeholder-exp p) code) + (setf deferred def1)) + (let ((method (method-placeholder-method p))) + (if (every (function null?) (instance-gcontext instance)) + (let ((mvar (tuple-2-2 + (assq method (instance-methods instance))))) + (setf (placeholder-exp p) (**var/def mvar))) + (mlet (((code def1) + (generate-dict-ref + instance tycon deferred decls edecls var)) + (sel (tuple-2-2 (assq method (class-selectors class))))) + (setf (method-placeholder-exp p) (**app (**var/def sel) code)) + (setf deferred def1))))) + deferred)) + +;;; This generates a reference to a specific dictionary and binds +;;; needed subdictionaries. Since subdictionaries may be part of the outer +;;; type environment new placeholders may be generated for later resolution. + +(define (generate-dict-ref instance type deferred decls edecls var) + (let* ((ctxt (instance-gcontext instance)) + (dict (dict-ref-code instance))) + (do-contexts (class ctxt) (ty (ntycon-args type)) + (let ((ntype (prune ty))) + (cond + ((ntycon? ntype) + (mlet ((ntype (expand-ntype-synonym ntype)) + (alg (ntycon-tycon ntype)) + (instance (lookup-instance alg class)) + ((code dv1) + (generate-dict-ref + instance ntype deferred decls edecls var))) + (setf dict (**app dict code)) + (setf deferred dv1))) + ((non-generic? ntype) + (let ((p (**dict-placeholder + class ntype edecls var))) + (setf dict (**app dict p)) + (push p deferred))) + ((null? (ntyvar-dict-params ntype)) + (let ((ref-code (**dict-placeholder + class ntype edecls var))) + (when (maybe-default-ambiguous-tyvar + ntype var (valdef-module (car edecls))) + (process-placeholder ref-code '() decls)) + (setf dict (**app dict ref-code)))) + (else + (let ((p (locate-params (ntyvar-dict-params ntype) edecls decls))) + (setf dict (**app dict (dict-reference-code class p)))))))) + (values dict deferred))) + +;;; The following routines deal with recursive placeholders. The basic +;;; strategy is to pass the entire context as a parameter with each +;;; recursive call (this could be optimized later to make use of an +;;; internal entry point). The basic complication is that the context +;;; of each function in a letrec may be arranged differently. + +;;; This generates a call inside decl 'from' to the var 'to'. Vmap is an +;;; alist from vars to a list of vars corresponding to the gtyvars of +;;; the decl signature. + +(define (recursive-call-code from to vmap) + (let ((exp (**var/def to)) + (tyvars (tuple-2-2 (assq to vmap))) + (contexts (gtype-context (var-type to)))) + (do-contexts (class contexts) (tyvar tyvars) + (setf exp (**app exp (locate-param-var tyvar class from)))) + exp)) + +(define (locate-param-var tyvar class decl) + (let ((vmap (tuple-2-2 (assq decl (ntyvar-dict-params tyvar))))) + (**var/def (tuple-2-2 (assq class vmap))))) + +;;; This is used to get the code for a specific dictionary reference. + +(define (dict-ref-code instance) + (**var/def (instance-dictionary instance))) + +;;; This is used to locate the correct enclosing decl. + +(define (search-enclosing-decls decl-list decls) + (cond ((null? decl-list) + (error "Lost decl in search-enclosing-decls!")) + ((memq (car decl-list) decls) + (car decl-list)) + (else + (search-enclosing-decls (cdr decl-list) decls)))) + diff --git a/type/expression-typechecking.scm b/type/expression-typechecking.scm new file mode 100644 index 0000000..f4606d1 --- /dev/null +++ b/type/expression-typechecking.scm @@ -0,0 +1,364 @@ +;;; This file contains typecheckers for all expressions except vars and +;;; declarations. + +;;; From valdef-structs: +;;; valdef, single-fun-def are in type-decls + +(define-type-checker guarded-rhs + (type-check guarded-rhs rhs rhs-type + (type-check guarded-rhs guard guard-type + (type-unify guard-type *bool-type* + (type-mismatch/fixed (guarded-rhs-guard object) + "Guards must be of type Bool" guard-type)) + (return-type object rhs-type)))) + +;;; These type checkers deal with patterns. + +(define-type-checker as-pat + (type-check as-pat pattern as-type + (setf (var-type (var-ref-var (as-pat-var object))) as-type) + (return-type object as-type))) + +(define-type-checker irr-pat + (type-check irr-pat pattern pattern-type + (return-type object pattern-type))) + +(define-type-checker var-pat + (fresh-type var-type + (setf (var-type (var-ref-var (var-pat-var object))) var-type) + (return-type object var-type))) + +(define-type-checker wildcard-pat + (fresh-type pat-type + (return-type object pat-type))) + +;;; Constant patterns create a piece of code to actually to the +;;; match: ((==) k), where k is the constant. This code is placed in the +;;; match-fn slot of the const-pat and is used by the cfn. + +(define-type-checker const-pat + (let* ((val (const-pat-value object)) + (match-fn (**app (**var/def (core-symbol "==")) val))) + (setf (const-pat-match-fn object) match-fn) + (type-check const-pat match-fn match-type + (fresh-type res-type + (type-unify match-type (**arrow res-type *bool-type*) #f) + (return-type object res-type))))) + +(define-type-checker plus-pat + (let* ((kp (**int (plus-pat-k object))) + (km (**int (- (plus-pat-k object)))) + (match-fn (**app (**var/def (core-symbol "<=")) kp)) + (bind-fn (**app (**var/def (core-symbol "+")) km))) + (setf (plus-pat-match-fn object) match-fn) + (setf (plus-pat-bind-fn object) bind-fn) + (fresh-type res-type + (setf (ntyvar-context res-type) (list (core-symbol "Integral"))) + (type-check plus-pat match-fn match-type + (type-check plus-pat bind-fn bind-type + (type-check plus-pat pattern pat-type + (type-unify match-type (**arrow pat-type *bool-type*) #f) + (type-unify bind-type (**arrow pat-type pat-type) #f) + (type-unify res-type pat-type #f) + (return-type object res-type))))))) + +(define-type-checker pcon + (type-check/list pcon pats arg-types + (fresh-type res-type + (let ((con-type (instantiate-gtype (con-signature (pcon-con object))))) + (type-unify con-type (**arrow/l-2 arg-types res-type) #f) + (return-type object res-type))))) + +(define-type-checker list-pat + (if (null? (list-pat-pats object)) + (return-type object (instantiate-gtype + (algdata-signature (core-symbol "List")))) + (type-check/unify-list list-pat pats element-type + (type-mismatch/list object + "List elements have different types") + (return-type object (**list-of element-type))))) + +;;; These are in the order defined in exp-structs.scm + +(define-type-checker lambda + (with-new-tyvars + (fresh-monomorphic-types (length (lambda-pats object)) arg-vars + (type-check/list lambda pats arg-types + (unify-list arg-types arg-vars) + (type-check lambda body body-type + (return-type object (**arrow/l-2 arg-vars body-type))))))) + +(define-type-checker let + (type-check/decls let decls + (type-check let body let-type + (return-type object let-type)))) + +(define-type-checker if + (type-check if test-exp test-type + (type-unify test-type *bool-type* + (type-mismatch/fixed object + "The test in an if statement must be of type Bool" + test-type)) + (type-check if then-exp then-type + (type-check if else-exp else-type + (type-unify then-type else-type + (type-mismatch object + "then and else clauses have different types" + then-type else-type)) + (return-type object then-type))))) + +(define-type-checker case + (with-new-tyvars + (let ((case-exp object)) ; needed since object is rebound later + (fresh-monomorphic-type arg-type + (type-check case exp exp-type + (type-unify arg-type exp-type #f) ; just to make it monomorphic + (fresh-type res-type + (dolist (object (case-alts object)) + (recover-type-error ;;; %%% Needs work + (type-check alt pat pat-type + (type-unify pat-type arg-type + (type-mismatch case-exp + "Case patterns type conflict." + pat-type arg-type)) + (type-check/decls alt where-decls + (type-check/unify-list alt rhs-list rhs-type + (type-mismatch/list case-exp + "Guarded expressions must have the same type") + (type-unify rhs-type res-type + (type-mismatch case-exp + "Case expression alternatives must have the same type" + rhs-type res-type))))))) + (return-type case-exp res-type))))))) + +;;; Expressions with signatures are transformed into let expressions +;;; with signatures. + +;;; exp :: type is rewritten as +;;; let temp = exp +;;; temp :: type +;;; in temp + +(define-type-checker exp-sign + (type-rewrite + (let* ((temp-var (create-temp-var "TC")) + (decl (**valdef (**var-pat/def temp-var) '() (exp-sign-exp object))) + (let-exp (**let (list decl) (**var/def temp-var))) + (signature (exp-sign-signature object))) + (setf (var-signature temp-var) + (ast->gtype (signature-context signature) + (signature-type signature))) + let-exp))) + +;;; Rather than complicate the ast structure with a new node for dictSel +;;; we recognize the dictSel primitive as an application and treat it +;;; specially. + +(define-type-checker app + (if (and (var-ref? (app-fn object)) + (eq? (var-ref-var (app-fn object)) (core-symbol "dictSel"))) + (type-check-dict-sel (app-arg object)) + (type-check app fn fn-type + (type-check app arg arg-type + (fresh-type res-type + (fresh-type arg-type-1 + (type-unify fn-type (**arrow arg-type-1 res-type) + (type-mismatch/fixed object + "Attempt to call a non-function" + fn-type)) + (type-unify arg-type-1 arg-type + (type-mismatch object + "Argument type mismatch" arg-type-1 arg-type)) + (return-type object res-type))))))) + +;;; This is a special hack for typing dictionary selection as used in +;;; generic tuple functions. This extracts a dictionary from a TupleDict +;;; object and uses is to resolve the overloading of a designated +;;; expression. The expresion must generate exactly one new context. + +(define (type-check-dict-sel arg) + (when (or (not (app? arg)) + (not (app? (app-fn arg)))) + (dict-sel-error)) + (let* ((exp (app-fn (app-fn arg))) + (dict-var (app-arg (app-fn arg))) + (i (app-arg arg)) + (p (dynamic *placeholders*))) + (mlet (((object exp-type) (dispatch-type-check exp))) + ; check for exactly one new context + (when (or (eq? (dynamic *placeholders*) p) + (not (eq? (cdr (dynamic *placeholders*)) p))) + (dict-sel-error)) + (mlet ((placeholder (car (dynamic *placeholders*))) + (tyvar (placeholder-tyvar placeholder)) + ((dict-var-ast dict-var-type) (dispatch-type-check dict-var)) + ((index-ast index-type) (dispatch-type-check i))) + (setf (ntyvar-context tyvar) '()) ; prevent context from leaking out + (setf (dynamic *placeholders*) p) + (type-unify dict-var-type + (**ntycon (core-symbol "TupleDicts") '()) #f) + (type-unify index-type *int-type* #f) + (cond ((method-placeholder? placeholder) + (dict-sel-error)) ; I am lazy. This means that + ; dictSel must not be passed a method + (else + (setf (placeholder-exp placeholder) + (**app (**var/def (core-symbol "dictSel")) + dict-var-ast index-ast)))) + (return-type object exp-type))))) + +(define (dict-sel-error) + (fatal-error 'dict-sel-error "Bad dictSel usage.")) + +(define-type-checker con-ref + (return-type object (instantiate-gtype (con-signature (con-ref-con object))))) + +(define-type-checker integer-const + (cond ((const-overloaded? object) + (setf (const-overloaded? object) '#f) + (type-rewrite (**fromInteger object))) + (else + (return-type object *Integer-type*)))) + +(define-type-checker float-const + (cond ((const-overloaded? object) + (setf (const-overloaded? object) '#f) + (type-rewrite (**fromRational object))) + (else + (return-type object *Rational-type*)))) + +(define-type-checker char-const + (return-type object *char-type*)) + +(define-type-checker string-const + (return-type object *string-type*)) + +(define-type-checker list-exp + (if (null? (list-exp-exps object)) + (return-type object (instantiate-gtype + (algdata-signature (core-symbol "List")))) + (type-check/unify-list list-exp exps element-type + (type-mismatch/list object + "List elements do not share a common type") + (return-type object (**list-of element-type))))) + +(define-type-checker sequence + (type-rewrite (**enumFrom (sequence-from object)))) + +(define-type-checker sequence-to + (type-rewrite (**enumFromTo (sequence-to-from object) + (sequence-to-to object)))) + +(define-type-checker sequence-then + (type-rewrite (**enumFromThen (sequence-then-from object) + (sequence-then-then object)))) + +(define-type-checker sequence-then-to + (type-rewrite (**enumFromThenTo (sequence-then-to-from object) + (sequence-then-to-then object) + (sequence-then-to-to object)))) + +(define-type-checker list-comp + (with-new-tyvars + (dolist (object (list-comp-quals object)) + (if (is-type? 'qual-generator object) + (fresh-type pat-type + (push pat-type (dynamic *non-generic-tyvars*)) + (type-check qual-generator pat pat-type-1 + (type-unify pat-type pat-type-1 #f) + (type-check qual-generator exp qual-exp-type + (type-unify (**list-of pat-type) qual-exp-type + (type-mismatch/fixed object + "Generator expression is not a list" qual-exp-type))))) + (type-check qual-filter exp filter-type + (type-unify filter-type *bool-type* + (type-mismatch/fixed object + "Filter must have type Bool" filter-type))))) + (type-check list-comp exp exp-type + (return-type object (**list-of exp-type))))) + +(define-type-checker section-l + (type-check section-l op op-type + (type-check section-l exp exp-type + (fresh-type a-type + (fresh-type b-type + (fresh-type c-type + (type-unify op-type (**arrow a-type b-type c-type) + (type-mismatch/fixed object + "Binary function required in section" op-type)) + (type-unify b-type exp-type + (type-mismatch object + "Argument type mismatch" b-type exp-type)) + (return-type object (**arrow a-type c-type)))))))) + +(define-type-checker section-r + (type-check section-r op op-type + (type-check section-r exp exp-type + (fresh-type a-type + (fresh-type b-type + (fresh-type c-type + (type-unify op-type (**arrow a-type b-type c-type) + (type-mismatch/fixed object + "Binary function required" op-type)) + (type-unify exp-type a-type + (type-mismatch object + "Argument type mismatch" a-type exp-type)) + (return-type object (**arrow b-type c-type)))))))) + +(define-type-checker omitted-guard + (return-type object *bool-type*)) + +(define-type-checker con-number + (let ((arg-type (instantiate-gtype + (algdata-signature (con-number-type object))))) + (type-check con-number value arg-type1 + (type-unify arg-type arg-type1 #f) + (return-type object *int-type*)))) + +(define-type-checker sel + (let ((con-type (instantiate-gtype + (con-signature (sel-constructor object))))) + (mlet (((res-type exp-type1) (get-ith-type con-type (sel-slot object)))) + (type-check sel value exp-type + (type-unify exp-type exp-type1 #f) + (return-type object res-type))))) + +(define (get-ith-type type i) + (let ((args (ntycon-args type))) ; must be an arrow + (if (eq? i 0) + (values (car args) (get-ith-type/last (cadr args))) + (get-ith-type (cadr args) (1- i))))) + +(define (get-ith-type/last type) + (if (eq? (ntycon-tycon type) (core-symbol "Arrow")) + (get-ith-type/last (cadr (ntycon-args type))) + type)) + +(define-type-checker is-constructor + (let ((alg-type (instantiate-gtype + (algdata-signature + (con-alg (is-constructor-constructor object)))))) + (type-check is-constructor value arg-type + (type-unify arg-type alg-type #f) + (return-type object *bool-type*)))) + +(define-type-checker cast + (type-check cast exp _ + (fresh-type res + (return-type object res)))) + +;;; This is used for overloaded methods. The theory is to avoid supplying +;;; the context at the class level. This type checks the variable as if it had +;;; the supplied signature. + +(define-type-checker overloaded-var-ref + (let* ((var (overloaded-var-ref-var object)) + (gtype (overloaded-var-ref-sig object)) + (ovar-type (var-type var))) + (when (recursive-type? ovar-type) + (error + "Implementation error: overloaded method found a recursive type")) + (mlet (((ntype new-vars) (instantiate-gtype/newvars gtype)) + (object1 (insert-dict-placeholders + (**var/def var) new-vars object))) + (return-type object1 ntype)))) diff --git a/type/pattern-binding.scm b/type/pattern-binding.scm new file mode 100644 index 0000000..769e155 --- /dev/null +++ b/type/pattern-binding.scm @@ -0,0 +1,38 @@ +;;; This implements the pattern binding rule. + +(define (apply-pattern-binding-rule? decls) + (not + (every (lambda (decl) + (or (function-binding? decl) + (simple-pattern-binding-with-signature? decl))) + decls))) + +(define (function-binding? decl) + (let ((defs (valdef-definitions decl))) + (not (null? (single-fun-def-args (car defs)))))) + +(define (simple-pattern-binding-with-signature? decl) + (let ((lhs (valdef-lhs decl)) + (defs (valdef-definitions decl))) + (and (is-type? 'var-pat lhs) + (null? (single-fun-def-args (car defs))) + (not (eq? (var-signature (var-ref-var (var-pat-var lhs))) '#f))))) + +(define (do-pattern-binding-rule decls necessary-tyvars ng-list) + (setf ng-list (append necessary-tyvars ng-list)) + (find-exported-pattern-bindings decls) + ng-list) + +(define (find-exported-pattern-bindings decls) + (dolist (decl decls) + (dolist (var-ref (collect-pattern-vars (valdef-lhs decl))) + (let ((var (var-ref-var var-ref))) + (when (def-exported? var) + (recoverable-error 'exported-pattern-binding + "Can't export pattern binding of ~A~%" var-ref)) + (when (not (eq? (var-signature var) '#f)) + (recoverable-error 'entire-group-needs-signature + "Variable ~A signature declaration ignored~%" var-ref)))))) + + + diff --git a/type/type-decl.scm b/type/type-decl.scm new file mode 100644 index 0000000..790c0ca --- /dev/null +++ b/type/type-decl.scm @@ -0,0 +1,337 @@ +;;; This deals with declarations (let & letrec). The input is a list of +;;; declarations (valdefs) which may contain recursive-decl-groups, as +;;; introduced in dependency analysis. This function alters the list +;;; of non-generic type variables. Expressions containing declarations +;;; need to rebind the non-generic list around the decls and all expressions +;;; within their scope. + +;;; This returns an updated decl list with recursive decl groups removed. + +(define (type-decls decls) + (cond ((null? decls) + '()) + ((is-type? 'recursive-decl-group (car decls)) + (let ((d (recursive-decl-group-decls (car decls)))) + (type-recursive d) + (append d (type-decls (cdr decls))))) + (else + (type-non-recursive (car decls)) + (cons (car decls) + (type-decls (cdr decls)))))) + +;;; This typechecks a mutually recursive group of declarations (valdefs). +;;; Generate a monomorphic variable for each declaration and unify it with +;;; the lhs of the decl. The variable all-vars collects all variables defined +;;; by the declaration group. Save the values of placeholders and ng-list +;;; before recursing. + +;;; The type of each variable is marked as recursive. + +(define (type-recursive decls) + (let ((old-ng (dynamic *non-generic-tyvars*)) + (old-placeholders (dynamic *placeholders*)) + (all-vars '()) + (new-tyvars '()) + (decls+tyvars '())) + ;; on a type error set all types to `a' and give up. + (setf (dynamic *placeholders*) '()) + (recover-type-error + (lambda (r) + (make-dummy-sigs decls) + (setf (dynamic *dict-placeholders*) old-placeholders) + (funcall r)) + ;; Type the lhs of each decl and then mark each variable bound + ;; in the decl as recursive. + (dolist (d decls) + (fresh-type lhs-type + (push lhs-type (dynamic *non-generic-tyvars*)) + (push lhs-type new-tyvars) + (type-decl-lhs d lhs-type) + (push (tuple d lhs-type) decls+tyvars)) + (dolist (var-ref (collect-pattern-vars (valdef-lhs d))) + (let ((var (var-ref-var var-ref))) + (push var all-vars) + (setf (var-type var) + (make recursive-type (type (var-type var)) + (placeholders '())))))) + +;;; This types the decl right hand sides. Each rhs type is unified with the +;;; tyvar corresponding to the lhs. Before checking the signatures, the +;;; ng-list is restored. + + (dolist (d decls+tyvars) + (let ((rhs-type (type-decl-rhs (tuple-2-1 d))) + (lhs-type (tuple-2-2 d))) + (type-unify lhs-type rhs-type + (type-mismatch (tuple-2-1 d) + "Decl type mismatch" lhs-type rhs-type)))) + (setf (dynamic *non-generic-tyvars*) old-ng) + (let ((sig-contexts (check-user-signatures all-vars))) + +;;; This generalizes the signatures of recursive decls. First, the +;;; context of the declaration group is computed. Any tyvar in the +;;; bodies with a non-empty context must appear in all signatures that +;;; are non-ambiguous. + + (let* ((all-tyvars (collect-tyvars/l new-tyvars)) + (overloaded-tyvars '())) + (dolist (tyvar all-tyvars) + (when (and (ntyvar-context tyvar) (not (non-generic? tyvar))) + (push tyvar overloaded-tyvars))) + (reconcile-sig-contexts overloaded-tyvars sig-contexts) + ;; We should probably also emit a warning about inherently + ;; ambiguous decls. + (when (and overloaded-tyvars + (apply-pattern-binding-rule? decls)) + (setf (dynamic *non-generic-tyvars*) + (do-pattern-binding-rule + decls overloaded-tyvars old-ng)) + (setf overloaded-tyvars '())) + ;; The next step is to compute the signatures of the defined + ;; variables and to define all recursive placeholders. When + ;; there is no context the placeholders become simple var refs. + ;; and the types are simply converted. + (cond ((null? overloaded-tyvars) + (dolist (var all-vars) + (let ((r (var-type var))) + (setf (var-type var) (recursive-type-type (var-type var))) + (dolist (p (recursive-type-placeholders r)) + (setf (recursive-placeholder-exp p) + (**var/def var))) + (generalize-type var)))) + ;; When the declaration has a context things get very hairy. + ;; First, grap the recursive placeholders before generalizing the + ;; types. + (else + ;; Mark the overloaded tyvars as read-only. This prevents + ;; signature unification from changing the set of tyvars + ;; defined in the mapping. + (dolist (tyvar overloaded-tyvars) + (setf (ntyvar-read-only? tyvar) '#t)) + (let ((r-placeholders '())) + (dolist (var all-vars) + (let ((rt (var-type var))) + (dolist (p (recursive-type-placeholders rt)) + (push p r-placeholders)) + (setf (var-type var) (recursive-type-type rt)))) + ;; Now compute a signature for each definition and do dictionary + ;; conversion. The var-map defines the actual parameter associated + ;; with each of the overloaded tyvars. + (let ((var-map (map (lambda (decl) + (tuple (decl-var decl) + (generalize-overloaded-type + decl overloaded-tyvars))) + decls))) + ;; Finally discharge each recursive placeholder. + (dolist (p r-placeholders) + (let ((ref-to (recursive-placeholder-var p)) + (decl-from + (search-enclosing-decls + (recursive-placeholder-enclosing-decls p) + decls))) + (setf (recursive-placeholder-exp p) + (recursive-call-code decl-from ref-to var-map))) + ))))) + (setf (dynamic *placeholders*) + (process-placeholders + (dynamic *placeholders*) old-placeholders decls))))))) + +;;; Non-recursive decls are easier. Save the placeholders, use a fresh type +;;; for the left hand side, check signatures, and generalize. + +(define (type-non-recursive decl) + (remember-context decl + (fresh-type lhs-type + (let ((old-placeholders (dynamic *placeholders*)) + (all-vars (map (lambda (x) (var-ref-var x)) + (collect-pattern-vars (valdef-lhs decl))))) + (setf (dynamic *placeholders*) '()) + (recover-type-error + (lambda (r) + (make-dummy-sigs (list decl)) + (setf (dynamic *placeholders*) old-placeholders) + (funcall r)) + (type-decl-lhs decl lhs-type) + (let ((rhs-type (type-decl-rhs decl))) + (type-unify lhs-type rhs-type + (type-mismatch decl + "Decl type mismatch" lhs-type rhs-type))) + (check-user-signatures all-vars) + (let ((all-tyvars (collect-tyvars lhs-type)) + (overloaded-tyvars '())) + (dolist (tyvar all-tyvars) + (when (ntyvar-context tyvar) + (push tyvar overloaded-tyvars))) + (when (and overloaded-tyvars + (apply-pattern-binding-rule? (list decl))) + (setf (dynamic *non-generic-tyvars*) + (do-pattern-binding-rule + (list decl) overloaded-tyvars (dynamic *non-generic-tyvars*))) + (setf overloaded-tyvars '())) + (if (null? overloaded-tyvars) + (dolist (var all-vars) + (generalize-type var)) + (generalize-overloaded-type decl '())) + (setf (dynamic *placeholders*) + (process-placeholders + (dynamic *placeholders*) old-placeholders (list decl))))))))) + +;;; These functions type check definition components. + +;;; This unifies the type of the lhs pattern with a type variable. + +(define (type-decl-lhs object type) + (dynamic-let ((*enclosing-decls* (cons object (dynamic *enclosing-decls*)))) + (remember-context object + (type-check valdef lhs pat-type + (type-unify type pat-type #f))))) + + +;;; This types the right hand side. The *enclosing-decls* variable is +;;; used to keep track of which decl the type checker is inside. This +;;; is needed for both defaulting (to find which module defaults apply) +;;; and recursive types to keep track of the dictionary parameter variables +;;; for recursive references. + +(define (type-decl-rhs object) + (dynamic-let ((*enclosing-decls* (cons object (dynamic *enclosing-decls*)))) + (remember-context object + (type-check/unify-list valdef definitions res-type + (type-mismatch/list object + "Right hand sides have different types") + res-type)))) + + +;;; This is similar to typing lambda. + +(define-type-checker single-fun-def + (fresh-monomorphic-types (length (single-fun-def-args object)) tyvars + (type-check/list single-fun-def args arg-types + (unify-list tyvars arg-types) + (type-check/decls single-fun-def where-decls + (type-check/unify-list single-fun-def rhs-list rhs-type + (type-mismatch/list object + "Bodies have incompatible types") + (return-type object (**arrow/l-2 arg-types rhs-type))))))) + + +;;; These functions are part of the generalization process. + +;;; This function processes user signature declarations for the set of +;;; variables defined in a declaration. Since unification of one signature +;;; may change the type associated with a previously verified signature, +;;; signature unification is done twice unless only one variable is +;;; involved. The context of the signatures is returned to compare +;;; with the overall context of the declaration group. + +(define (check-user-signatures vars) + (cond ((null? (cdr vars)) + (let* ((var (car vars)) + (sig (var-signature var))) + (if (eq? sig '#f) + '() + (list (tuple var (check-var-signature var sig)))))) + (else + (let ((sigs '())) + (dolist (var vars) + (let ((sig (var-signature var))) + (unless (eq? sig '#f) + (check-var-signature var sig)))) + (dolist (var vars) + (let ((sig (var-signature var))) + (unless (eq? sig '#f) + (push (tuple var (check-var-signature var sig)) sigs)))) + sigs)))) + + +(define (check-var-signature var sig) + (mlet (((sig-type sig-vars) (instantiate-gtype/newvars sig))) + (dolist (tyvar sig-vars) + (setf (ntyvar-read-only? tyvar) '#t)) + (type-unify (remove-recursive-type (var-type var)) sig-type + (signature-mismatch var)) + (dolist (tyvar sig-vars) + (setf (ntyvar-read-only? tyvar) '#f)) + sig-vars)) + +;;; Once the declaration context is computed, it must be compared to the +;;; contexts given by the user. All we need to check is that all tyvars +;;; constrained in the user signatures are also in the decl-context. +;;; All user supplied contexts are correct at this point - we just need +;;; to see if some ambiguous portion of the context exists. + +;;; This error message needs work. We need to present the contexts. + +(define (reconcile-sig-contexts overloaded-tyvars sig-contexts) + (dolist (sig sig-contexts) + (let ((sig-vars (tuple-2-2 sig))) + (dolist (d overloaded-tyvars) + (when (not (memq d sig-vars)) + (type-error +"Declaration signature has insufficiant context in declaration~%~A~%" + (tuple-2-1 sig))))))) + +;;; This is used for noisy type inference + +(define (report-typing var) + (when (memq 'type (dynamic *printers*)) + (let* ((name (symbol->string (def-name var)))) + (when (not (or (string-starts? "sel-" name) + (string-starts? "i-" name) + (string-starts? "default-" name) + (string-starts? "dict-" name))) + (format '#t "~A :: ~A~%" var (var-type var)))))) + +;;; This is used during error recovery. When a type error occurs, all +;;; variables defined in the enclosing declaration are set to type `a' +;;; and typing is resumed. + +(define (make-dummy-sigs decls) + (let ((dummy-type (make gtype (context '(())) + (type (**gtyvar 0))))) + (dolist (d decls) + (dolist (var-ref (collect-pattern-vars (valdef-lhs d))) + (let ((var (var-ref-var var-ref))) + (setf (var-type var) dummy-type)))))) + + +;;; This is used to generalize the variable signatures. If there is +;;; an attached signature, the signature is used. Otherwise the ntype +;;; is converted to a gtype. + +(define (generalize-type var) + (if (eq? (var-signature var) '#f) + (setf (var-type var) (ntype->gtype (var-type var))) + (setf (var-type var) (var-signature var))) + (report-typing var)) + +;;; For overloaded types, it is necessary to map the declaration context +;;; onto the generalized type. User signatures may provide different but +;;; equivilant contexts for different declarations in a decl goup. + +;;; The overloaded-vars argument allows ambiguous contexts. This is not +;;; needed for non-recursive vars since the context cannot be ambiguous. + +(define (generalize-overloaded-type decl overloaded-vars) + (let* ((var (decl-var decl)) + (sig (var-signature var)) + (new-tyvars '())) + (cond ((eq? sig '#f) + (mlet (((gtype tyvars) + (ntype->gtype/env (var-type var) overloaded-vars))) + (setf (var-type var) gtype) + (setf new-tyvars tyvars))) + (else + (mlet (((ntype tyvars) (instantiate-gtype/newvars sig))) + (unify ntype (var-type var)) + (setf (var-type var) sig) + (setf new-tyvars (prune/l tyvars))))) + (report-typing var) + (dictionary-conversion/definition decl new-tyvars) + new-tyvars)) + +(define (remove-recursive-type ty) + (if (recursive-type? ty) + (recursive-type-type ty) + ty)) + diff --git a/type/type-error-handlers.scm b/type/type-error-handlers.scm new file mode 100644 index 0000000..ac7af9c --- /dev/null +++ b/type/type-error-handlers.scm @@ -0,0 +1,40 @@ +;;; This file contains error handlers for the type checker. + +(define (type-error msg . args) + (apply (function phase-error) `(type-error ,msg ,@args)) + (report-non-local-type-error) + (continue-from-type-error)) + +(define (report-non-local-type-error) + (when (pair? (dynamic *type-error-handlers*)) + (funcall (car (dynamic *type-error-handlers*))))) + +(define (continue-from-type-error) + (funcall (car (dynamic *type-error-recovery*)))) + +(define (type-mismatch/fixed object msg type) + (format '#t "While typing ~A:~%~A~%Type: ~A~%" object msg type)) + +(define (type-mismatch object msg type1 type2) + (format '#t "While type checking~%~A~%~A~%Types: ~A~% ~A~%" + object msg type1 type2)) + +(define (type-mismatch/list types object msg) + (format '#t "While typing ~A:~%~A~%Types: ~%" object msg) + (dolist (type types) + (format '#t "~A~%" type))) + +;;; Error handlers + +(define (signature-mismatch var) + (format '#t + "Signature mismatch for ~A~%Inferred type: ~A~%Declared type: ~A~%" + var + (remove-type-wrapper (ntype->gtype (var-type var))) + (var-signature var))) + +(define (remove-type-wrapper ty) + (if (recursive-type? ty) (recursive-type-type ty) ty)) + + +
\ No newline at end of file diff --git a/type/type-macros.scm b/type/type-macros.scm new file mode 100644 index 0000000..c6dc168 --- /dev/null +++ b/type/type-macros.scm @@ -0,0 +1,159 @@ + +;;; This file also contains some random globals for the type checker: + +(define-walker type ast-td-type-walker) + +;;; Some pre-defined types +(define *bool-type* '()) +(define *char-type* '()) +(define *string-type* '()) +(define *int-type* '()) +(define *integer-type* '()) +(define *rational-type* '()) + +;;; These two globals are used throughout the typechecker to avoid +;;; passing lots of stuff in each function call. + +(define *placeholders* '()) +(define *non-generic-tyvars* '()) +(define *enclosing-decls* '()) + +;;; Used by the defaulting mechanism + +(define *default-decls* '()) + +;;; Used in error handling & recovery + +(define *type-error-handlers* '()) +(define *type-error-recovery* '()) + + +;;; This associates a type checker function with an ast type. The variable +;;; `object' is bound to the value being types. + +(define-syntax (define-type-checker ast-type . cont) + `(define-walker-method type ,ast-type (object) + ,@cont)) + +;;; This recursively type checks a structure slot in the current object. +;;; This updates the ast in the slot (since type checking rewrites the ast) +;;; and binds the computed type to a variable. The slot must contain an +;;; expression. + +(define-syntax (type-check struct slot var . cont) + `(mlet ((($$$ast$$$ ,var) + (dispatch-type-check (struct-slot ',struct ',slot object)))) + (setf (struct-slot ',struct ',slot object) $$$ast$$$) + ,@cont)) + +;;; This is used to scope decls. + +(define-syntax (with-new-tyvars . cont) + `(dynamic-let ((*non-generic-tyvars* (dynamic *non-generic-tyvars*))) + ,@cont)) + + +;;; Similar to type-check, the slot must contain a list of decls. +;;; This must be done before any reference to a variable defined in the +;;; decls is typechecked. + +(define-syntax (type-check/decls struct slot . cont) + `(with-new-tyvars + (let (($$$decls$$$ + (type-decls (struct-slot ',struct ',slot object)))) + (setf (struct-slot ',struct ',slot object) $$$decls$$$) + ,@cont))) + +;;; The type checker returns an expression / type pair. This +;;; abstracts the returned value. + +(define-syntax (return-type object type) + `(values ,object ,type)) + +;;; When an ast slot contains a list of expressions, there are two +;;; possibilities: the expressions all share the same type or each has +;;; an independant type. In the first case, a single type (computed +;;; by unifying all types in the list) is bound to a variable. + +(define-syntax (type-check/unify-list struct slot var error-handler . cont) + `(mlet ((($$$ast$$$ $$$types$$$) + (do-type-check/list (struct-slot ',struct ',slot object)))) + (setf (struct-slot ',struct ',slot object) $$$ast$$$) + (with-type-error-handler ,error-handler ($$$types$$$) + (unify-list/single-type $$$types$$$) + (let ((,var (car $$$types$$$))) + ,@cont)))) + +;;; When a list of expressions does not share a common type, the result is +;;; a list of types. + +(define-syntax (type-check/list struct slot var . cont) + `(mlet ((($$$ast$$$ ,var) + (do-type-check/list (struct-slot ',struct ',slot object)))) + (setf (struct-slot ',struct ',slot object) $$$ast$$$) + ,@cont)) + +;;; This creates a fresh tyvar and binds it to a variable. + +(define-syntax (fresh-type var . cont) + `(let ((,var (**ntyvar))) + ,@cont)) + +;;; This drives the unification routine. Two types are unified and the +;;; context is updated. Currently no error handling is implemented to +;;; deal with unification errors. + +(define-syntax (type-unify type1 type2 error-handler) + `(with-type-error-handler ,error-handler () + (unify ,type1 ,type2))) + +;;; This generates a fresh set of monomorphic type variables. + +(define-syntax (fresh-monomorphic-types n vars . cont) + `(with-new-tyvars + (let ((,vars '())) + (dotimes (i ,n) + (let ((tv (**ntyvar))) + (push tv ,vars) + (push tv (dynamic *non-generic-tyvars*)))) + ,@cont))) + +;;; This creates a single monomorphic type variable. + +(define-syntax (fresh-monomorphic-type var . cont) + `(let* ((,var (**ntyvar))) + (with-new-tyvars + (push ,var (dynamic *non-generic-tyvars*)) + ,@cont))) + +;;; This is used to rewrite the current ast as a new ast and then +;;; recursively type check the new ast. The original ast is saved for +;;; error message printouts. + +(define-syntax (type-rewrite ast) + `(mlet (((res-ast type) (dispatch-type-check ,ast)) + (res (**save-old-exp object res-ast))) + (return-type res type))) + +;;; These are the type error handlers + +(define-syntax (recover-type-error error-handler . body) + (let ((temp (gensym)) + (err-fn (gensym))) + `(let/cc ,temp + (let ((,err-fn ,error-handler)) + (dynamic-let ((*type-error-recovery* + (cons (lambda () + (funcall ,err-fn ,temp)) + (dynamic *type-error-recovery*)))) + ,@body))))) + +(define-syntax (with-type-error-handler handler extra-args . body) + (if (eq? handler '#f) + `(begin ,@body) + `(dynamic-let ((*type-error-handlers* + (cons (lambda () + (,(car handler) ,@extra-args ,@(cdr handler))) + (dynamic *type-error-handlers*)))) + ,@body))) + diff --git a/type/type-main.scm b/type/type-main.scm new file mode 100644 index 0000000..c5ffe14 --- /dev/null +++ b/type/type-main.scm @@ -0,0 +1,56 @@ + +;;; This is the main entry point to the type checker. + + +(define (do-haskell-type-check object modules) + (type-init modules) + (when (is-type? 'let object) ; may be void + (dynamic-let ((*non-generic-tyvars* '()) + (*placeholders* '()) + (*enclosing-decls* '())) + (type-check/decls let decls + (setf (dynamic *non-generic-tyvars*) '()) + (process-placeholders (dynamic *placeholders*) '() '())))) + 'done) + +;;; This is the main recursive entry to the type checker. + +(define (dispatch-type-check exp) + (remember-context exp + (call-walker type exp))) + +(define (do-type-check/list exps) + (if (null? exps) + (values '() '()) + (mlet (((obj1 type1) (dispatch-type-check (car exps))) + ((objs types) (do-type-check/list (cdr exps)))) + (values (cons obj1 objs) (cons type1 types))))) + +(define (type-init modules) + ;; Built in types + (setf *char-type* (**ntycon (core-symbol "Char") '())) + (setf *string-type* (**ntycon (core-symbol "List") + (list *char-type*))) + (setf *bool-type* (**ntycon (core-symbol "Bool") '())) + (setf *int-type* (**ntycon (core-symbol "Int") '())) + (setf *integer-type* (**ntycon (core-symbol "Integer") '())) + (setf *rational-type* (**ntycon (core-symbol "Ratio") + (list *integer-type*))) + (setf *default-decls* '()) + (dolist (m modules) + (let ((default-types '())) + (dolist (d (default-decl-types (module-default m))) + (let* ((ty (ast->gtype '() d)) + (ntype (gtype-type ty))) + (cond ((not (null? (gtype-context ty))) + (recoverable-error 'not-monotype + "~A is not a monotype in default decl" ty)) + ((not (type-in-class? ntype (core-symbol "Num"))) + (recoverable-error 'not-Num-class + "~A is not in class Num" ty)) + (else + (push ntype default-types))))) + (push (tuple (module-name m) (reverse default-types)) *default-decls*)))) + +(define (remember-placeholder placeholder) + (push placeholder (dynamic *placeholders*))) diff --git a/type/type-vars.scm b/type/type-vars.scm new file mode 100644 index 0000000..4091ce4 --- /dev/null +++ b/type/type-vars.scm @@ -0,0 +1,60 @@ +;;; This type checks a variable. Possible cases: +;;; a) recursive variables +;;; b) method variables +;;; c) generalized variables +;;; d) other variables + +(define-type-checker var-ref + (let* ((var (var-ref-var object)) + (type (var-type var))) + (cond ((method-var? var) +;;; The context of a method variable always has the carrier class +;;; first. + (mlet (((ntype new-tyvars) (instantiate-gtype/newvars type)) + (carrier-tyvar (car new-tyvars)) + (extra-context (cdr new-tyvars)) + (p (**method-placeholder + var carrier-tyvar (dynamic *enclosing-decls*) object)) + (new-object (insert-dict-placeholders p extra-context object))) + (remember-placeholder p) + (return-type (**save-old-exp object new-object) ntype))) + ((recursive-type? type) + (let ((placeholder (**recursive-placeholder + var (dynamic *enclosing-decls*)))) + (push placeholder (recursive-type-placeholders type)) + (return-type placeholder (recursive-type-type type)))) + ((gtype? type) + (mlet (((ntype new-vars) (instantiate-gtype/newvars type)) + (object1 (insert-dict-placeholders object new-vars object))) + (return-type (if (eq? object1 object) + object + (**save-old-exp object object1)) + ntype))) + (else + (return-type object type))))) + +;;; This takes an expression and a context and returns an updated +;;; expression containing placeholders for the context information +;;; implied by the context. Tyvars in the context are added to dict-vars. + +(define (insert-dict-placeholders object tyvars var) + (cond ((null? tyvars) + object) + ((null? (ntyvar-context (car tyvars))) + (insert-dict-placeholders object (cdr tyvars) var)) + (else + (let ((tyvar (car tyvars))) + (insert-dict-placeholders + (insert-dict-placeholders/tyvar + tyvar (ntyvar-context tyvar) object var) + (cdr tyvars) + var))))) + +(define (insert-dict-placeholders/tyvar tyvar classes object var) + (if (null? classes) + object + (let ((p (**dict-placeholder + (car classes) tyvar (dynamic *enclosing-decls*) var))) + (remember-placeholder p) + (insert-dict-placeholders/tyvar tyvar (cdr classes) + (**app object p) var)))) diff --git a/type/type.scm b/type/type.scm new file mode 100644 index 0000000..8a3a82f --- /dev/null +++ b/type/type.scm @@ -0,0 +1,32 @@ +(define-compilation-unit type + (source-filename "$Y2/type/") + (require ast haskell-utils) + (unit type-macros + (source-filename "type-macros.scm")) + (unit unify + (require type-macros) + (source-filename "unify.scm")) + (unit type-main + (require type-macros) + (source-filename "type-main.scm")) + (unit type-decl + (require type-macros) + (source-filename "type-decl.scm")) + (unit dictionary + (require type-macros) + (source-filename "dictionary.scm")) + (unit default + (require type-macros) + (source-filename "default.scm")) + (unit pattern-binding + (require type-macros) + (source-filename "pattern-binding.scm")) + (unit type-vars + (require type-macros) + (source-filename "type-vars.scm")) + (unit expression-typechecking + (require type-macros) + (source-filename "expression-typechecking.scm")) + (unit type-error-handlers + (require type-macros) + (source-filename "type-error-handlers.scm"))) diff --git a/type/unify.scm b/type/unify.scm new file mode 100644 index 0000000..59248c9 --- /dev/null +++ b/type/unify.scm @@ -0,0 +1,154 @@ + +;;; File: type/unify.scm Author: John + +;;; This is the basic unification algorithm used in type checking. + +;;; Unification failure invokes the current type error handler + +;;; Start by removing instantiated type variables from the type. + +(define (unify type1 type2) + (unify-1 (prune type1) (prune type2))) + +;;; The only real tweak here is the read-only bit on type variables. +;;; The rule is that a RO tyvar can be unified only with a generic +;;; non-RO tyvar which has the same or more general context. + +;;; Aside from this, this is standard unification except that context +;;; propagation is needed when a tyvar with a non-empty context is +;;; instantiated. + +;;; If type2 is a tyvar and type1 is not they are switched. + +(define (unify-1 type1 type2) + (cond ((eq? type1 type2) ;; this catches variable to variable unify + 'OK) + ((ntyvar? type1) + (cond ((occurs-in-type type1 type2) + (type-error "Circular type: cannot unify ~A with ~A" + type1 type2)) + ((ntyvar-read-only? type1) + (cond ((or (not (ntyvar? type2)) (ntyvar-read-only? type2)) + (type-error + "Signature too general: cannot unify ~A with ~A" + type1 type2)) + (else + (unify-1 type2 type1)))) + ((and (ntyvar? type2) + (ntyvar-read-only? type2) + (non-generic? type1)) + (type-error + "Type signature cannot be used: monomorphic type variables present.")) + (else + (instantiate-tyvar type1 type2) + (let ((classes (ntyvar-context type1))) + (if (null? classes) + 'OK + (propagate-contexts/ntype type1 type2 classes)))))) + ((ntyvar? type2) + (unify-1 type2 type1)) + ((eq? (ntycon-tycon type1) (ntycon-tycon type2)) + (unify-list (ntycon-args type1) (ntycon-args type2))) + (else + (let ((etype1 (expand-ntype-synonym type1)) + (etype2 (expand-ntype-synonym type2))) + (if (same-tycon? (ntycon-tycon etype1) (ntycon-tycon etype2)) + (unify-list (ntycon-args etype1) (ntycon-args etype2)) + ;; This error message should probably show both the original + ;; and the expanded types for clarity. + (type-error + "Type conflict: type ~A does not match ~A" + etype1 etype2)))))) + + +(define-integrable (instantiate-tyvar tyvar val) + (setf (ntyvar-value tyvar) val)) + +;;; This is needed since interface files may leave multiple def's +;;; for the same tycon sitting around. + +(define (same-tycon? ty1 ty2) + (or (eq? ty1 ty2) + (and (eq? (def-name ty1) (def-name ty2)) + (eq? (def-module ty1) (def-module ty2))))) + + +;;; unifies two lists of types pairwise. Used for tycon args. + +(define (unify-list args1 args2) + (if (null? args1) + 'OK + (begin (unify-list (cdr args1) (cdr args2)) + (unify (car args1) (car args2))))) + +;;; combines a list of types into a single type. Used in constructs +;;; such as [x,y,z] and case expressions. + +(define (unify-list/single-type types) + (when (not (null? types)) + (let ((type (car types))) + (dolist (type2 (cdr types)) + (unify type type2))))) + +;;; This propagates the context from a just instantiated tyvar to the +;;; instantiated value. If the value is a tycon, instances must be +;;; looked up. If the value is a tyvar, the context is added to that of +;;; other tyvar. + +;;; This is used to back out of the unification on errors. This is a +;;; poor mans trail stack! Without this, error messages get very +;;; obscure. + +(define *instantiated-tyvar* '()) + +(define (propagate-contexts/ntype tyvar type classes) + (dynamic-let ((*instantiated-tyvar* tyvar)) + (propagate-contexts/inner type classes))) + +(define (propagate-contexts/inner type classes) + (let ((type (prune type))) + (if (ntyvar? type) + (if (ntyvar-read-only? type) + (if (context-implies? (ntyvar-context type) classes) + 'OK ; no need for context propagation here + (begin + (setf (ntyvar-value (dynamic *instantiated-tyvar*)) '#f) + (type-error "Signature context is too general"))) + (if (null? (ntyvar-context type)) + (setf (ntyvar-context type) classes) + (setf (ntyvar-context type) + (merge-contexts classes (ntyvar-context type))))) + (propagate-contexts-1 (expand-ntype-synonym type) classes)))) + +;;; The type has now been expanded. This propagates each class constraint +;;; in turn. + +(define (propagate-contexts-1 type classes) + (dolist (class classes) + (propagate-single-class type class))) + +;;; Now we have a single class & data type. Either an instance decl can +;;; be found or a type error should be signalled. Once the instance +;;; decl is found, contexts are propagated to the component types. + +(define (propagate-single-class type class) + (let ((instance (lookup-instance (ntycon-tycon type) class))) + (cond ((eq? instance '#f) + ;; This remove the instantiation which caused the type + ;; error - perhaps stop error propagation & make + ;; error message better. + (setf (ntyvar-value (dynamic *instantiated-tyvar*)) '#f) + (type-error "Type ~A is not in class ~A" type class)) + (else + ;; The instance contains a list of class constraints for + ;; each argument. This loop pairs the argument to the + ;; type constructor with the context required by the instance + ;; decl. + (dolist2 (classes (instance-gcontext instance)) + (arg (ntycon-args type)) + (propagate-contexts/inner arg classes))))) + 'OK) + +;;; The routines which handle contexts (merge-contexts and context-implies?) +;;; are in type-utils. The occurs check is also there. + diff --git a/util/README b/util/README new file mode 100644 index 0000000..a39e4bc --- /dev/null +++ b/util/README @@ -0,0 +1,2 @@ +This directory contains random utilities that are used in various places +around the compiler. diff --git a/util/annotation-utils.scm b/util/annotation-utils.scm new file mode 100644 index 0000000..8e2baf2 --- /dev/null +++ b/util/annotation-utils.scm @@ -0,0 +1,41 @@ + +;;; Some general utilities for dealing with annotations + +;;; Lookup an annotation on a var + +(define (lookup-annotation var aname) + (lookup-annotation-1 (var-annotations var) aname)) + +(define (lookup-annotation-1 a aname) + (if (null? a) + '#f + (if (eq? aname (annotation-value-name (car a))) + (car a) + (lookup-annotation-1 (cdr a) aname)))) + +;;; This parses a string denoting a strictness property into a list +;;; of booleans. "S,N,S" -> (#t #f #t) + +(define (parse-strictness str) + (parse-strictness-1 str 0)) + +(define (parse-strictness-1 str i) + (if (>= i (string-length str)) + (signal-bad-strictness-annotation str) + (let* ((ch (char-downcase (string-ref str i))) + (s (cond ((char=? ch '#\s) + '#t) + ((char=? ch '#\n) + '#f) + (else + (signal-bad-strictness-annotation str))))) + (cond ((eqv? (1+ i) (string-length str)) + (list s)) + ((char=? (string-ref str (1+ i)) '#\,) + (cons s (parse-strictness-1 str (+ i 2)))) + (else + (signal-bad-strictness-annotation str)))))) + +(define (signal-bad-strictness-annotation str) + (fatal-error 'bad-strictness "Bad strictness annotation: ~A~%" str)) + diff --git a/util/constructors.scm b/util/constructors.scm new file mode 100644 index 0000000..2fa8bd3 --- /dev/null +++ b/util/constructors.scm @@ -0,0 +1,339 @@ +;;; This file contains ast construction functions. These +;;; functions are supplied for commonly used ast structures to +;;; avoid the longer `make' normally required. + +;;; Function names are the type names with a `**' prefix. For reference +;;; nodes, the /def for builds the node from a definition instead of a name. + +;;; Note: maybe these should be made automagicly someday. + +;;; from exp-structs: + +(define (**lambda args body) + (**lambda/pat (map (function **pat) args) body)) + +(define (**lambda/pat pats body) + (if (null? pats) + body + (make lambda (pats pats) (body body)))) + + + +;;; Make a case expression. + +(define (**case exp alts) + (make case (exp exp) (alts alts))) + +(define (**alt/simple pat exp) + (**alt pat + (list (make guarded-rhs + (guard (make omitted-guard)) + (rhs exp))) + '())) + +(define (**alt pat rhs-list where-decls) + (make alt (pat pat) (rhs-list rhs-list) (where-decls where-decls))) + + + + +(define (**let decls body) + (if decls + (make let (decls decls) (body body)) + body)) + +(define (**if test then-exp else-exp) + (make if (test-exp test) (then-exp then-exp) (else-exp else-exp))) + +(define (**app fn . args) ; any number of args + (**app/l fn args)) + +(define (**app/l fn args) ; second args is a list + (if (null? args) + fn + (**app/l (make app (fn fn) (arg (car args))) + (cdr args)))) + +(define (**var name) + (make var-ref (name name) (var (dynamic *undefined-def*)) (infix? '#f))) + +(define (**var/def def) ; arg is an entry + (make var-ref (var def) (name (def-name def)) (infix? '#f))) + +(define (**con/def def) + (make con-ref (name (def-name def)) (con def) (infix? '#f))) + +(define (**int x) + (make integer-const (value x))) + +(define (**char x) + (make char-const (value x))) + +(define (**string x) + (make string-const (value x))) + +(define (**listcomp exp quals) + (make list-comp (exp exp) (quals quals))) + +(define (**gen pat exp) + (make qual-generator (pat (**pat pat)) (exp exp))) + +(define (**omitted-guard) + (make omitted-guard)) + +(define (**con-number exp algdata) + (make con-number (type algdata) (value exp))) + +(define (**sel con exp i) + (make sel (constructor con) (value exp) (slot i))) + +(define (**is-constructor exp con) + (make is-constructor (value exp) (constructor con))) + +;;; From valdef-structs + +(define (**signdecl vars type) + (make signdecl (vars (map (function **var) vars)) (signature type))) + +(define (**signdecl/def vars type) + (make signdecl (vars (map (function **var/def) vars)) (signature type))) + +(define (**define name args val) + (**valdef (**pat name) (map (function **pat) args) val)) + +(define (**valdef/def var exp) + (**valdef/pat (**var-pat/def var) exp)) + +(define (**valdef/pat pat exp) + (**valdef pat '() exp)) + +(define (**valdef lhs args rhs) + (make valdef + (lhs lhs) + (definitions + (list (make single-fun-def + (args args) + (rhs-list + (list (make guarded-rhs + (guard (**omitted-guard)) + (rhs rhs)))) + (where-decls '()) + (infix? '#f)))))) + + +;;; Patterns (still in valdef-structs) + +;;; The **pat function converts a very simple lisp-style pattern representation +;;; into corresponding ast structure. The conversion: +;;; a) _ => wildcard +;;; b) a symbol => Var pattern +;;; c) an integer / string => const pattern +;;; d) a list of pats starting with 'tuple => Pcon +;;; e) a list of pats starting with a con definition => Pcon + +(define (**pat v) + (cond ((eq? v '_) (**wildcard-pat)) + ((symbol? v) + (make var-pat (var (**var v)))) + ((var? v) + (make var-pat (var (**var/def v)))) + ((integer? v) + (make const-pat (value (**int v)))) + ((string? v) + (make const-pat (value (**string v)))) + ((and (pair? v) (eq? (car v) 'tuple)) + (**pcon/tuple (map (function **pat) (cdr v)))) + ((and (pair? v) (con? (car v))) + (**pcon/def (car v) (map (function **pat) (cdr v)))) + (else + (error "Bad pattern in **pat: ~A~%" v)))) + +(define (**pcon name pats) + (make pcon (name (add-con-prefix/symbol name)) + (con (dynamic *undefined-def*)) (pats pats) (infix? '#f))) + +(define (**pcon/def def pats) + (make pcon (name (def-name def)) (con def) (pats pats) (infix? '#f))) + +(define (**pcon/tuple pats) + (**pcon/def (tuple-constructor (length pats)) pats)) + +;;; Make a variable pattern from the var + +(define (**var-pat/def var) + (make var-pat + (var (**var/def var)))) + +(define (**wildcard-pat) + (make wildcard-pat)) + + +;;; Either make a tuple, or return the single element of a list. + +(define (**tuple-pat pats) + (cond ((null? pats) + (**pcon/def (core-symbol "UnitConstructor") '())) + ((null? (cdr pats)) + (car pats)) + (else + (**pcon/tuple pats)))) + + +;;; From type-structs.scm + +(define (**tycon name args) + (make tycon (name name) (args args) (def (dynamic *undefined-def*)))) + +(define (**tycon/def def args) + (make tycon (name (def-name def)) (def def) (args args))) + +(define (**tyvar name) + (make tyvar (name name))) + +(define (**signature context type) + (make signature (context context) (type type))) + +(define (**class/def def) + (make class-ref (name (def-name def)) (class def))) + +(define (**context tycls tyvar) + (make context (class tycls) (tyvar tyvar))) + +;;; From tc-structs + +(define (**ntyvar) + (make ntyvar (value '#f) (context '()) (dict-params '()))) + +(define (**ntycon tycon args) + (make ntycon (tycon tycon) (args args))) + +(define (**arrow . args) + (**arrow/l args)) + +(define (**arrow/l args) + (if (null? (cdr args)) + (car args) + (**ntycon (core-symbol "Arrow") + (list (car args) (**arrow/l (cdr args)))))) + +(define (**arrow/l-2 args final-val) + (if (null? args) + final-val + (**ntycon (core-symbol "Arrow") + (list (car args) (**arrow/l-2 (cdr args) final-val))))) + +(define (**list-of arg) + (**ntycon (core-symbol "List") (list arg))) + +(define (**recursive-placeholder var edecls) + (make recursive-placeholder (var var) (exp '#f) + (enclosing-decls edecls))) + +(define (**dict-placeholder class tyvar edecls var) + (make dict-placeholder + (class class) (exp '#f) (overloaded-var var) + (tyvar tyvar) (enclosing-decls edecls))) + +(define (**method-placeholder method tyvar edecls var) + (make method-placeholder + (method method) (exp '#f) (overloaded-var var) + (tyvar tyvar) (enclosing-decls edecls))) + +;;; Some less primitive stuff + +(define (**tuple-sel n i exp) ;; 0 <= i < n + (if (eqv? n 1) + exp + (**sel (tuple-constructor n) exp i))) + +(define (**abort msg) + (**app (**var/def (core-symbol "error")) + (**string msg))) + +(define (**tuple/l args) + (cond ((null? args) + (**con/def (core-symbol "UnitConstructor"))) + ((null? (cdr args)) + (car args)) + (else + (**app/l (**con/def (tuple-constructor (length args))) + args)))) + +(define (**tuple . args) + (**tuple/l args)) + +(define (**tuple-type/l args) + (cond ((null? args) + (**tycon/def (core-symbol "UnitConstructor") '())) + ((null? (cdr args)) + (car args)) + (else + (**tycon/def (tuple-tycon (length args)) args)))) + +(define (**tuple-type . args) + (**tuple-type/l args)) + +(define (**arrow-type . args) + (**arrow-type/l args)) + +(define (**arrow-type/l args) + (if (null? (cdr args)) + (car args) + (**tycon/def (core-symbol "Arrow") (list (car args) + (**arrow-type/l (cdr args)))))) + +(define (**fromInteger x) + (**app (**var/def (core-symbol "fromInteger")) x)) + +(define (**fromRational x) + (**app (**var/def (core-symbol "fromRational")) x)) + +(define (**gtyvar n) + (make gtyvar (varnum n))) + +(define (**gtype context type) + (make gtype (context context) (type type))) + +(define (**fixity a p) + (make fixity (associativity a) (precedence p))) + +(define (**ntycon/tuple . args) + (let ((arity (length args))) + (**ntycon (tuple-tycon arity) args))) + +(define (**ntycon/arrow . args) + (**ntycon/arrow-l args)) + +(define (**ntycon/arrow-l args) + (let ((arg (if (integer? (car args)) + (**gtyvar (car args)) + (car args)))) + (if (null? (cdr args)) + arg + (**arrow arg (**ntycon/arrow-l (cdr args)))))) + +(define (**save-old-exp old new) + (make save-old-exp (old-exp old) (new-exp new))) + + + +;;; These are used by the CFN. + +(define (**case-block block-name exps) + (make case-block + (block-name block-name) + (exps exps))) + +(define (**return-from block-name exp) + (make return-from + (block-name block-name) + (exp exp))) + +(define (**and-exp . exps) + (cond ((null? exps) + (**con/def (core-symbol "True"))) + ((null? (cdr exps)) + (car exps)) + (else + (make and-exp (exps exps))))) + diff --git a/util/haskell-utils.scm b/util/haskell-utils.scm new file mode 100644 index 0000000..c851cda --- /dev/null +++ b/util/haskell-utils.scm @@ -0,0 +1,22 @@ +(define-compilation-unit haskell-utils + (source-filename "$Y2/util/") + (require global) + (unit constructors + (source-filename "constructors.scm")) + (unit prec-utils + (source-filename "prec-utils.scm")) + (unit walk-ast + (source-filename "walk-ast.scm")) + (unit pattern-vars + (source-filename "pattern-vars.scm") + (require walk-ast)) + (unit instance-manager + (source-filename "instance-manager.scm")) + (unit signature + (source-filename "signature.scm")) + (unit type-utils + (source-filename "type-utils.scm")) + (unit annotation-utils + (source-filename "annotation-utils.scm")) + ) + diff --git a/util/instance-manager.scm b/util/instance-manager.scm new file mode 100644 index 0000000..231e27d --- /dev/null +++ b/util/instance-manager.scm @@ -0,0 +1,161 @@ + +;;; This file has some random utilities dealing with instances. + +;;; Right now, this is a linear search off the class. + +(define (lookup-instance alg-def class-def) + (let ((res (lookup-instance-1 alg-def (class-instances class-def)))) + (if (and (eq? res '#f) (algdata-real-tuple? alg-def)) + (lookup-possible-tuple-instances alg-def class-def) + res))) + +(define (lookup-instance-1 alg-def instances) + (cond ((null? instances) + '#f) + ((eq? (instance-algdata (car instances)) alg-def) + (if (instance-ok? (car instances)) + (car instances) + '#f)) + (else + (lookup-instance-1 alg-def (cdr instances))))) + +(define (lookup-possible-tuple-instances alg-def class-def) + (cond ((eq? class-def (core-symbol "Eq")) + (get-tuple-eq-instance alg-def)) + ((eq? class-def (core-symbol "Ord")) + (get-tuple-ord-instance alg-def)) + ((eq? class-def (core-symbol "Ix")) + (get-tuple-ix-instance alg-def)) + ((eq? class-def (core-symbol "Text")) + (get-tuple-text-instance alg-def)) + ((eq? class-def (core-symbol "Binary")) + (get-tuple-binary-instance alg-def)) + (else '#f))) + +(define *saved-eq-instances* '()) +(define *saved-ord-instances* '()) +(define *saved-ix-instances* '()) +(define *saved-text-instances* '()) +(define *saved-binary-instances* '()) + +(define (get-tuple-eq-instance tpl) + (let ((res (assq tpl *saved-eq-instances*))) + (if (not (eq? res '#f)) + (tuple-2-2 res) + (let ((inst (make-tuple-instance + tpl (core-symbol "Eq") (core-symbol "tupleEqDict")))) + (push (tuple tpl inst) *saved-eq-instances*) + inst)))) + +(define (get-tuple-ord-instance tpl) + (let ((res (assq tpl *saved-ord-instances*))) + (if (not (eq? res '#f)) + (tuple-2-2 res) + (let ((inst (make-tuple-instance + tpl (core-symbol "Ord") (core-symbol "tupleOrdDict")))) + (push (tuple tpl inst) *saved-ord-instances*) + inst)))) + +(define (get-tuple-ix-instance tpl) + (let ((res (assq tpl *saved-ix-instances*))) + (if (not (eq? res '#f)) + (tuple-2-2 res) + (let ((inst (make-tuple-instance + tpl (core-symbol "Ix") (core-symbol "tupleIxDict")))) + (push (tuple tpl inst) *saved-ix-instances*) + inst)))) + +(define (get-tuple-text-instance tpl) + (let ((res (assq tpl *saved-text-instances*))) + (if (not (eq? res '#f)) + (tuple-2-2 res) + (let ((inst (make-tuple-instance + tpl (core-symbol "Text") (core-symbol "tupleTextDict")))) + (push (tuple tpl inst) *saved-text-instances*) + inst)))) + +(define (get-tuple-binary-instance tpl) + (let ((res (assq tpl *saved-binary-instances*))) + (if (not (eq? res '#f)) + (tuple-2-2 res) + (let ((inst (make-tuple-instance + tpl (core-symbol "Binary") + (core-symbol "tupleBinaryDict")))) + (push (tuple tpl inst) *saved-binary-instances*) + inst)))) + +(define (make-tuple-instance algdata class dict) + (let* ((size (tuple-size algdata)) + (tyvars (gen-symbols size)) + (context (map (lambda (tyvar) + (**context (**class/def class) tyvar)) + tyvars)) + (sig (**tycon/def algdata (map (lambda (x) (**tyvar x)) tyvars))) + (gcontext (gtype-context (ast->gtype context sig)))) + (make instance + (algdata algdata) + (tyvars tyvars) + (class class) + (context context) + (gcontext gcontext) + (methods '()) + (dictionary dict) + (ok? '#t) + (special? '#t)))) + +;;; I know these are somewhere else too ... + +(define (tuple-size alg) + (con-arity (car (algdata-constrs alg)))) + +(define (gen-symbols n) + (gen-symbols-1 n '(|a| |b| |c| |d| |e| |f| |g| |h| |i| |j| |k| |l| |m| + |n| |o| |p| |q| |r| |s| |t| |u| |v| |w| |x| |y| |z|))) + +(define (gen-symbols-1 n vars) + (if (eqv? n 0) + '() + (if (null? vars) + (cons (string->symbol (format '#f "x~A" n)) + (gen-symbols-1 (1- n) '())) + (cons (car vars) (gen-symbols-1 (1- n) (cdr vars)))))) + +;;; This handles the dynamic linking of instances into classes + +(define (link-instances modules) + (dolist (m modules) + ;; clear out any instances sitting around from old compiles + (dolist (class (module-class-defs m)) + (setf (class-instances class) '()))) + (dolist (m modules) + (dolist (inst (module-instance-defs m)) + (link-instance inst))) + ) + +(define (link-instance inst) ; links an instance into the associated class + (push inst (class-instances (instance-class inst)))) + +;;; This creates a new instance object and installs it. + +(predefine (make-new-var name)) ; in tdecl/tdecl-utils.scm + +(define (new-instance class algdata tyvars) + (let* ((dict-name + (string-append "dict-" + (symbol->string (print-name class)) "-" + (symbol->string (print-name algdata)))) + (inst (make instance (algdata algdata) + (tyvars tyvars) + (class class) + (gcontext '()) + (context '()) + (dictionary (make-new-var dict-name))))) + (link-instance inst) + inst)) + + + + + + + diff --git a/util/pattern-vars.scm b/util/pattern-vars.scm new file mode 100644 index 0000000..78cb361 --- /dev/null +++ b/util/pattern-vars.scm @@ -0,0 +1,40 @@ +;;; This collects the vars bound in a pattern. + +(define-walker collect-pattern-vars ast-td-collect-pattern-vars-walker) + +(define (collect-pattern-vars x) + (collect-pattern-vars-1 x '())) + +(define (collect-pattern-vars-1 x vars-so-far) + (call-walker collect-pattern-vars x vars-so-far)) + +(define (collect-pattern-vars/list l vars-so-far) + (if (null? l) + vars-so-far + (collect-pattern-vars/list (cdr l) + (collect-pattern-vars-1 (car l) vars-so-far)))) + +(define-local-syntax (collect-pattern-vars-processor + slot type object-form accum-form) + (let ((stype (sd-type slot)) + (sname (sd-name slot))) + (cond ((eq? stype 'var-ref) + `(cons (struct-slot ',type ',sname ,object-form) ,accum-form)) + ((eq? stype 'pattern) + `(collect-pattern-vars-1 + (struct-slot ',type ',sname ,object-form) + ,accum-form)) + ((equal? stype '(list pattern)) + `(collect-pattern-vars/list + (struct-slot ',type ',sname ,object-form) ,accum-form)) + (else +; (format '#t "Collect-pattern-vars: skipping slot ~A in ~A~%" +; sname +; type) + accum-form) + ))) + +(define-collecting-walker-methods collect-pattern-vars + (as-pat irr-pat var-pat wildcard-pat const-pat plus-pat pcon list-pat + pp-pat-list pp-pat-plus pp-pat-negated) + collect-pattern-vars-processor) diff --git a/util/prec-utils.scm b/util/prec-utils.scm new file mode 100644 index 0000000..6ff7a1a --- /dev/null +++ b/util/prec-utils.scm @@ -0,0 +1,115 @@ +;;; prec-util.scm -- utilities for precedence parsing and printing of +;;; expressions +;;; +;;; author : Sandra Loosemore +;;; date : 15 Feb 1992 +;;; +;;; The functions in this file are used by the expression printers +;;; and by precedence parsing. + + +;;; Uncurry the function application, looking for a con-ref as the +;;; actual function being applied. Return the con-ref-con and a list +;;; of the arguments. + +(define (extract-constructor fn args) + (cond ((is-type? 'con-ref fn) + (values (con-ref-con fn) args)) + ((is-type? 'app fn) + (extract-constructor (app-fn fn) (cons (app-arg fn) args))) + (else + (values '#f '())))) + + +;;; If this is an infix operator application, there are really two nested +;;; applications that we handle at once. The "fn" on the outer app +;;; points to a nested app which is a var-ref or con-ref with the infix? +;;; slot set to T. +;;; Returns three values: the fixity info, the operator, and the first +;;; argument (the arg to the outer application is the second argument). + +(define (extract-infix-operator fn) + (if (is-type? 'app fn) + (let* ((new-fn (app-fn fn)) + (arg (app-arg fn)) + (fixity (operator-fixity new-fn))) + (if fixity + (values fixity new-fn arg) + (values '#f '#f '#f))) + (values '#f '#f '#f))) + + +;;; Return the fixity info for a reference to a var or con. +;;; If it doesn't have an explicit fixity, use the default of +;;; left associativity and precedence 9. + +(define default-fixity + (make fixity (associativity 'l) (precedence 9))) + +(define (operator-fixity fn) + (if (is-type? 'save-old-exp fn) + (operator-fixity (save-old-exp-old-exp fn)) + (or (and (is-type? 'var-ref fn) + (var-ref-infix? fn) + (or (and (var-ref-var fn) + (not (eq? (var-ref-var fn) *undefined-def*)) + (var-fixity (var-ref-var fn))) + default-fixity)) + (and (is-type? 'con-ref fn) + (con-ref-infix? fn) + (or (and (con-ref-con fn) + (not (eq? (con-ref-con fn) *undefined-def*)) + (con-fixity (con-ref-con fn))) + default-fixity)) + (and (is-type? 'pcon fn) + (pcon-infix? fn) + (or (and (pcon-con fn) + (not (eq? (pcon-con fn) *undefined-def*)) + (con-fixity (pcon-con fn))) + default-fixity)) + '#f))) + + + +;;; Determine the precedence of an expression. +;;; *** What about unary -? + +(define (precedence-of-exp exp associativity) + (cond ((is-type? 'save-old-exp exp) + (precedence-of-exp (save-old-exp-old-exp exp) associativity)) + ((is-type? 'aexp exp) 10) + ((is-type? 'app exp) + (multiple-value-bind (fixity op arg1) + (extract-infix-operator (app-fn exp)) + (declare (ignore op arg1)) + (if fixity + (if (eq? associativity (fixity-associativity fixity)) + (1+ (fixity-precedence fixity)) + (fixity-precedence fixity)) + 10))) + ((is-type? 'lambda exp) 10) + ((is-type? 'let exp) 10) + ((is-type? 'if exp) 10) + ((is-type? 'case exp) 10) + ((pp-exp-list-section? exp) 10) + ((is-type? 'negate exp) 10) ; hack, hack + (else + 0))) + + +;;; Determine whether a pp-exp-list is really a section -- the +;;; first or last exp in the list is really an infix op. + +(define (pp-exp-list-section? object) + (if (is-type? 'pp-exp-list object) + (let ((exps (pp-exp-list-exps object))) + (or (infix-var-or-con? (car exps)) + (infix-var-or-con? (list-ref exps (1- (length exps)))))) + '#f)) + +(define (infix-var-or-con? object) + (or (and (is-type? 'var-ref object) + (var-ref-infix? object)) + (and (is-type? 'con-ref object) + (con-ref-infix? object)))) + diff --git a/util/signature.scm b/util/signature.scm new file mode 100644 index 0000000..aea41eb --- /dev/null +++ b/util/signature.scm @@ -0,0 +1,90 @@ +;;; This file handles the scoping and error checking of signatures. + +;;; Possible errors: +;;; Wrong arity in a tycon +;;; Ambiguous context + +;;; Other errors may be present; these are detected at a higher level. +;;; The list of variables used in the signature is returned. + +(define (resolve-signature signature) + (with-slots signature (context type) signature + (let ((tyvars (resolve-type type))) + (resolve-signature-aux tyvars context) + tyvars))) + +(define (resolve-signature-aux tyvars context) + (dolist (ctxt context) + (with-slots context (class tyvar) ctxt + (when (not (memq tyvar tyvars)) + (signal-ambiguous-context tyvar)) + (resolve-class class)))) + +(define (resolve-type type) + (resolve-type-1 type '())) + +(define (resolve-type-1 type vars) + (cond ((tyvar? type) + (cons (tyvar-name type) vars)) + (else + (resolve-tycon type) + (with-slots tycon (name def args) type + (when (not (eq? def *undefined-def*)) + (if (eqv? (tycon-def-arity def) -1) + (setf (tycon-def-arity def) (length args)) + (when (not (eqv? (length args) (tycon-def-arity def))) + (signal-tycon-arity name type)))) + (resolve-type/list args vars))))) + +(define (resolve-type/list args vars) + (if (null? args) + vars + (resolve-type/list (cdr args) (resolve-type-1 (car args) vars)))) + +;;; This returns the names of the tyvars in a simple tycon + +(define (simple-tyvar-list simple) + (remember-context simple + (let* ((res (map (lambda (x) (tyvar-name x)) (tycon-args simple))) + (dups (find-duplicates res))) + (when (not (null? dups)) + (signal-non-linear-type-vars simple)) + res))) + +;;; This is used to build the class dictionary signature. + +(define (substitute-tyvar type tyvar new) + (cond ((tyvar? type) + (if (eq? (tyvar-name type) tyvar) + new + (**tyvar (tyvar-name type)))) + ((tycon? type) + (with-slots tycon (name def args) type + (make tycon (name name) (def def) + (args (map (lambda (x) (substitute-tyvar x tyvar new)) + args))))) + (else + (**signature (signature-context type) + (substitute-tyvar (signature-type type) tyvar new))))) + + + +;;; Error signalling routines + +(define (signal-ambiguous-context tyvar) + (phase-error 'ambiguous-context + "~a is referenced in a context, but is not bound as a type variable." + tyvar)) + +(define (signal-tycon-arity name type) + (phase-error 'tycon-arity + "The wrong number of arguments are supplied to the constructor ~a~%~ + in the type ~a." + name type)) + + +(define (signal-non-linear-type-vars simple) + (phase-error 'non-linear-type-vars + "There are duplicate type variables in ~s." + simple)) + diff --git a/util/type-utils.scm b/util/type-utils.scm new file mode 100644 index 0000000..c9b4504 --- /dev/null +++ b/util/type-utils.scm @@ -0,0 +1,308 @@ + +;;; The `prune' function removes instantiated type variables at the +;;; top level of a type. + +;;; It returns an uninstantiated type variable or a type constructor. + +(define-integrable (prune ntype) + (if (ntyvar? ntype) + (if (instantiated? ntype) + (prune-1 (ntyvar-value ntype)) + ntype) + ntype)) + +;;; This is because lucid can't hack inlining recursive fns. + +(define (prune-1 x) (prune x)) + +(define-integrable (instantiated? ntyvar) + (ntyvar-value ntyvar)) +; (not (eq? (ntyvar-value ntyvar) '#f))) ;*** Lucid compiler bug? + +(define (prune/l l) + (map (function prune) l)) + + +;;; These functions convert between AST types and gtypes. Care is taken to +;;; ensure that the gtyvars are in the same order that they appear in the +;;; context. This is needed to make dictionary conversion work right. + +(define (ast->gtype context type) + (mlet (((gcontext env) (context->gcontext context '() '())) + ((type env1) (type->gtype type env)) + (gcontext-classes (arrange-gtype-classes env1 gcontext))) + (**gtype gcontext-classes type))) + +;;; This is similar except that the ordering of the tyvars is as defined in +;;; the data type. This is used only for instance declarations and allows +;;; for simple context implication checks. It also used by the signature +;;; of the dictionary variable. + +(define (ast->gtype/inst context type) + (mlet (((type env) (type->gtype type '())) + ((gcontext env1) (context->gcontext context '() env)) + (gcontext-classes (arrange-gtype-classes env1 gcontext))) + (**gtype gcontext-classes type))) + +;;; This converts a context into gtype form [[class]]: a list of classes +;;; for each gtyvar. This returns the context and the gtyvar environment. + +(define (context->gcontext context gcontext env) + (if (null? context) + (values gcontext env) + (mlet ((sym (context-tyvar (car context))) + (class (class-ref-class (context-class (car context)))) + ((n new-env) (ast->gtyvar sym env)) + (old-context (get-gtyvar-context n gcontext)) + (new-context (merge-single-class class old-context)) + (new-gcontext (cons (tuple n new-context) gcontext))) + (context->gcontext (cdr context) new-gcontext new-env)))) + +;;; This assigns a gtyvar number to a tyvar name. + +(define (ast->gtyvar sym env) + (let ((res (assq sym env))) + (if (eq? res '#f) + (let ((n (length env))) + (values n (cons (tuple sym n) env))) + (values (tuple-2-2 res) env)))) + +(define (get-gtyvar-context n gcontext) + (cond ((null? gcontext) + '()) + ((eqv? n (tuple-2-1 (car gcontext))) + (tuple-2-2 (car gcontext))) + (else (get-gtyvar-context n (cdr gcontext))))) + +(define (type->gtype type env) + (if (tyvar? type) + (mlet (((n env1) (ast->gtyvar (tyvar-name type) env))) + (values (**gtyvar n) env1)) + (mlet (((types env1) (type->gtype/l (tycon-args type) env))) + (values (**ntycon (tycon-def type) types) env1)))) + +(define (type->gtype/l types env) + (if (null? types) + (values '() env) + (mlet (((type env1) (type->gtype (car types) env)) + ((other-types env2) (type->gtype/l (cdr types) env1))) + (values (cons type other-types) env2)))) + +(define (arrange-gtype-classes env gcontext) + (arrange-gtype-classes-1 0 (length env) env gcontext)) + +(define (arrange-gtype-classes-1 m n env gcontext) + (if (equal? m n) + '() + (cons (get-gtyvar-context m gcontext) + (arrange-gtype-classes-1 (1+ m) n env gcontext)))) + +;;; These routines convert gtypes back to ordinary types. + +(define (instantiate-gtype g) + (mlet (((gtype _) (instantiate-gtype/newvars g))) + gtype)) + +(define (instantiate-gtype/newvars g) + (if (null? (gtype-context g)) + (values (gtype-type g) '()) + (let ((new-tyvars (create-new-tyvars (gtype-context g)))) + (values (copy-gtype (gtype-type g) new-tyvars) new-tyvars)))) + +(define (create-new-tyvars ctxts) + (if (null? ctxts) + '() + (let ((tyvar (**ntyvar))) + (setf (ntyvar-context tyvar) (car ctxts)) + (cons tyvar (create-new-tyvars (cdr ctxts)))))) + +(define (copy-gtype g env) + (cond ((ntycon? g) + (**ntycon (ntycon-tycon g) + (map (lambda (g1) (copy-gtype g1 env)) + (ntycon-args g)))) + ((ntyvar? g) + g) + ((gtyvar? g) + (list-ref env (gtyvar-varnum g))) + ((const-type? g) + (const-type-type g)))) + +;;; ntypes may contain synonyms. These are expanded here. Only the +;;; top level synonym is expanded. + +(define (expand-ntype-synonym type) + (if (and (ntycon? type) + (synonym? (ntycon-tycon type))) + (let ((syn (ntycon-tycon type))) + (expand-ntype-synonym + (expand-ntype-synonym-1 (synonym-body syn) + (map (lambda (var val) + (tuple var val)) + (synonym-args syn) + (ntycon-args type))))) + type)) + +(define (expand-ntype-synonym-1 type env) + (if (tyvar? type) + (tuple-2-2 (assq (tyvar-name type) env)) + (**ntycon (tycon-def type) + (map (lambda (ty) (expand-ntype-synonym-1 ty env)) + (tycon-args type))))) + +;;; This is used in generalization. Note that ntyvars will remain when +;;; non-generic tyvars are encountered. + +(define (ntype->gtype ntype) + (mlet (((res _) (ntype->gtype/env ntype '()))) + res)) + +(define (ntype->gtype/env ntype required-vars) + (mlet (((gtype env) (ntype->gtype-1 ntype required-vars))) + (values + (make gtype (type gtype) (context (map (lambda (x) (ntyvar-context x)) + env))) + env))) + +(define (ntype->gtype-1 ntype env) + (let ((ntype (prune ntype))) + (cond ((ntycon? ntype) + (mlet (((args env1) (ntype->gtype/l (ntycon-args ntype) env))) + (values (**ntycon (ntycon-tycon ntype) args) env1))) + (else + (ntyvar->gtyvar ntype env))))) + +(define (ntype->gtype/l types env) + (if (null? types) + (values '() env) + (mlet (((type env1) (ntype->gtype-1 (car types) env)) + ((types2 env2) (ntype->gtype/l (cdr types) env1))) + (values (cons type types2) env2)))) + +(define (ntyvar->gtyvar ntyvar env) + (if (non-generic? ntyvar) + (values ntyvar env) + (let ((l (list-pos ntyvar env))) + (if (eq? l '#f) + (values (**gtyvar (length env)) (append env (list ntyvar))) + (values (**gtyvar l) env))))) + +(define (list-pos x l) + (list-pos-1 x l 0)) + +(define (list-pos-1 x l n) + (cond ((null? l) + '#f) + ((eq? x (car l)) + n) + (else + (list-pos-1 x (cdr l) (1+ n))))) + + +;;; These utils are used in dictionary conversion. + +(define (**dsel/method class method dict-code) + (let ((pos (locate-in-list method (class-method-vars class) 0))) + (**tuple-sel (class-dict-size class) pos dict-code))) + +(define (**dsel/dict class dict-class dict-code) + (let ((pos (locate-in-list + dict-class (class-super* class) (class-n-methods class)))) + (**tuple-sel (class-dict-size class) pos dict-code))) + +(define (locate-in-list var l pos) + (if (null? l) + (error "Locate in list failed") + (if (eq? var (car l)) + pos + (locate-in-list var (cdr l) (1+ pos))))) + +;;; These routines deal with contexts. A context is a list classes. + +;;; A context is normalized whenever class is a superclass of another. + +(define (merge-contexts ctxt1 ctxt2) + (if (null? ctxt1) + ctxt2 + (merge-single-class (car ctxt1) (merge-contexts (cdr ctxt1) ctxt2)))) + +;;; This could perhaps avoid some consing but I don't imagine it would +;;; make much difference. + +(define (merge-single-class class ctxt) + (cond ((null? ctxt) + (list class)) + ((eq? class (car ctxt)) + ctxt) + ((memq class (class-super* (car ctxt))) + ctxt) + ((memq (car ctxt) (class-super* class)) + (merge-single-class class (cdr ctxt))) + (else + (cons (car ctxt) (merge-single-class class (cdr ctxt)))))) + +;;; This determines if ctxt2 is contained in ctxt1. + +(define (context-implies? ctxt1 ctxt2) + (or (null? ctxt2) + (and (single-class-implies? ctxt1 (car ctxt2)) + (context-implies? ctxt1 (cdr ctxt2))))) + +(define (single-class-implies? ctxt class) + (and (not (null? ctxt)) + (or (memq class ctxt) + (super-class-implies? ctxt class)))) + +(define (super-class-implies? ctxt class) + (and (not (null? ctxt)) + (or (memq class (class-super* (car ctxt))) + (super-class-implies? (cdr ctxt) class)))) + +;;; This looks at the context of a full signature. + +(define (full-context-implies? ctxt1 ctxt2) + (or (null? ctxt1) + (and (context-implies? (car ctxt1) (car ctxt2)) + (full-context-implies? (cdr ctxt1) (cdr ctxt2))))) + +;;; This is used to avoid type circularity on unification. + +(define (occurs-in-type tyvar type) ; Cardelli algorithm + (let ((type (prune type))) + (if (ntyvar? type) + (eq? type tyvar) + (occurs-in-type/l tyvar (ntycon-args type))))) + +; Does a tyvar occur in a list of types? +(define (occurs-in-type/l tyvar types) + (if (null? types) + '#f + (or (occurs-in-type tyvar (car types)) + (occurs-in-type/l tyvar (cdr types))))) + +(define-integrable (non-generic? tyvar) + (occurs-in-type/l tyvar (dynamic *non-generic-tyvars*))) + +(define (collect-tyvars ntype) + (collect-tyvars-1 ntype '())) + +(define (collect-tyvars-1 ntype vars) + (let ((ntype (prune ntype))) + (if (ntyvar? ntype) + (if (or (memq ntype vars) (non-generic? ntype)) + vars + (cons ntype vars)) + (collect-tyvars/l-1 (ntycon-args ntype) vars)))) + +(define (collect-tyvars/l types) + (collect-tyvars/l-1 types '())) + +(define (collect-tyvars/l-1 types vars) + (if (null? types) + vars + (collect-tyvars/l-1 (cdr types) (collect-tyvars-1 (car types) vars)))) + +;;; Random utilities + +(define (decl-var decl) + (var-ref-var (var-pat-var (valdef-lhs decl)))) diff --git a/util/walk-ast.scm b/util/walk-ast.scm new file mode 100644 index 0000000..aecffc6 --- /dev/null +++ b/util/walk-ast.scm @@ -0,0 +1,156 @@ +;;; walk-ast.scm -- general-purpose walkers for AST structures. +;;; +;;; author : Sandra & John +;;; date : 30 Jan 1992 +;;; +;;; + +;;;===================================================================== +;;; Basic support, macros +;;;===================================================================== + + +;;; Here is a macro for accessing the walker function for a particular +;;; type. +;;; The walk-type names the walker. +;;; If an accessor argument is provided, it must name a SETF'able function +;;; or macro that takes a type descriptor as an argument. This is used to +;;; do the lookup of the walker function for the given type. +;;; If no explicit accessor is provided, one will be created. It will +;;; use a hash table keyed off the type names to store the walker functions. +;;; In either case, the mapping between the walker name and accessor is +;;; stored in the hash table ast-walker-table. + +(define ast-walker-table (make-table)) + +(define-syntax (define-walker walk-type . maybe-accessor) + (let ((accessor-name (if (null? maybe-accessor) + (symbol-append walk-type '-walker) + (car maybe-accessor)))) + (setf (table-entry ast-walker-table walk-type) accessor-name) + `(begin + ,@(if (null? maybe-accessor) + (let ((accessor-table (symbol-append '* walk-type '-table*))) + `((define ,accessor-table (make-table)) + (define-syntax (,accessor-name td) + (list 'table-entry + ',accessor-table + (list 'td-name td))))) + '()) + (setf (table-entry ast-walker-table ',walk-type) + ',accessor-name) + ',walk-type))) + +(define-syntax (ast-walker walk-type td) + (let ((accessor (table-entry ast-walker-table walk-type))) + `(,accessor ,td))) + + +;;; This macro dispatches a walker on an object of type ast-node. + +(define-syntax (call-walker walk-type object . args) + (let ((temp (gensym "OBJ"))) + `(let ((,temp ,object)) + (funcall (or (ast-walker ,walk-type (struct-type-descriptor ,temp)) + (walker-not-found-error ',walk-type ,temp)) + ,temp + ,@args)) + )) + +(define (walker-not-found-error walk-type object) + (error "There is no ~a walker for structure ~A defined." + walk-type (td-name (struct-type-descriptor object)))) + + + +;;; Define an individual walker for a particular type. The body should +;;; return either the original object or a replacement for it. + +(define-syntax (define-walker-method walk-type type args . body) + (let ((function-name (symbol-append walk-type '- type))) + `(begin + (define (,function-name ,@args) ,@body) + (setf (ast-walker ,walk-type (lookup-type-descriptor ',type)) + (function ,function-name)) + ',function-name))) + + + +;;;===================================================================== +;;; Support for default walker methods +;;;===================================================================== + +;;; Two kinds of walkers are supported: a collecting walker, which +;;; walks over a tree collecting some sort of returned result while +;;; not changing the tree itself, and a rewriting walker which maps +;;; ast to ast. + +;;; The basic template for a collecting walk is: +;;; (define-walker-method walk-type type (object accum) +;;; (sf1 (sf2 object ... (sfn accum))) +;;; where sfi = slot function for the ith slot. +;;; +;;; The slot-processor should be the name of a macro that is called with four +;;; arguments: a slot descriptor, the object type name, a form +;;; representing the object being traversed, and a form representing the +;;; accumulated value. +;;; If the slot does not participate in the walk, this last argument should +;;; be returned unchanged as the expansion of the macro. + +(define-syntax (define-collecting-walker-methods walk-type types + slot-processor) + `(begin + ,@(map (lambda (type) + (make-collecting-walker-method walk-type type slot-processor)) + types))) + +(define (make-collecting-walker-method walk-type type slot-processor) + `(define-walker-method ,walk-type ,type (object accum) + object ; prevent possible unreferenced variable warning + ,(make-collecting-walker-method-body + 'accum + type + (td-slots (lookup-type-descriptor type)) + slot-processor))) + +(define (make-collecting-walker-method-body base type slots slot-processor) + (if (null? slots) + base + `(,slot-processor ,(car slots) ,type object + ,(make-collecting-walker-method-body + base type (cdr slots) slot-processor)))) + + + +;;; A rewriting walker traverses the ast modifying various subtrees. +;;; The basic template here is: +;;; (define-walker-method walker type (object . args) +;;; (setf (slot1 object) (walk (slot1 object))) +;;; (setf (slot2 object) (walk (slot2 object))) +;;; ... +;;; object) + +;;; The basic macro to generate default walkers is as above except +;;; that the slot-processor macro is called with only +;;; two arguments, the slot and object type. +;;; The `args' is the actual lambda-list for the methods, and bindings +;;; can be referenced inside the code returned by the macro. +;;; If a slot participates in the walk, the macro should return code +;;; to SETF the slot, as in the template above. Otherwise, the macro +;;; should just return #f. + +(define-syntax (define-modify-walker-methods walk-type types args + slot-processor) + `(begin + ,@(map (lambda (type) + (make-modify-walker-method walk-type type args + slot-processor)) + types))) + +(define (make-modify-walker-method walk-type type args slot-processor) + `(define-walker-method ,walk-type ,type ,args + ,@(cdr args) ; prevent possible unreferenced variable warnings + ,@(map (lambda (slot) + `(,slot-processor ,slot ,type)) + (td-slots (lookup-type-descriptor type))) + ,(car args))) |