├── lib ├── void.hop ├── case.hop ├── list.sed ├── y.hop ├── range.hop ├── sums.hop ├── products.hop ├── Makefile.in ├── words.hop ├── Makefile ├── fold.hop ├── set.hop ├── maybe.hop ├── functions.hop ├── ctype.hop ├── diag.hop ├── tree.hop ├── lines.hop ├── seq.hop ├── arith.hop ├── sort.hop ├── lists.hop ├── list.hop └── Standard.hop ├── src ├── hopelib.h ├── exceptions.h ├── Assoc.sed ├── interrupt.h ├── number.h ├── functors.h ├── functor_type.h ├── compare.h ├── eval.h ├── compile.h ├── stream.h ├── pr_ty_value.h ├── bad_rectype.h ├── text.h ├── pr_type.h ├── typevar.h ├── align.h ├── newstring.h ├── source.h ├── names.h ├── remember_type.h ├── builtin.h ├── TODO ├── interpret.h ├── type_check.h ├── polarity.h ├── num.h ├── structs.h ├── module.h ├── cons.h ├── set.c ├── plan9args.h ├── output.h ├── pr_value.h ├── LOCATIONS ├── char_array.h ├── op.sed ├── table.h ├── pr_expr.h ├── interrupt.c ├── op.h ├── path.h ├── set.h ├── error.h ├── eval.c ├── newstring.c ├── table.c ├── BUGS ├── Mult-op.awk ├── memory.c ├── stack.h ├── heap.h ├── path.c ├── type_value.h ├── memory.h ├── config.h.in ├── NOTES ├── config.h ├── value.c ├── value.h ├── char.h ├── HISTORY ├── hope.1.in ├── cases.h ├── defs.h ├── hope.1 ├── print.h ├── remember_type.c ├── main.c ├── output.c ├── stream.c ├── char.c ├── compare.c ├── functor_type.c ├── cases.c ├── functors.c ├── deftype.h ├── pr_ty_value.c ├── Makefile.in ├── char_array.c ├── pr_type.c ├── yyparse.h ├── bad_rectype.c ├── polarity.c ├── expr.h └── builtin.c ├── test ├── primes.in ├── io.in ├── type_errs.in ├── sections.in ├── lambdas.in └── hope_tut.in ├── sh ├── header ├── grammar ├── makedepend └── install-sh ├── doc ├── latexonly.tex ├── check_src ├── h2l.awk ├── hope.bib ├── verb.nawk ├── verb-query.nawk ├── Makefile.in └── Makefile ├── .gitignore ├── README.md ├── Makefile ├── INSTALL ├── configure.in └── README /lib/void.hop: -------------------------------------------------------------------------------- 1 | data void == Nothing; 2 | -------------------------------------------------------------------------------- /src/hopelib.h: -------------------------------------------------------------------------------- 1 | #define HOPELIB "/usr/local/share/hope/lib" 2 | -------------------------------------------------------------------------------- /test/primes.in: -------------------------------------------------------------------------------- 1 | uses seq, arith; 2 | 3 | front_seq(25, primes); 4 | -------------------------------------------------------------------------------- /test/io.in: -------------------------------------------------------------------------------- 1 | uses list, lines; 2 | lines(read "../test/hope_tut.in")@200; 3 | write "Hello world\n"; 4 | -------------------------------------------------------------------------------- /lib/case.hop: -------------------------------------------------------------------------------- 1 | ! Ultra-simple case construct 2 | 3 | dec case : alpha -> (alpha -> beta) -> beta; 4 | --- case x f <= f x; 5 | -------------------------------------------------------------------------------- /test/type_errs.in: -------------------------------------------------------------------------------- 1 | ord 23; 2 | 3 | 1 = 'a'; 4 | 5 | [1, 'a', 'b', 'c']; 6 | 7 | dec f: alpha -> alpha; 8 | --- f 1 <= 1; 9 | -------------------------------------------------------------------------------- /lib/list.sed: -------------------------------------------------------------------------------- 1 | /^data list/c\ 2 | data listShape alpha beta == nil ++ alpha :: beta;\ 3 | type list alpha == listShape alpha (list alpha); 4 | -------------------------------------------------------------------------------- /src/exceptions.h: -------------------------------------------------------------------------------- 1 | #ifndef EXCEPTIONS_H 2 | #define EXCEPTIONS_H 3 | 4 | #include 5 | 6 | extern jmp_buf execerror; 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /src/Assoc.sed: -------------------------------------------------------------------------------- 1 | /^%token[ ][ ]*[LRN]BINARY[0-9][0-9]*$/ { 2 | /LBINARY/ s/token/left/ 3 | /RBINARY/ s/token/right/ 4 | /NBINARY/ s/token/nonassoc/ 5 | } 6 | -------------------------------------------------------------------------------- /test/sections.in: -------------------------------------------------------------------------------- 1 | (-)(3, 1); 2 | (3-) 1; 3 | (-1) 3; 4 | (-); 5 | (1-); 6 | (-1); 7 | 8 | dec minus: num -> num; 9 | --- minus <= (0-); 10 | 11 | display; 12 | -------------------------------------------------------------------------------- /src/interrupt.h: -------------------------------------------------------------------------------- 1 | #ifndef INTERRUPT_H 2 | #define INTERRUPT_H 3 | 4 | #include "defs.h" 5 | 6 | extern void disable_interrupt(void); 7 | extern void enable_interrupt(void); 8 | 9 | #endif 10 | -------------------------------------------------------------------------------- /src/number.h: -------------------------------------------------------------------------------- 1 | #ifndef NUMBER_H 2 | #define NUMBER_H 3 | 4 | #include "defs.h" 5 | 6 | /* 7 | * Resolve identifiers. 8 | */ 9 | 10 | extern Bool nr_branch(Branch *branch); 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /src/functors.h: -------------------------------------------------------------------------------- 1 | #ifndef FUNCTORS_H 2 | #define FUNCTORS_H 3 | 4 | #include "defs.h" 5 | 6 | /* 7 | * Definition of 'functors'. 8 | */ 9 | 10 | extern void def_functor(DefType *dt); 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /sh/header: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # extract the public part of a Hope module 4 | 5 | sed -n '/^private;/q 6 | /^$/ { 7 | : loop 8 | N 9 | /\nprivate;/q 10 | /\n$/ b loop 11 | } 12 | p 13 | ' ${1-Standard} 14 | -------------------------------------------------------------------------------- /src/functor_type.h: -------------------------------------------------------------------------------- 1 | #ifndef FUNCTOR_TYPE_H 2 | #define FUNCTOR_TYPE_H 3 | 4 | #include "defs.h" 5 | 6 | /* 7 | * Generate types of 'functors'. 8 | */ 9 | 10 | extern Cell *functor_type(DefType *dt); 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /src/compare.h: -------------------------------------------------------------------------------- 1 | #ifndef COMPARE_H 2 | #define COMPARE_H 3 | 4 | #include "defs.h" 5 | 6 | /* 7 | * Set up comparison code 8 | * Call after reading standard module. 9 | */ 10 | extern void init_cmps(void); 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /doc/latexonly.tex: -------------------------------------------------------------------------------- 1 | \newcommand{\op}{$\oplus$} 2 | \newenvironment{block}{\begin{tabular}[t]{@{}l@{}}}{\end{tabular}} 3 | \newcommand{\sub}[2]{$\mbox{#1}_{#2}$} 4 | \newcommand{\primesub}[2]{$\mbox{#1}'_{#2}$} 5 | \newcommand{\Cdots}{$\cdots$} 6 | -------------------------------------------------------------------------------- /src/eval.h: -------------------------------------------------------------------------------- 1 | #ifndef EVAL_H 2 | #define EVAL_H 3 | 4 | #include "defs.h" 5 | 6 | /* 7 | * Evaluation of expressions. 8 | */ 9 | 10 | extern void eval_expr(Expr *expr); 11 | extern void wr_expr(Expr *expr, const char *file); 12 | 13 | #endif 14 | -------------------------------------------------------------------------------- /lib/y.hop: -------------------------------------------------------------------------------- 1 | ! fixed point combinators 2 | 3 | dec Ycurry : (alpha -> alpha) -> alpha; 4 | --- Ycurry f <= Z Z where Z == lambda z => f(z z); 5 | 6 | dec Yturing : (alpha -> alpha) -> alpha; 7 | --- Yturing <= Z Z where Z == lambda z => lambda f => f(z z f); 8 | -------------------------------------------------------------------------------- /src/compile.h: -------------------------------------------------------------------------------- 1 | #ifndef COMPILE_H 2 | #define COMPILE_H 3 | 4 | #include "defs.h" 5 | 6 | extern UCase *comp_branch(UCase *old_body, Branch *branch); 7 | 8 | /* Compile all the LAMBDAs in expr. */ 9 | extern void comp_expr(Expr *expr); 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /src/stream.h: -------------------------------------------------------------------------------- 1 | #ifndef STREAM_H 2 | #define STREAM_H 3 | 4 | #include "defs.h" 5 | 6 | extern Cell *open_stream(Cell *arg); 7 | extern Cell *read_stream(Cell *cell); 8 | extern void reset_streams(void); 9 | extern void close_streams(void); 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /src/pr_ty_value.h: -------------------------------------------------------------------------------- 1 | #ifndef PR_TY_VALUE_H 2 | #define PR_TY_VALUE_H 3 | 4 | /* 5 | * Printing of inferred types. 6 | */ 7 | 8 | #include "defs.h" 9 | 10 | global void init_pr_ty_value(void); 11 | 12 | global void pr_ty_value(FILE *f, Cell *type); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /src/bad_rectype.h: -------------------------------------------------------------------------------- 1 | #ifndef BAD_RECTYPE_H 2 | #define BAD_RECTYPE_H 3 | 4 | #include "defs.h" 5 | 6 | /* 7 | * type is an illegal body for head if it contains a use of head 8 | * with different arguments. 9 | */ 10 | extern Bool bad_rectype(DefType *head, Type *type); 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /src/text.h: -------------------------------------------------------------------------------- 1 | #ifndef TEXT_H 2 | #define TEXT_H 3 | 4 | #include "defs.h" 5 | #include "char.h" 6 | 7 | /* 8 | * A text literal, guaranteed null-terminated, but may contain extra nulls. 9 | */ 10 | 11 | typedef struct { 12 | const SChar *t_start; 13 | int t_length; 14 | } Text; 15 | 16 | #endif 17 | -------------------------------------------------------------------------------- /sh/grammar: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | : extract the grammar from a Yacc file 4 | 5 | sed ' 6 | 1,/%%/d 7 | /%%/,$d 8 | /^ *{.*}/d 9 | /^ *{/,/}/d 10 | s/[ ]*%prec.*// 11 | s/\/\*.*\*\/// 12 | /\/\*/,/\*\//d 13 | / *{/!{ 14 | s/[ ]*{/\ 15 | {/ 16 | P 17 | D 18 | } 19 | ' ${1-yyparse.y} | cat -s 20 | -------------------------------------------------------------------------------- /src/pr_type.h: -------------------------------------------------------------------------------- 1 | #ifndef PR_TYPE_H 2 | #define PR_TYPE_H 3 | 4 | #include "defs.h" 5 | 6 | /* 7 | * Printing of types. 8 | */ 9 | 10 | extern void pr_qtype(FILE *f, QType *qtype); 11 | 12 | extern void pr_type(FILE *f, Type *type); 13 | extern void pr_deftype(FILE *f, DefType *dt, Bool full); 14 | 15 | #endif 16 | -------------------------------------------------------------------------------- /doc/check_src: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Check .src files 4 | 5 | nawk_file=$HOME/public_html/Hope/utils/tree.nawk 6 | 7 | for file 8 | do 9 | echo Checking $file ... 10 | grep -n '\\begin{query}' $file | 11 | cut -d: -f1 | 12 | sed "s@.*@nawk -f $nawk_file QLINE=& $file $file | hope@" | 13 | sh >/dev/null 14 | done 15 | -------------------------------------------------------------------------------- /src/typevar.h: -------------------------------------------------------------------------------- 1 | #ifndef TYPEVAR_H 2 | #define TYPEVAR_H 3 | 4 | #include "defs.h" 5 | #include "newstring.h" 6 | 7 | /* 8 | * Type variables. 9 | */ 10 | typedef String TVar; 11 | 12 | extern void tv_declare(String name); 13 | extern Bool tv_lookup(String name); 14 | extern void tv_print(FILE *f, Natural n); 15 | 16 | #endif 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Object files 2 | *.o 3 | *.ko 4 | *.obj 5 | *.elf 6 | 7 | # Precompiled Headers 8 | *.gch 9 | *.pch 10 | 11 | # Libraries 12 | *.lib 13 | *.a 14 | *.la 15 | *.lo 16 | 17 | # Shared objects (inc. Windows DLLs) 18 | *.dll 19 | *.so 20 | *.so.* 21 | *.dylib 22 | 23 | # Executables 24 | *.exe 25 | *.out 26 | *.app 27 | *.i*86 28 | *.x86_64 29 | *.hex 30 | -------------------------------------------------------------------------------- /lib/range.hop: -------------------------------------------------------------------------------- 1 | ! functions returning ranges of numbers 2 | 3 | ! m..n = the list of integers between m and n inclusive. 4 | ! from n = the infinite list of integers starting at n. 5 | 6 | infix .. : 4; 7 | dec .. : num # num -> list num; 8 | --- n..m <= if n > m then [] else n::(succ n..m); 9 | 10 | dec from : num -> list num; 11 | --- from n <= n::from(succ n); 12 | -------------------------------------------------------------------------------- /src/align.h: -------------------------------------------------------------------------------- 1 | #ifndef ALIGN_H 2 | #define ALIGN_H 3 | 4 | /* 5 | * Determine the alignment of doubles on the current machine. 6 | */ 7 | 8 | typedef struct { char c; double d; } PtrRec; 9 | 10 | #define ALIGNMENT ((int)&(((PtrRec *)0)->d)) 11 | 12 | /* If that doesn't work, the following is conservative: */ 13 | /* #define ALIGNMENT sizeof(double) */ 14 | 15 | #endif 16 | -------------------------------------------------------------------------------- /lib/sums.hop: -------------------------------------------------------------------------------- 1 | ! Sum type 2 | 3 | infixr OR : 3; 4 | data alpha OR beta == Left alpha ++ Right beta; 5 | 6 | infixr \/ : 1; 7 | dec \/ : (alpha -> gamma) # (beta -> gamma) -> alpha OR beta -> gamma; 8 | --- (f \/ g) (Left x) <= f x; 9 | --- (f \/ g) (Right y) <= g y; 10 | 11 | dec either : alpha OR alpha -> alpha; 12 | --- either(Left x) <= x; 13 | --- either(Right y) <= y; 14 | -------------------------------------------------------------------------------- /src/newstring.h: -------------------------------------------------------------------------------- 1 | #ifndef NEWSTRING_H 2 | #define NEWSTRING_H 3 | 4 | /* 5 | * Heap storage for strings. 6 | * Each string is assigned a unique address, so that direct address 7 | * comparisons can be used for string equality tests. 8 | */ 9 | 10 | typedef const char *String; 11 | 12 | extern void init_strings(void); 13 | extern String newstring(const char *s); 14 | extern String newnstring(const char *s, int n); 15 | 16 | #endif 17 | -------------------------------------------------------------------------------- /src/source.h: -------------------------------------------------------------------------------- 1 | #ifndef SOURCE_H 2 | #define SOURCE_H 3 | 4 | #include "defs.h" 5 | 6 | extern const Byte *inptr; 7 | 8 | extern void init_source(FILE *src, Bool gen_listing); 9 | extern void enterfile(FILE *f); 10 | extern Bool interactive(void); 11 | extern Bool _getline(void); 12 | 13 | #ifdef RE_EDIT 14 | extern void set_script(const char *filename); 15 | extern void restart(const char *script_file); 16 | #endif 17 | 18 | #endif 19 | -------------------------------------------------------------------------------- /src/names.h: -------------------------------------------------------------------------------- 1 | #ifndef NAMES_H 2 | #define NAMES_H 3 | 4 | #include "defs.h" 5 | #include "newstring.h" 6 | 7 | /* reserved words */ 8 | extern String n_or, n_valof, n_is, n_eq, n_gives, 9 | n_abstype, n_data, n_dec, 10 | n_infix, n_infixr, n_type, n_typevar, n_uses, 11 | n_else, n_if, n_in, n_lambda, n_let, 12 | n_letrec, n_mu, n_then, n_where, n_whererec; 13 | /* special type constructor arguments */ 14 | extern String n_pos, n_neg, n_none; 15 | 16 | #endif 17 | -------------------------------------------------------------------------------- /src/remember_type.h: -------------------------------------------------------------------------------- 1 | #ifndef REMEMBER_TYPE_H 2 | #define REMEMBER_TYPE_H 3 | 4 | #include "defs.h" 5 | 6 | /* 7 | * Remember this one? 8 | * Called whenever a type is defined in the Standard module. 9 | */ 10 | extern void remember_type(DefType *dt); 11 | 12 | /* 13 | * Called at the end of the Standard module, to check that all the 14 | * types and constructors required internally have been defined. 15 | */ 16 | extern void check_type_defs(void); 17 | 18 | #endif 19 | -------------------------------------------------------------------------------- /src/builtin.h: -------------------------------------------------------------------------------- 1 | #ifndef BUILTIN_H 2 | #define BUILTIN_H 3 | 4 | #include "defs.h" 5 | 6 | extern void init_builtins(void); 7 | 8 | /* conversions between string representations */ 9 | 10 | /* Convert a C string to a string value. */ 11 | extern Cell *c2hope(const Byte *str); 12 | 13 | /* 14 | * Convert a string value to a C string. 15 | * It is an error if the string has more than n-1 characters. 16 | */ 17 | extern void hope2c(Byte *s, int n, Cell *arg); 18 | 19 | #endif 20 | -------------------------------------------------------------------------------- /src/TODO: -------------------------------------------------------------------------------- 1 | Comparison of functions: this must be caught, or it will cause the 2 | interpreter to go haywire. It gets caught now, but it's not pretty. 3 | 4 | Make it faster (how?) 5 | 6 | Unification must be done on expanded types, but more unfolded types 7 | should be instantiated to more compact ones. This has been done, but 8 | needs cleaning up. 9 | 10 | Access to command line arguments, probably via a built-in constant 11 | argv : list(list char); 12 | (This is done, but undocumented, as is #!) 13 | -------------------------------------------------------------------------------- /src/interpret.h: -------------------------------------------------------------------------------- 1 | #ifndef INTERPRET_H 2 | #define INTERPRET_H 3 | 4 | #include "defs.h" 5 | #include "newstring.h" 6 | 7 | /* name of most recently entered function, for error reporting */ 8 | extern String cur_function; 9 | 10 | /* 11 | * Interpreter for an expression. 12 | * See compile.c for the translation schemes. 13 | */ 14 | extern void interpret(Expr *action, Expr *expr); 15 | 16 | /* 17 | * Reduce a value to head normal form 18 | */ 19 | extern Cell *evaluate(Cell *value); 20 | 21 | #endif 22 | -------------------------------------------------------------------------------- /test/lambdas.in: -------------------------------------------------------------------------------- 1 | (lambda f => lambda x => lambda y => f(x, y)) (+); 2 | 3 | (lambda f => lambda x => lambda y => f(x, y)) (+) 3; 4 | 5 | (lambda x => lambda y => x) (lambda z => 0); 6 | 7 | (lambda x => lambda y => (+)x) (1, 2); 8 | 9 | infix COMMA: 3; 10 | data new_type == num COMMA num; 11 | 12 | dec left: new_type -> num; 13 | --- left(a COMMA b) <= b; 14 | 15 | (lambda x => lambda y => left x)(1 COMMA 2); 16 | 17 | infix op: 4; 18 | 19 | lambda (op) => lambda x => x op x; 20 | 21 | (lambda (op) => lambda x => x op x) (*); 22 | -------------------------------------------------------------------------------- /lib/products.hop: -------------------------------------------------------------------------------- 1 | ! functions associated with the product type 2 | 3 | infixr /\ : 2; 4 | dec /\ : (alpha -> beta) # (alpha -> beta') -> alpha -> beta # beta'; 5 | --- (f /\ g) x <= (f x, g x); 6 | 7 | dec fst : alpha # beta -> alpha; 8 | --- fst (x, y) <= x; 9 | 10 | dec snd : alpha # beta -> beta; 11 | --- snd (x, y) <= y; 12 | 13 | dec dup : alpha -> alpha # alpha; 14 | --- dup x <= (x, x); 15 | 16 | dec flip : (alpha # alpha') # (beta # beta') -> 17 | (alpha # beta) # (alpha' # beta'); 18 | --- flip ((x, x'), (y, y')) <= ((x, y), (x', y')); 19 | -------------------------------------------------------------------------------- /src/type_check.h: -------------------------------------------------------------------------------- 1 | #ifndef TYPE_CHECK_H 2 | #define TYPE_CHECK_H 3 | 4 | #include "defs.h" 5 | 6 | extern Cell *expr_type; /* last inferred type */ 7 | 8 | extern Bool chk_func(Branch *branch, Func *fn); 9 | 10 | extern Bool ty_instance(Type *type1, Natural ntvars1, 11 | Type *type2, Natural ntvars2); 12 | 13 | /* 14 | * Top level: must have 15 | * lambda input => expr: list char -> T 16 | * 17 | * Side effect: set expr_type to T. 18 | */ 19 | extern void chk_expr(Expr *expr); 20 | 21 | extern void chk_list(Expr *expr); 22 | 23 | #endif 24 | -------------------------------------------------------------------------------- /src/polarity.h: -------------------------------------------------------------------------------- 1 | #ifndef POLARITY_H 2 | #define POLARITY_H 3 | 4 | /* 5 | * Polarities of type constructor arguments. 6 | */ 7 | 8 | #include "defs.h" 9 | #include "newstring.h" 10 | 11 | extern String type_arg_name(Type *var, Bool full); 12 | 13 | extern void set_polarities(TypeList *varlist); 14 | 15 | extern Bool check_polarities(TypeList *decl_vars, TypeList *def_vars); 16 | 17 | extern void start_polarities(DefType *deftype, TypeList *varlist); 18 | extern void compute_polarities(Type *type); 19 | extern void finish_polarities(void); 20 | 21 | #endif 22 | -------------------------------------------------------------------------------- /src/num.h: -------------------------------------------------------------------------------- 1 | #ifndef NUM_H 2 | #define NUM_H 3 | 4 | #include "defs.h" 5 | 6 | /* 7 | * The representation of the type `num'. 8 | */ 9 | 10 | /* define this to use real numbers (well, double) */ 11 | #define REALS 12 | 13 | #ifdef REALS 14 | # include 15 | # include 16 | # define Num double 17 | # define atoNUM atof 18 | # define NUMfmt "%.*g", DBL_DIG 19 | # define Zero 0.0 20 | #else 21 | # define Num long 22 | # define atoNUM atol 23 | # define NUMfmt "%ld" 24 | # define Zero 0L 25 | #endif 26 | 27 | extern Num atoNUM(const char *s); 28 | 29 | #endif 30 | -------------------------------------------------------------------------------- /src/structs.h: -------------------------------------------------------------------------------- 1 | #ifndef STRUCTS_H 2 | #define STRUCTS_H 3 | 4 | /* 5 | * Forward declarations of some widely used struct's. 6 | */ 7 | 8 | typedef struct _Cons Cons; 9 | typedef struct _DefType DefType; 10 | typedef struct _Type Type; 11 | typedef struct _QType QType; 12 | typedef struct _TypeList TypeList; 13 | 14 | typedef struct _Func Func; 15 | typedef struct _Branch Branch; 16 | typedef struct _Expr Expr; 17 | typedef struct _UCase UCase; 18 | typedef struct _LCase LCase; 19 | typedef struct _CharArray CharArray; 20 | 21 | typedef struct _Cell Cell; 22 | 23 | #endif 24 | -------------------------------------------------------------------------------- /src/module.h: -------------------------------------------------------------------------------- 1 | #ifndef MODULE_H 2 | #define MODULE_H 3 | 4 | #include "defs.h" 5 | #include "newstring.h" 6 | 7 | extern void mod_init(void); 8 | extern String mod_name(void); /* name of current module */ 9 | extern Bool mod_system(void); /* in a system module? */ 10 | extern void mod_use(String name); 11 | extern void mod_save(String name); 12 | extern void mod_dump(FILE *f); 13 | extern void mod_file(char *buf, String name); 14 | extern void mod_fetch(void); 15 | extern void mod_finish(void); 16 | extern void mod_private(void); 17 | extern void display(void); 18 | 19 | #endif 20 | -------------------------------------------------------------------------------- /src/cons.h: -------------------------------------------------------------------------------- 1 | #ifndef CONS_H 2 | #define CONS_H 3 | 4 | #include "defs.h" 5 | #include "newstring.h" 6 | 7 | struct _Cons { 8 | String c_name; 9 | Type *c_type; 10 | unsigned char c_nargs; 11 | unsigned char c_index; 12 | unsigned char c_ntvars; 13 | SBool c_tupled; 14 | Cons *c_next; 15 | }; 16 | 17 | extern Cons *constructor(String name, Bool tupled, TypeList *args); 18 | extern Cons *alt_cons(Cons *constr, Cons *next); 19 | extern Cons *cons_lookup(String name); 20 | extern Cons *cons_local(String name); 21 | 22 | extern Cons *nil, *cons, *succ, *true, *false; 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /src/set.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "set.h" 3 | 4 | global void 5 | set_clear(SetPtr set, Natural n) 6 | { 7 | while (n-- > 0) 8 | *set++ = 0; 9 | } 10 | 11 | global Natural 12 | set_card(SetPtr set, Natural n) 13 | { 14 | Natural count; 15 | Natural bits; 16 | 17 | count = 0; 18 | while (n-- > 0) 19 | for (bits = *set++; bits != 0; bits >>= 1) 20 | if ((bits & 01) != 0) 21 | count++; 22 | return count; 23 | } 24 | 25 | global void 26 | set_union(SetPtr set1, Natural n1, SetPtr set2, Natural n2) 27 | { 28 | if (n2 < n1) 29 | n1 = n2; 30 | while (n1-- > 0) 31 | *set1++ |= *set2++; 32 | } 33 | -------------------------------------------------------------------------------- /src/plan9args.h: -------------------------------------------------------------------------------- 1 | /* 2 | * plan 9 argument parsing 3 | */ 4 | #define ARGBEGIN for((argv0? 0: (argv0= *argv)),argv++,argc--;\ 5 | argv[0] && argv[0][0]=='-' && argv[0][1];\ 6 | argc--, argv++) {\ 7 | const char *_args, *_argt;\ 8 | char _argc;\ 9 | _args = &argv[0][1];\ 10 | if(_args[0]=='-' && _args[1]==0){\ 11 | argc--; argv++; break;\ 12 | }\ 13 | _argc=0;while(*_args) switch(_argc= *_args++) 14 | #define ARGEND } 15 | #define ARGF() (_argt=_args, _args="",\ 16 | (*_argt? _argt: argv[1]? (argc--, *++argv): "")) 17 | #define ARGC() _argc 18 | 19 | const char *argv0; /* extern in Plan 9 */ 20 | -------------------------------------------------------------------------------- /src/output.h: -------------------------------------------------------------------------------- 1 | #ifndef OUTPUT_H 2 | #define OUTPUT_H 3 | 4 | /* 5 | * The builtins "print" and "write_element". 6 | */ 7 | 8 | #include "defs.h" 9 | 10 | extern Expr *e_return, *e_print, *e_wr_list; 11 | 12 | extern void init_print(void); 13 | 14 | /* 15 | * Print value and inferred type on standard output 16 | */ 17 | extern Cell *print_value(Cell *value); 18 | 19 | /* 20 | * Direct a list-valued output to the terminal or a file 21 | */ 22 | 23 | extern void open_out_file(const char *name); 24 | extern void save_out_file(void); 25 | extern void close_out_file(void); 26 | 27 | extern Cell *write_value(Cell *value); 28 | 29 | #endif 30 | -------------------------------------------------------------------------------- /lib/Makefile.in: -------------------------------------------------------------------------------- 1 | SHELL = /bin/sh 2 | 3 | # stuff from configure: 4 | prefix = @prefix@ 5 | INSTALL = @INSTALL@ 6 | INSTALL_DATA = @INSTALL_DATA@ 7 | 8 | # where the standard modules live 9 | hopelib = @HOPELIB@ 10 | 11 | # experimental version of some libraries 12 | newlib = $(hopelib).new 13 | 14 | all: 15 | 16 | install: 17 | $(INSTALL) -d $(hopelib) 18 | for f in *.hop; do $(INSTALL_DATA) $$f $(hopelib); done 19 | $(INSTALL) -d $(newlib) 20 | sed -f list.sed Standard.hop >Standard-new.hop 21 | $(INSTALL_DATA) Standard-new.hop $(newlib)/Standard.hop 22 | rm -f Standard-new.hop 23 | 24 | distclean clean clobber: 25 | rm -f Standard-new.hop 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | hope 2 | ==== 3 | 4 | ![maintenance-status](https://img.shields.io/badge/maintenance-as--is-yellow.svg) 5 | 6 | Hope is a lazily evaluated functional programming language developed in 1970's 7 | by Ross Paterson. It influenced the design of other lazy languages such as 8 | Miranda and Haskell. 9 | 10 | This version is derived from the source that was once available from the author's 11 | home page (http://web.archive.org/web/20110709142512/http://www.soi.city.ac.uk/~ross/Hope/). 12 | 13 | The goal of this project is to preserve Hope in its original form, so the only changes 14 | being made are fixes required to get it to build on modern systems. 15 | -------------------------------------------------------------------------------- /lib/words.hop: -------------------------------------------------------------------------------- 1 | ! break a string into a list of words, and the reverse 2 | 3 | dec words : list char -> list(list char); 4 | dec unwords : list(list char) -> list char; 5 | 6 | ! words(unwords ws) = ws 7 | 8 | private; 9 | 10 | uses ctype, list; 11 | 12 | dec words': list char -> list(list char); 13 | --- words' "" <= []; 14 | --- words' cs <= w::words rest 15 | where (w, rest) == span (not o isspace) cs; 16 | 17 | --- words cs <= words' (after_with isspace cs); 18 | 19 | dec prespace : list char # list char -> list char; 20 | --- prespace(w, rest) <= ' ' :: w <> rest; 21 | 22 | --- unwords [] <= ""; 23 | --- unwords (w::ws) <= w <> foldr("", prespace) ws; 24 | -------------------------------------------------------------------------------- /src/pr_value.h: -------------------------------------------------------------------------------- 1 | #ifndef PR_VALUE_H 2 | #define PR_VALUE_H 3 | 4 | /* 5 | * Printing of computed values (fully evaluated) 6 | */ 7 | 8 | #include "defs.h" 9 | #include "newstring.h" 10 | #include "path.h" 11 | 12 | extern void pr_value(FILE *f, Cell *value); 13 | 14 | extern void pr_f_match(Func *defun, Cell *env); 15 | extern void pr_l_match(Expr *func, Cell *env); 16 | 17 | /* 18 | * Print actual parameter, taking its value from the environment. 19 | */ 20 | extern void pr_actual(FILE *f, int level, Path path, int context); 21 | extern void pr_f_actual(FILE *f, String name, int level, 22 | Path path, int context); 23 | 24 | extern String val_name(int level, Path path); 25 | 26 | #endif 27 | -------------------------------------------------------------------------------- /src/LOCATIONS: -------------------------------------------------------------------------------- 1 | eval builtin.[ch] compare.[ch] compile.[ch] eval.[ch] exceptions.h 2 | interpret.[ch] interrupt.[ch] output.[ch] stream.[ch] value.[ch] 3 | exprs argc.h cases.[ch] char.[ch] char_array.[ch] expr.[ch] module.[ch] 4 | num.h number.[ch] path.[ch] set.[ch] table.[ch] 5 | include defs.h structs.h 6 | main main.c plan9args.h 7 | memory heap.h memory.[ch] newstring.[ch] runtime.c stack.h 8 | print pr_expr.[ch] pr_ty_value.[ch] pr_type.[ch] pr_value.[ch] print.h 9 | source error.h names.h op.h source.[ch] text.h yylex.c yyparse.y 10 | type_check functor_type.[ch] type_check.[ch] type_value.[ch] 11 | types bad_rectype.[ch] cons.h deftype.[ch] functors.[ch] polarity.[ch] 12 | remember_type.[ch] typevar.h 13 | -------------------------------------------------------------------------------- /lib/Makefile: -------------------------------------------------------------------------------- 1 | # Generated automatically from Makefile.in by configure. 2 | SHELL = /bin/sh 3 | 4 | # stuff from configure: 5 | prefix = /usr/local 6 | INSTALL = /usr/bin/install -c 7 | INSTALL_DATA = ${INSTALL} -m 644 8 | 9 | # where the standard modules live 10 | hopelib = ${prefix}/share/hope/lib 11 | 12 | # experimental version of some libraries 13 | newlib = $(hopelib).new 14 | 15 | all: 16 | 17 | install: 18 | $(INSTALL) -d $(hopelib) 19 | for f in *.hop; do $(INSTALL_DATA) $$f $(hopelib); done 20 | $(INSTALL) -d $(newlib) 21 | sed -f list.sed Standard.hop >Standard-new.hop 22 | $(INSTALL_DATA) Standard-new.hop $(newlib)/Standard.hop 23 | rm -f Standard-new.hop 24 | 25 | distclean clean clobber: 26 | rm -f Standard-new.hop 27 | -------------------------------------------------------------------------------- /src/char_array.h: -------------------------------------------------------------------------------- 1 | #ifndef CHAR_ARRAY_H 2 | #define CHAR_ARRAY_H 3 | 4 | #include "defs.h" 5 | #include "char.h" 6 | 7 | /* 8 | * Sparse arrays indexed by characters. 9 | * Specification: 10 | * 11 | * index(new(x), c) = x 12 | * index(copy(a), c) = index(a, c) 13 | * index(assign(a, c', x), c) = if c' = c then x else index(a, c) 14 | * index(map(a, f), c) = f(index(a, c)) 15 | */ 16 | typedef UCase *ArrayElement; 17 | typedef ArrayElement EltMap(ArrayElement x); 18 | 19 | extern CharArray *ca_new(ArrayElement x); 20 | extern CharArray *ca_copy(CharArray *a); 21 | extern ArrayElement ca_index(CharArray *a, Char c); 22 | 23 | extern void ca_assign(CharArray *a, Char c, ArrayElement x); 24 | extern void ca_map(CharArray *a, EltMap *f); 25 | 26 | #endif 27 | -------------------------------------------------------------------------------- /src/op.sed: -------------------------------------------------------------------------------- 1 | /^%token[ ]*BINARY/i\ 2 | %token BIN_BASE 3 | /^.*[:|].*BINARY.*[^}]$/ { 4 | : loop 5 | N 6 | /}$/!b loop 7 | } 8 | /BINARY/ { 9 | s/BINARY/LBINARY1/ 10 | p 11 | s/^[a-z0-9_]*[ ]*:/ |/ 12 | s/LBINARY/RBINARY/ 13 | p 14 | s/RBINARY1/LBINARY2/ 15 | p 16 | s/LBINARY/RBINARY/ 17 | p 18 | s/RBINARY2/LBINARY3/ 19 | p 20 | s/LBINARY/RBINARY/ 21 | p 22 | s/RBINARY3/LBINARY4/ 23 | p 24 | s/LBINARY/RBINARY/ 25 | p 26 | s/RBINARY4/LBINARY5/ 27 | p 28 | s/LBINARY/RBINARY/ 29 | p 30 | s/RBINARY5/LBINARY6/ 31 | p 32 | s/LBINARY/RBINARY/ 33 | p 34 | s/RBINARY6/LBINARY7/ 35 | p 36 | s/LBINARY/RBINARY/ 37 | p 38 | s/RBINARY7/LBINARY8/ 39 | p 40 | s/LBINARY/RBINARY/ 41 | p 42 | s/RBINARY8/LBINARY9/ 43 | p 44 | s/LBINARY/RBINARY/ 45 | } 46 | -------------------------------------------------------------------------------- /src/table.h: -------------------------------------------------------------------------------- 1 | #ifndef TABLE_H 2 | #define TABLE_H 3 | 4 | #include "defs.h" 5 | #include "newstring.h" 6 | 7 | typedef struct _TabElt TabElt; 8 | 9 | typedef struct { 10 | TabElt *t_front; 11 | TabElt **t_end; 12 | } Table; 13 | 14 | /* Make this the first field in your structure */ 15 | struct _TabElt { 16 | String t_name; 17 | TabElt *t_next; 18 | }; 19 | 20 | typedef void TableAction(TabElt *elem); 21 | 22 | extern void t_init(Table *table); 23 | extern void t_insert(Table *table, TabElt *element); 24 | extern void t_delete(Table *table, TabElt *element); 25 | extern void t_copy(Table *table1, const Table *table2); 26 | extern TabElt *t_lookup(const Table *table, String name); 27 | extern void t_foreach(const Table *table, TableAction *action); 28 | 29 | #endif 30 | -------------------------------------------------------------------------------- /src/pr_expr.h: -------------------------------------------------------------------------------- 1 | #ifndef PR_EXPR_H 2 | #define PR_EXPR_H 3 | 4 | #include "defs.h" 5 | #include "newstring.h" 6 | #include "char.h" 7 | 8 | /* 9 | * Printing of functions. 10 | */ 11 | 12 | extern void pr_fundef(FILE *f, Func *fn); 13 | 14 | /* 15 | * Printing of expressions. 16 | * 17 | * level = no. of environment levels supplied by the expression. 18 | * Others are fetched from the current environment with get_actual(). 19 | */ 20 | 21 | extern void pr_expr(FILE *f, Expr *expr); 22 | extern void pr_c_expr(FILE *f, Expr *expr, int level, int context); 23 | extern void pr_char(FILE *f, Char c); 24 | extern void pr_branch(FILE *f, Branch *branch, int level); 25 | 26 | /* 27 | * If expr amounts to an identifier, return it, else NULL. 28 | */ 29 | extern String expr_name(Expr *expr, int level); 30 | 31 | #endif 32 | -------------------------------------------------------------------------------- /lib/fold.hop: -------------------------------------------------------------------------------- 1 | ! some generalized higher-order functions for recursive types 2 | ! (an experimental exploitation of regular types) 3 | 4 | ! if YF == F YF, 5 | ! fold F : (F alpha -> alpha) -> YF -> alpha 6 | ! unfold F : (alpha -> F alpha) -> alpha -> YF 7 | ! rec F : (YF # F alpha -> alpha) -> YF -> alpha 8 | 9 | uses products; 10 | 11 | dec fold : ((gamma -> alpha) -> gamma -> beta) -> 12 | (beta -> alpha) -> gamma -> alpha; 13 | --- fold F f <= f o F(fold F f); 14 | 15 | dec unfold : ((alpha -> gamma) -> beta -> gamma) -> 16 | (alpha -> beta) -> alpha -> gamma; 17 | --- unfold F f <= F(unfold F f) o f; 18 | 19 | ! Primitive recursion 20 | 21 | dec rec : ((gamma -> gamma # alpha) -> gamma -> beta) -> 22 | (beta -> alpha) -> gamma -> alpha; 23 | --- rec F f <= f o F(id /\ rec F f); 24 | !!! rec F f <= snd o fold F (F fst /\ f); 25 | -------------------------------------------------------------------------------- /lib/set.hop: -------------------------------------------------------------------------------- 1 | ! sets (an example of an abstract data type) 2 | 3 | abstype set pos; 4 | 5 | infixr & : 5; 6 | infixr U : 4; 7 | 8 | dec {} : set alpha; 9 | dec empty : set alpha; 10 | dec & : alpha # set alpha -> set alpha; 11 | dec U : set alpha # set alpha -> set alpha; 12 | dec choose : set alpha -> alpha # set alpha; 13 | dec card : set alpha -> num; 14 | 15 | private; 16 | 17 | uses list; 18 | 19 | ! A set is represented as an ordered list without duplicates. 20 | 21 | type set alpha == list alpha; 22 | 23 | --- {} <= []; 24 | --- empty <= []; 25 | 26 | --- x & [] <= [x]; 27 | --- x & (y::ys) <= 28 | if x < y then x::y::ys 29 | else if x = y then y::ys 30 | else y::(x & ys); 31 | 32 | --- s1 U s2 <= foldr(s1, (&)) s2; 33 | 34 | --- choose(x::xs) <= (x, xs); 35 | 36 | --- card <= length; 37 | 38 | --- set f <= foldr(empty, (&)) o map f; 39 | -------------------------------------------------------------------------------- /lib/maybe.hop: -------------------------------------------------------------------------------- 1 | ! the Maybe monad 2 | 3 | ! c.f. "The essence of functional programming", P. Wadler, POPL, 1992. 4 | 5 | data maybe alpha == No ++ Yes alpha; 6 | 7 | dec unit_maybe : alpha -> maybe alpha; 8 | --- unit_maybe x <= Yes x; 9 | 10 | dec bind_maybe : maybe alpha -> (alpha -> maybe beta) -> maybe beta; 11 | --- bind_maybe No f <= No; 12 | --- bind_maybe (Yes x) f <= f x; 13 | 14 | ! assertions 15 | 16 | infix AND : 2; 17 | dec AND : bool # maybe alpha -> maybe alpha; 18 | --- true AND x <= x; 19 | --- false AND y <= No; 20 | 21 | ! exceptions 22 | 23 | infix OR : 1; 24 | dec OR : maybe alpha # alpha -> alpha; 25 | --- No OR y <= y; 26 | --- (Yes x) OR y <= x; 27 | 28 | infix --> : 2; 29 | dec --> : bool # alpha -> maybe alpha; 30 | --- false --> x <= No; 31 | --- true --> x <= Yes x; 32 | 33 | dec flatten : maybe alpha -> alpha; 34 | --- flatten(Yes x) <= x; 35 | -------------------------------------------------------------------------------- /src/interrupt.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "interrupt.h" 3 | #include "error.h" 4 | 5 | #include 6 | 7 | local RETSIGTYPE onintr(int sig); 8 | local RETSIGTYPE onalarm(int sig); 9 | 10 | global void 11 | disable_interrupt(void) 12 | { 13 | #ifdef unix 14 | (void)signal(SIGALRM, SIG_IGN); 15 | #endif 16 | (void)signal(SIGINT, SIG_IGN); 17 | } 18 | 19 | global void 20 | enable_interrupt(void) 21 | { 22 | #ifdef unix 23 | if (time_limit > 0) { 24 | (void)signal(SIGALRM, onalarm); 25 | alarm(time_limit); 26 | } 27 | #endif 28 | (void)signal(SIGINT, onintr); 29 | } 30 | 31 | /*ARGSUSED*/ 32 | local RETSIGTYPE 33 | onintr(int sig) 34 | { 35 | disable_interrupt(); 36 | error(EXECERR, "interrupted"); 37 | } 38 | 39 | /*ARGSUSED*/ 40 | local RETSIGTYPE 41 | onalarm(int sig) 42 | { 43 | disable_interrupt(); 44 | error(EXECERR, "time limit exceeded"); 45 | } 46 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | SHELL = /bin/sh 2 | 3 | configure_args = 4 | dirs = doc lib src 5 | 6 | all: config.status 7 | for dir in $(dirs); do (cd $$dir; make all); done 8 | 9 | install: config.status 10 | for dir in $(dirs); do (cd $$dir; make install); done 11 | 12 | clean: config.status 13 | for dir in $(dirs); do (cd $$dir; make clean); done 14 | 15 | distclean: config.status 16 | for dir in $(dirs); do (cd $$dir; make distclean); done 17 | rm -f config.cache config.log config.status 18 | 19 | clobber: config.status 20 | for dir in $(dirs); do (cd $$dir; make clobber); done 21 | for dir in $(dirs); do rm -f $$dir/Makefile; done 22 | rm -f src/config.h src/config.h.in src/stamp-h.in 23 | rm -f config.cache config.log config.status 24 | rm -f configure 25 | 26 | config.status: configure 27 | ./configure $(configure_args) 28 | 29 | configure: configure.in 30 | autoheader 31 | autoconf 32 | -------------------------------------------------------------------------------- /src/op.h: -------------------------------------------------------------------------------- 1 | #ifndef OP_H 2 | #define OP_H 3 | 4 | #include "defs.h" 5 | #include "newstring.h" 6 | #include "table.h" 7 | 8 | /* 9 | * Associativity and precedence of operators. 10 | * The values of the ASSOC_ constants must be in the order that 11 | * the binary operators are generated by Mult-op.awk (qv), 12 | * so that the calculation in lookup() in yylex.c will work. 13 | */ 14 | typedef enum { 15 | ASSOC_LEFT, 16 | ASSOC_RIGHT, 17 | /* count of the above */ 18 | NUM_ASSOC 19 | } Assoc; 20 | 21 | typedef struct { 22 | TabElt op_linkage; 23 | short op_prec; 24 | Assoc op_assoc; 25 | } Op; 26 | 27 | #define op_name op_linkage.t_name 28 | 29 | extern void op_declare(String name, int prec, Assoc assoc); 30 | extern Op *op_lookup(String name); 31 | 32 | /* 33 | * The range of precedences of user-defined infix operators. 34 | */ 35 | #define MINPREC 1 36 | #define MAXPREC 9 37 | 38 | #endif 39 | -------------------------------------------------------------------------------- /lib/functions.hop: -------------------------------------------------------------------------------- 1 | ! various higher-order functions 2 | 3 | ! reversed function application. e.g. x.f.g.h = h(g(f(x))) 4 | infix . : 9; 5 | dec . : alpha # (alpha -> beta) -> beta; 6 | --- x.f <= f(x); 7 | 8 | ! curry - turn a binary function into a function producing a function. 9 | ! (Named after Haskell B. Curry) 10 | ! e.g. curry f x y = f(x, y) 11 | dec curry : (alpha # beta -> gamma) -> alpha -> beta -> gamma; 12 | --- curry f <= lambda x => lambda y => f(x, y); 13 | 14 | dec uncurry : (alpha -> beta -> gamma) -> alpha # beta -> gamma; 15 | --- uncurry f (x, y) <= f x y; 16 | 17 | dec mkpair : alpha -> beta -> alpha # beta; 18 | --- mkpair x y <= (x, y); 19 | 20 | ! const c = a function mapping everything to c. 21 | dec const : alpha -> beta -> alpha; 22 | --- const x y <= x; 23 | 24 | ! times n f = f composed n times (Church numerals) 25 | dec times : num -> (alpha -> alpha) -> alpha -> alpha; 26 | --- times 0 f <= id; 27 | --- times (succ n) f <= f o times n f; 28 | -------------------------------------------------------------------------------- /src/path.h: -------------------------------------------------------------------------------- 1 | #ifndef PATH_H 2 | #define PATH_H 3 | 4 | #include "defs.h" 5 | 6 | typedef char *Path; 7 | #define MAXPATH 40 8 | 9 | enum { 10 | P_END, 11 | P_LEFT, 12 | P_RIGHT, 13 | P_STRIP, 14 | P_PRED, 15 | P_UNROLL, 16 | /* count of the above */ 17 | P_NCLASSES 18 | }; 19 | 20 | #define P_EMPTY "" 21 | 22 | #define p_equal(p1,p2) (strcmp(p1, p2) == 0) 23 | #define p_less(p1,p2) (strcmp(p1, p2) < 0) 24 | #define p_empty(p) (*(p) == P_END) 25 | #define p_pop(p) ((p)+1) 26 | #define p_top(p) (*(p)) 27 | 28 | /* new paths, overwritten by next call */ 29 | extern Path p_new(void); 30 | extern Path p_reverse(Path p); 31 | 32 | /* to be used only on a path supplied by p_new() or p_push() */ 33 | extern Path p_push(int dir, Path p); 34 | 35 | /* temporary storage for a number of paths */ 36 | extern void p_init(char *buf, int size); 37 | extern Path p_save(Path p); 38 | 39 | /* permanent storage for paths */ 40 | extern Path p_stash(Path p); 41 | 42 | #endif 43 | -------------------------------------------------------------------------------- /lib/ctype.hop: -------------------------------------------------------------------------------- 1 | ! character classification functions 2 | 3 | dec isalpha, isupper, islower, isdigit, isxdigit, isalnum, 4 | isspace, ispunct, isctrl, isascii, isgraph : char -> bool; 5 | 6 | dec tolower, toupper : char -> char; 7 | 8 | ! definitions for ASCII -- adjust for different character sets 9 | 10 | --- isalpha c <= isupper c or islower c; 11 | --- isupper c <= 'A' =< c and c =< 'Z'; 12 | --- islower c <= 'a' =< c and c =< 'z'; 13 | --- isdigit c <= '0' =< c and c =< '9'; 14 | --- isxdigit c <= isdigit c or 'a' =< c and c =< 'f' or 'A' =< c and c =< 'F'; 15 | --- isalnum c <= isalpha c or isdigit c; 16 | --- isspace c <= c = ' ' or c = '\t' or c = '\n'; 17 | --- ispunct c <= isgraph c and c /= ' ' and not(isalnum c); 18 | --- isctrl c <= isascii c and not(isgraph c); 19 | --- isgraph c <= ' ' =< c and c =< '~'; 20 | --- isascii c <= ord c < 128; 21 | 22 | --- tolower c <= if isupper c then chr(ord c + 32) else c; 23 | --- toupper c <= if islower c then chr(ord c - 32) else c; 24 | -------------------------------------------------------------------------------- /doc/h2l.awk: -------------------------------------------------------------------------------- 1 | BEGIN { 2 | # modes 3 | start = 0 4 | code = 1 5 | text = 2 6 | # initial state 7 | mode = start 8 | blank = 0 9 | code_prefix = " " 10 | } 11 | 12 | /^$/ { 13 | blank = 1 14 | } 15 | 16 | /^! / { 17 | if (mode == code) 18 | print "\\end{verbatim}" 19 | else if (blank) 20 | print "" 21 | blank = 0 22 | mode = text 23 | print substr($0, 3) 24 | } 25 | 26 | /^!! / { 27 | if (mode == code) 28 | print "\\end{verbatim}" 29 | blank = 0 30 | mode = text 31 | print "\\subsection{" substr($0, 4) "}" 32 | } 33 | 34 | /^! / { 35 | if (mode != code) 36 | print "\\begin{verbatim}" 37 | else if (blank) 38 | print "" 39 | blank = 0 40 | mode = code 41 | print code_prefix "! " substr($0, 3) 42 | } 43 | 44 | /^[^!]/ { 45 | if (mode != code) 46 | print "\\begin{verbatim}" 47 | else if (blank) 48 | print "" 49 | blank = 0 50 | mode = code 51 | print code_prefix $0 52 | } 53 | 54 | END { 55 | if (mode == code) 56 | print "\\end{verbatim}" 57 | } 58 | -------------------------------------------------------------------------------- /lib/diag.hop: -------------------------------------------------------------------------------- 1 | ! diagonalization of the product of a pair of lists 2 | 3 | infixr // : 3; 4 | dec // : list alpha # list beta -> list(alpha # beta); 5 | 6 | ! xs//ys is the concatenation of the following diagonals, 7 | ! each running down and right: 8 | ! 9 | ! 3 . . . . . . . 10 | ! \ 11 | ! 2 . . . . . . . 12 | ! ys \ \ 13 | ! 1 . . . . . . . 14 | ! \ \ \ 15 | ! 0 . . . . . . . 16 | ! 17 | ! 0 1 2 3 4 5 6 ... 18 | ! 19 | ! xs 20 | 21 | private; 22 | 23 | uses lists; 24 | 25 | dec diagonal : list alpha # list beta # list beta -> list(alpha # beta); 26 | 27 | ! produce all the diagonals up to and including the one starting 28 | ! in the top left corner (if any). 29 | 30 | --- diagonal(xs, rev_ys, y::ys) <= 31 | (xs||y::rev_ys) <> diagonal(xs, y::rev_ys, ys); 32 | 33 | ! produce all the diagonals after the one starting in the top 34 | ! left corner (if any). 35 | 36 | --- diagonal(xs, rev_ys, []) <= 37 | concat(map (||rev_ys) (tails (tail xs))); 38 | 39 | --- xs//ys <= diagonal(xs, [], ys); 40 | -------------------------------------------------------------------------------- /src/set.h: -------------------------------------------------------------------------------- 1 | #ifndef SET_H 2 | #define SET_H 3 | 4 | #include "defs.h" 5 | 6 | #define BYTESIZE 8 7 | #define WORDSIZE (BYTESIZE*sizeof(Natural)) 8 | 9 | /* declare a set of [0..size-1] */ 10 | #define SET(name,size) Natural name[((size)+WORDSIZE-1)/WORDSIZE] 11 | #define NWords(set) ((Natural)(sizeof(set)/sizeof(Natural))) 12 | 13 | typedef Natural *SetPtr; /* local reference to a set */ 14 | 15 | extern void set_clear(SetPtr s, Natural n); 16 | extern Natural set_card(SetPtr s, Natural n); 17 | extern void set_union(SetPtr s1, Natural n1, SetPtr s2, Natural n2); 18 | 19 | #define ADD(set,n) (set[(n)/WORDSIZE] |= 1<<((n)%WORDSIZE)) 20 | #define REMOVE(set,n) (set[(n)/WORDSIZE] &= ~(1<<((n)%WORDSIZE))) 21 | #define MEMBER(set,n) ((set[(n)/WORDSIZE] & 1<<((n)%WORDSIZE)) != 0) 22 | 23 | /* the following do NOT work on SetPtrs */ 24 | #define CLEAR(set) set_clear(set, NWords(set)) 25 | #define CARD(set) set_card(set, NWords(set)) 26 | #define UNION(set1,set2) set_union(set1, NWords(set1), set2, NWords(set2)) 27 | 28 | #endif 29 | -------------------------------------------------------------------------------- /doc/hope.bib: -------------------------------------------------------------------------------- 1 | @inproceedings{hope, 2 | author = "R.M. Burstall and D.B MacQueen and D.T. Sanella", 3 | title = "Hope: An Experimental Applicative Language", 4 | booktitle = "The 1980 LISP Conference", 5 | address = "Stanford", 6 | pages = "136-143", 7 | month = Aug, 8 | year = 1980, 9 | note = "Also CSR-62-80, Dept of Computer Science, University of Edinburgh" 10 | } 11 | 12 | @article{tutorial, 13 | author = "Roger Bailey", 14 | title = "A {Hope} Tutorial", 15 | url = "../hope_tut/index.html", 16 | journal = "Byte", 17 | pages = "235-258", 18 | month = Aug, 19 | year = 1985 20 | } 21 | 22 | @book{field&harrison, 23 | author = "A.J. Field and P.G. Harrison", 24 | title = "Functional Programming", 25 | publisher = "Addison Wesley", 26 | address = "Wokingham, England", 27 | year = 1988 28 | } 29 | 30 | @book{bailey, 31 | author = "Roger Bailey", 32 | title = "Functional Programming in {Hope}", 33 | publisher = "Ellis Horwood", 34 | address = "Chichester, England", 35 | year = 1990 36 | } 37 | -------------------------------------------------------------------------------- /lib/tree.hop: -------------------------------------------------------------------------------- 1 | ! a binary tree type 2 | 3 | data tree alpha == Tip ++ Branch(alpha # tree alpha # tree alpha); 4 | 5 | dec fold_tree : beta # (alpha # beta # beta -> beta) -> 6 | tree alpha -> beta; 7 | --- fold_tree(e, n) Tip <= e; 8 | --- fold_tree(e, n) (Branch(x, l, r)) <= 9 | n(x, fold_tree(e, n) l, fold_tree(e, n) r); 10 | 11 | dec flatten : tree alpha -> list alpha; 12 | 13 | dec show_tree : (alpha -> list char) -> tree alpha -> list char; 14 | 15 | private; 16 | 17 | dec append : tree alpha # list alpha -> list alpha; 18 | --- append(Tip, xs) <= xs; 19 | --- append(Branch(x, l, r), xs) <= append(l, x::append(r, xs)); 20 | 21 | --- flatten t <= append(t, []); 22 | 23 | dec show_tree' : (alpha -> list char) -> 24 | list char -> tree alpha -> list char -> list char; 25 | --- show_tree' show_elt prefix Tip rest <= ""; 26 | --- show_tree' show_elt prefix (Branch(x, l, r)) rest <= 27 | let prefix' == " " <> prefix in 28 | show_tree' show_elt prefix' l ( 29 | prefix <> show_elt x <> "\n" <> 30 | show_tree' show_elt prefix' r rest 31 | ); 32 | 33 | --- show_tree show_elt t <= show_tree' show_elt "" t ""; 34 | -------------------------------------------------------------------------------- /lib/lines.hop: -------------------------------------------------------------------------------- 1 | ! break a stream of characters into lines, and the reverse 2 | 3 | dec lines : list char -> list(list char); 4 | ! lines(text) = the list of lines in text. Lines are terminated by the 5 | ! newline character ('\n'), although the final newline may be missing. 6 | ! The newline characters do not appear in the result. Example: 7 | ! lines("Hello world\ngoodbye\n") = ["Hello world", "goodbye"] 8 | 9 | dec unlines : list(list char) -> list char; 10 | ! unlines(linelist) = the concatenation of a list of lines, with a newline 11 | ! character added to the end of each line. Example: 12 | ! unlines(["Hello world", "goodbye"]) = "Hello world\ngoodbye\n" 13 | 14 | ! lines and unlines satisfy 15 | ! lines(unlines(linelist)) = linelist 16 | ! unlines(lines(text)) = text, if text ends with a newline 17 | ! = text <> "\n", otherwise 18 | 19 | private; 20 | 21 | --- lines [] <= []; 22 | --- lines(c::cs) <= 23 | if c = '\n' then []::lines cs 24 | else (lambda [] => [[c]] ! missing final newline 25 | | l::ls => (c::l)::ls 26 | ) (lines cs); 27 | 28 | --- unlines [] <= []; 29 | --- unlines(l::ls) <= l <> '\n' :: unlines ls; 30 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | INSTALLATION PROCEDURE 2 | 3 | Unix: 4 | make install 5 | 6 | That will put everything under /usr/local. If you want them somewhere 7 | else, set configure_args in the top-level Makefile. 8 | 9 | Others: 10 | - you will need to adjust hopelib.h for the target machine. 11 | - copy *.[hc] and ../lib/*.hop to your machine. 12 | - bash it till it fits. 13 | 14 | The Hope error message: 15 | fatal error - can't read module 'Standard' 16 | indicates a slip-up in hopelib.h. 17 | 18 | VARIABLES 19 | 20 | You might wish to (un)define the following cpp variables: 21 | 22 | REALS num.h represent numbers as double, rather than long. 23 | STATS runtime.c produce statistics on space usage and the 24 | garbage collector. 25 | STATS interpret.c produce statistics on expressions entered. 26 | 27 | There are also a number of variables in print.h which control the way 28 | expressions, values and types are parenthesized on output. 29 | 30 | You might also wish to adjust the variable MEMSIZE (in memory.c), which 31 | controls the amount of data space used. 32 | 33 | OTHER FILES 34 | 35 | NOTES maintenance notes 36 | HISTORY revision history 37 | -------------------------------------------------------------------------------- /src/error.h: -------------------------------------------------------------------------------- 1 | #ifndef ERROR_H 2 | #define ERROR_H 3 | 4 | /* error categories - these are also indices for an array in error() (qv) */ 5 | enum { 6 | LEXERR, /* lexical error */ 7 | SYNERR, /* syntax error */ 8 | SEMERR, /* semantic error, except type errors */ 9 | TYPEERR, /* type conflict */ 10 | EXECERR, /* run-time error */ 11 | USERERR, /* user error */ 12 | FATALERR, /* fatal error */ 13 | LIBERR, /* library error */ 14 | INTERR /* internal error */ 15 | }; 16 | 17 | extern FILE *errout; /* initialized by start_err_line() */ 18 | 19 | extern void start_err_line(void); 20 | /* call before line written to errout */ 21 | extern void error(int errtype, const char *fmt, ...); 22 | /* 23 | * If errtype >= TYPEERR, error() will not return. 24 | * Also, any error in a system module is treated as a library error. 25 | */ 26 | extern void yyerror(const char *msg); 27 | 28 | #ifdef DEBUG 29 | # define ASSERT(x) if (! (x)) \ 30 | error(INTERR, "assertion failed: \"%s\", line %d\n", \ 31 | __FILE__, __LINE__) 32 | #else 33 | # define ASSERT(x) 34 | #endif 35 | 36 | extern Bool erroneous; /* error already reported in the current line */ 37 | 38 | extern Bool recovering(void); /* Yacc is recovering */ 39 | 40 | #endif 41 | -------------------------------------------------------------------------------- /src/eval.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "eval.h" 3 | #include "expr.h" 4 | #include "error.h" 5 | #include "compile.h" 6 | #include "interpret.h" 7 | #include "stream.h" 8 | #include "number.h" 9 | #include "output.h" 10 | #include "type_check.h" 11 | #include "exceptions.h" 12 | 13 | local Bool create_environment(Expr *expr); 14 | 15 | /* 16 | * Evaluation of expressions. 17 | */ 18 | 19 | global jmp_buf execerror; 20 | 21 | local Bool 22 | create_environment(Expr *expr) 23 | { 24 | return nr_branch(new_unary(id_expr(newstring("input")), 25 | expr, 26 | (Branch *)0)); 27 | } 28 | 29 | global void 30 | eval_expr(Expr *expr) 31 | { 32 | if (erroneous) 33 | return; 34 | if (create_environment(expr)) { 35 | reset_streams(); 36 | if (! setjmp(execerror)) { 37 | chk_expr(expr); 38 | comp_expr(expr); 39 | interpret(e_print, expr); 40 | } 41 | close_streams(); 42 | } 43 | } 44 | 45 | global void 46 | wr_expr(Expr *expr, const char *file) 47 | { 48 | if (erroneous) 49 | return; 50 | if (create_environment(expr)) { 51 | reset_streams(); 52 | if (! setjmp(execerror)) { 53 | open_out_file(file); 54 | chk_list(expr); 55 | comp_expr(expr); 56 | interpret(e_wr_list, expr); 57 | save_out_file(); 58 | } else 59 | close_out_file(); 60 | close_streams(); 61 | } 62 | } 63 | -------------------------------------------------------------------------------- /src/newstring.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "newstring.h" 3 | #include "memory.h" 4 | #include "align.h" 5 | 6 | #define TABSIZ 293 /* should be prime */ 7 | 8 | typedef struct _Ident Ident; 9 | struct _Ident { 10 | Ident *link; 11 | char text[ALIGNMENT]; /* stub for size purposes */ 12 | }; 13 | #define SizeIdent(n) (sizeof(Ident) - ALIGNMENT + 1 + (n)) 14 | 15 | local Ident *table[TABSIZ]; 16 | local Natural hash(const Byte *s, int n); 17 | 18 | global void 19 | init_strings(void) 20 | { 21 | Ident **tp; 22 | 23 | for (tp = table; tp != &table[TABSIZ]; tp++) 24 | *tp = NULL; 25 | } 26 | 27 | global String 28 | newstring(const char *s) 29 | { 30 | return newnstring(s, strlen(s)); 31 | } 32 | 33 | global String 34 | newnstring(const char *s, int n) 35 | { 36 | Ident *np, **p; 37 | 38 | p = &table[hash((const Byte *)s, n)]; 39 | for (np = *p; np != NULL; np = np->link) 40 | if (strncmp(np->text, s, n) == 0 && np->text[n] == '\0') 41 | return np->text; 42 | np = (Ident *)s_alloc((Natural)SizeIdent(n)); 43 | np->link = *p; 44 | *p = np; 45 | np->text[n] = '\0'; 46 | return strncpy(np->text, s, n); 47 | } 48 | 49 | #define A 17 50 | #define B 89 51 | #define C 167 52 | 53 | local Natural 54 | hash(const Byte *s, int n) 55 | { 56 | return n <= 0 ? 0 : 57 | (Natural)(n + A*s[0] + B*s[n/2] + C*s[n-1])%TABSIZ; 58 | } 59 | -------------------------------------------------------------------------------- /configure.in: -------------------------------------------------------------------------------- 1 | dnl Process this file with autoconf to produce a configure script. 2 | AC_INIT(src/interpret.c) 3 | 4 | AC_CONFIG_AUX_DIR(sh) 5 | 6 | PACKAGE=hope 7 | AC_SUBST(PACKAGE) 8 | 9 | VERSION=1.0 10 | AC_SUBST(VERSION) 11 | 12 | HOPELIB=$datadir/$PACKAGE/lib 13 | AC_SUBST(HOPELIB) 14 | HOPEDOC=$datadir/doc/$PACKAGE 15 | AC_SUBST(HOPEDOC) 16 | 17 | dnl Checks for programs. 18 | AC_PROG_AWK 19 | AC_PROG_CC 20 | AC_PROG_CPP 21 | AC_PROG_INSTALL 22 | AC_PROG_YACC 23 | 24 | if test "$GCC" = yes 25 | then CFLAGS="$CFLAGS -pipe -pedantic -Wall -W" 26 | CFLAGS="$CFLAGS -Wshadow -Wbad-function-cast -Wcast-qual -Wcast-align" 27 | CFLAGS="$CFLAGS -Wwrite-strings -Wpointer-arith -Wnested-externs" 28 | CFLAGS="$CFLAGS -Wstrict-prototypes -Wmissing-prototypes -Wmissing-declarations" 29 | fi 30 | 31 | dnl Checks for libraries. 32 | AC_CHECK_LIB(m,atan) 33 | 34 | dnl Checks for header files. 35 | AC_HEADER_STDC 36 | AC_CHECK_HEADERS(malloc.h unistd.h) 37 | 38 | dnl Checks for typedefs, structures, and compiler characteristics. 39 | AC_C_CONST 40 | AC_TYPE_SIGNAL 41 | AC_TYPE_SIZE_T 42 | 43 | dnl Checks for library functions. 44 | AC_FUNC_ALLOCA 45 | AC_FUNC_VPRINTF 46 | AC_CHECK_FUNCS(remove) 47 | AC_CHECK_FUNCS(atanh erf hypot) 48 | 49 | AC_CONFIG_HEADER(src/config.h) 50 | AC_OUTPUT(doc/Makefile lib/Makefile src/Makefile) 51 | 52 | (cd src; make depend) 53 | -------------------------------------------------------------------------------- /src/table.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "table.h" 3 | #include "newstring.h" 4 | 5 | global void 6 | t_init(Table *table) 7 | { 8 | table->t_front = NULL; 9 | table->t_end = &(table->t_front); 10 | } 11 | 12 | global void 13 | t_insert(table, element) 14 | Table *table; 15 | TabElt *element; 16 | { 17 | *(table->t_end) = element; 18 | table->t_end = &(element->t_next); 19 | element->t_next = NULL; 20 | } 21 | 22 | global void 23 | t_delete(table, element) 24 | Table *table; 25 | TabElt *element; 26 | { 27 | TabElt **ep; 28 | 29 | for (ep = &(table->t_front); *ep != NULL; ep = &((*ep)->t_next)) 30 | if (*ep == element) { 31 | *ep = (*ep)->t_next; 32 | if (*ep == NULL) 33 | table->t_end = ep; 34 | return; 35 | } 36 | } 37 | 38 | global void 39 | t_copy(Table *table1, const Table *table2) 40 | { 41 | if (table2->t_front == NULL) 42 | t_init(table1); 43 | else { 44 | table1->t_front = table2->t_front; 45 | table1->t_end = table2->t_end; 46 | } 47 | } 48 | 49 | global TabElt * 50 | t_lookup(const Table *table, String name) 51 | { 52 | TabElt *elem; 53 | 54 | for (elem = table->t_front; elem != NULL; elem = elem->t_next) 55 | if (elem->t_name == name) 56 | return elem; 57 | return NULL; 58 | } 59 | 60 | global void 61 | t_foreach(const Table *table, TableAction *action) 62 | { 63 | TabElt *elem; 64 | 65 | for (elem = table->t_front; elem != NULL; elem = elem->t_next) 66 | (*action)(elem); 67 | } 68 | -------------------------------------------------------------------------------- /src/BUGS: -------------------------------------------------------------------------------- 1 | There is no numeric overflow checking. 2 | 3 | Type synonyms are sometimes unrolled too much. 4 | 5 | Bugs with the extension to mu's and change of functors: 6 | - Explicit definitions are allowed (they're needed for # and ->) but 7 | are not checked. 8 | - Polarity of mu-types is not done properly. 9 | - Types like mu x => x and so on (including synonyms that turn out to 10 | be projections) haven't been thoroughly checked. 11 | - MAX_VARS_IN_TYPE is not checked with respect to mu variables. 12 | 13 | LANGUAGE PROBLEMS 14 | 15 | In order to have alpha', beta', etc accepted as type variables, primes 16 | are ignored in typevar declarations. 17 | 18 | If multiple-argument lambda-expressions are permitted, expressions like 19 | lambda cons x => e 20 | will no longer mean what they used to. So currently there're not allowed. 21 | 22 | If you use "Standard-new.hop", strings and explicit lists get list types: 23 | >: [1, 2]; 24 | >> [1, 2] : list num 25 | >: "ab"; 26 | >> "ab" : list char 27 | >: ['a', 'b']; 28 | >> "ab" : list char 29 | If you use :: and nil you get the more general types: 30 | >: 1::2::nil; 31 | >> [1, 2] : listShape num (listShape num (listShape alpha beta)) 32 | >: 'a'::'b'::nil; 33 | >> "ab" : listShape char (listShape char (listShape alpha beta)) 34 | Unfortunately, there are outputs like 35 | >: 1::'a'::nil; 36 | >> [1, 'a'] : listShape num (listShape char (listShape alpha beta)) 37 | which cannot be re-entered in the form shown. 38 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | A lazy interpreter for the functional language Hope 2 | Copyright 1990,1991,1993 by Ross Paterson 3 | 4 | See also the WWW page at http://www.soi.city.ac.uk/~ross/Hope/ 5 | 6 | LICENCE AND DISCLAIMER 7 | 8 | In the following, "this program" refers to the Hope interpreter and its 9 | documentation, excluding Roger Bailey's Hope Tutorial. 10 | 11 | This program is free software; you can redistribute it and/or modify it 12 | under the terms of the GNU General Public License as published by the 13 | Free Software Foundation; either version 2 of the License, or (at your 14 | option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 18 | or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 19 | for more details. 20 | 21 | You should have received a copy of the GNU General Public License along 22 | with this program; if not, write to the Free Software Foundation, Inc., 23 | 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 24 | 25 | SUBDIRECTORIES 26 | 27 | doc a short reference manual (in LaTeX) 28 | lib various Hope modules 29 | src C source for the interpreter 30 | test a small test suite for the interpreter 31 | sh miscellaneous shell scripts. 32 | 33 | Please contact me if you find or fix a bug, do a port or think of an 34 | improvement. 35 | -- 36 | Ross Paterson 37 | Department of Computing, City University, London EC1 38 | -------------------------------------------------------------------------------- /doc/verb.nawk: -------------------------------------------------------------------------------- 1 | # - delete break between query and response 2 | # - insert hyperlink after queries (not done yet) 3 | 4 | BEGIN { 5 | query_line = 0 6 | end_query_pending = 0 7 | verb_prefix = " " 8 | } 9 | 10 | NR == 1 { 11 | print "% This file was automatically generated from " FILENAME 12 | print "% (Why not edit that instead?)" 13 | print "" 14 | } 15 | 16 | /^\\begin{(pseudocode|definition|verbatim)}/ { 17 | flush_query() 18 | begin_verb() 19 | next 20 | } 21 | 22 | /^\\end{(pseudocode|definition|verbatim)}/ { 23 | end_verb() 24 | next 25 | } 26 | 27 | /^\\begin{query}/ { 28 | flush_query() 29 | in_query = 1 30 | query_line = FNR 31 | begin_verb() 32 | next 33 | } 34 | 35 | /^\\end{query}/ { 36 | end_query_pending = 1 37 | in_query = 0 38 | verbatim = 0 39 | next 40 | } 41 | 42 | /^\\begin{response}/ { 43 | in_response = 1 44 | if (end_query_pending) { 45 | end_query_pending = 0 46 | verbatim = 1 47 | } 48 | else 49 | begin_verb() 50 | next 51 | } 52 | 53 | /^\\end{response}/ { 54 | in_response = 0 55 | end_verb() 56 | next 57 | } 58 | 59 | { 60 | flush_query() 61 | if (verbatim && length > 0) 62 | printf "%s", verb_prefix 63 | print 64 | } 65 | 66 | function begin_verb() { 67 | print "\\begin{verbatim}" 68 | verbatim = 1 69 | } 70 | 71 | function end_verb() { 72 | print "\\end{verbatim}" 73 | verbatim = 0 74 | } 75 | 76 | function flush_query() { 77 | if (verbatim) 78 | return 79 | if (end_query_pending) { 80 | end_verb() 81 | end_query_pending = 0 82 | } 83 | } 84 | -------------------------------------------------------------------------------- /src/Mult-op.awk: -------------------------------------------------------------------------------- 1 | # This gets run on op.h whenever it changes, to produce op.sed 2 | 3 | # Extract the values of minprec and maxprec from the header file 4 | 5 | $1 == "#define" && $2 == "MINPREC" { minprec = $3 } 6 | $1 == "#define" && $2 == "MAXPREC" { maxprec = $3 } 7 | 8 | END { # Generate a sed script to do the following to the Yacc input: 9 | 10 | # (1) insert a dummy symbol before the binary operator tokens. 11 | # (The preferences are added later by Assoc.sed.) 12 | 13 | print "/^%token[ \t]*BINARY/i\\" 14 | print "%token BIN_BASE" 15 | 16 | # (2) group BINARY grammar rules with their actions, 17 | # so they can all be replicated together. 18 | # Assumes such rules always have actions, that the final '}' 19 | # ends a line, and that no '}' within the action ends a line. 20 | 21 | print "/^.*[:|].*BINARY.*[^}]$/ {" 22 | print " : loop" 23 | print " N" 24 | print " /}$/!b loop" 25 | print "}" 26 | 27 | # (3) replicate all lines containing BINARY with 28 | # LBINARY, RBINARY, ..., LBINARY, RBINARY 29 | # If a BINARY rule comes first in a production, all copies 30 | # after the first have "nonterminal :" changed to "\t|". 31 | 32 | print "/BINARY/ {" 33 | print " s/BINARY/LBINARY" minprec "/" 34 | print " p" 35 | print " s/^[a-z0-9_]*[ \t]*:/\t|/" 36 | print " s/LBINARY/RBINARY/" 37 | for (i = minprec+1; i <= maxprec; i++) { 38 | print " p" 39 | print " s/RBINARY" (i-1) "/LBINARY" i "/" 40 | print " p" 41 | print " s/LBINARY/RBINARY/" 42 | } 43 | print "}" 44 | } 45 | -------------------------------------------------------------------------------- /lib/seq.hop: -------------------------------------------------------------------------------- 1 | ! infinite sequences 2 | 3 | uses products, fold; 4 | 5 | type seq alpha == alpha # seq alpha; 6 | 7 | dec fold_seq : (alpha # beta -> beta) -> seq alpha -> beta; 8 | --- fold_seq <= fold (id #); 9 | 10 | dec unfold_seq : (beta -> alpha # beta) -> beta -> seq alpha; 11 | --- unfold_seq <= unfold (id #); 12 | 13 | dec gen_seq : (alpha -> alpha) -> alpha -> seq alpha; 14 | --- gen_seq f <= unfold_seq (id /\ f); 15 | 16 | dec filter_seq : (alpha -> bool) -> seq alpha -> seq alpha; 17 | --- filter_seq cond <= 18 | fold_seq (lambda (x, y) => if cond x then (x, y) else y); 19 | 20 | dec zip_seq : seq alpha # seq beta -> seq(alpha # beta); 21 | --- zip_seq <= unfold_seq flip; 22 | 23 | dec unzip_seq : seq(alpha # beta) -> seq alpha # seq beta; 24 | --- unzip_seq <= seq fst /\ seq snd; 25 | 26 | dec transpose : seq(seq alpha) -> seq(seq alpha); 27 | --- transpose <= unfold (id #) unzip_seq; 28 | !!! transpose <= fold (id #) zip_seq; 29 | 30 | uses list; 31 | 32 | dec front_seq : num # seq alpha -> list alpha; 33 | --- front_seq(0, s) <= []; 34 | --- front_seq(n+1, (x, xs)) <= x::front_seq(n, xs); 35 | 36 | dec after_seq : num # seq alpha -> seq alpha; 37 | --- after_seq(0, s) <= s; 38 | --- after_seq(n+1, (x, xs)) <= after_seq(n, xs); 39 | 40 | dec split_seq : (alpha -> bool) -> seq alpha -> list alpha # seq alpha; 41 | --- split_seq p (x, xs) <= 42 | if p x then ((x::) # id) (split_seq p xs) 43 | else ([], xs); 44 | 45 | dec select_seq : num # seq alpha -> alpha; 46 | --- select_seq(0, (x, xs)) <= x; 47 | --- select_seq(n+1, (x, xs)) <= select_seq(n, xs); 48 | -------------------------------------------------------------------------------- /src/memory.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "memory.h" 3 | #include "error.h" 4 | #include "align.h" 5 | 6 | /* size of space for compiled code, tables, stack and heap */ 7 | #define MEGABYTE (1024*1024L) 8 | #define MEMSIZE 16*MEGABYTE 9 | 10 | /* 11 | * The granularity of allocation is the alignment granularity. 12 | */ 13 | #define RoundDown(n) ((n)/ALIGNMENT*ALIGNMENT) 14 | #define RoundUp(n) RoundDown((n) + (ALIGNMENT-1)) 15 | 16 | global char *base_memory, *top_memory; 17 | global char *top_string, *base_table, *base_temp; 18 | global char *lim_temp; 19 | 20 | global void 21 | init_memory(void) 22 | { 23 | if ((base_memory = (char *)malloc((size_t)MEMSIZE)) == NULL) 24 | error(FATALERR, "can't allocate memory"); 25 | top_memory = base_memory + RoundDown(MEMSIZE); 26 | 27 | lim_temp = top_string = base_memory; 28 | base_table = base_temp = top_memory; 29 | } 30 | 31 | global void * 32 | s_alloc(Natural n) 33 | { 34 | char *start; 35 | 36 | start = top_string; 37 | top_string += RoundUp(n); 38 | lim_temp = top_string; 39 | if (base_temp < lim_temp) 40 | error(FATALERR, "can't store string: out of memory"); 41 | return (void *)start; 42 | } 43 | 44 | global void * 45 | t_alloc(Natural n) 46 | { 47 | base_temp -= RoundUp(n); 48 | if (base_temp < lim_temp) 49 | error(FATALERR, "out of memory"); 50 | return (void *)base_temp; 51 | } 52 | 53 | global void 54 | clean_slate(void) 55 | { 56 | base_temp = base_table; 57 | lim_temp = top_string; 58 | } 59 | 60 | global void 61 | preserve(void) 62 | { 63 | base_table = base_temp; 64 | lim_temp = top_string; 65 | } 66 | -------------------------------------------------------------------------------- /src/stack.h: -------------------------------------------------------------------------------- 1 | #ifndef STACK_H 2 | #define STACK_H 3 | 4 | /* 5 | * The run-time cell stack. 6 | */ 7 | 8 | #include "defs.h" 9 | 10 | /* 11 | * enable stack -- required for any calls to Push(). 12 | * start_heap() must have already been called. 13 | */ 14 | extern void start_stack(void); 15 | 16 | typedef union _StkElt StkElt; 17 | union _StkElt { 18 | Cell *stk_value; 19 | StkElt *stk_update; /* pointer to update frame */ 20 | }; 21 | 22 | extern StkElt *stack; 23 | 24 | #define FORCE_MARK NOCELL 25 | 26 | #define Push(cell) ((--stack)->stk_value = (cell)) 27 | #define Pop() (stack++->stk_value) 28 | #define Top() (stack->stk_value) 29 | #define Pop_void() (stack++) 30 | 31 | /* 32 | * Update frames: 33 | * IsUpdate() there is an update frame on the top of the stack. 34 | * PushUpdate(cp) push an update frame pointing to cp onto the stack. 35 | * PopUpdate() pop the update from on top of the stack, returning 36 | * its cell pointer. 37 | * 38 | * Update frames on the stack consist of: 39 | * a pointer to the cell to be updated. 40 | * a pointer to the next update frame on the stack. 41 | * pushed onto the stack in that order. 42 | */ 43 | #define UPD_FRAME 2 /* size of a frame on the stack */ 44 | 45 | extern StkElt *last_update; /* top update frame */ 46 | 47 | #define IsUpdate() (stack == last_update) 48 | #define PushUpdate(cell) (\ 49 | Push(cell),\ 50 | (--stack)->stk_update = last_update,\ 51 | last_update = stack) 52 | /* IsUpdate() should be true when PopUpdate() is called */ 53 | #define PopUpdate() (\ 54 | last_update = stack++->stk_update,\ 55 | Pop()) 56 | 57 | extern void chk_stack(int required); 58 | 59 | #endif 60 | -------------------------------------------------------------------------------- /lib/arith.hop: -------------------------------------------------------------------------------- 1 | ! some simple arithmetic functions 2 | 3 | uses seq; 4 | 5 | ! powers function 6 | infixr ^ : 7; 7 | dec ^ : num # num -> num; 8 | --- (^) <= pow; 9 | 10 | ! factorial 11 | dec fact : num -> num; 12 | --- fact 0 <= 1; 13 | --- fact(succ n) <= succ n * fact n; 14 | 15 | dec e, pi : num; 16 | --- e <= exp 1; 17 | --- pi <= acos 0 * 2; 18 | 19 | ! area under the normal curve 20 | dec normal, normalc : num -> num; 21 | --- normal x <= erf(x/sqrt 2); 22 | --- normalc x <= erfc(x/sqrt 2); 23 | 24 | ! factorize a number 25 | dec factors : num -> list num; 26 | 27 | ! Euler's totient function 28 | dec totient : num -> num; 29 | 30 | ! infinite sequence of Fibonacci numbers 31 | dec fibs : seq num; 32 | 33 | ! infinite sequence of primes 34 | dec primes : seq num; 35 | 36 | private; 37 | 38 | dec factorize : num # seq num -> list num; 39 | --- factorize(n, (f, fs)) <= 40 | if f*f > n then [n] 41 | else if n mod f = 0 42 | then f::factorize(n div f, (f, fs)) 43 | else factorize(n, fs); 44 | 45 | --- factors n <= factorize(n, (2, gen_seq (+2) 3)); 46 | 47 | uses lists; 48 | 49 | !!! totient(Prod_i (pi^ei)) = Prod_i ((pi-1)*pi^(ei-1)) 50 | 51 | dec adjust : list num -> list num; 52 | --- adjust [] <= []; 53 | --- adjust [x] <= [x-1]; 54 | --- adjust (x1::x2::xs) <= 55 | (if x1 = x2 then x1 else x1-1)::adjust(x2::xs); 56 | 57 | --- totient n <= product (adjust (factors n)); 58 | 59 | --- fibs <= fib_seq whererec 60 | fib_seq == (0, 1, seq (+) (zip_seq (fib_seq, snd fib_seq))); 61 | 62 | ! prime generation with the sieve of Eratosthenes 63 | 64 | dec nonmultiple : num -> num -> bool; 65 | --- nonmultiple n m <= m mod n /= 0; 66 | 67 | dec sieve : seq num -> seq num; 68 | --- sieve(p, rest) <= (p, sieve(filter_seq (nonmultiple p) rest)); 69 | 70 | --- primes <= sieve(gen_seq (+1) 2); 71 | -------------------------------------------------------------------------------- /src/heap.h: -------------------------------------------------------------------------------- 1 | #ifndef HEAP_H 2 | #define HEAP_H 3 | 4 | #include "defs.h" 5 | #include "path.h" 6 | #include "num.h" 7 | #include "char.h" 8 | 9 | /* 10 | * Classes of cells on the heap, arranged by number of cell children 11 | * they have. First we list the underlying names, and then the names 12 | * they are given by the type checker and interpreter. 13 | * Note: the top bit of this class (GC_MARK) is set, and cleared again, 14 | * by the garbage collector. 15 | */ 16 | #define GC_MARK 0100 17 | 18 | #define C_MAXARITY 2 19 | #define C_CLASSBITS 4 20 | #define C_NCLASSES ((C_MAXARITY+1)<>C_CLASSBITS) 24 | 25 | #define NOCELL ((Cell *)0) 26 | 27 | struct _Cell { 28 | char c_class; 29 | char c_misc_num; /* PAPP */ 30 | union { 31 | Num cu_num; /* Num */ 32 | Char cu_char; /* CHAR */ 33 | FILE *cu_file; /* STREAM */ 34 | struct { /* unary nodes */ 35 | union { 36 | DefType *cu_tcons; /* TSUB */ 37 | Cons *cu_cons; /* CONST, CONS */ 38 | Expr *cu_expr; /* SUSP, PAPP */ 39 | Path cu_path; /* DIRS */ 40 | UCase *cu_code; /* UCASE */ 41 | LCase *cu_lcase; /* LCASE */ 42 | } co_union; 43 | Cell *cu_cell; 44 | } cu_one; 45 | struct { /* binary nodes */ 46 | Cell *cu_left, *cu_right; /* PAIR */ 47 | } cu_two; 48 | } c_union; 49 | }; 50 | 51 | /* free list */ 52 | #define c_foll c_union.cu_one.cu_cell 53 | 54 | #define c_sub c_union.cu_one.cu_cell 55 | #define c_sub1 c_union.cu_two.cu_left 56 | #define c_sub2 c_union.cu_two.cu_right 57 | 58 | /* 59 | * The heap of cells 60 | */ 61 | extern void start_heap(void); 62 | /* required before any calls to new_cell() */ 63 | extern Cell *new_cell(int class); 64 | extern void chk_heap(Cell *current, int required); 65 | extern void heap_stats(void); 66 | 67 | #endif 68 | -------------------------------------------------------------------------------- /src/path.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "path.h" 3 | #include "memory.h" 4 | 5 | #define MAX_PATH 40 /* max. length of a path (not checked) */ 6 | 7 | /* 8 | * Create a new, empty path. 9 | * Returned value points to a static area that will be overwritten 10 | * by the next call. 11 | */ 12 | global Path 13 | p_new(void) 14 | { 15 | static char path_buf[MAX_PATH]; 16 | 17 | path_buf[MAX_PATH-1] = P_END; 18 | return &path_buf[MAX_PATH-1]; 19 | } 20 | 21 | global Path 22 | p_push(int dir, Path p) 23 | { 24 | *--p = dir; 25 | return p; 26 | } 27 | 28 | /* permanent storage for a path */ 29 | global Path 30 | p_stash(Path p) 31 | { 32 | return strcpy(NEWARRAY(char, strlen(p) + 1), p); 33 | } 34 | 35 | /* temporary storage for a number of paths */ 36 | local char *p_buffer; 37 | local char *pb_end; 38 | local int pb_size; /* not checked at present */ 39 | 40 | global void 41 | p_init(char *buf, int size) 42 | { 43 | pb_end = p_buffer = buf; 44 | pb_size = size; 45 | } 46 | 47 | global Path 48 | p_save(Path p) 49 | { 50 | char *new; 51 | 52 | new = strcpy(pb_end, p); 53 | pb_end += strlen(p)+1; 54 | return new; 55 | } 56 | 57 | /* 58 | * Reverse a path, adding an UNROLL before each direction in the initial 59 | * string of LEFTs and RIGHTs. 60 | * Returned value points to a static area that will be overwritten 61 | * by the next call. 62 | */ 63 | global Path 64 | p_reverse(Path old) 65 | { 66 | static char path_buf[MAX_PATH]; 67 | Path new; 68 | int dir; 69 | 70 | path_buf[MAX_PATH-1] = P_END; 71 | new = &path_buf[MAX_PATH-1]; 72 | 73 | repeat { 74 | until(p_empty(old)); 75 | dir = p_top(old); 76 | new = p_push(dir, new); 77 | old = p_pop(old); 78 | until(dir != P_LEFT && dir != P_RIGHT); 79 | new = p_push(P_UNROLL, new); 80 | } 81 | while (! p_empty(old)) { 82 | new = p_push(p_top(old), new); 83 | old = p_pop(old); 84 | } 85 | return new; 86 | } 87 | -------------------------------------------------------------------------------- /src/type_value.h: -------------------------------------------------------------------------------- 1 | #ifndef TYPE_VALUE_H 2 | #define TYPE_VALUE_H 3 | 4 | #include "defs.h" 5 | #include "heap.h" 6 | 7 | extern Bool unify(Cell *type1, Cell *type2); 8 | extern Bool instance(Type *type, Natural ntvars, Cell *inf_type); 9 | extern Cell *deref(Cell *type); 10 | extern Cell *copy_type(Type *type, Natural ntvars, Bool frozen); 11 | extern Cell *expand_type(Cell *type); 12 | 13 | extern Cell *new_func_type(Cell *from, Cell *to); 14 | extern Cell *new_prod_type(Cell *left, Cell *right); 15 | extern Cell *new_list_type(Cell *element); 16 | extern Cell *new_const_type(DefType *dt); 17 | 18 | /* type cell classes */ 19 | #define C_TVAR CellClass(0, 8) 20 | #define C_VOID CellClass(0, 9) 21 | #define C_FROZEN CellClass(0, 10) 22 | #define C_VISITED CellClass(0, 11) 23 | #define C_TSUB CellClass(1, 8) 24 | #define C_TREF CellClass(1, 9) 25 | #define C_TLIST CellClass(2, 8) 26 | #define C_TCONS CellClass(2, 9) 27 | 28 | /* fields for type structures */ 29 | #define c_tcons c_union.cu_one.co_union.cu_tcons /* TSUB */ 30 | #define c_targ c_union.cu_one.cu_cell /* TSUB */ 31 | #define c_tref c_union.cu_one.cu_cell /* TREF */ 32 | #define c_varno c_misc_num /* TVAR, TCONS */ 33 | 34 | #define c_targ1 c_targ->c_full->c_head /* TCONS */ 35 | #define c_targ2 c_targ->c_full->c_tail->c_head /* TCONS */ 36 | 37 | #define c_abbr c_union.cu_two.cu_left /* TSYN */ 38 | #define c_full c_union.cu_two.cu_right /* TSYN */ 39 | #define c_head c_union.cu_two.cu_left /* TLIST */ 40 | #define c_tail c_union.cu_two.cu_right /* TLIST */ 41 | 42 | extern Cell *new_tvar(void); 43 | extern Cell *new_tsub(DefType *tcons, Cell *targ); 44 | extern Cell *new_tref(Cell *tref); 45 | extern Cell *new_void(void); 46 | extern Cell *new_frozen(void); 47 | extern Cell *new_tsyn(Cell *abbr, Cell *full); 48 | extern Cell *new_tlist(Cell *left, Cell *right); 49 | extern Cell *new_tcons(DefType *tcons, Cell *targ); 50 | 51 | #endif 52 | -------------------------------------------------------------------------------- /src/memory.h: -------------------------------------------------------------------------------- 1 | #ifndef MEMORY_H 2 | #define MEMORY_H 3 | 4 | /* 5 | * A large chunk of memory is allocated once at the start. 6 | * Subsequently, this area is divided as follows: 7 | * 8 | * Pointers Allocation functions 9 | * -------- -------------------- 10 | * High ------------------------- <-- top_memory 11 | * | Table space: | 12 | * | structures and code | 13 | * |-----------------------| <-- base_table 14 | * | temporary table space | t_alloc(n) 15 | * |-----------------------| <-- base_temp 16 | * | Run-time stack | Push(cell) 17 | * |-----------------------| <-- stack 18 | * | | | 19 | * | v | 20 | * | | 21 | * | | 22 | * | ^ | 23 | * | | | 24 | * |-----------------------| <-- heap 25 | * | Heap | new_cell(class) 26 | * |-----------------------| <-- top_string 27 | * | String space | s_alloc(n) 28 | * Low ------------------------- <-- base_memory 29 | * 30 | * There is also a pointer lim_temp, which is either equal to top_string 31 | * or, when the heap but not the stack is enabled, a fence between heap 32 | * and base_temp. 33 | */ 34 | 35 | extern void init_memory(void); /* set up everything */ 36 | extern void preserve(void); 37 | /* make temporary table space permanent, re-enable s_alloc() and t_alloc() */ 38 | extern void clean_slate(void); 39 | /* discard temporary table space, re-enable s_alloc() and t_alloc() */ 40 | 41 | /* 42 | * Other calls: 43 | * start_heap() enable calls to new_cell(), disabling s_alloc(). 44 | * start_stack() enable calls to Push() and chk_heap(), 45 | * disabling t_alloc(). 46 | */ 47 | 48 | extern void *s_alloc(Natural nbytes); 49 | extern void *t_alloc(Natural nbytes); 50 | 51 | extern void heap_stats(void); 52 | 53 | #define NEWARRAY(type,size) ((type *)t_alloc((Natural)sizeof(type)*(size))) 54 | #define NEW(type) NEWARRAY(type, 1) 55 | 56 | extern char *base_memory, *top_memory; 57 | extern char *top_string, *base_table, *base_temp; 58 | extern char *lim_temp; 59 | 60 | #endif 61 | -------------------------------------------------------------------------------- /src/config.h.in: -------------------------------------------------------------------------------- 1 | /* src/config.h.in. Generated automatically from configure.in by autoheader. */ 2 | 3 | /* Define if using alloca.c. */ 4 | #undef C_ALLOCA 5 | 6 | /* Define to empty if the keyword does not work. */ 7 | #undef const 8 | 9 | /* Define to one of _getb67, GETB67, getb67 for Cray-2 and Cray-YMP systems. 10 | This function is required for alloca.c support on those systems. */ 11 | #undef CRAY_STACKSEG_END 12 | 13 | /* Define if you have alloca, as a function or macro. */ 14 | #undef HAVE_ALLOCA 15 | 16 | /* Define if you have and it should be used (not on Ultrix). */ 17 | #undef HAVE_ALLOCA_H 18 | 19 | /* Define if you don't have vprintf but do have _doprnt. */ 20 | #undef HAVE_DOPRNT 21 | 22 | /* Define if you have the vprintf function. */ 23 | #undef HAVE_VPRINTF 24 | 25 | /* Define as the return type of signal handlers (int or void). */ 26 | #undef RETSIGTYPE 27 | 28 | /* Define to `unsigned' if doesn't define. */ 29 | #undef size_t 30 | 31 | /* If using the C implementation of alloca, define if you know the 32 | direction of stack growth for your system; otherwise it will be 33 | automatically deduced at run-time. 34 | STACK_DIRECTION > 0 => grows toward higher addresses 35 | STACK_DIRECTION < 0 => grows toward lower addresses 36 | STACK_DIRECTION = 0 => direction of growth unknown 37 | */ 38 | #undef STACK_DIRECTION 39 | 40 | /* Define if you have the ANSI C header files. */ 41 | #undef STDC_HEADERS 42 | 43 | /* Define if you have the atanh function. */ 44 | #undef HAVE_ATANH 45 | 46 | /* Define if you have the erf function. */ 47 | #undef HAVE_ERF 48 | 49 | /* Define if you have the hypot function. */ 50 | #undef HAVE_HYPOT 51 | 52 | /* Define if you have the remove function. */ 53 | #undef HAVE_REMOVE 54 | 55 | /* Define if you have the header file. */ 56 | #undef HAVE_MALLOC_H 57 | 58 | /* Define if you have the header file. */ 59 | #undef HAVE_UNISTD_H 60 | 61 | /* Define if you have the m library (-lm). */ 62 | #undef HAVE_LIBM 63 | -------------------------------------------------------------------------------- /src/NOTES: -------------------------------------------------------------------------------- 1 | Maintenance Notes for the Hope interpreter: 2 | 3 | If you make any changes to the code, please sign them clearly in the code, 4 | and also in the file HISTORY. 5 | 6 | PROGRAM STRUCTURE 7 | 8 | General header files: 9 | defs.h structs.h 10 | Main program: 11 | main.c plan9args.h 12 | Source input, lexical analysis and parsing: 13 | error.h names.h op.h source.[ch] text.h yylex.c yyparse.y 14 | Type structures: 15 | bad_rectype.[ch] cons.h deftype.[ch] functors.[ch] polarity.[ch] 16 | remember_type.[ch] typevar.h 17 | Expression structures: 18 | cases.[ch] char.[ch] char_array.[ch] expr.[ch] module.[ch] 19 | num.h number.[ch] path.[ch] set.[ch] table.[ch] 20 | Type checking: 21 | functor_type.[ch] type_check.[ch] type_value.[ch] 22 | Evaluation: 23 | builtin.[ch] compare.[ch] compile.[ch] eval.[ch] exceptions.h 24 | interpret.[ch] interrupt.[ch] output.[ch] stream.[ch] value.[ch] 25 | Memory management: 26 | heap.h memory.[ch] newstring.[ch] runtime.c stack.h 27 | Printing: 28 | pr_expr.[ch] pr_ty_value.[ch] pr_type.[ch] pr_value.[ch] print.h 29 | 30 | MISCELLANEOUS NOTES 31 | 32 | The parser is built using yacc. Infix operators are implemented by 33 | a series of left- and right-associative tokens, all represented in 34 | yyparse.y by the symbol BINARY. The file is preprocessed with the sed 35 | scripts op.sed and Assoc.sed to replicate all lines mentioning BINARY. 36 | This means that C compiler error messages will refer to lines in 37 | yyparse.c, not yyparse.y. The file op.sed is itself generated by 38 | Mult-op.awk from op.h. All this is done automatically by the Makefile. 39 | 40 | If you add files or change the #include's, run 'make depend' to update 41 | make's dependency information. 42 | 43 | Read the comment in memory.c before you contemplate allocating memory. 44 | 45 | To test your changes, run "make check". 46 | 47 | If you've changed compilation or the interpreter, enable the definition 48 | of STATS (print space usage statistics) in runtime.c for testing. 49 | 50 | If something goes wrong with the interpreter, try defining TRACE in 51 | interpret.c for more information. 52 | -------------------------------------------------------------------------------- /src/config.h: -------------------------------------------------------------------------------- 1 | /* src/config.h. Generated automatically by configure. */ 2 | /* src/config.h.in. Generated automatically from configure.in by autoheader. */ 3 | 4 | /* Define if using alloca.c. */ 5 | /* #undef C_ALLOCA */ 6 | 7 | /* Define to empty if the keyword does not work. */ 8 | /* #undef const */ 9 | 10 | /* Define to one of _getb67, GETB67, getb67 for Cray-2 and Cray-YMP systems. 11 | This function is required for alloca.c support on those systems. */ 12 | /* #undef CRAY_STACKSEG_END */ 13 | 14 | /* Define if you have alloca, as a function or macro. */ 15 | #define HAVE_ALLOCA 1 16 | 17 | /* Define if you have and it should be used (not on Ultrix). */ 18 | #define HAVE_ALLOCA_H 1 19 | 20 | /* Define if you don't have vprintf but do have _doprnt. */ 21 | /* #undef HAVE_DOPRNT */ 22 | 23 | /* Define if you have the vprintf function. */ 24 | #define HAVE_VPRINTF 1 25 | 26 | /* Define as the return type of signal handlers (int or void). */ 27 | #define RETSIGTYPE void 28 | 29 | /* Define to `unsigned' if doesn't define. */ 30 | /* #undef size_t */ 31 | 32 | /* If using the C implementation of alloca, define if you know the 33 | direction of stack growth for your system; otherwise it will be 34 | automatically deduced at run-time. 35 | STACK_DIRECTION > 0 => grows toward higher addresses 36 | STACK_DIRECTION < 0 => grows toward lower addresses 37 | STACK_DIRECTION = 0 => direction of growth unknown 38 | */ 39 | /* #undef STACK_DIRECTION */ 40 | 41 | /* Define if you have the ANSI C header files. */ 42 | #define STDC_HEADERS 1 43 | 44 | /* Define if you have the atanh function. */ 45 | #define HAVE_ATANH 1 46 | 47 | /* Define if you have the erf function. */ 48 | #define HAVE_ERF 1 49 | 50 | /* Define if you have the hypot function. */ 51 | #define HAVE_HYPOT 1 52 | 53 | /* Define if you have the remove function. */ 54 | #define HAVE_REMOVE 1 55 | 56 | /* Define if you have the header file. */ 57 | #define HAVE_MALLOC_H 1 58 | 59 | /* Define if you have the header file. */ 60 | #define HAVE_UNISTD_H 1 61 | 62 | /* Define if you have the m library (-lm). */ 63 | #define HAVE_LIBM 1 64 | -------------------------------------------------------------------------------- /src/value.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "value.h" 3 | 4 | global Cell * 5 | new_pair(Cell *left, Cell *right) 6 | { 7 | Cell *cp; 8 | 9 | cp = new_cell(C_PAIR); 10 | cp->c_left = left; 11 | cp->c_right = right; 12 | return cp; 13 | } 14 | 15 | global Cell * 16 | new_dirs(Path path, Cell *val) 17 | { 18 | Cell *cp; 19 | 20 | cp = new_cell(C_DIRS); 21 | cp->c_path = path; 22 | cp->c_val = val; 23 | return cp; 24 | } 25 | 26 | global Cell * 27 | new_cons(Cons *data_constructor, Cell *arg) 28 | { 29 | Cell *cp; 30 | 31 | cp = new_cell(C_CONS); 32 | cp->c_cons = data_constructor; 33 | cp->c_arg = arg; 34 | return cp; 35 | } 36 | 37 | global Cell * 38 | new_susp(Expr *expr, Cell *env) 39 | { 40 | Cell *cp; 41 | 42 | cp = new_cell(C_SUSP); 43 | cp->c_expr = expr; 44 | cp->c_env = env; 45 | return cp; 46 | } 47 | 48 | global Cell * 49 | new_papp(Expr *expr, Cell *env, int arity) 50 | { 51 | Cell *cp; 52 | 53 | cp = new_cell(C_PAPP); 54 | cp->c_expr = expr; 55 | cp->c_env = env; 56 | cp->c_arity = arity; 57 | return cp; 58 | } 59 | 60 | global Cell * 61 | new_ucase(UCase *code, Cell *env) 62 | { 63 | Cell *cp; 64 | 65 | cp = new_cell(C_UCASE); 66 | cp->c_code = code; 67 | cp->c_env = env; 68 | return cp; 69 | } 70 | 71 | global Cell * 72 | new_lcase(LCase *lcase, Cell *env) 73 | { 74 | Cell *cp; 75 | 76 | cp = new_cell(C_LCASE); 77 | cp->c_lcase = lcase; 78 | cp->c_env = env; 79 | return cp; 80 | } 81 | 82 | global Cell * 83 | new_cnst(Cons *data_constant) 84 | { 85 | Cell *cp; 86 | 87 | cp = new_cell(C_CONST); 88 | cp->c_cons = data_constant; 89 | return cp; 90 | } 91 | 92 | global Cell * 93 | new_num(Num n) 94 | { 95 | Cell *cp; 96 | 97 | cp = new_cell(C_NUM); 98 | cp->c_num = n; 99 | return cp; 100 | } 101 | 102 | global Cell * 103 | new_char(Char c) 104 | { 105 | Cell *cp; 106 | 107 | cp = new_cell(C_CHAR); 108 | cp->c_char = c; 109 | return cp; 110 | } 111 | 112 | global Cell * 113 | new_stream(FILE *f) 114 | { 115 | Cell *cp; 116 | 117 | cp = new_cell(C_STREAM); 118 | cp->c_file = f; 119 | return cp; 120 | } 121 | -------------------------------------------------------------------------------- /lib/sort.hop: -------------------------------------------------------------------------------- 1 | ! sorting 2 | 3 | dec sort : list alpha -> list alpha; 4 | 5 | dec uniq : list alpha -> list alpha; 6 | ! eliminate adjacent duplicates from a list 7 | 8 | private; 9 | 10 | ! Here are 4 implementations of sorting - take your pick 11 | 12 | uses list; 13 | 14 | ! Insertion sorting 15 | 16 | dec insert : alpha # list alpha -> list alpha; 17 | --- insert(x, []) <= [x]; 18 | --- insert(x, y::ys) <= if x < y then x::y::ys else y::insert(x, ys); 19 | 20 | dec isort : list alpha -> list alpha; 21 | --- isort <= foldr([], insert); 22 | 23 | ! Selection sorting 24 | 25 | dec select : list(alpha) -> alpha # list(alpha); 26 | --- select [x] <= (x, []); 27 | --- select(x::y::l) <= 28 | if x < least then (x, least::rest) else (least, x::rest) 29 | where (least, rest) == select(y::l); 30 | 31 | dec ssort : list(alpha) -> list(alpha); 32 | --- ssort [] <= []; 33 | --- ssort(x::xs) <= 34 | least :: ssort(rest) where (least, rest) == select(x::xs); 35 | 36 | ! Partition sorting (quicksort) 37 | 38 | dec qsort' : list alpha # list alpha -> list alpha; 39 | !!! qsort'(xs, ys) <= qsort xs <> ys; 40 | --- qsort'([], ys) <= ys; 41 | --- qsort'(x::xs, ys) <= 42 | qsort'(smaller, x::qsort'(larger, ys)) 43 | where (smaller, larger) == partition (< x) xs; 44 | 45 | dec qsort : list alpha -> list alpha; 46 | --- qsort xs <= qsort'(xs, []); 47 | 48 | ! Merge sorting 49 | 50 | dec split : list alpha -> list alpha # list alpha; 51 | --- split [] <= ([], []); 52 | --- split(x::xs) <= (x::zs, ys) where (ys, zs) == split xs; 53 | 54 | dec merge : list alpha # list alpha -> list alpha; 55 | --- merge([], ys) <= ys; 56 | --- merge(xs, []) <= xs; 57 | --- merge(x::xs, y::ys) <= 58 | if x < y then x::merge(xs, y::ys) else y::merge(x::xs, ys); 59 | 60 | dec msort : list alpha -> list alpha; 61 | --- msort [] <= []; 62 | --- msort [x] <= [x]; 63 | --- msort(x1::x2::xs) <= 64 | merge(msort(x1::ys), msort(x2::zs)) where (ys, zs) == split xs; 65 | 66 | --- sort <= msort; 67 | 68 | ! Removal of duplicates 69 | 70 | dec uniq' : alpha -> list alpha -> list alpha; 71 | --- uniq' x [] <= []; 72 | --- uniq' x (y::ys) <= if x = y then uniq' x ys else y::uniq' y ys; 73 | 74 | --- uniq [] <= []; 75 | --- uniq(x::xs) <= x::uniq' x xs; 76 | -------------------------------------------------------------------------------- /src/value.h: -------------------------------------------------------------------------------- 1 | #ifndef VALUE_H 2 | #define VALUE_H 3 | 4 | #include "defs.h" 5 | #include "path.h" 6 | #include "num.h" 7 | #include "char.h" 8 | #include "heap.h" 9 | 10 | /* data cell classes */ 11 | #define C_NUM CellClass(0, 0) 12 | #define C_CHAR CellClass(0, 1) 13 | #define C_CONST CellClass(0, 2) /* constant */ 14 | #define C_STREAM CellClass(0, 3) /* partially read input stream */ 15 | #define C_HOLE CellClass(0, 4) /* black hole */ 16 | #define C_CONS CellClass(1, 0) /* constructed term */ 17 | #define C_SUSP CellClass(1, 1) /* term and environment */ 18 | #define C_DIRS CellClass(1, 2) /* directions and value */ 19 | #define C_UCASE CellClass(1, 3) /* upper case */ 20 | #define C_LCASE CellClass(1, 4) /* lower case */ 21 | #define C_PAPP CellClass(1, 5) /* partial application */ 22 | #define C_PAIR CellClass(2, 0) /* pair and list builder */ 23 | 24 | /* fields for data cells */ 25 | #define c_arity c_misc_num /* PAPP */ 26 | #define c_num c_union.cu_num /* Num */ 27 | #define c_char c_union.cu_char /* CHAR */ 28 | #define c_file c_union.cu_file /* STREAM */ 29 | #define c_cons c_union.cu_one.co_union.cu_cons /* CONST, CONS */ 30 | #define c_arg c_union.cu_one.cu_cell /* CONS */ 31 | #define c_expr c_union.cu_one.co_union.cu_expr /* SUSP, PAPP */ 32 | #define c_code c_union.cu_one.co_union.cu_code /* UCASE */ 33 | #define c_lcase c_union.cu_one.co_union.cu_lcase /* LCASE */ 34 | #define c_env c_union.cu_one.cu_cell /* SUSP, UCASE, LCASE, PAPP */ 35 | #define c_path c_union.cu_one.co_union.cu_path /* DIRS */ 36 | #define c_val c_union.cu_one.cu_cell /* DIRS */ 37 | #define c_left c_union.cu_two.cu_left /* PAIR */ 38 | #define c_right c_union.cu_two.cu_right /* PAIR */ 39 | 40 | extern Cell *new_num(Num n); 41 | extern Cell *new_char(Char c); 42 | extern Cell *new_stream(FILE *f); 43 | extern Cell *new_cnst(Cons *data_constant); 44 | extern Cell *new_cons(Cons *data_constructor, Cell *arg); 45 | extern Cell *new_susp(Expr *expr, Cell *env); 46 | extern Cell *new_papp(Expr *expr, Cell *env, int arity); 47 | extern Cell *new_dirs(Path path, Cell *val); 48 | extern Cell *new_ucase(UCase *code, Cell *env); 49 | extern Cell *new_lcase(LCase *lcase, Cell *env); 50 | extern Cell *new_pair(Cell *left, Cell *right); 51 | 52 | #endif 53 | -------------------------------------------------------------------------------- /src/char.h: -------------------------------------------------------------------------------- 1 | #ifndef CHAR_H 2 | #define CHAR_H 3 | 4 | #include "defs.h" 5 | 6 | /* 7 | * By default, the char type refers to an 8-bit character set whose 8 | * first 128 positions are the ASCII characters, e.g. ASCII itself, 9 | * or any of the ISO 8859 alphabets. 10 | * 11 | * Set UCS to make the char type refer to the universal character 12 | * set ISO 10646-1 UCS-2 (a.k.a Unicode). The first 256 positions in 13 | * this character set coincide with ISO 8859-1 (Latin-1). For external 14 | * purposes, this will be encoded using the UTF (a.k.a. FSS-UTF, UTF-2) 15 | * Byte encoding. (UTF encodes ASCII characters as themselves.) 16 | * 17 | * If UCS is defined, you can also define UTF_LIBS to use special symbols 18 | * in the syntax, but this will need special versions of the libraries. 19 | */ 20 | /* #define UCS */ 21 | /* #define UTF_LIBS */ 22 | 23 | /* SChar is best for arrays, Char for variables */ 24 | #ifdef UCS 25 | typedef unsigned short SChar; 26 | #else 27 | typedef Byte SChar; 28 | #endif 29 | typedef unsigned int Char; 30 | 31 | #ifdef UCS 32 | #define MaxChar ((Char)0xfffdL) 33 | #else 34 | #define MaxChar ((Char)0xff) 35 | #endif 36 | 37 | extern Char FetchChar(const Byte **p); 38 | extern void BackChar(const Byte **p); 39 | extern long GetChar(FILE *f); 40 | extern void PutChar(Char c, FILE *f); 41 | 42 | #ifndef UCS 43 | #define FetchChar(p) (*(*p)++) 44 | #define BackChar(p) ((*p)--) 45 | #define GetChar(f) getc(f) 46 | #define PutChar(ch,f) ((void)putc(ch, f)) 47 | #endif 48 | 49 | /* character classes */ 50 | #include 51 | 52 | #ifdef UCS 53 | /* extra characters are treated as either punctuation of alphabetic */ 54 | #define ExtPunct(c) (0x2000 <= (c) && (c) <= 0x3020) 55 | 56 | #define IsCntrl(c) (isascii(c) && iscntrl(c)) 57 | #define IsSpace(c) (isascii(c) && isspace(c)) 58 | #define IsDigit(c) (isascii(c) && isdigit(c)) 59 | #define IsPunct(c) (isascii(c) ? ispunct(c) : ExtPunct(c)) 60 | #define IsAlpha(c) (isascii(c) ? isalpha(c) : ! ExtPunct(c)) 61 | #define IsAlNum(c) (isascii(c) ? isalnum(c) : ! ExtPunct(c)) 62 | #else /* ! UCS */ 63 | #define IsCntrl(c) iscntrl(c) 64 | #define IsSpace(c) isspace(c) 65 | #define IsDigit(c) isdigit(c) 66 | #define IsPunct(c) ispunct(c) 67 | #define IsAlpha(c) isalpha(c) 68 | #define IsAlNum(c) isalnum(c) 69 | #endif /* UCS */ 70 | 71 | #endif 72 | -------------------------------------------------------------------------------- /src/HISTORY: -------------------------------------------------------------------------------- 1 | REVISION HISTORY 2 | 3 | I originally wrote this interpreter to have a well-behaved implementation 4 | of a simple functional language for use with an undergraduate course. 5 | 6 | 31 Jul 1988 initial version used in CS225 at UofQ 7 | 8 | 31 Jan 1989 added type, abstype, private, parameterless definitions 9 | 10 | 4 Mar 1989 added operator sections 11 | 12 | 16 Jul 1989 general clean-up; use of "Standard" module 13 | 14 | 25 Jul 1989 #ifdef AMIGA sections [Bill Segall, Ross] 15 | 16 | 6 Nov 1989 back end rewritten to use a Krivine machine; 17 | simplification of pattern compilation. [Ross, Andrew Moran] 18 | output & comparison functions in "Standard". 19 | 20 | 11 Mar 1990 edit command, and re-editing (RE_EDIT) 21 | 22 | 3 Jul 1990 switched from reference counting to mark-scan garbage 23 | collection; 24 | added letrec/whererec; num as double. 25 | 26 | 10 Mar 1991 improved re-editing (inspired by the Mocka system). 27 | re-organization of pattern matching, including best-fit 28 | and more efficient character matching. 29 | n+k pattern as abbreviation for succ^k(n). 30 | replaced update markers with stack frames. 31 | 32 | 12 Jan 1993 added curried function definitions. 33 | caught redefinition of values as constructors/constants 34 | and vice versa. 35 | changed treatment of primed type variables. 36 | 37 | 19 Jan 1993 regular types (i.e. type synonyms may be recursive). 38 | lazy expansion of type synonyms. 39 | 40 | 22 Feb 1993 'dec' declarations may be fulfilled by data constructors. 41 | 42 | 21 Apr 1993 automatic declaration and definition of 'map' functions 43 | corresponding to type and type constructor identifiers. 44 | They may be overridden with explicit definitions. 45 | 46 | 4 Nov 1993 support for UTF-encoded Unicode characters. 47 | 48 | 25 Mar 1994 curried data and type constructors. 49 | made 'compare' available. 50 | 51 | 1 Jul 1994 added options for use in a CGI. 52 | 53 | 15 Dec 1994 small extension to recursive type synonyms: permutations 54 | of arguments now allowed in recursive uses. 55 | 56 | 15 Mar 1995 cyclic types now printed using mu-notation. 57 | added mu-expressions. 58 | 59 | 16 Aug 1995 added the black hole optimization. 60 | 61 | 11 Jun 1997 added -f command line argument, #! hack and argv. 62 | 63 | 16 Apr 1999 cleanup, autoconf, GPL. 64 | -------------------------------------------------------------------------------- /src/hope.1.in: -------------------------------------------------------------------------------- 1 | .TH HOPE 1 2 | .SH NAME 3 | hope \- a lazy interpreter for the functional language Hope 4 | .SH SYNOPSIS 5 | .B hope 6 | [ 7 | .B \-lr 8 | ] 9 | [ 10 | .B \-f 11 | .I file 12 | ] 13 | [ 14 | .B \-t 15 | .I nsecs 16 | ] 17 | [ 18 | .I args 19 | ] 20 | .SH DESCRIPTION 21 | .LP 22 | .B Hope 23 | is an interactive interpreter for a lazy variant 24 | of the functional language Hope. 25 | It is most commonly run without options or arguments, 26 | and reads commands from the standard input, 27 | and prints results on the standard output. 28 | If the standard input is a terminal, 29 | .I hope 30 | prompts with the string 31 | .RI ` >: '. 32 | A simple use is to enter an expression, terminated by a semicolon. 33 | The interpreter will respond by printing the value and type of the expression, 34 | < preceded by 35 | .RI ` >> '. 36 | For example, 37 | .nf 38 | \fI>:\fP 6*7; 39 | \fI>>\fP 42 : num 40 | .fi 41 | .LP 42 | See the documentation for more complicated uses. 43 | .SH OPTIONS 44 | These options are mainly useful for non-interactive use of the interpreter. 45 | .IP \fB\-l\fP 46 | Generate a listing of the input, with embedded error messages. 47 | .IP \fB\-r\fP 48 | The interpreter is run in restricted mode: 49 | all file I/O is disabled (except for reading of libraries). 50 | .IP \fB\-f\fR\ \fIfile\fR 51 | Read input from 52 | .I file 53 | instead of the standard input. 54 | This is useful for Hope scripts, whose first line would be 55 | .nf 56 | \fB"#! @fullpath@ -f\fP \fIarg\fP ... 57 | .fi 58 | Any additional arguments will be available through the variable 59 | .IR argv . 60 | .IP \fB\-t\fR\ \fIn\fR 61 | Evaluation of any expression is interrupted if it takes more than 62 | .I n 63 | seconds. 64 | .SH FILES 65 | .IP @hopelib@ 66 | The standard library directory. 67 | .SH ENVIRONMENT 68 | .IP \fBHOPEPATH\fP 69 | A colon-separated list of directories to search for Hope modules in 70 | .B uses 71 | commands. 72 | An empty entry refers to the standard library directory. 73 | The default value is 74 | .RI ` .: '. 75 | .LP 76 | A Hope module 77 | .I name 78 | is stored in a file `\fIname\fP\fB.hop\fP'. 79 | .SH "SEE ALSO" 80 | .IP \(bu 81 | .IR "A Hope Interpreter \- Reference" , 82 | Ross Paterson. 83 | .IP \(bu 84 | .IR "A Hope Tutorial" , 85 | Roger Bailey. 86 | .LP 87 | Both documents should be distributed with this program. 88 | .SH AUTHOR 89 | .LP 90 | Ross Paterson 91 | -------------------------------------------------------------------------------- /src/cases.h: -------------------------------------------------------------------------------- 1 | #ifndef CASES_H 2 | #define CASES_H 3 | 4 | #include "defs.h" 5 | #include "path.h" 6 | 7 | /* 8 | * The upper part of case constructs. 9 | */ 10 | 11 | enum { 12 | UC_CASE, /* upper level of case expression */ 13 | UC_F_NOMATCH, /* no-match error on function */ 14 | UC_L_NOMATCH, /* no-match error on lambda */ 15 | UC_SUCCESS, /* body expression */ 16 | UC_STRICT /* strict function */ 17 | }; 18 | 19 | struct _UCase { 20 | short uc_class; 21 | union { 22 | struct { /* CASE */ 23 | short ucu_references; 24 | short ucu_level; 25 | Path ucu_path; 26 | LCase *ucu_cases; 27 | } uc_case; 28 | Func *ucu_defun; /* F_NOMATCH */ 29 | Expr *ucu_expr; /* L_NOMATCH, STRICT */ 30 | struct { /* SUCCESS */ 31 | int ucu_size; 32 | Expr *ucu_body; 33 | } uc_success; 34 | } uc_union; 35 | }; 36 | #define uc_references uc_union.uc_case.ucu_references /* CASE */ 37 | #define uc_level uc_union.uc_case.ucu_level /* CASE */ 38 | #define uc_path uc_union.uc_case.ucu_path /* CASE */ 39 | #define uc_cases uc_union.uc_case.ucu_cases /* CASE */ 40 | #define uc_defun uc_union.ucu_defun /* F_NOMATCH */ 41 | #define uc_who uc_union.ucu_expr /* L_NOMATCH */ 42 | #define uc_real uc_union.ucu_expr /* STRICT */ 43 | #define uc_body uc_union.uc_success.ucu_body /* SUCCESS */ 44 | #define uc_size uc_union.uc_success.ucu_size /* SUCCESS */ 45 | 46 | extern UCase *ucase(int level, Path path, LCase *cases); 47 | extern UCase *f_nomatch(Func *defun); 48 | extern UCase *l_nomatch(Expr *who); 49 | extern UCase *success(Expr *body, int size); 50 | extern UCase *strict(Expr *real); 51 | extern UCase *copy_ucase(UCase *old); 52 | 53 | /* 54 | * The lower part of case constructs. 55 | */ 56 | 57 | enum { 58 | LC_ALGEBRAIC, /* algebraic data type */ 59 | LC_NUMERIC, /* numbers -- <0, 0, succ(n) */ 60 | LC_CHARACTER /* characters */ 61 | }; 62 | 63 | struct _LCase { 64 | short lc_class; 65 | int lcu_arity; 66 | union { 67 | UCase **lcu_limbs; /* ALGEBRAIC, NUMERIC */ 68 | CharArray *lcu_c_limbs; /* CHARACTER */ 69 | } lc_union; 70 | }; 71 | #define lc_arity lcu_arity 72 | #define lc_limbs lc_union.lcu_limbs 73 | #define lc_c_limbs lc_union.lcu_c_limbs 74 | 75 | /* indexes for number cases */ 76 | enum { LESS, EQUAL, GREATER }; 77 | 78 | extern LCase *alg_case(Natural arity, UCase *def); 79 | extern LCase *num_case(UCase *def); 80 | extern LCase *char_case(UCase *def); 81 | 82 | #endif 83 | -------------------------------------------------------------------------------- /src/defs.h: -------------------------------------------------------------------------------- 1 | #ifndef DEFS_H 2 | #define DEFS_H 3 | /* 4 | * A lazy Hope interpreter 5 | * 6 | * Ross Paterson 7 | */ 8 | 9 | /* 10 | * Global compilation options -- adjust to taste 11 | * 12 | * See also: 13 | * REALS (in num.h) 14 | * UCS and UTF_LIBS (in char.h) 15 | * STATS (in runtime.c) 16 | * TRACE (in interpret.c) 17 | */ 18 | 19 | /* set this to facilitate debugging, by retaining symbols 20 | #define DEBUG 21 | */ 22 | 23 | /* set NLS to enable Natural language support 24 | #define NLS 25 | */ 26 | 27 | /* no need to touch anything else */ 28 | 29 | #include "config.h" 30 | 31 | /* 32 | * Standard Definitions 33 | */ 34 | 35 | #include 36 | 37 | #ifdef MSDOS 38 | # define msdos 39 | #endif 40 | 41 | #ifdef msdos 42 | # undef unix 43 | #endif 44 | 45 | #ifdef unix 46 | # define RE_EDIT 47 | #endif 48 | 49 | #include 50 | #include 51 | 52 | #ifdef DEBUG 53 | # define local 54 | #else 55 | # define local static 56 | #endif 57 | #define global 58 | 59 | typedef unsigned int Natural; 60 | typedef unsigned char Byte; 61 | typedef int Bool; 62 | typedef char SBool; 63 | #define TRUE 1 64 | #define FALSE 0 65 | 66 | #define when break; case 67 | #define or : case 68 | #define otherwise break; default 69 | 70 | #define repeat for (;;) 71 | #define until(c) if (c) break 72 | 73 | #define SIZE(array) (sizeof(array)/sizeof(array[0])) 74 | 75 | #include "error.h" 76 | 77 | /* a sop to keep dumb checkers happy (and an extra debugging check) */ 78 | #define NOT_REACHED ASSERT(FALSE); exit(1) 79 | 80 | /* 81 | * System-dependent stuff 82 | */ 83 | 84 | #ifdef RE_EDIT 85 | extern void edit(const char *name); 86 | #else 87 | # define edit(name) 88 | #endif 89 | 90 | extern void init_lex(void); 91 | extern int yyparse(void); 92 | extern int yylex(void); 93 | 94 | /* 95 | * Command-line flags 96 | */ 97 | extern Bool restricted; /* disable file I/O */ 98 | extern int time_limit; /* evaluation time limit in seconds */ 99 | /* default = 0 (no limit) */ 100 | 101 | extern const char *const *cmd_args; /* other arguments */ 102 | 103 | #include "structs.h" 104 | 105 | /* 106 | * Unix functions. 107 | */ 108 | 109 | #ifdef HAVE_UNISTD_H 110 | # include 111 | # ifndef HAVE_REMOVE 112 | # define remove unlink 113 | # endif 114 | #endif 115 | 116 | #endif 117 | -------------------------------------------------------------------------------- /src/hope.1: -------------------------------------------------------------------------------- 1 | .TH HOPE 1 2 | .SH NAME 3 | hope \- a lazy interpreter for the functional language Hope 4 | .SH SYNOPSIS 5 | .B hope 6 | [ 7 | .B \-lr 8 | ] 9 | [ 10 | .B \-f 11 | .I file 12 | ] 13 | [ 14 | .B \-t 15 | .I nsecs 16 | ] 17 | [ 18 | .I args 19 | ] 20 | .SH DESCRIPTION 21 | .LP 22 | .B Hope 23 | is an interactive interpreter for a lazy variant 24 | of the functional language Hope. 25 | It is most commonly run without options or arguments, 26 | and reads commands from the standard input, 27 | and prints results on the standard output. 28 | If the standard input is a terminal, 29 | .I hope 30 | prompts with the string 31 | .RI ` >: '. 32 | A simple use is to enter an expression, terminated by a semicolon. 33 | The interpreter will respond by printing the value and type of the expression, 34 | < preceded by 35 | .RI ` >> '. 36 | For example, 37 | .nf 38 | \fI>:\fP 6*7; 39 | \fI>>\fP 42 : num 40 | .fi 41 | .LP 42 | See the documentation for more complicated uses. 43 | .SH OPTIONS 44 | These options are mainly useful for non-interactive use of the interpreter. 45 | .IP \fB\-l\fP 46 | Generate a listing of the input, with embedded error messages. 47 | .IP \fB\-r\fP 48 | The interpreter is run in restricted mode: 49 | all file I/O is disabled (except for reading of libraries). 50 | .IP \fB\-f\fR\ \fIfile\fR 51 | Read input from 52 | .I file 53 | instead of the standard input. 54 | This is useful for Hope scripts, whose first line would be 55 | .nf 56 | \fB"#! /usr/local/bin/hope -f\fP \fIarg\fP ... 57 | .fi 58 | Any additional arguments will be available through the variable 59 | .IR argv . 60 | .IP \fB\-t\fR\ \fIn\fR 61 | Evaluation of any expression is interrupted if it takes more than 62 | .I n 63 | seconds. 64 | .SH FILES 65 | .IP /usr/local/share/hope/lib 66 | The standard library directory. 67 | .SH ENVIRONMENT 68 | .IP \fBHOPEPATH\fP 69 | A colon-separated list of directories to search for Hope modules in 70 | .B uses 71 | commands. 72 | An empty entry refers to the standard library directory. 73 | The default value is 74 | .RI ` .: '. 75 | .LP 76 | A Hope module 77 | .I name 78 | is stored in a file `\fIname\fP\fB.hop\fP'. 79 | .SH "SEE ALSO" 80 | .IP \(bu 81 | .IR "A Hope Interpreter \- Reference" , 82 | Ross Paterson. 83 | .IP \(bu 84 | .IR "A Hope Tutorial" , 85 | Roger Bailey. 86 | .LP 87 | Both documents should be distributed with this program. 88 | .SH AUTHOR 89 | .LP 90 | Ross Paterson 91 | -------------------------------------------------------------------------------- /src/print.h: -------------------------------------------------------------------------------- 1 | #ifndef PRINT_H 2 | #define PRINT_H 3 | 4 | #include "defs.h" 5 | #include "op.h" 6 | 7 | /* 8 | * Defining the following names affects the number of extra parentheses 9 | * added to the output representation of expressions, values and types 10 | * (beyond the minimal correct parenthesization), as follows: 11 | * 12 | * name means: always put parentheses around 13 | * ---------------------------------------------------- 14 | * PAR_TUPLES tuples, even at the top level, e.g. (1, 2, 3). 15 | * PAR_INFIX infix arguments to other infix operators, 16 | * e.g. (x * y) + z 17 | * PAR_ARGUMENT arguments of prefix functions, e.g. f (x). 18 | * 19 | * Note that the parser always accepts the minimal parenthesization. 20 | */ 21 | 22 | #define PAR_TUPLES 23 | /* #define PAR_INFIX */ 24 | /* #define PAR_ARGUMENT */ 25 | 26 | /* 27 | * The range of precedences 28 | */ 29 | 30 | /* weakest binding: always needs parentheses */ 31 | #define PREC_INFIX (MINPREC-6) 32 | #define PREC_COMMA (MINPREC-5) 33 | #define PREC_LAMBDA (MINPREC-4) 34 | #define PREC_MU PREC_LAMBDA 35 | #define PREC_LET (MINPREC-3) 36 | #define PREC_WHERE (MINPREC-2) 37 | #define PREC_IF (MINPREC-1) 38 | 39 | /* User-defined infix operators: MINPREC..MAXPREC */ 40 | 41 | #define PREC_APPLY (MAXPREC+1) 42 | #define PREC_ATOMIC (MAXPREC+2) 43 | /* strongest binding: never needs parentheses */ 44 | 45 | /* 46 | * Context precedences 47 | */ 48 | 49 | #define InnerPrec(prec,context) ((prec) < (context) ? PREC_INFIX : (context)) 50 | 51 | /* top-level expression, pattern or value */ 52 | #ifdef PAR_TUPLES 53 | # define PREC_BODY PREC_LAMBDA 54 | #else 55 | # define PREC_BODY PREC_COMMA 56 | #endif 57 | 58 | /* the left and right arguments of an infix operator */ 59 | #ifdef PAR_INFIX 60 | # define LeftPrec(op) (MAXPREC+1) 61 | # define RightPrec(op) (MAXPREC+1) 62 | #else 63 | # define LeftPrec(op) (op->op_prec + (op->op_assoc != ASSOC_LEFT)) 64 | # define RightPrec(op) (op->op_prec + (op->op_assoc != ASSOC_RIGHT)) 65 | #endif 66 | 67 | /* 68 | * formal parameter of a LAMBDA. 69 | * If LAMBDA's are are changed to have multiple arguments (cf. yyparse()), 70 | * this should be changed to PREC_APPLY+1. 71 | */ 72 | #define PREC_FORMAL PREC_BODY 73 | 74 | /* the argument of a function, in prefix format */ 75 | #ifdef PAR_ARGUMENT 76 | # define PREC_ARG (PREC_ATOMIC+1) 77 | #else 78 | # define PREC_ARG (PREC_APPLY+1) 79 | #endif 80 | 81 | #endif 82 | -------------------------------------------------------------------------------- /src/remember_type.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "remember_type.h" 3 | #include "deftype.h" 4 | #include "cons.h" 5 | #include "expr.h" 6 | #include "error.h" 7 | #include "newstring.h" 8 | 9 | typedef struct { 10 | const char *type_name; 11 | DefType **type_ref; 12 | } NoteType; 13 | 14 | local NoteType note_type[] = { 15 | #ifdef UTF_LIBS 16 | { "\xe2\x86\x92", &function }, 17 | { "\xc3\x97", &product }, 18 | #else 19 | { "->", &function }, 20 | { "#", &product }, 21 | #endif 22 | { "bool", &truval }, 23 | { "num", &num }, 24 | { "list", &list }, 25 | { "char", &character }, 26 | { NULL, NULL } 27 | }; 28 | 29 | typedef struct { 30 | const char *cons_name; 31 | Cons **cons_ref; 32 | Expr **expr_ref; 33 | } NoteCons; 34 | 35 | local NoteCons note_cons[] = { 36 | { "nil", &nil, &e_nil }, 37 | { "::", &cons, &e_cons }, 38 | { "succ", &succ, NULL }, 39 | { NULL, NULL, NULL } 40 | }; 41 | 42 | /* 43 | * Remember this one? 44 | * Called whenever a type is defined in the Standard module. 45 | */ 46 | 47 | global void 48 | remember_type(DefType *dt) 49 | { 50 | NoteType *ntp; 51 | NoteCons *ncp; 52 | Cons *cp; 53 | 54 | for (ntp = note_type; ntp->type_name != NULL; ntp++) 55 | if (dt->dt_name == newstring(ntp->type_name)) 56 | *(ntp->type_ref) = dt; 57 | if (IsDataType(dt)) 58 | for (ncp = note_cons; ncp->cons_name != NULL; ncp++) 59 | for (cp = dt->dt_cons; cp != NULL; cp = cp->c_next) 60 | if (cp->c_name == newstring(ncp->cons_name)) { 61 | if (ncp->cons_ref != NULL) 62 | *(ncp->cons_ref) = cp; 63 | if (ncp->expr_ref != NULL) 64 | *(ncp->expr_ref) = 65 | cons_expr(cp); 66 | } 67 | } 68 | 69 | /* 70 | * Called at the end of the Standard module, to check that all the 71 | * types and constructors required internally have been defined. 72 | */ 73 | global void 74 | check_type_defs(void) 75 | { 76 | NoteType *ntp; 77 | NoteCons *ncp; 78 | 79 | for (ntp = note_type; ntp->type_name != NULL; ntp++) 80 | if (*(ntp->type_ref) == NULL) 81 | error(LIBERR, "%s: standard type not defined", 82 | ntp->type_name); 83 | for (ncp = note_cons; ncp->cons_name != NULL; ncp++) { 84 | if ((ncp->cons_ref != NULL && *(ncp->cons_ref) == NULL) || 85 | (ncp->expr_ref != NULL && *(ncp->expr_ref) == NULL)) 86 | error(LIBERR, "%s: standard constructor not defined", 87 | ncp->cons_name); 88 | } 89 | if ((f_id = fn_local(newstring("id"))) == NULL) 90 | error(LIBERR, "%s: standard function not defined", "id"); 91 | } 92 | -------------------------------------------------------------------------------- /src/main.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "memory.h" 3 | #include "module.h" 4 | #include "source.h" 5 | #include "error.h" 6 | #ifdef unix 7 | #include "plan9args.h" 8 | #endif 9 | 10 | #ifdef NLS 11 | #include 12 | #endif 13 | 14 | global Bool restricted; /* disable file I/O */ 15 | global int time_limit; /* evaluation time limit in seconds */ 16 | 17 | global const char *const *cmd_args; 18 | 19 | global int 20 | main(int argc, const char *const argv[]) 21 | { 22 | Bool gen_listing; /* generate a listing on stderr */ 23 | const char *source_file; 24 | FILE *src; 25 | #ifdef RE_EDIT 26 | const char *script_file; 27 | 28 | script_file = NULL; 29 | #endif 30 | source_file = NULL; 31 | gen_listing = restricted = FALSE; 32 | time_limit = 0; 33 | #ifdef unix 34 | ARGBEGIN { 35 | case 'f': source_file = ARGF(); 36 | when 'l': gen_listing = TRUE; 37 | when 'r': restricted = TRUE; 38 | when 't': time_limit = atoi(ARGF()); 39 | #ifdef RE_EDIT 40 | when 's': script_file = ARGF(); 41 | #endif 42 | otherwise: 43 | fprintf(stderr, "usage: %s -lr -f file -t nsecs\n", 44 | argv0); 45 | return 1; 46 | } ARGEND 47 | cmd_args = argv; 48 | #else 49 | cmd_args = argv+1; 50 | #endif 51 | 52 | if (source_file != NULL) { 53 | src = fopen(source_file, "r"); 54 | if (src == NULL) { 55 | fprintf(stderr, "%s: can't read file '%s'\n", 56 | argv0, source_file); 57 | return 1; 58 | } 59 | } else 60 | src = stdin; 61 | 62 | #ifdef NLS 63 | (void)setlocale (LC_ALL, ""); 64 | #endif 65 | init_memory(); 66 | init_strings(); 67 | init_lex(); 68 | init_source(src, gen_listing); 69 | 70 | #ifdef RE_EDIT 71 | if (script_file != NULL) 72 | set_script(script_file); /* re-entry after an edit */ 73 | #endif 74 | mod_init(); /* begin standard module */ 75 | preserve(); 76 | (void)yyparse(); /* read commands from files and user */ 77 | heap_stats(); 78 | if (source_file != NULL) 79 | fclose(src); 80 | return 0; 81 | } 82 | 83 | #ifdef RE_EDIT 84 | /* 85 | * Restart Hope, reading from the script_file. 86 | * The neatest way would be to just longjmp back to the start, 87 | * but it's too much trouble to get the external data back into 88 | * the right state, or to make sure the program doesn't depend on 89 | * its initial state. So, we just exec ourselves again, passing 90 | * the script_file as an argument. 91 | */ 92 | global void 93 | restart(const char *script_file) 94 | { 95 | (void)execlp(argv0, argv0, "-s", script_file, (char *)0); 96 | error(FATALERR, "cannot restart"); 97 | } 98 | #endif 99 | -------------------------------------------------------------------------------- /sh/makedepend: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Generate dependencies of source files on header files. 4 | # Only inclusions of relative file names yield dependencies. 5 | 6 | cppflags= 7 | files= 8 | replace=true 9 | makefile= 10 | objsuffix=.o 11 | delimiter="# DO NOT DELETE THIS LINE -- make depend depends on it." 12 | width=78 13 | picky=true 14 | 15 | for arg 16 | do 17 | case $arg in 18 | -[DI]*) cppflags="$cppflags $arg" ;; 19 | -Y*) dir=`expr "$arg" : '-.\(.*\)'` 20 | cppflags="$cppflags -nostdinc" 21 | case "$dir" in 22 | ?*) cppflags="$cppflags -I$dir" ;; 23 | esac ;; 24 | -a) replace=false ;; 25 | -f*) makefile=`expr "$arg" : '-.\(.*\)'` ;; 26 | -g) ;; # don't know what this is 27 | -m) ;; # unimplemented 28 | -o*) objsuffix=`expr "$arg" : '-.\(.*\)'` ;; 29 | -p*) objprefix=`expr "$arg" : '-.\(.*\)'` ;; 30 | -s*) delimiter=`expr "$arg" : '-.\(.*\)'` ;; 31 | -v) ;; # unimplemented 32 | -w*) width=`expr "$arg" : '-.\(.*\)'` ;; 33 | --) case $picky in 34 | true) picky=false ;; 35 | false) picky=true ;; 36 | esac ;; 37 | -*) if $picky 38 | then echo "$0: warning: ignoring option '$arg'" >&2 39 | fi ;; 40 | *) files="$files $arg" ;; 41 | esac 42 | done 43 | 44 | case "$makefile" in 45 | "") if [ -f makefile ] 46 | then makefile=makefile 47 | else makefile=Makefile 48 | fi ;; 49 | esac 50 | 51 | if [ -f $makefile ] && grep -s "^$delimiter\$" $makefile >/dev/null 52 | then 53 | if $replace 54 | then ed - $makefile <>$makefile 64 | fi 65 | 66 | for file in $files 67 | do objname="$objprefix"`expr "$file" : '\(.*\)\.[^.]*$'`"$objsuffix" 68 | gcc $cppflags -E $file | 69 | grep '^# 1 "[a-z0-9A-Z][^"]*"' | 70 | sed ' s/[^"]*"\([^"]*\)".*/\1/ 71 | s|///*|/|g 72 | : dotloop 73 | s|/./|/|g 74 | t dotloop 75 | s|^./|| 76 | : ddloop 77 | s|[^/][^/]*/\.\./||g 78 | t ddloop 79 | '"s|^|$objname |" | 80 | fgrep -v " $file" 81 | done | sort -u | 82 | awk ' $1 != last { 83 | if (NR > 1) 84 | print line 85 | line = $1 ":" 86 | line_length = length(line) 87 | last = $1 88 | } 89 | { 90 | word_length = length($2) 91 | line_length += 1 + word_length 92 | if (line_length < max_line_length) 93 | line = line " " $2 94 | else { 95 | print line, "\\" 96 | line = "\t" $2 97 | line_length = 8 + word_length 98 | } 99 | } 100 | END { 101 | if (NR > 0) 102 | print line 103 | }' "max_line_length=$width" - >>$makefile 104 | -------------------------------------------------------------------------------- /doc/verb-query.nawk: -------------------------------------------------------------------------------- 1 | # - delete break between query and response 2 | # - insert hyperlink after queries (not done yet) 3 | 4 | BEGIN { 5 | query_line = 0 6 | end_query_pending = 0 7 | verb_prefix = " " 8 | nqs = nrs = 0 9 | } 10 | 11 | NR == 1 { 12 | print "% This file was automatically generated from " FILENAME 13 | print "% (Why not edit that instead?)" 14 | print "" 15 | } 16 | 17 | /^\\begin{(pseudocode|definition|verbatim)}/ { 18 | flush_query() 19 | begin_verb() 20 | next 21 | } 22 | 23 | /^\\end{(pseudocode|definition|verbatim)}/ { 24 | end_verb() 25 | next 26 | } 27 | 28 | /^\\begin{query}/ { 29 | flush_query() 30 | in_query = 1 31 | query_line = FNR 32 | print "\\begin{latexonly}" 33 | begin_verb() 34 | next 35 | } 36 | 37 | /^\\end{query}/ { 38 | end_query_pending = 1 39 | in_query = 0 40 | verbatim = 0 41 | next 42 | } 43 | 44 | /^\\begin{response}/ { 45 | in_response = 1 46 | if (end_query_pending) { 47 | end_query_pending = 0 48 | verbatim = 1 49 | } 50 | else 51 | begin_verb() 52 | next 53 | } 54 | 55 | /^\\end{response}/ { 56 | in_response = 0 57 | end_verb() 58 | next 59 | } 60 | 61 | in_query == 1 { q[++nqs] = $0 } 62 | in_response == 1 { r[++nrs] = $0 } 63 | 64 | { 65 | flush_query() 66 | if (verbatim && length > 0) 67 | printf "%s", verb_prefix 68 | print 69 | } 70 | 71 | /^\\maketitle/ { 72 | print "\\begin{htmlonly}" 73 | print "{\\em Note:}" 74 | print "The queries in this document may be run by selecting them," 75 | print "if your browser can handle forms." 76 | print "\\end{htmlonly}" 77 | } 78 | 79 | function begin_verb() { 80 | print "\\begin{verbatim}" 81 | verbatim = 1 82 | } 83 | 84 | function end_verb() { 85 | print "\\end{verbatim}" 86 | verbatim = 0 87 | } 88 | 89 | function flush_query() { 90 | if (verbatim) 91 | return 92 | if (end_query_pending) { 93 | end_verb() 94 | end_query_pending = 0 95 | } 96 | if (nqs > 0 || nrs > 0) { 97 | anchor = "" 98 | print "\\end{latexonly}" 99 | print "\\begin{rawhtml}" 100 | print "
"
101 | 		for (i = 1; i <= nqs; i++) {
102 | 			line = quote(q[i])
103 | 			match(line, " *")
104 | 			print verb_prefix substr(line, 1, RLENGTH) anchor substr(line, RLENGTH+1) ""
105 | 		}
106 | 		for (i = 1; i <= nrs; i++)
107 | 			print verb_prefix quote(r[i])
108 | 		print "
" 109 | print "\\end{rawhtml}" 110 | nqs = nrs = 0 111 | } 112 | } 113 | 114 | function quote(s) { 115 | gsub("&", "\\&", s) 116 | gsub("<", "\\<", s) 117 | gsub(">", "\\>", s) 118 | return s 119 | } 120 | -------------------------------------------------------------------------------- /src/output.c: -------------------------------------------------------------------------------- 1 | /* 2 | * The builtins "print" and "write_element". 3 | */ 4 | 5 | #include "defs.h" 6 | #include "output.h" 7 | #include "expr.h" 8 | #include "cases.h" 9 | #include "type_value.h" 10 | #include "type_check.h" 11 | #include "pr_ty_value.h" 12 | #include "value.h" 13 | #include "pr_value.h" 14 | #include "memory.h" 15 | #include "error.h" 16 | 17 | #define STDOUT stdout 18 | 19 | global Expr *e_return, *e_print, *e_wr_list; 20 | 21 | global void 22 | init_print(void) 23 | { 24 | Func *fn; 25 | 26 | e_return = NEW(Expr); 27 | e_return->e_class = E_RETURN; 28 | fn = fn_lookup(newstring("return")); 29 | ASSERT( fn != NULL ); 30 | fn->f_code = success(e_return, 0); 31 | 32 | fn = fn_lookup(newstring("print")); 33 | ASSERT( fn != NULL ); 34 | e_print = NEW(Expr); 35 | e_print->e_class = E_DEFUN; 36 | e_print->e_defun = fn; 37 | 38 | fn = fn_lookup(newstring("write_list")); 39 | ASSERT( fn != NULL ); 40 | e_wr_list = NEW(Expr); 41 | e_wr_list->e_class = E_DEFUN; 42 | e_wr_list->e_defun = fn; 43 | } 44 | 45 | /* 46 | * Print value and inferred type on standard output 47 | */ 48 | global Cell * 49 | print_value(Cell *value) 50 | { 51 | (void)fprintf(STDOUT, ">> "); 52 | pr_value(STDOUT, value); 53 | (void)fprintf(STDOUT, " : "); 54 | pr_ty_value(STDOUT, expr_type); 55 | (void)fprintf(STDOUT, "\n"); 56 | return new_susp(e_return, NOCELL); 57 | } 58 | 59 | /* 60 | * Direct a list-valued output to the terminal or a file 61 | */ 62 | 63 | local FILE *out_file; 64 | local const char *out_name; 65 | 66 | #define TEMPFILE "TempFile" 67 | 68 | global void 69 | open_out_file(const char *name) 70 | { 71 | if (restricted) 72 | error(EXECERR, "file output disabled"); 73 | if (name == NULL) 74 | out_file = STDOUT; 75 | else if ((out_file = fopen(TEMPFILE, "w")) == NULL) 76 | error(EXECERR, "can't create temporary file"); 77 | out_name = name; 78 | } 79 | 80 | global void 81 | save_out_file(void) 82 | { 83 | if (out_name != NULL) { 84 | (void)fclose(out_file); 85 | (void)remove(out_name); 86 | /* (void)link(TEMPFILE, out_name); (void)unlink(TEMPFILE); */ 87 | (void)rename(TEMPFILE, out_name); 88 | } 89 | } 90 | 91 | global void 92 | close_out_file(void) 93 | { 94 | if (out_name != NULL) { 95 | (void)fclose(out_file); 96 | (void)remove(TEMPFILE); 97 | } 98 | } 99 | 100 | global Cell * 101 | write_value(Cell *value) 102 | { 103 | if (value->c_class == C_CHAR) 104 | PutChar(value->c_char, out_file); 105 | else { 106 | pr_value(out_file, value); 107 | (void)fprintf(out_file, "\n"); 108 | } 109 | return new_susp(e_wr_list, NOCELL); 110 | } 111 | -------------------------------------------------------------------------------- /src/stream.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "stream.h" 3 | #include "error.h" 4 | #include "expr.h" 5 | #include "cons.h" 6 | #include "value.h" 7 | #include "builtin.h" 8 | 9 | #define MAX_STREAMS 20 /* max. no. of streams (checked) */ 10 | #define MAX_FILENAME 100 /* max. len. of file name (checked) */ 11 | #define MAX_INPUTLINE 256 /* max. len. of tty input line (checked) */ 12 | 13 | /* 14 | * Table of open streams, 15 | * so we can close any left open at the end of evaluation. 16 | */ 17 | local FILE *str_table[MAX_STREAMS]; 18 | 19 | local int get_one_char(void); 20 | local void end_stream(FILE *f); 21 | 22 | global Cell * 23 | open_stream(Cell *arg) 24 | { 25 | char filename[MAX_FILENAME]; 26 | FILE **fp; 27 | 28 | if (restricted) 29 | error(EXECERR, "read function disabled"); 30 | 31 | hope2c((Byte *)filename, MAX_FILENAME, arg); 32 | 33 | /* find a free slot in the stream table */ 34 | for (fp = str_table; *fp != NULL; fp++) 35 | if (fp == &str_table[MAX_STREAMS]) 36 | error(EXECERR, "stream table full"); 37 | 38 | /* try to open the file */ 39 | if ((*fp = fopen(filename, "r")) == NULL) 40 | error(EXECERR, "'%s': can't read file", filename); 41 | return new_stream(*fp); 42 | } 43 | 44 | global Cell * 45 | read_stream(Cell *cell) 46 | { 47 | long c; 48 | 49 | c = cell->c_file == stdin ? get_one_char() : GetChar(cell->c_file); 50 | if (c == EOF) { 51 | end_stream(cell->c_file); 52 | return new_cnst(nil); 53 | } 54 | return new_cons(cons, 55 | new_pair(new_char((Char)c), new_stream(cell->c_file))); 56 | } 57 | 58 | local char str_line[MAX_INPUTLINE]; 59 | local const Byte *str_lptr; 60 | 61 | global void 62 | reset_streams(void) 63 | { 64 | FILE **fp; 65 | 66 | str_lptr = (const Byte *)""; 67 | for (fp = str_table; fp != &str_table[MAX_STREAMS]; fp++) 68 | *fp = NULL; 69 | } 70 | 71 | /* 72 | * Line-buffering for standard input, because if not all the input is used, 73 | * we want to discard the rest of the last line input. 74 | */ 75 | local int 76 | get_one_char(void) 77 | { 78 | if (*str_lptr == '\0') { 79 | if (fgets(str_line, sizeof(str_line), stdin) == NULL) { 80 | clearerr(stdin); 81 | return EOF; 82 | } 83 | str_lptr = (const Byte *)str_line; 84 | } 85 | return FetchChar(&str_lptr); 86 | } 87 | 88 | local void 89 | end_stream(FILE *f) 90 | { 91 | FILE **fp; 92 | 93 | if (f != stdin) { 94 | (void)fclose(f); 95 | for (fp = str_table; *fp != f; fp++) 96 | ; 97 | *fp = NULL; 98 | } 99 | } 100 | 101 | global void 102 | close_streams(void) 103 | { 104 | FILE **fp; 105 | 106 | for (fp = str_table; fp != &str_table[MAX_STREAMS]; fp++) 107 | if (*fp != NULL) { 108 | (void)fclose(*fp); 109 | *fp = NULL; 110 | } 111 | } 112 | -------------------------------------------------------------------------------- /src/char.c: -------------------------------------------------------------------------------- 1 | #ifdef UCS 2 | 3 | #include "defs.h" 4 | #include "char.h" 5 | 6 | /* 7 | * The UTF-FSS (aka UTF-2) encoding of UCS, as described in the following 8 | * quote from Ken Thompson's utf-fss.c: 9 | * 10 | * Bits Hex Min Hex Max Byte Sequence in Binary 11 | * 7 00000000 0000007f 0vvvvvvv 12 | * 11 00000080 000007FF 110vvvvv 10vvvvvv 13 | * 16 00000800 0000FFFF 1110vvvv 10vvvvvv 10vvvvvv 14 | * 21 00010000 001FFFFF 11110vvv 10vvvvvv 10vvvvvv 10vvvvvv 15 | * 26 00200000 03FFFFFF 111110vv 10vvvvvv 10vvvvvv 10vvvvvv 10vvvvvv 16 | * 31 04000000 7FFFFFFF 1111110v 10vvvvvv 10vvvvvv 10vvvvvv 10vvvvvv 10vvvvvv 17 | * 18 | * The UCS value is just the concatenation of the v bits in the multibyte 19 | * encoding. When there are multiple ways to encode a value, for example 20 | * UCS 0, only the shortest encoding is legal. 21 | */ 22 | 23 | /* invalid sequences are ignored */ 24 | 25 | global Char 26 | FetchChar(const Byte **p) 27 | { 28 | Char c; 29 | int extras; 30 | unsigned bit; 31 | 32 | extras = 0; 33 | c = *(*p)++; 34 | if ((c & 0x80) == 0) /* ASCII character */ 35 | return c; 36 | /* how many extra bytes? */ 37 | extras = 1; 38 | for (bit = 0x20; (c & bit) != 0; bit >>= 1) 39 | extras++; 40 | if (bit > 0) 41 | c &= bit-1; 42 | while (extras-- > 0) 43 | c = (c<<6) | *(*p)++&0x3f; 44 | return c; 45 | } 46 | 47 | global void 48 | BackChar(const Byte **p) 49 | { 50 | while ((*--*p & 0xc0) == 0x80) 51 | ; 52 | } 53 | 54 | global long 55 | GetChar(FILE *f) 56 | { 57 | int c; 58 | Char wc; 59 | int extras; 60 | unsigned bit; 61 | 62 | extras = 0; 63 | while ((c = getc(f)) != EOF) { 64 | if ((c & 0x80) == 0) /* ASCII character */ 65 | return (long)c; 66 | if ((c & 0xc0) == 0x80) { /* tail character */ 67 | if (extras > 0) { /* in the right place */ 68 | wc = (wc<<6) | c&0x3f; 69 | if (--extras == 0) 70 | return (long)wc; 71 | } 72 | } else { /* head of sequence */ 73 | /* how many extra bytes? */ 74 | wc = (Char)c; 75 | extras = 1; 76 | for (bit = 0x20; (wc & bit) != 0; bit >>= 1) 77 | extras++; 78 | if (bit > 0) 79 | wc &= bit-1; 80 | } 81 | } 82 | return EOF; 83 | } 84 | 85 | global void 86 | PutChar(Char *wc, FILE *f) 87 | { 88 | Char tmp; 89 | int extras; 90 | 91 | if ((wc & ~0x7f) == 0) { 92 | (void)putc(wc, f); 93 | return; 94 | } 95 | /* how many extra bytes are required? */ 96 | extras = 1; 97 | for (tmp = wc >> 11; tmp != 0; tmp >>= 5) 98 | extras++; 99 | /* put header Byte */ 100 | (void)putc(0xff&(0x7f80 >> extras) | (wc >> (extras*6)), f); 101 | /* put tail bytes */ 102 | while (extras-- != 0) 103 | (void)putc(0x80|0x3f&(wc >> (extras*6)), f); 104 | } 105 | #endif /* UCS */ 106 | -------------------------------------------------------------------------------- /doc/Makefile.in: -------------------------------------------------------------------------------- 1 | SHELL = /bin/sh 2 | 3 | prefix = @prefix@ 4 | AWK = @AWK@ 5 | INSTALL = @INSTALL@ 6 | docdir = @HOPEDOC@ 7 | srcdir = @HOPEDOC@/src 8 | 9 | htmldir = $(docdir) 10 | 11 | tex_srcs = ref_man.tex 12 | src_srcs = hope_tut.src examples.src 13 | Roger = Roger Bailey <rb@doc.ic.ac.uk> 14 | Ross = Ross Paterson <ross@soi.city.ac.uk> 15 | 16 | made_tex = op.tex Standard.tex 17 | 18 | # It is also possible to generate HTML versions: you'll need Latex2html, 19 | # c.f. http://cbl.leeds.ac.uk/nikos/tex2html/doc/latex2html/latex2html.html 20 | L2H_FLAGS = -info '' -no_navigation # -dont_include latexonly 21 | LATEX2HTML = latex2html $(L2H_FLAGS) 22 | 23 | tex_made = $(src_srcs:.src=.tex) 24 | tex_files = $(tex_srcs) $(tex_made) 25 | dirs = $(tex_files:%.tex=%) 26 | html = $(tex_files:%.tex=%/index.html) 27 | docs = $(tex_files:%.tex=%.dvi) $(tex_files:%.tex=%.ps) 28 | 29 | .SUFFIXES: 30 | .SUFFIXES: .ps .dvi .tex .src 31 | 32 | %.tex: %.src 33 | $(AWK) -f verb.nawk $*.src >$@ 34 | 35 | %.dvi: %.tex 36 | latex $* 37 | if grep -s '^LaTeX Warning: Citation .* undefined' $*.log;\ 38 | then bibtex $*; latex $*;\ 39 | fi 40 | if grep -s '^LaTeX Warning: Label(s) may have changed' $*.log;\ 41 | then latex $*;\ 42 | fi 43 | 44 | %.ps: %.dvi 45 | dvips $* -o $@ 46 | 47 | docs: $(docs) 48 | 49 | html: $(html) 50 | 51 | all: docs html 52 | 53 | ref_man.dvi: $(made_tex) hope.bib 54 | 55 | # Latex files derived from C and Hope sources 56 | 57 | op.tex: ../src/op.h 58 | sed -n 's/^#define[ ][ ]*\(M[IA][NX]PREC\)[ ][ ]*\([0-9]*\).*/\\newcommand{\\\1}{\2}/p' ../src/op.h >$@ 59 | 60 | ../src/op.h: 61 | cd ../src; make op.h 62 | 63 | # can't use echo here as BSD and SYSV versions treat backslashes differently. 64 | Standard.tex: ../lib/Standard.hop h2l.awk 65 | ../sh/header ../lib/Standard.hop | $(AWK) -f h2l.awk | expand >$@ 66 | 67 | # HTML versions of the documents 68 | 69 | hope_tut/index.html: hope_tut.tex hope_tut.dvi 70 | rm -rf hope_tut 71 | $(LATEX2HTML) -address '$(Roger)' hope_tut.tex 72 | 73 | ref_man/index.html: ref_man.dvi 74 | rm -rf ref_man 75 | $(LATEX2HTML) -address '$(Ross)' ref_man.tex 76 | 77 | examples/index.html: examples.tex examples.dvi 78 | rm -rf examples 79 | $(LATEX2HTML) -address '$(Ross)' examples.tex 80 | 81 | install: all 82 | $(INSTALL) -d $(docdir) 83 | for file in $(docs); do gzip <$$file >$(docdir)/$$file.gz; done 84 | $(INSTALL) -d $(htmldir) 85 | for dir in $(dirs); do rm -rf $(htmldir)/$$dir; done 86 | cp -r $(dirs) $(htmldir) 87 | # cp $(src_srcs) $(srcdir) 88 | 89 | clean: 90 | rm -f *.blg *.dvi *.log *.ps *.pdf 91 | rm -f $(made_tex) 92 | rm -rf $(dirs) 93 | 94 | distclean: 95 | rm -f *.aux *.bbl *.glo *.idx *.lof *.lot *.toc 96 | 97 | clobber: clean 98 | rm -f *.aux *.bbl *.glo *.idx *.lof *.lot *.toc 99 | rm -f $(tex_made) 100 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | # Generated automatically from Makefile.in by configure. 2 | SHELL = /bin/sh 3 | 4 | prefix = /usr/local 5 | AWK = mawk 6 | INSTALL = /usr/bin/install -c 7 | docdir = ${prefix}/share/doc/hope 8 | srcdir = ${prefix}/share/doc/hope/src 9 | 10 | htmldir = $(docdir) 11 | 12 | tex_srcs = ref_man.tex 13 | src_srcs = hope_tut.src examples.src 14 | Roger = Roger Bailey <rb@doc.ic.ac.uk> 15 | Ross = Ross Paterson <ross@soi.city.ac.uk> 16 | 17 | made_tex = op.tex Standard.tex 18 | 19 | # It is also possible to generate HTML versions: you'll need Latex2html, 20 | # c.f. http://cbl.leeds.ac.uk/nikos/tex2html/doc/latex2html/latex2html.html 21 | L2H_FLAGS = -info '' -no_navigation # -dont_include latexonly 22 | LATEX2HTML = latex2html $(L2H_FLAGS) 23 | 24 | tex_made = $(src_srcs:.src=.tex) 25 | tex_files = $(tex_srcs) $(tex_made) 26 | dirs = $(tex_files:%.tex=%) 27 | html = $(tex_files:%.tex=%/index.html) 28 | docs = $(tex_files:%.tex=%.dvi) $(tex_files:%.tex=%.ps) 29 | 30 | .SUFFIXES: 31 | .SUFFIXES: .ps .dvi .tex .src 32 | 33 | %.tex: %.src 34 | $(AWK) -f verb.nawk $*.src >$@ 35 | 36 | %.dvi: %.tex 37 | latex $* 38 | if grep -s '^LaTeX Warning: Citation .* undefined' $*.log;\ 39 | then bibtex $*; latex $*;\ 40 | fi 41 | if grep -s '^LaTeX Warning: Label(s) may have changed' $*.log;\ 42 | then latex $*;\ 43 | fi 44 | 45 | %.ps: %.dvi 46 | dvips $* -o $@ 47 | 48 | docs: $(docs) 49 | 50 | html: $(html) 51 | 52 | all: docs html 53 | 54 | ref_man.dvi: $(made_tex) hope.bib 55 | 56 | # Latex files derived from C and Hope sources 57 | 58 | op.tex: ../src/op.h 59 | sed -n 's/^#define[ ][ ]*\(M[IA][NX]PREC\)[ ][ ]*\([0-9]*\).*/\\newcommand{\\\1}{\2}/p' ../src/op.h >$@ 60 | 61 | ../src/op.h: 62 | cd ../src; make op.h 63 | 64 | # can't use echo here as BSD and SYSV versions treat backslashes differently. 65 | Standard.tex: ../lib/Standard.hop h2l.awk 66 | ../sh/header ../lib/Standard.hop | $(AWK) -f h2l.awk | expand >$@ 67 | 68 | # HTML versions of the documents 69 | 70 | hope_tut/index.html: hope_tut.tex hope_tut.dvi 71 | rm -rf hope_tut 72 | $(LATEX2HTML) -address '$(Roger)' hope_tut.tex 73 | 74 | ref_man/index.html: ref_man.dvi 75 | rm -rf ref_man 76 | $(LATEX2HTML) -address '$(Ross)' ref_man.tex 77 | 78 | examples/index.html: examples.tex examples.dvi 79 | rm -rf examples 80 | $(LATEX2HTML) -address '$(Ross)' examples.tex 81 | 82 | install: all 83 | $(INSTALL) -d $(docdir) 84 | for file in $(docs); do gzip <$$file >$(docdir)/$$file.gz; done 85 | $(INSTALL) -d $(htmldir) 86 | for dir in $(dirs); do rm -rf $(htmldir)/$$dir; done 87 | cp -r $(dirs) $(htmldir) 88 | # cp $(src_srcs) $(srcdir) 89 | 90 | clean: 91 | rm -f *.blg *.dvi *.log *.ps *.pdf 92 | rm -f $(made_tex) 93 | rm -rf $(dirs) 94 | 95 | distclean: 96 | rm -f *.aux *.bbl *.glo *.idx *.lof *.lot *.toc 97 | 98 | clobber: clean 99 | rm -f *.aux *.bbl *.glo *.idx *.lof *.lot *.toc 100 | rm -f $(tex_made) 101 | -------------------------------------------------------------------------------- /lib/lists.hop: -------------------------------------------------------------------------------- 1 | ! more list utility functions 2 | 3 | uses list; 4 | 5 | dec member : alpha # list alpha -> bool; 6 | !!! member(x, l) <= true iff x occurs in the list l 7 | 8 | dec many : alpha -> list alpha; 9 | !!! many x <= an infinite list of x's 10 | 11 | dec repeat : num # alpha -> list alpha; 12 | !!! repeat(n, x) <= a list of n x's. 13 | 14 | infix -- : 4; 15 | dec -- : list alpha # list alpha -> list alpha; 16 | !!! l1 -- l2 <= l1 with an occurrence (if any) of each element in l2 removed 17 | 18 | dec head : list alpha -> alpha; 19 | !!! head [x1,...,xn] <= x1; 20 | 21 | dec tail : list alpha -> list alpha; 22 | !!! tail [x1,...,xn] <= [x2,...,xn]; 23 | 24 | dec last : list alpha -> alpha; 25 | !!! last [x1,...,xn] <= xn; 26 | 27 | dec init : list alpha -> list alpha; 28 | !!! init [x1,...,xn] <= [x1,...,xn-1]; 29 | 30 | dec rotl : list alpha -> list alpha; 31 | !!! rotl [x1,...,xn] <= [x2,...,xn,x1]; 32 | 33 | dec rotr : list alpha -> list alpha; 34 | !!! rotr [x1,...,xn] <= [xn,x1,...,xn-1]; 35 | 36 | dec tails : list alpha -> list(list alpha); 37 | !!! tails [x1,...,xn] <= [[x1,...,xn], [x2,...,xn], ..., [xn], []]; 38 | 39 | dec inits : list alpha -> list(list alpha); 40 | !!! inits [x1,...,xn] <= [[], [x1], ..., [x1,...,xn-1], [x1,...,xn]]; 41 | 42 | dec scan : beta # (beta # alpha -> beta) -> list alpha -> list beta; 43 | !!! scan(c, f) l <= map (foldl(c, f)) (inits l); 44 | 45 | dec concat : list(list alpha) -> list alpha; 46 | !!! concat [l1,...,ln] <= l1 <> ... <> ln; 47 | 48 | dec sum, product : list num -> num; 49 | !!! sum [x1,...,xn] <= x1 + ... + xn; 50 | !!! product [x1,...,xn] <= x1 * ... * xn; 51 | 52 | dec any, all : list bool -> bool; 53 | !!! any [x1,...,xn] <= x1 or ... or xn; 54 | !!! all [x1,...,xn] <= x1 and ... and xn; 55 | 56 | private; 57 | 58 | --- member(x, l) <= any (map (=x) l); 59 | 60 | --- many x <= xs whererec xs == x::xs; 61 | 62 | --- repeat(n, x) <= front(n, many x); 63 | 64 | dec remove : alpha # list alpha -> list alpha; 65 | --- remove(x, ys) <= filter (/= x) ys; 66 | 67 | --- xs -- ys <= foldr(xs, remove) ys; 68 | 69 | --- head(x::xs) <= x; 70 | 71 | --- tail(x::xs) <= xs; 72 | 73 | --- last [x] <= x; 74 | --- last(x::xs) <= last xs ; 75 | 76 | --- init [x] <= []; 77 | --- init(x::xs) <= x::init xs; 78 | 79 | --- rotl [] <= []; 80 | --- rotl(x::xs) <= xs <> [x]; 81 | 82 | --- rotr [] <= []; 83 | --- rotr xs <= last xs :: init xs; 84 | 85 | dec proper_tails : list alpha -> list(list alpha); 86 | --- proper_tails [] <= []; 87 | --- proper_tails(x::xs) <= tails xs; 88 | 89 | --- tails l <= l::proper_tails l; 90 | 91 | --- inits <= ([]::) o (lambda [] => [] | x::xs => map (x::) (inits xs)); 92 | 93 | --- scan(c, f) <= (c::) o (lambda [] => [] | x::xs => scan(f(c, x), f) xs); 94 | 95 | --- concat <= foldr([], (<>)); 96 | 97 | --- sum <= foldr(0, (+)); 98 | 99 | --- product <= foldr(1, (*)); 100 | 101 | --- any <= foldr(false, (or)); 102 | 103 | --- all <= foldr(true, (and)); 104 | -------------------------------------------------------------------------------- /src/compare.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "compare.h" 3 | #include "expr.h" 4 | #include "cons.h" 5 | #include "cases.h" 6 | #include "value.h" 7 | #include "path.h" 8 | #include "error.h" 9 | 10 | /* 11 | * Comparisons 12 | * 13 | * This is all complicated by the fact that comparisons are done lazily. 14 | */ 15 | 16 | local Expr *e_cmp, *e_cmppair; 17 | local Cons *c_less, *c_equal, *c_greater; 18 | 19 | local Cell *compare(Cell *arg); 20 | local Cons *cmp_args(Cell *first, Cell *second); 21 | 22 | /* 23 | * Set up comparison code 24 | * Call after reading standard module. 25 | */ 26 | global void 27 | init_cmps(void) 28 | { 29 | Func *fn; 30 | 31 | /* 32 | * The following weird structure causes the 2 arguments of cmp 33 | * to be unrolled. 34 | * If they are functions, and try to get their arguments, the 35 | * routine chk_argument() in interpret.c will detect this structure 36 | * and report an error. Yes, we're talking major kludge, so be 37 | * careful about changing it. 38 | */ 39 | e_cmp = apply_expr(dir_expr(p_push(P_LEFT, p_new())), 40 | apply_expr(dir_expr(p_push(P_RIGHT, p_new())), 41 | builtin_expr(compare))); 42 | fn = fn_lookup(newstring("compare")); 43 | ASSERT( fn != NULL ); 44 | fn->f_code = success(e_cmp, 0); 45 | fn->f_arity = 1; 46 | fn->f_branch = NULL; 47 | 48 | fn = fn_lookup(newstring("cmp_pair")); 49 | ASSERT( fn != NULL ); 50 | e_cmppair = fn->f_code->uc_body; 51 | 52 | c_less = cons_lookup(newstring("LESS")); 53 | c_equal = cons_lookup(newstring("EQUAL")); 54 | c_greater = cons_lookup(newstring("GREATER")); 55 | ASSERT( c_less != NULL ); 56 | ASSERT( c_equal != NULL ); 57 | ASSERT( c_greater != NULL ); 58 | } 59 | 60 | /* 61 | * Called by the the built-in function "compare", to compare two values. 62 | * Comparison of functions should be excluded by the type-checker. 63 | * For now, a kludge called chk_argument() in the interpreter does it. 64 | */ 65 | local Cell * 66 | compare(Cell *arg) 67 | { 68 | switch (arg->c_left->c_class) { 69 | case C_NUM or C_CHAR or C_CONST: 70 | return new_cnst(cmp_args(arg->c_left, arg->c_right)); 71 | when C_CONS: 72 | return arg->c_left->c_cons == arg->c_right->c_cons ? 73 | new_susp(e_cmp, 74 | new_pair(new_pair(arg->c_left->c_arg, 75 | arg->c_right->c_arg), 76 | NOCELL)) : 77 | new_cnst(cmp_args(arg->c_left, arg->c_right)); 78 | when C_PAIR: 79 | return new_susp(e_cmppair, new_pair(arg, NOCELL)); 80 | otherwise: 81 | NOT_REACHED; 82 | } 83 | } 84 | 85 | local Cons * 86 | cmp_args(Cell *first, Cell *second) 87 | { 88 | switch (first->c_class) { 89 | case C_NUM: 90 | return first->c_num == second->c_num ? c_equal : 91 | first->c_num < second->c_num ? 92 | c_less : c_greater; 93 | when C_CHAR: 94 | return first->c_char == second->c_char ? c_equal : 95 | first->c_char < second->c_char ? 96 | c_less : c_greater; 97 | when C_CONST: 98 | return first->c_cons == second->c_cons ? c_equal : 99 | first->c_cons->c_index < second->c_cons->c_index ? 100 | c_less : c_greater; 101 | when C_CONS: 102 | return first->c_cons->c_index < second->c_cons->c_index ? 103 | c_less : c_greater; 104 | otherwise: 105 | NOT_REACHED; 106 | } 107 | } 108 | -------------------------------------------------------------------------------- /src/functor_type.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "functor_type.h" 3 | #include "deftype.h" 4 | #include "type_value.h" 5 | #include "error.h" 6 | 7 | /* 8 | * Generate types of 'functors'. 9 | */ 10 | 11 | local int num_tvars_in(TypeList *varlist); 12 | 13 | local Cell *fold_typelist(TypeList *varlist, Cell **targ, Cell *finish, 14 | Cell *(*fn)(Type *head, Cell *tail, Cell **targ)); 15 | 16 | local Cell *result_domain(Type *head, Cell *tail, Cell **targ); 17 | local Cell *result_range(Type *head, Cell *tail, Cell **targ); 18 | local Cell *tupled_args(Type *head, Cell *tail, Cell **targ); 19 | local Cell *curried_args(Type *head, Cell *tail, Cell **targ); 20 | 21 | local Cell *functor_arg(Type *tvar, Cell **targ); 22 | 23 | global Cell * 24 | functor_type(DefType *dt) 25 | { 26 | int ntvars; 27 | int i; 28 | Cell *result_type; 29 | Cell *type_arg[MAX_TVARS_IN_TYPE]; 30 | 31 | ntvars = num_tvars_in(dt->dt_varlist); 32 | for (i = 0; i < ntvars; i++) 33 | type_arg[i] = new_tvar(); 34 | 35 | result_type = new_func_type( 36 | new_tcons(dt, 37 | fold_typelist(dt->dt_varlist, type_arg, 38 | NOCELL, result_domain)), 39 | new_tcons(dt, 40 | fold_typelist(dt->dt_varlist, type_arg, 41 | NOCELL, result_range))); 42 | return expand_type( 43 | dt->dt_tupled ? 44 | new_func_type(fold_typelist(dt->dt_varlist, type_arg, 45 | NOCELL, tupled_args), 46 | result_type) : 47 | fold_typelist(dt->dt_varlist, type_arg, 48 | result_type, curried_args)); 49 | } 50 | 51 | local int 52 | num_tvars_in(TypeList *varlist) 53 | { 54 | Type *head; 55 | int ntvars; 56 | 57 | ntvars = 0; 58 | for ( ; varlist != NULL; varlist = varlist->ty_tail) { 59 | head = varlist->ty_head; 60 | ntvars += (head->ty_pos ? 1 : 2) * (head->ty_neg ? 1 : 2); 61 | } 62 | return ntvars; 63 | } 64 | 65 | /* 66 | * NB: functor argument types must be generated in order left-to-right 67 | * so that they get the right variable numbers. 68 | */ 69 | 70 | local Cell * 71 | fold_typelist(TypeList *varlist, Cell **targ, Cell *finish, 72 | Cell *(*fn)(Type *head, Cell *tail, Cell **targ)) 73 | { 74 | Type *head; 75 | 76 | if (varlist == NULL) 77 | return finish; 78 | head = varlist->ty_head; 79 | return (*fn)(head, 80 | fold_typelist( 81 | varlist->ty_tail, 82 | targ + (head->ty_pos ? 1 : 2) * (head->ty_neg ? 1 : 2), 83 | finish, 84 | fn), 85 | targ); 86 | } 87 | 88 | local Cell * 89 | result_domain(Type *head, Cell *tail_type, Cell **targ) 90 | { 91 | return new_tlist(*targ, tail_type); 92 | } 93 | 94 | local Cell * 95 | result_range(Type *head, Cell *tail_type, Cell **targ) 96 | { 97 | return new_tlist(*(targ + (head->ty_pos && head->ty_neg ? 0 : 1)), 98 | tail_type); 99 | } 100 | 101 | local Cell * 102 | tupled_args(Type *head, Cell *tail_type, Cell **targ) 103 | { 104 | Cell *head_type; 105 | 106 | head_type = functor_arg(head, targ); 107 | return tail_type == NULL ? head_type : 108 | new_prod_type(head_type, tail_type); 109 | } 110 | 111 | local Cell * 112 | curried_args(Type *head, Cell *tail_type, Cell **targ) 113 | { 114 | return new_func_type(functor_arg(head, targ), tail_type); 115 | } 116 | 117 | local Cell * 118 | functor_arg(Type *tvar, Cell **targ) 119 | { 120 | Cell *domain_type, *range_type; 121 | 122 | if (tvar->ty_pos) { 123 | if (tvar->ty_neg) 124 | domain_type = range_type = *targ; 125 | else { 126 | domain_type = *targ; 127 | range_type = *(targ+1); 128 | } 129 | } else { 130 | if (tvar->ty_neg) { 131 | domain_type = *(targ+1); 132 | range_type = *targ; 133 | } 134 | else { 135 | domain_type = *(targ+2); 136 | range_type = *(targ+3); 137 | } 138 | } 139 | return new_func_type(domain_type, range_type); 140 | } 141 | -------------------------------------------------------------------------------- /src/cases.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "cases.h" 3 | #include "expr.h" 4 | #include "char_array.h" 5 | #include "memory.h" 6 | 7 | local LCase *copy_lcase(LCase *old); 8 | local UCase *new_reference(UCase *node); 9 | 10 | /* 11 | * Upper case expressions. 12 | */ 13 | 14 | global UCase * 15 | ucase(int level, Path path, LCase *cases) 16 | { 17 | UCase *code; 18 | 19 | code = NEW(UCase); 20 | code->uc_class = UC_CASE; 21 | code->uc_references = 1; 22 | code->uc_level = level; 23 | code->uc_path = path; 24 | code->uc_cases = cases; 25 | return code; 26 | } 27 | 28 | global UCase * 29 | f_nomatch(Func *defun) 30 | { 31 | UCase *code; 32 | 33 | code = NEW(UCase); 34 | code->uc_class = UC_F_NOMATCH; 35 | code->uc_defun = defun; 36 | return code; 37 | } 38 | 39 | global UCase * 40 | l_nomatch(Expr *who) 41 | { 42 | UCase *code; 43 | 44 | code = NEW(UCase); 45 | code->uc_class = UC_L_NOMATCH; 46 | code->uc_who = who; 47 | return code; 48 | } 49 | 50 | global UCase * 51 | success(Expr *body, int size) 52 | { 53 | UCase *code; 54 | 55 | code = NEW(UCase); 56 | code->uc_class = UC_SUCCESS; 57 | code->uc_body = body; 58 | code->uc_size = size; 59 | return code; 60 | } 61 | 62 | global UCase * 63 | strict(Expr *real) 64 | { 65 | UCase *code; 66 | 67 | code = NEW(UCase); 68 | code->uc_class = UC_STRICT; 69 | code->uc_real = real; 70 | return code; 71 | } 72 | 73 | global UCase * 74 | copy_ucase(UCase *old) 75 | { 76 | UCase *new; 77 | 78 | new = NEW(UCase); 79 | new->uc_class = old->uc_class; 80 | switch (old->uc_class) { 81 | case UC_CASE: 82 | new->uc_references = 1; 83 | new->uc_level = old->uc_level; 84 | new->uc_path = old->uc_path; 85 | new->uc_cases = copy_lcase(old->uc_cases); 86 | when UC_F_NOMATCH: 87 | new->uc_defun = old->uc_defun; 88 | when UC_L_NOMATCH: 89 | new->uc_who = old->uc_who; 90 | when UC_SUCCESS: 91 | new->uc_body = old->uc_body; 92 | new->uc_size = old->uc_size; 93 | when UC_STRICT: 94 | new->uc_real = old->uc_real; 95 | otherwise: 96 | NOT_REACHED; 97 | } 98 | return new; 99 | } 100 | 101 | /* 102 | * Lower case expressions. 103 | */ 104 | 105 | global LCase * 106 | alg_case(Natural arity, UCase *def) 107 | { 108 | LCase *lcase; 109 | Natural i; 110 | 111 | lcase = NEW(LCase); 112 | lcase->lc_class = LC_ALGEBRAIC; 113 | lcase->lc_arity = arity; 114 | lcase->lc_limbs = NEWARRAY(UCase *, arity); 115 | for (i = 0; i < arity; i++) 116 | lcase->lc_limbs[i] = def; 117 | return lcase; 118 | } 119 | 120 | global LCase * 121 | num_case(UCase *def) 122 | { 123 | LCase *lcase; 124 | 125 | lcase = alg_case((Natural)3, def); 126 | lcase->lc_class = LC_NUMERIC; 127 | return lcase; 128 | } 129 | 130 | global LCase * 131 | char_case(UCase *def) 132 | { 133 | LCase *lcase; 134 | 135 | lcase = NEW(LCase); 136 | lcase->lc_class = LC_CHARACTER; 137 | lcase->lc_arity = 256; /* number of characters */ 138 | lcase->lc_c_limbs = ca_new(def); 139 | return lcase; 140 | } 141 | 142 | local LCase * 143 | copy_lcase(LCase *old) 144 | { 145 | LCase *new; 146 | int i; 147 | 148 | new = NEW(LCase); 149 | new->lc_class = old->lc_class; 150 | new->lc_arity = old->lc_arity; 151 | switch (old->lc_class) { 152 | case LC_ALGEBRAIC or LC_NUMERIC: 153 | new->lc_limbs = NEWARRAY(UCase *, old->lc_arity); 154 | for (i = 0; i < old->lc_arity; i++) 155 | new->lc_limbs[i] = new_reference(old->lc_limbs[i]); 156 | when LC_CHARACTER: 157 | new->lc_c_limbs = ca_copy(old->lc_c_limbs); 158 | ca_map(new->lc_c_limbs, new_reference); 159 | otherwise: 160 | NOT_REACHED; 161 | } 162 | return new; 163 | } 164 | 165 | local UCase * 166 | new_reference(UCase *node) 167 | { 168 | if (node->uc_class == UC_CASE) 169 | node->uc_references++; 170 | return node; 171 | } 172 | -------------------------------------------------------------------------------- /src/functors.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "functors.h" 3 | #include "deftype.h" 4 | #include "cons.h" 5 | #include "expr.h" 6 | 7 | /* 8 | * Definition of 'functors'. 9 | */ 10 | 11 | local Expr *expr_of_type(Type *type); 12 | local Expr *expr_of_typelist(TypeList *typelist); 13 | local Expr *multi_apply_expr(Expr *func, TypeList *typelist); 14 | local Expr *pat_of_constr(Cons *cp); 15 | local Expr *body_of_constr(Cons *cp); 16 | 17 | /* 18 | * Identifier STRINGs, different from each other and any real String. 19 | * The are 26 of them, so that's the maximum arity of data constructors. 20 | */ 21 | local String variable[] = { 22 | "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", 23 | "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z" 24 | }; 25 | 26 | global void 27 | def_functor(DefType *dt) 28 | { 29 | Cons *cp; 30 | Expr *lhs; 31 | 32 | if (dt->dt_arity == 0) { 33 | /* 34 | * Nullary type T gives the definition 35 | * --- T x <= x; 36 | */ 37 | def_value( 38 | apply_expr(id_expr(dt->dt_name), 39 | id_expr(variable[0])), 40 | id_expr(variable[0])); 41 | } else if (IsSynType(dt)) { 42 | /* 43 | * A type synonym definition 44 | * type T(a1, ..., an) == t; 45 | * generates a value definition 46 | * --- T(a1, ..., an) <= t; 47 | */ 48 | lhs = dt->dt_tupled ? 49 | apply_expr(id_expr(dt->dt_name), 50 | expr_of_typelist(dt->dt_varlist)) : 51 | multi_apply_expr(id_expr(dt->dt_name), dt->dt_varlist); 52 | def_value(lhs, expr_of_type(dt->dt_type)); 53 | } else { 54 | /* 55 | * A data type definition 56 | * data T(a1, ..., an) == ... ++ c t1 ... tk ++ ...; 57 | * generates value definitions 58 | * --- T(a1, ..., an) (c x1 ... xk) <= 59 | * c (t1 x1) ... (tk xk); 60 | * Similarly for T a1 ... an 61 | */ 62 | for (cp = dt->dt_cons; cp != NULL; cp = cp->c_next) { 63 | lhs = dt->dt_tupled ? 64 | apply_expr(id_expr(dt->dt_name), 65 | expr_of_typelist(dt->dt_varlist)) : 66 | multi_apply_expr(id_expr(dt->dt_name), 67 | dt->dt_varlist); 68 | def_value(apply_expr(lhs, pat_of_constr(cp)), 69 | body_of_constr(cp)); 70 | } 71 | } 72 | fn_local(dt->dt_name)->f_explicit_def = FALSE; 73 | } 74 | 75 | local Expr * 76 | pat_of_constr(Cons *cp) 77 | { 78 | Expr *pat; 79 | int i; 80 | 81 | pat = cons_expr(cp); 82 | for (i = 0; i < cp->c_nargs; i++) 83 | pat = apply_expr(pat, id_expr(variable[i])); 84 | return pat; 85 | } 86 | 87 | local Expr * 88 | body_of_constr(Cons *cp) 89 | { 90 | Expr *body; 91 | int i; 92 | Type *type; 93 | 94 | body = cons_expr(cp); 95 | for (i = 0, type = cp->c_type; 96 | i < cp->c_nargs; 97 | i++, type = type->ty_secondarg) 98 | body = apply_expr(body, 99 | apply_expr(expr_of_type(type->ty_firstarg), 100 | id_expr(variable[i]))); 101 | return body; 102 | } 103 | 104 | local Expr * 105 | expr_of_type(Type *type) 106 | { 107 | return type->ty_class == TY_VAR ? 108 | id_expr(type->ty_var) : 109 | type->ty_class == TY_MU ? 110 | mu_expr(id_expr(type->ty_var), 111 | expr_of_type(type->ty_body)) : 112 | type->ty_deftype->dt_tupled ? 113 | apply_expr(id_expr(type->ty_deftype->dt_name), 114 | expr_of_typelist(type->ty_args)) : 115 | multi_apply_expr(id_expr(type->ty_deftype->dt_name), 116 | type->ty_args); 117 | } 118 | 119 | local Expr * 120 | expr_of_typelist(TypeList *typelist) 121 | { 122 | return typelist->ty_tail == NULL ? expr_of_type(typelist->ty_head) : 123 | pair_expr(expr_of_type(typelist->ty_head), 124 | expr_of_typelist(typelist->ty_tail)); 125 | } 126 | 127 | local Expr * 128 | multi_apply_expr(Expr *func, TypeList *typelist) 129 | { 130 | while (typelist != NULL) { 131 | func = apply_expr(func, expr_of_type(typelist->ty_head)); 132 | typelist = typelist->ty_tail; 133 | } 134 | return func; 135 | } 136 | -------------------------------------------------------------------------------- /src/deftype.h: -------------------------------------------------------------------------------- 1 | #ifndef DEFTYPE_H 2 | #define DEFTYPE_H 3 | 4 | #include "defs.h" 5 | #include "newstring.h" 6 | #include "table.h" 7 | #include "typevar.h" 8 | 9 | /* 10 | * Defined types. 11 | */ 12 | struct _DefType { 13 | TabElt dt_linkage; 14 | char dt_arity; 15 | char dt_syn_depth; /* depth of synonym definitions */ 16 | /* a depth of 0 implies a data type */ 17 | SBool dt_private; /* definition of type is private */ 18 | SBool dt_tupled; 19 | unsigned char dt_index; /* zero for global deftypes */ 20 | /* index+1 for local ones */ 21 | TypeList *dt_varlist; 22 | TypeList *dt_oldvarlist; 23 | union { 24 | Cons *dtu_cons; /* list of constants and constructors */ 25 | Type *dtu_type; /* synonymous type */ 26 | } dt_union; 27 | }; 28 | #define dt_name dt_linkage.t_name 29 | #define dt_next dt_linkage.t_next 30 | #define dt_cons dt_union.dtu_cons 31 | #define dt_type dt_union.dtu_type 32 | 33 | #define IsAbsType(dt) ((dt)->dt_syn_depth == 0 && (dt)->dt_cons == NULL) 34 | #define IsDataType(dt) ((dt)->dt_syn_depth == 0 && (dt)->dt_cons != NULL) 35 | #define IsSynType(dt) ((dt)->dt_syn_depth > 0) 36 | 37 | extern void dt_declare(DefType *dt); 38 | extern DefType *dt_lookup(String name); 39 | extern DefType *dt_local(String name); 40 | extern void fix_synonyms(void); 41 | 42 | extern void start_dec_type(void); 43 | extern DefType *new_deftype(String name, Bool tupled, TypeList *vars); 44 | 45 | extern void abstype(DefType *deftype); 46 | extern void type_syn(DefType *deftype, Type *type); 47 | extern void decl_type(DefType *deftype, Cons *conslist); 48 | 49 | extern TVar alpha; 50 | extern DefType *product, *function, *list, *num, *truval, *character; 51 | 52 | /* 53 | * Types 54 | */ 55 | 56 | /* maximum depth of mu quantifiers in a type (not checked) */ 57 | #define MAX_MU_DEPTH 8 58 | /* maximum depth of type synonyms (checked) */ 59 | #define MAX_SYN_DEPTH 50 60 | 61 | #define MAX_TVARS_IN_TYPE 40 /* (checked) */ 62 | 63 | struct _TypeList { 64 | Type *ty_head; 65 | TypeList *ty_tail; 66 | }; 67 | 68 | typedef enum { 69 | TY_VAR, /* type variable */ 70 | TY_CONS, /* type constructor applied to zero or more types */ 71 | TY_MU /* recursive type */ 72 | } TypeClass; 73 | 74 | struct _Type { 75 | char ty_class; /* small TypeClass */ 76 | SBool ty_misc_bool; /* for CONS */ 77 | union { 78 | struct { 79 | TVar tyu_var; 80 | SBool tyu_mu_bound; /* bound by a mu */ 81 | unsigned char tyu_index; 82 | SBool tyu_pos; /* used positively */ 83 | SBool tyu_neg; /* used negatively */ 84 | } tyu_v; 85 | struct { 86 | DefType *tyu_deftype; 87 | TypeList *tyu_args; 88 | } tyu_def; 89 | struct { 90 | TVar tyu_muvar; 91 | Type *tyu_body; 92 | } tyu_mu; 93 | } ty_union; 94 | }; 95 | #define ty_tupled ty_misc_bool 96 | #define ty_var ty_union.tyu_v.tyu_var 97 | #define ty_mu_bound ty_union.tyu_v.tyu_mu_bound 98 | #define ty_index ty_union.tyu_v.tyu_index 99 | #define ty_neg ty_union.tyu_v.tyu_neg 100 | #define ty_pos ty_union.tyu_v.tyu_pos 101 | #define ty_deftype ty_union.tyu_def.tyu_deftype 102 | #define ty_args ty_union.tyu_def.tyu_args 103 | #define ty_firstarg ty_union.tyu_def.tyu_args->ty_head 104 | #define ty_secondarg ty_union.tyu_def.tyu_args->ty_tail->ty_head 105 | #define ty_muvar ty_union.tyu_mu.tyu_muvar 106 | #define ty_body ty_union.tyu_mu.tyu_body 107 | 108 | /* 109 | * ty_index: 110 | * If a type variable is mu-bound, a de Bruijn number 111 | * Otherwise: 112 | * If in a type definition, the parameter index 113 | * If in a value declaration, a variable number 114 | */ 115 | 116 | extern Type *new_type(String ident, Bool tupled, TypeList *args); 117 | extern Type *new_tv(TVar tvar); 118 | extern Type *def_type(DefType *dt, TypeList *args); 119 | extern Type *pair_type(Type *type1, Type *type2); 120 | extern Type *func_type(Type *type1, Type *type2); 121 | extern TypeList *cons_type(Type *type, TypeList *typelist); 122 | extern void enter_mu_tv(String ident); 123 | extern Type *mu_type(Type *body); 124 | 125 | extern void remember_type(DefType *dt); 126 | extern void check_type_defs(void); 127 | 128 | /* 129 | * Types qualified by a list of type constructors, 130 | * for use in value declarations. 131 | */ 132 | 133 | struct _QType { 134 | unsigned char qt_ntvars; /* no. of type variables in type */ 135 | Type *qt_type; 136 | }; 137 | 138 | extern QType *qualified_type(Type *type); 139 | 140 | #endif 141 | -------------------------------------------------------------------------------- /src/pr_ty_value.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Printing of inferred types. 3 | */ 4 | 5 | #include "defs.h" 6 | #include "pr_ty_value.h" 7 | #include "typevar.h" 8 | #include "deftype.h" 9 | #include "type_value.h" 10 | #include "op.h" 11 | #include "print.h" 12 | #include "names.h" 13 | #include "error.h" 14 | 15 | local void pr_c_ty_value(FILE *f, Cell *type, int context); 16 | local int n_ty_precedence(Cell *type); 17 | 18 | local Bool occurs(Cell *type1, Cell *type2); 19 | 20 | /* number of known type variables (including mu's) */ 21 | local int var_count; 22 | 23 | global void 24 | init_pr_ty_value(void) 25 | { 26 | var_count = 0; 27 | } 28 | 29 | global void 30 | pr_ty_value(FILE *f, Cell *type) 31 | { 32 | pr_c_ty_value(f, type, PREC_BODY); 33 | } 34 | 35 | /* 36 | * Print a type. 37 | * The occurs check for mu-types makes this quadratic, but I can't 38 | * think of anything better (and maybe it's not too bad). 39 | */ 40 | local void 41 | pr_c_ty_value(FILE *f, Cell *type, int context) 42 | { 43 | Op *op; 44 | int prec; 45 | Bool is_mu; 46 | DefType *tcons; 47 | Cell *targ; 48 | 49 | type = deref(type); 50 | is_mu = type->c_class == C_VOID || occurs(type, type); 51 | prec = is_mu ? PREC_MU : n_ty_precedence(type); 52 | 53 | if (prec < context) 54 | (void)fprintf(f, "("); 55 | 56 | if (is_mu) { 57 | var_count++; 58 | type->c_varno = var_count; 59 | (void)fprintf(f, "%s ", n_mu); 60 | tv_print(f, (Natural)(type->c_varno - 1)); 61 | (void)fprintf(f, " %s ", n_gives); 62 | } 63 | 64 | switch (type->c_class) { 65 | case C_TVAR: 66 | if (type->c_varno == 0) { 67 | var_count++; 68 | type->c_varno = var_count; 69 | } 70 | tv_print(f, (Natural)(type->c_varno - 1)); 71 | when C_VOID: 72 | tv_print(f, (Natural)(type->c_varno - 1)); 73 | when C_TCONS: 74 | ASSERT( type->c_abbr->c_class == C_TSUB ); 75 | tcons = type->c_abbr->c_tcons; 76 | targ = type->c_abbr->c_targ; 77 | ASSERT( tcons->dt_arity == 0 || targ->c_class == C_TLIST ); 78 | /* mark it as a VAR in case we encounter it recursively */ 79 | type->c_class = C_TVAR; 80 | if (tcons->dt_arity == 2 && tcons->dt_tupled && 81 | (op = op_lookup(tcons->dt_name)) != NULL) { 82 | /* infix */ 83 | pr_c_ty_value(f, targ->c_head, LeftPrec(op)); 84 | (void)fprintf(f, " %s ", tcons->dt_name); 85 | pr_c_ty_value(f, targ->c_tail->c_head, RightPrec(op)); 86 | } else if (tcons->dt_tupled) { 87 | (void)fprintf(f, "%s (", tcons->dt_name); 88 | pr_c_ty_value(f, targ->c_head, PREC_BODY); 89 | for (targ = targ->c_head; 90 | targ != NOCELL; 91 | targ = targ->c_tail) { 92 | ASSERT( targ->c_class == C_TLIST ); 93 | (void)fprintf(f, ", "); 94 | pr_c_ty_value(f, targ->c_head, PREC_BODY); 95 | } 96 | (void)fprintf(f, ")"); 97 | } else { 98 | (void)fprintf(f, "%s", tcons->dt_name); 99 | for ( ; targ != NOCELL; targ = targ->c_tail) { 100 | ASSERT( targ->c_class == C_TLIST ); 101 | (void)fprintf(f, " "); 102 | pr_c_ty_value(f, targ->c_head, PREC_ARG); 103 | } 104 | } 105 | type->c_class = C_TCONS; 106 | otherwise: 107 | NOT_REACHED; 108 | } 109 | 110 | if (prec < context) 111 | (void)fprintf(f, ")"); 112 | } 113 | 114 | /* 115 | * Does type1 occur as a proper sub-type of type2? 116 | * (both are dereferenced.) 117 | */ 118 | local Bool 119 | occurs(Cell *type1, Cell *type2) 120 | { 121 | Cell *arg; 122 | Cell *type; 123 | 124 | if (type2->c_class == C_TCONS) { 125 | /* mark it in case we encounter it recursively */ 126 | type2->c_class = C_VISITED; 127 | for (arg = type2->c_abbr->c_targ; 128 | arg != NOCELL; 129 | arg = arg->c_tail) { 130 | ASSERT( arg->c_class == C_TLIST ); 131 | type = deref(arg->c_head); 132 | if (type1 == type || occurs(type1, type)) { 133 | type2->c_class = C_TCONS; 134 | return TRUE; 135 | } 136 | } 137 | type2->c_class = C_TCONS; 138 | } 139 | return FALSE; 140 | } 141 | 142 | local int 143 | n_ty_precedence(Cell *type) 144 | { 145 | Op *op; 146 | DefType *tcons; 147 | 148 | switch (type->c_class) { 149 | case C_VOID: 150 | return PREC_MU; 151 | case C_TCONS: 152 | tcons = type->c_abbr->c_tcons; 153 | if (tcons->dt_arity == 0) 154 | return PREC_ATOMIC; 155 | if (tcons->dt_arity == 2 && 156 | (op = op_lookup(tcons->dt_name)) != NULL) 157 | return op->op_prec; 158 | return PREC_APPLY; 159 | when C_TVAR: 160 | return PREC_ATOMIC; 161 | otherwise: 162 | NOT_REACHED; 163 | } 164 | } 165 | -------------------------------------------------------------------------------- /src/Makefile.in: -------------------------------------------------------------------------------- 1 | SHELL = /bin/sh 2 | 3 | # stuff from configure: 4 | prefix = @prefix@ 5 | exec_prefix = @exec_prefix@ 6 | 7 | # Fiddlable parameters: 8 | # What the program is called. 9 | name = @PACKAGE@ 10 | # Where to put the executable version. 11 | bindir = @bindir@ 12 | # Small test suite, used by "make check". 13 | testdir = ../test 14 | 15 | # more stuff from configure: 16 | AWK = @AWK@ 17 | CC = @CC@ 18 | CFLAGS = @CFLAGS@ 19 | INSTALL = @INSTALL@ 20 | INSTALL_DATA = @INSTALL_DATA@ 21 | INSTALL_PROGRAM = @INSTALL_PROGRAM@ 22 | LDFLAGS = @LDFLAGS@ 23 | LIBS = @LIBS@ 24 | YACC = @YACC@ 25 | mandir = @mandir@/man1 26 | 27 | # Where the standard modules live. 28 | hopelib = @HOPELIB@ 29 | 30 | c_srcs = bad_rectype.c builtin.c cases.c char.c char_array.c compare.c \ 31 | compile.c deftype.c eval.c expr.c functor_type.c functors.c \ 32 | interpret.c interrupt.c main.c memory.c module.c newstring.c \ 33 | number.c output.c path.c polarity.c pr_expr.c pr_ty_value.c \ 34 | pr_type.c pr_value.c remember_type.c runtime.c set.c source.c \ 35 | stream.c table.c type_check.c type_value.c value.c yylex.c 36 | parser = yyparse 37 | 38 | sources = $(c_srcs) $(parser).y 39 | c_made = $(parser).c 40 | h_made = hopelib.h $(parser).h 41 | other_made = op.sed 42 | tmps = y.output y.tab.y y.tab.h y.tab.c y.tab.o 43 | 44 | assoc = Assoc.sed 45 | mult_op = Mult-op.awk 46 | 47 | cfiles = $(c_srcs) $(c_made) 48 | objects = $(cfiles:.c=.o) 49 | 50 | $(name): $(objects) 51 | $(CC) $(LDFLAGS) -o $@ $(objects) $(LIBS) 52 | 53 | all: $(name) $(name).1 54 | 55 | install: check $(name).1 56 | $(INSTALL) -d $(hopelib) 57 | $(INSTALL_PROGRAM) -s $(name) $(bindir) 58 | $(INSTALL_DATA) $(name).1 $(mandir) 59 | 60 | $(name).1: $(name).1.in 61 | sed -e 's:@hopelib@:$(hopelib):' -e 's:@fullpath@:$(bindir)/$(name):' $(name).1.in >$@ 62 | 63 | cfiles: $(c_made) $(h_made) 64 | 65 | # Miscellaneous derived files 66 | 67 | tags: $(sources) 68 | ctags -tw $(sources) 69 | 70 | # Various levels of safe clean-up: 71 | # distclean - temporary files, object files and executables 72 | # new - generated files specific to an architecture 73 | # clean - all generated files except the main program 74 | # clobber - all generated files 75 | 76 | distclean: cfiles 77 | rm -f *.o core a.out errors 78 | rm -f $(name) 79 | rm -f $(tmps) 80 | 81 | new: 82 | rm -f *.o core a.out errors $(h_made) 83 | rm -f $(name) 84 | 85 | clean: 86 | rm -f *.o core a.out errors tags LOG 87 | rm -f $(h_made) $(c_made) $(other_made) 88 | rm -f $(tmps) 89 | 90 | clobber: clean 91 | rm -f $(name) $(name).1 92 | 93 | # Test a new version of the interpreter, by 94 | # (1) running it on some examples and comparing with the expected output. 95 | # (2) checking all the system modules go through OK. 96 | # If all is well, there will be no output. 97 | 98 | errors: $(name) $(testdir)/*.in $(testdir)/*.out ../lib/* 99 | for file in $(testdir)/*.in;\ 100 | do STEM=`basename $$file .in`;\ 101 | HOPEPATH=../lib nice ./$(name) -f $$file 2>&1 |\ 102 | diff - $(testdir)/$$STEM.out |\ 103 | sed "s/^/$$STEM: /";\ 104 | done >$@ 105 | LC_ALL=C; for file in ../lib/[a-z]*.hop;\ 106 | do HOPEPATH=../lib nice ./$(name) -f $$file 2>&1;\ 107 | done >>$@ 108 | 109 | check: errors 110 | test ! -s errors 111 | 112 | hopelib.h: 113 | echo '#define HOPELIB "$(hopelib)"' >$@ 114 | 115 | # Generate parser from $(parser).y by using one sed file (generated from op.h) 116 | # to replicate all lines mentioning BINARY, and another to give the generated 117 | # tokens the correct associativity. 118 | 119 | # The hiding of yyerrstatus is a hack for Bison: see yyparse.y 120 | 121 | $(parser).h $(parser).c: $(parser).y op.sed $(assoc) 122 | sed -f op.sed $(parser).y | sed -f $(assoc) >y.tab.y 123 | $(YACC) $(YFLAGS) -d y.tab.y 124 | grep -v '^# *line' y.tab.c |\ 125 | sed -e '1s/*malloc(), //' -e 's:^ int yyerrstatus;:/* & */:' >$(parser).c 126 | mv y.tab.h $(parser).h 127 | rm -f y.tab.y y.tab.c 128 | 129 | op.sed: op.h $(mult_op) 130 | $(AWK) -f $(mult_op) op.h >$@ 131 | 132 | # for grammar debugging 133 | 134 | y.output: $(parser).y op.sed $(assoc) 135 | sed -f op.sed $(parser).y | sed -f $(assoc) >y.tab.y 136 | $(YACC) -v y.tab.y 137 | rm -f y.tab.y y.tab.c 138 | 139 | # Generate dependencies of source files on header files. 140 | # Only inclusions of relative file names yield dependencies. 141 | 142 | depend: cfiles 143 | ../sh/makedepend -- $(DEFS) -- $(c_srcs) $(c_made) 144 | 145 | -------------------------------------------------------------------------------- /src/char_array.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "char_array.h" 3 | #include "memory.h" 4 | #include "char.h" 5 | 6 | struct _CharArray { 7 | Natural ca_size; /* no. of indices assigned to */ 8 | SChar *ca_index; /* ordered array of length size */ 9 | ArrayElement *ca_value; /* corresponding array of values */ 10 | ArrayElement ca_default; /* value of the rest */ 11 | }; 12 | 13 | #define MIN_POWER 1 14 | #define MIN_SIZE (1<= MIN_SIZE 20 | * and >= ca_size (the used size). When the array is full, we allocate 21 | * a new array twice as long as the old one, and discard the old array. 22 | * This means an average space wastage of 177%, but tree schemes are 23 | * even worse. This could be ameliorated by free lists, and/or by 24 | * changing the step factor, but that's a bit too tricky for me. 25 | */ 26 | 27 | local Natural ca_lookup(SChar *array, Natural size, Char c); 28 | local void ca_insert(CharArray *array, Char c, ArrayElement x); 29 | 30 | global CharArray * 31 | ca_new(ArrayElement x) 32 | { 33 | CharArray *array; 34 | 35 | array = NEW(CharArray); 36 | array->ca_size = 0; 37 | array->ca_index = NEWARRAY(SChar, MIN_SIZE); 38 | array->ca_value = NEWARRAY(ArrayElement, MIN_SIZE); 39 | array->ca_default = x; 40 | return array; 41 | } 42 | 43 | global CharArray * 44 | ca_copy(CharArray *array) 45 | { 46 | CharArray *new_array; 47 | Natural n; 48 | 49 | new_array = NEW(CharArray); 50 | new_array->ca_size = array->ca_size; 51 | for (n = MIN_SIZE; n < array->ca_size; n *= 2) 52 | ; 53 | new_array->ca_index = NEWARRAY(SChar, n); 54 | new_array->ca_value = NEWARRAY(ArrayElement, n); 55 | for (n = 0; n < array->ca_size; n++) { 56 | new_array->ca_index[n] = array->ca_index[n]; 57 | new_array->ca_value[n] = array->ca_value[n]; 58 | } 59 | new_array->ca_default = array->ca_default; 60 | return new_array; 61 | } 62 | 63 | /* 64 | * Binary search for element in ordered array. 65 | * Returns index of c in array if successful, otherwise size. 66 | */ 67 | local Natural 68 | ca_lookup(SChar *array, Natural size, Char c) 69 | { 70 | Natural low, mid, high; 71 | 72 | low = 0; 73 | high = size; 74 | while (low != high) { 75 | /* 76 | * Invariant: 77 | * 0 <= n < low => array[n] < c 78 | * high <= n < size => array[n] <= c 79 | * Bound function: high - low 80 | */ 81 | mid = (low+high)/2; 82 | if (array[mid] < c) 83 | low = mid+1; 84 | else 85 | high = mid; 86 | } 87 | return low < size && array[low] == c ? low : size; 88 | } 89 | 90 | global ArrayElement 91 | ca_index(CharArray *array, Char c) 92 | { 93 | Natural n; 94 | 95 | n = ca_lookup(array->ca_index, array->ca_size, c); 96 | return n == array->ca_size ? array->ca_default : array->ca_value[n]; 97 | } 98 | 99 | local void 100 | ca_insert(CharArray *array, Char c, ArrayElement x) 101 | { 102 | Natural size; 103 | Natural n; 104 | Byte *new_index; 105 | ArrayElement *new_value; 106 | 107 | /* 108 | * The array is full if the size is >= MIN_SIZE and is a power 109 | * of 2, which is what the following tricky '&' tests. 110 | * In this case, and we double its allocated size. 111 | */ 112 | size = array->ca_size; 113 | if (size >= MIN_SIZE && (size&(size-1)) == 0) { 114 | new_index = NEWARRAY(SChar, size*2); 115 | new_value = NEWARRAY(ArrayElement, size*2); 116 | for (n = 0; n < size; n++) { 117 | new_index[n] = array->ca_index[n]; 118 | new_value[n] = array->ca_value[n]; 119 | } 120 | array->ca_index = new_index; 121 | array->ca_value = new_value; 122 | } 123 | /* 124 | * Now that there is room, insert the new element in order. 125 | */ 126 | for (n = size; n > 0 && array->ca_index[n-1] > c; n--) { 127 | array->ca_index[n] = array->ca_index[n-1]; 128 | array->ca_value[n] = array->ca_value[n-1]; 129 | } 130 | array->ca_index[n] = c; 131 | array->ca_value[n] = x; 132 | array->ca_size = size+1; 133 | } 134 | 135 | global void 136 | ca_assign(CharArray *array, Char c, ArrayElement x) 137 | { 138 | Natural n; 139 | 140 | n = ca_lookup(array->ca_index, array->ca_size, c); 141 | if (n < array->ca_size) 142 | array->ca_value[n] = x; 143 | else 144 | ca_insert(array, c, x); 145 | } 146 | 147 | global void 148 | ca_map(CharArray *array, EltMap *f) 149 | { 150 | Natural n; 151 | 152 | for (n = 0; n < array->ca_size; n++) 153 | array->ca_value[n] = (*f)(array->ca_value[n]); 154 | array->ca_default = (*f)(array->ca_default); 155 | } 156 | -------------------------------------------------------------------------------- /src/pr_type.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "pr_type.h" 3 | #include "deftype.h" 4 | #include "cons.h" 5 | #include "polarity.h" 6 | #include "op.h" 7 | #include "print.h" 8 | #include "names.h" 9 | 10 | /* 11 | * Printing of types. 12 | */ 13 | 14 | local void pr_tycons(FILE *f, DefType *dt, TypeList *args); 15 | local void ty_print(FILE *f, Type *type, int context); 16 | local int ty_precedence(Type *type); 17 | local void pr_alt(FILE *f, Cons *alt); 18 | 19 | global void 20 | pr_qtype(FILE *f, QType *qtype) 21 | { 22 | pr_type(f, qtype->qt_type); 23 | } 24 | 25 | global void 26 | pr_type(FILE *f, Type *type) 27 | { 28 | ty_print(f, type, PREC_BODY); 29 | } 30 | 31 | local void 32 | ty_print(FILE *f, Type *type, int context) 33 | { 34 | int prec; 35 | 36 | prec = ty_precedence(type); 37 | if (prec < context) 38 | (void)fprintf(f, "("); 39 | switch (type->ty_class) { 40 | case TY_VAR: 41 | (void)fprintf(f, "%s", type->ty_var); 42 | when TY_MU: 43 | (void)fprintf(f, "%s %s %s ", n_mu, type->ty_muvar, n_gives); 44 | ty_print(f, type->ty_body, prec); 45 | when TY_CONS: 46 | pr_tycons(f, type->ty_deftype, type->ty_args); 47 | otherwise: 48 | NOT_REACHED; 49 | } 50 | if (prec < context) 51 | (void)fprintf(f, ")"); 52 | } 53 | 54 | local void 55 | pr_tycons(FILE *f, DefType *dt, TypeList *args) 56 | { 57 | Op *op; 58 | 59 | if (! dt->dt_tupled) { 60 | (void)fprintf(f, "%s", dt->dt_name); 61 | for ( ; args != NULL; args = args->ty_tail) { 62 | (void)fprintf(f, " "); 63 | ty_print(f, args->ty_head, PREC_ARG); 64 | } 65 | } else if (dt->dt_arity == 2 && (op = op_lookup(dt->dt_name)) != NULL) { 66 | ty_print(f, args->ty_head, LeftPrec(op)); 67 | (void)fprintf(f, " %s ", dt->dt_name); 68 | ty_print(f, args->ty_tail->ty_head, RightPrec(op)); 69 | } else { 70 | (void)fprintf(f, "%s (", dt->dt_name); 71 | for ( ; args != NULL; args = args->ty_tail) { 72 | ty_print(f, args->ty_head, PREC_BODY); 73 | if (args->ty_tail != NULL) 74 | (void)fprintf(f, ", "); 75 | } 76 | (void)fprintf(f, ")"); 77 | } 78 | } 79 | 80 | local int 81 | ty_precedence(Type *type) 82 | { 83 | Op *op; 84 | 85 | if (type->ty_class == TY_VAR || type->ty_deftype->dt_arity == 0) 86 | return PREC_ATOMIC; 87 | if (type->ty_class == TY_MU) 88 | return PREC_MU; 89 | if (type->ty_deftype->dt_arity == 2 && 90 | (op = op_lookup(type->ty_deftype->dt_name)) != NULL) 91 | return op->op_prec; 92 | return PREC_APPLY; 93 | } 94 | 95 | global void 96 | pr_deftype(FILE *f, DefType *dt, Bool full) 97 | { 98 | TypeList *argp; 99 | Cons *alt; 100 | 101 | (void)fprintf(f, "%s ", 102 | full && IsSynType(dt) ? n_type : 103 | full && IsDataType(dt) ? n_data : n_abstype); 104 | if (dt->dt_arity == 2 && dt->dt_tupled && 105 | op_lookup(dt->dt_name) != NULL) 106 | (void)fprintf(f, "%s %s %s", 107 | type_arg_name(dt->dt_varlist->ty_head, full), 108 | dt->dt_name, 109 | type_arg_name(dt->dt_varlist->ty_tail->ty_head, full)); 110 | else if (dt->dt_tupled) { 111 | (void)fprintf(f, "%s(", dt->dt_name); 112 | for (argp = dt->dt_varlist; argp != NULL; argp = argp->ty_tail) 113 | (void)fprintf(f, argp->ty_tail == NULL ? "%s" : "%s, ", 114 | type_arg_name(argp->ty_head, full)); 115 | (void)fprintf(f, ")"); 116 | } else { 117 | (void)fprintf(f, "%s", dt->dt_name); 118 | for (argp = dt->dt_varlist; argp != NULL; argp = argp->ty_tail) 119 | (void)fprintf(f, " %s", 120 | type_arg_name(argp->ty_head, full)); 121 | } 122 | if (full) { 123 | if (IsSynType(dt)) { 124 | (void)fprintf(f, " %s ", n_eq); 125 | pr_type(f, dt->dt_type); 126 | } else if (IsDataType(dt)) { 127 | (void)fprintf(f, " %s ", n_eq); 128 | for (alt = dt->dt_cons; 129 | alt != NULL; 130 | alt = alt->c_next) { 131 | pr_alt(f, alt); 132 | if (alt->c_next != NULL) 133 | (void)fprintf(f, " %s ", n_or); 134 | } 135 | } 136 | } 137 | (void)fprintf(f, ";\n"); 138 | } 139 | 140 | local void 141 | pr_alt(FILE *f, Cons *alt) 142 | { 143 | Op *op; 144 | TypeList *args; 145 | 146 | if (alt->c_nargs == 0) 147 | (void)fprintf(f, "%s", alt->c_name); 148 | if (alt->c_nargs == 1 && (op = op_lookup(alt->c_name)) != NULL) { 149 | ty_print(f, alt->c_type->ty_firstarg->ty_firstarg, 150 | LeftPrec(op)); 151 | (void)fprintf(f, " %s ", alt->c_name); 152 | ty_print(f, alt->c_type->ty_firstarg->ty_secondarg, 153 | RightPrec(op)); 154 | } else { 155 | (void)fprintf(f, "%s", alt->c_name); 156 | for (args = alt->c_type->ty_args; 157 | args != NULL; 158 | args = args->ty_tail) { 159 | (void)fprintf(f, " "); 160 | ty_print(f, args->ty_head, PREC_ARG); 161 | } 162 | } 163 | } 164 | -------------------------------------------------------------------------------- /src/yyparse.h: -------------------------------------------------------------------------------- 1 | /* A Bison parser, made by GNU Bison 1.875a. */ 2 | 3 | /* Skeleton parser for Yacc-like parsing with Bison, 4 | Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. 5 | 6 | This program is free software; you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation; either version 2, or (at your option) 9 | any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place - Suite 330, 19 | Boston, MA 02111-1307, USA. */ 20 | 21 | /* As a special exception, when this file is copied by Bison into a 22 | Bison output file, you may use that output file without restriction. 23 | This special exception was added by the Free Software Foundation 24 | in version 1.24 of Bison. */ 25 | 26 | /* Tokens. */ 27 | #ifndef YYTOKENTYPE 28 | # define YYTOKENTYPE 29 | /* Put the tokens into the symbol table, so that GDB and other debuggers 30 | know about them. */ 31 | enum yytokentype { 32 | TYPEVAR = 258, 33 | ABSTYPE = 259, 34 | DATA = 260, 35 | TYPESYM = 261, 36 | DEC = 262, 37 | INFIX = 263, 38 | INFIXR = 264, 39 | USES = 265, 40 | PRIVATE = 266, 41 | DISPLAY = 267, 42 | SAVE = 268, 43 | WRITE = 269, 44 | TO = 270, 45 | EXIT = 271, 46 | EDIT = 272, 47 | DEFEQ = 273, 48 | OR = 274, 49 | VALOF = 275, 50 | IS = 276, 51 | GIVES = 277, 52 | THEN = 278, 53 | FORALL = 279, 54 | MODSYM = 280, 55 | PUBCONST = 281, 56 | PUBFUN = 282, 57 | PUBTYPE = 283, 58 | END = 284, 59 | MU = 285, 60 | IN = 286, 61 | WHEREREC = 287, 62 | WHERE = 288, 63 | ELSE = 289, 64 | BIN_BASE = 290, 65 | LBINARY1 = 291, 66 | RBINARY1 = 292, 67 | LBINARY2 = 293, 68 | RBINARY2 = 294, 69 | LBINARY3 = 295, 70 | RBINARY3 = 296, 71 | LBINARY4 = 297, 72 | RBINARY4 = 298, 73 | LBINARY5 = 299, 74 | RBINARY5 = 300, 75 | LBINARY6 = 301, 76 | RBINARY6 = 302, 77 | LBINARY7 = 303, 78 | RBINARY7 = 304, 79 | LBINARY8 = 305, 80 | RBINARY8 = 306, 81 | LBINARY9 = 307, 82 | RBINARY9 = 308, 83 | NONOP = 309, 84 | LAMBDA = 310, 85 | IF = 311, 86 | LETREC = 312, 87 | LET = 313, 88 | CHAR = 314, 89 | LITERAL = 315, 90 | NUMBER = 316, 91 | IDENT = 317, 92 | APPLY = 318, 93 | ALWAYS_REDUCE = 319 94 | }; 95 | #endif 96 | #define TYPEVAR 258 97 | #define ABSTYPE 259 98 | #define DATA 260 99 | #define TYPESYM 261 100 | #define DEC 262 101 | #define INFIX 263 102 | #define INFIXR 264 103 | #define USES 265 104 | #define PRIVATE 266 105 | #define DISPLAY 267 106 | #define SAVE 268 107 | #define WRITE 269 108 | #define TO 270 109 | #define EXIT 271 110 | #define EDIT 272 111 | #define DEFEQ 273 112 | #define OR 274 113 | #define VALOF 275 114 | #define IS 276 115 | #define GIVES 277 116 | #define THEN 278 117 | #define FORALL 279 118 | #define MODSYM 280 119 | #define PUBCONST 281 120 | #define PUBFUN 282 121 | #define PUBTYPE 283 122 | #define END 284 123 | #define MU 285 124 | #define IN 286 125 | #define WHEREREC 287 126 | #define WHERE 288 127 | #define ELSE 289 128 | #define BIN_BASE 290 129 | #define LBINARY1 291 130 | #define RBINARY1 292 131 | #define LBINARY2 293 132 | #define RBINARY2 294 133 | #define LBINARY3 295 134 | #define RBINARY3 296 135 | #define LBINARY4 297 136 | #define RBINARY4 298 137 | #define LBINARY5 299 138 | #define RBINARY5 300 139 | #define LBINARY6 301 140 | #define RBINARY6 302 141 | #define LBINARY7 303 142 | #define RBINARY7 304 143 | #define LBINARY8 305 144 | #define RBINARY8 306 145 | #define LBINARY9 307 146 | #define RBINARY9 308 147 | #define NONOP 309 148 | #define LAMBDA 310 149 | #define IF 311 150 | #define LETREC 312 151 | #define LET 313 152 | #define CHAR 314 153 | #define LITERAL 315 154 | #define NUMBER 316 155 | #define IDENT 317 156 | #define APPLY 318 157 | #define ALWAYS_REDUCE 319 158 | 159 | 160 | 161 | 162 | #if ! defined (YYSTYPE) && ! defined (YYSTYPE_IS_DECLARED) 163 | #line 101 "y.tab.y" 164 | typedef union YYSTYPE { 165 | Num numval; 166 | int intval; 167 | Text *textval; 168 | String strval; 169 | Natural charval; 170 | Type *type; 171 | TypeList *typelist; 172 | DefType *deftype; 173 | QType *qtype; 174 | Expr *expr; 175 | Branch *branch; 176 | Cons *cons; 177 | } YYSTYPE; 178 | /* Line 1240 of yacc.c. */ 179 | #line 180 "y.tab.h" 180 | # define yystype YYSTYPE /* obsolescent; will be withdrawn */ 181 | # define YYSTYPE_IS_DECLARED 1 182 | # define YYSTYPE_IS_TRIVIAL 1 183 | #endif 184 | 185 | extern YYSTYPE yylval; 186 | 187 | 188 | 189 | -------------------------------------------------------------------------------- /lib/list.hop: -------------------------------------------------------------------------------- 1 | ! general purpose list functions 2 | 3 | dec reverse : list alpha -> list alpha; 4 | !!! reverse [x1, ..., xn] <= [xn, ..., x1]; 5 | 6 | dec length : list alpha -> num; 7 | !!! length [x1, ..., xn] <= n; 8 | 9 | infixr || : 2; 10 | dec || : list(alpha) # list(beta) -> list(alpha # beta); 11 | ! || (aka zip) - turn a pair of lists into a list of pairs of corresponding 12 | ! elements. If the lists differ in length, the extra elements of the longer 13 | ! list are ignored. 14 | !!! [x1, ..., xn] || [y1, ..., yn] <= [(x1, y1), ..., (xl, yl)] 15 | ! where l == min(m, n); 16 | 17 | dec dist : alpha # list beta -> list(alpha # beta); 18 | !!! dist(a, [x1, ..., xn]) <= [(a, x1), ..., (a, xn)]; 19 | 20 | infix @ : 9; 21 | dec @ : list alpha # num -> alpha; 22 | ! l@n = the element of list `l' in position `n', counting from 0. 23 | !!! [x0, ..., xn-1]@i <= xi; 24 | 25 | dec front, after : num # list alpha -> list alpha; 26 | ! front(n, l) = the first n elements of the list l. 27 | ! after(n, l) = the rest of the list l after the first n elements. 28 | !!! front(n, [x1, ..., xm]) <= if n <= m then [x1, ..., xn] 29 | ! else [x1, ..., xm]; 30 | !!! after(n, [x1, ..., xm]) <= if n <= m then [xn+1, ..., xm] 31 | ! else []; 32 | ! front and after satisfy 33 | ! front(n, l) <> after(n, l) = l, 34 | ! even if l has fewer than n elements. 35 | 36 | ! the list functor is a.k.a. map for backward compatability. 37 | dec map : (alpha -> beta) -> list alpha -> list beta; 38 | ! map f l = the list obtained from l by applying f to each element. 39 | !!! map f [x1, ..., xn] <= [f(x1), ..., f(xn)]; 40 | 41 | dec foldr : beta # (alpha # beta -> beta) -> (list alpha -> beta); 42 | ! foldr - summarize a list using a constant and binary function: 43 | !!! foldr(c, f)([x1, ..., xn]) <= f(x1, f(x2, ... f(xn, c) ... )); 44 | ! e.g. foldr(0, (+))([1, 2, 3, 4]) = 10, 45 | ! foldr(1, (*))([1, 2, 3, 4]) = 24 46 | 47 | dec foldl : beta # (beta # alpha -> beta) -> (list alpha -> beta); 48 | ! foldl - like foldr, but from the left 49 | !!! foldl(c, f)([x1, ..., xn]) <= f( ... f(c, xn), ..., x1) 50 | 51 | dec iterate : (alpha -> alpha) -> alpha -> list alpha; 52 | !!! iterate f x <= [x, f x, f(f x), ... ]; 53 | 54 | dec filter : (alpha -> bool) -> list alpha -> list alpha; 55 | ! filter cond l = the list consisting of the elements of the list l that 56 | ! the function cond maps to true. 57 | 58 | dec partition : (alpha -> bool) -> list alpha -> list alpha # list alpha; 59 | !!! partition cond l <= (filter cond l, filter (not o cond) l); 60 | 61 | dec front_with, after_with : (alpha -> bool) -> list alpha -> list alpha; 62 | ! front_with cond l = the longest initial segment of the list l 63 | ! satisfying cond 64 | ! after_with cond l = the rest of the list l after the longest initial 65 | ! segment satisfying cond. 66 | !!! front_with cond [x1, ..., xn] <= [x1, ..., xm]; 67 | !!! after_with cond [x1, ..., xn] <= [xm+1, ..., xn]; 68 | ! where cond xi = true for 1 <= i <= m, and 69 | ! m = n or cond(xm+1) = false 70 | ! front_with and after_with satisfy 71 | ! front_with cond l <> after_with cond l = l 72 | 73 | dec span : (alpha -> bool) -> list alpha -> list alpha # list alpha; 74 | !!! span cond l <= (front_with cond l, after_with cond l); 75 | 76 | private; 77 | 78 | dec shunt : list alpha # list alpha -> list alpha; 79 | --- shunt([], ys) <= ys; 80 | --- shunt(x::xs, ys) <= shunt(xs, x::ys); 81 | 82 | --- reverse xs <= shunt(xs, []); 83 | 84 | --- length [] <= 0; 85 | --- length(x::xs) <= succ(length xs); 86 | 87 | dec zip' : alpha -> list alpha -> list beta -> list(alpha # beta); 88 | --- zip' x xs [] <= []; 89 | --- zip' x xs (y::ys) <= (x, y)::(xs||ys); 90 | 91 | --- [] || ys <= []; 92 | --- x::xs || ys <= zip' x xs ys; 93 | 94 | --- dist(x, []) <= []; 95 | --- dist(x, y::ys) <= (x, y) :: dist(x, ys); 96 | 97 | --- (x::xs)@0 <= x; 98 | --- (x::xs)@succ n <= xs@n; 99 | 100 | dec front' : num # list alpha -> list alpha; 101 | --- front'(n, []) <= []; 102 | --- front'(n, x::xs) <= x::front(n, xs); 103 | 104 | --- front(0, xs) <= []; 105 | --- front(succ n, xs) <= front'(n, xs); 106 | 107 | --- after(0, xs) <= xs; 108 | --- after(n, []) <= []; 109 | --- after(succ n, x::xs) <= after(n, xs); 110 | 111 | --- map f [] <= []; 112 | --- map f (x::xs) <= f x::map f xs; 113 | 114 | --- foldr(c, op) [] <= c; 115 | --- foldr(c, op) (x::xs) <= op(x, foldr(c, op) xs); 116 | 117 | --- foldl(c, op) [] <= c; 118 | --- foldl(c, op) (x::xs) <= foldl(op(c, x), op) xs; 119 | 120 | --- iterate f x <= x::iterate f (f x); 121 | 122 | --- filter cond [] <= []; 123 | --- filter cond (x::xs) <= 124 | if cond x then x::filter cond xs 125 | else filter cond xs; 126 | 127 | --- partition cond [] <= ([], []); 128 | --- partition cond (x::xs) <= 129 | if cond x then (x::ayes, nayes) else (ayes, x::nayes) 130 | where (ayes, nayes) == partition cond xs; 131 | 132 | --- front_with cond [] <= []; 133 | --- front_with cond (x::xs) <= if cond x then x::front_with cond xs else []; 134 | 135 | --- after_with cond [] <= []; 136 | --- after_with cond (x::xs) <= if cond x then after_with cond xs else x::xs; 137 | 138 | --- span cond [] <= ([], []); 139 | --- span cond (x::xs) <= 140 | if cond x 141 | then (x::f, a) where (f, a) == span cond xs 142 | else ([], x::xs); 143 | -------------------------------------------------------------------------------- /lib/Standard.hop: -------------------------------------------------------------------------------- 1 | ! The standard environment for Hope, implicitly used by every session 2 | ! and module. 3 | 4 | !! Standard type constructors 5 | 6 | ! Standard type variables. 7 | 8 | typevar alpha, beta, gamma; 9 | 10 | ! Function and product types. 11 | 12 | infixr -> : 2; 13 | abstype neg -> pos; 14 | 15 | infixr # : 4; 16 | abstype pos # pos; 17 | 18 | --- (a # b) (x, y) <= (a x, b y); 19 | 20 | infixr X : 4; 21 | type alpha X beta == alpha # beta; 22 | 23 | ! Normal right-to-left composition of f and g. 24 | 25 | infix o : 2; 26 | dec o : (beta -> gamma) # (alpha -> beta) -> alpha -> gamma; 27 | --- (f o g) x <= f(g x); 28 | 29 | --- (a -> b) f <= b o f o a; 30 | 31 | ! The identity function. 32 | 33 | dec id : alpha -> alpha; 34 | --- id x <= x; 35 | 36 | ! Booleans with the standard operations. 37 | 38 | data bool == false ++ true; 39 | type truval == bool; 40 | 41 | infix or : 1; 42 | infix and : 2; 43 | 44 | dec not : bool -> bool; 45 | --- not true <= false; 46 | --- not false <= true; 47 | 48 | dec and : bool # bool -> bool; 49 | --- false and p <= false; 50 | --- true and p <= p; 51 | 52 | dec or : bool # bool -> bool; 53 | --- true or p <= true; 54 | --- false or p <= p; 55 | 56 | dec if_then_else : bool -> alpha -> alpha -> alpha; 57 | --- if true then x else y <= x; 58 | --- if false then x else y <= y; 59 | 60 | ! Lists. 61 | 62 | infixr :: : 5; 63 | data list alpha == nil ++ alpha :: list alpha; 64 | 65 | ! List concatenation. 66 | 67 | infixr <> : 5; 68 | dec <> : list alpha # list alpha -> list alpha; 69 | --- [] <> ys <= ys; 70 | --- (x::xs) <> ys <= x::(xs <> ys); 71 | 72 | ! The type num behaves as if it were defined by: 73 | ! data num == 0 ++ succ num; 74 | ! but is actually implemented a little more efficiently. 75 | ! The type also contains negative numbers (and reals in some implementations). 76 | 77 | data num == succ num; 78 | 79 | ! Similarly, the type char behaves as if it were defined as an enumeration 80 | ! (in the normal order) of all the ASCII character constants. 81 | 82 | abstype char; 83 | 84 | --- char x <= x; 85 | 86 | !! Internally defined functions 87 | 88 | ! Comparison functions: 89 | ! these evaluate their arguments only to the extent necessary to determine 90 | ! their order. In comparing distinct constants and constructors, the 91 | ! lesser is the one which came earlier in the data definition in which 92 | ! both were defined. Pairs compare lexicographically, while comparison 93 | ! of functions triggers a run-time error. On the types num, char and 94 | ! list(char), these rules give the normal orderings. 95 | 96 | infix =, /= : 3; 97 | infix <, =<, >, >= : 4; 98 | dec =, /=, <, =<, >, >= : alpha # alpha -> bool; 99 | 100 | ! Lower-level comparison functions. 101 | 102 | data relation == LESS ++ EQUAL ++ GREATER; 103 | 104 | dec compare : alpha # alpha -> relation; 105 | 106 | --- x = y <= (\ EQUAL => true | _ => false) (compare(x, y)); 107 | --- x /= y <= (\ EQUAL => false | _ => true) (compare(x, y)); 108 | --- x < y <= (\ LESS => true | _ => false) (compare(x, y)); 109 | --- x >= y <= (\ LESS => false | _ => true) (compare(x, y)); 110 | --- x > y <= (\ GREATER => true | _ => false) (compare(x, y)); 111 | --- x =< y <= (\ GREATER => false | _ => true) (compare(x, y)); 112 | 113 | ! Conversions. 114 | 115 | dec ord : char -> num; 116 | dec chr : num -> char; 117 | 118 | dec num2str : num -> list char; 119 | dec str2num : list char -> num; 120 | 121 | ! The contents of a named file (created lazily). 122 | 123 | dec read : list char -> list char; 124 | 125 | ! Abort execution with an error message. 126 | 127 | dec error : list char -> alpha; 128 | 129 | ! The usual arithmetical functions. 130 | 131 | infix +, - : 5; 132 | infix *, /, div, mod : 6; 133 | dec +, -, *, /, div, mod : num # num -> num; 134 | 135 | ! Math library. 136 | 137 | dec cos, sin, tan, acos, asin, atan : num -> num; 138 | dec atan2, hypot : num # num -> num; 139 | dec cosh, sinh, tanh, acosh, asinh, atanh : num -> num; 140 | dec abs, ceil, floor : num -> num; 141 | dec exp, log, log10, sqrt : num -> num; 142 | dec pow : num # num -> num; 143 | dec erf, erfc : num -> num; 144 | 145 | ! Any extra arguments on the interpreter command line. 146 | 147 | dec argv : list(list char); 148 | 149 | ! Part of the special treatment of the succ constructor. 150 | 151 | dec succ : num -> num; 152 | --- succ n <= n+1; 153 | 154 | private; ! Bootstrapping 155 | 156 | ! Output management: 157 | 158 | dec return : alpha; ! evaluation causes an immediate exit 159 | 160 | dec print : alpha -> beta; ! strict built-in function 161 | !!! print x <= return; ! side effect: print x 162 | 163 | dec write_element : alpha -> list alpha -> beta; ! strict built-in function 164 | !!! write_element x <= write_list; ! side effect: print x in write form 165 | 166 | dec write_list : list alpha -> beta; 167 | --- write_list [] <= return; 168 | --- write_list(x::xs) <= write_element x xs; 169 | 170 | ! lexicographical ordering for pairs 171 | dec compare_cond : relation -> alpha -> alpha -> alpha -> alpha; 172 | --- compare_cond LESS l e g <= l; 173 | --- compare_cond EQUAL l e g <= e; 174 | --- compare_cond GREATER l e g <= g; 175 | 176 | dec cmp_pair : (alpha # beta) # (alpha # beta) -> relation; 177 | --- cmp_pair((x1, y1), (x2, y2)) <= 178 | compare_cond (compare(x1, x2)) LESS (compare(y1, y2)) GREATER; 179 | -------------------------------------------------------------------------------- /src/bad_rectype.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "bad_rectype.h" 3 | #include "deftype.h" 4 | #include "cons.h" 5 | #include "error.h" 6 | 7 | #define MAX_ARG_STACK 200 /* max. size of type arg stack (not checked) */ 8 | 9 | typedef enum { /* return types for check_recursion() */ 10 | REC_NONE, /* type contains no uses of the constructor */ 11 | REC_OK, /* type contains correct uses of the constructor */ 12 | REC_FAIL /* type contains an error (already reported) */ 13 | } RecType; 14 | 15 | local RecType check_recursion(DefType *head, Type *type); 16 | local Bool visited(DefType *deftype); 17 | 18 | /* 19 | * Stack of type synonyms whose expansions we are in. 20 | * Runs upwards. 21 | */ 22 | local DefType **dt_base; 23 | local DefType **dt_top; 24 | 25 | /* 26 | * Stack of arguments of type synonyms whose expansions we are in. 27 | * Arguments which refer to arguments of the head constructor are 28 | * represented by their argument number in that constructor. 29 | * Complex arguments are represented as -1, which cannot match. 30 | * Runs downwards. 31 | */ 32 | local short *arg_top; 33 | 34 | #define COMPLEX_ARG (-1) 35 | 36 | /* 37 | * type is an illegal body for head if it contains a use of head 38 | * with different arguments. 39 | */ 40 | global Bool 41 | bad_rectype(DefType *head, Type *type) 42 | { 43 | int i; 44 | short arg_stack[MAX_ARG_STACK]; 45 | DefType *dt_stack[MAX_SYN_DEPTH]; 46 | 47 | dt_top = dt_base = dt_stack; 48 | arg_top = arg_stack + MAX_ARG_STACK; 49 | 50 | arg_top -= head->dt_arity; 51 | for (i = head->dt_arity-1; i >= 0; i--) 52 | arg_top[i] = i; 53 | return check_recursion(head, type) == REC_FAIL; 54 | } 55 | 56 | local RecType 57 | check_recursion(DefType *head, Type *type) 58 | { 59 | TypeList *argp, *argp2; 60 | RecType result, sub_result; 61 | int arity; 62 | int i; 63 | Cons *ct; 64 | 65 | while (type->ty_class == TY_MU) 66 | type = type->ty_body; 67 | 68 | if (type->ty_class == TY_VAR || visited(type->ty_deftype)) 69 | return REC_NONE; 70 | 71 | if (type->ty_deftype == head) { 72 | /* 73 | * check that the arguments are a permutation of those 74 | * on the left side. It suffices to check that they are 75 | * all variables and none occurs twice. 76 | */ 77 | for (argp = type->ty_args; 78 | argp != NULL; 79 | argp = argp->ty_tail) { 80 | if (argp->ty_head->ty_class != TY_VAR) { 81 | error(SEMERR, 82 | "%s: recursive use with non-variable argument", 83 | head->dt_name); 84 | return REC_FAIL; 85 | } 86 | for (argp2 = type->ty_args; 87 | argp2 != argp; 88 | argp2 = argp2->ty_tail) 89 | if (argp2->ty_head->ty_index == 90 | argp->ty_head->ty_index) { 91 | error(SEMERR, 92 | "%s: recursive use with different arguments", 93 | head->dt_name); 94 | return REC_FAIL; 95 | } 96 | } 97 | return REC_OK; 98 | } 99 | 100 | arity = type->ty_deftype->dt_arity; 101 | 102 | *dt_top++ = type->ty_deftype; 103 | for (argp = type->ty_args, i = 0; 104 | argp != NULL; 105 | argp = argp->ty_tail, i++) 106 | arg_top[i - arity] = argp->ty_head->ty_class == TY_VAR ? 107 | arg_top[argp->ty_head->ty_index] : COMPLEX_ARG; 108 | arg_top -= arity; 109 | 110 | /* check expansion of type synonym */ 111 | if (IsSynType(type->ty_deftype)) { 112 | result = check_recursion(head, type->ty_deftype->dt_type); 113 | if (result == REC_FAIL) 114 | return REC_FAIL; 115 | } else { /* it's a data-type */ 116 | result = REC_NONE; 117 | for (ct = type->ty_deftype->dt_cons; 118 | ct != NULL; 119 | ct = ct->c_next) 120 | if (ct->c_nargs > 0) { 121 | sub_result = check_recursion(head, 122 | ct->c_type->ty_firstarg); 123 | if (sub_result == REC_FAIL) 124 | return REC_FAIL; 125 | if (sub_result == REC_OK) 126 | result = REC_OK; 127 | } 128 | } 129 | 130 | /* pop stacks */ 131 | arg_top += arity; 132 | dt_top--; 133 | 134 | /* 135 | * If the expansion of a type constructor contains a recursive 136 | * use of the constructor being defined, then defining this 137 | * constructor will make that one recursive too. The situation 138 | * is something like 139 | * 140 | * abstype a(v1, ..., vn); 141 | * type b(u1, ..., um) == ... a(v1, ..., vn) ...; 142 | * type a(v1, ..., vn) == ... b(u1, ..., um) ...; 143 | * 144 | * If a and b have different arities, then one of them must have 145 | * different arguments for the recursive use; we have already 146 | * checked a, so an error is being introduced into b. 147 | * If they have the same arities, and a has checked out, then the 148 | * two variable lists must be permutations of each other, and b 149 | * will also be legal. 150 | */ 151 | if (result == REC_OK && arity != head->dt_arity) { 152 | error(SEMERR, 153 | "%s: recursive use of '%s' has different arguments", 154 | head->dt_name, 155 | type->ty_deftype->dt_name); 156 | return REC_FAIL; 157 | } 158 | 159 | /* check arguments of type constructor */ 160 | for (argp = type->ty_args; argp != NULL; argp = argp->ty_tail) { 161 | sub_result = check_recursion(head, argp->ty_head); 162 | if (sub_result == REC_FAIL) 163 | return REC_FAIL; 164 | if (sub_result == REC_OK) 165 | result = REC_OK; 166 | } 167 | return result; 168 | } 169 | 170 | /* 171 | * Is deftype on the stack of expanded type synonyms? 172 | */ 173 | local Bool 174 | visited(DefType *deftype) 175 | { 176 | DefType **dp; 177 | 178 | for (dp = dt_base; dp != dt_top; dp++) 179 | if (*dp == deftype) 180 | return TRUE; 181 | return FALSE; 182 | } 183 | -------------------------------------------------------------------------------- /src/polarity.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "polarity.h" 3 | #include "deftype.h" 4 | #include "error.h" 5 | #include "names.h" 6 | 7 | /* 8 | * Polarities of type constructor arguments. 9 | */ 10 | 11 | global String 12 | type_arg_name(Type *var, Bool full) 13 | { 14 | return full ? var->ty_var : 15 | var->ty_pos ? (var->ty_neg ? var->ty_var : n_pos) : 16 | var->ty_neg ? n_neg : n_none; 17 | } 18 | 19 | global void 20 | set_polarities(TypeList *varlist) 21 | { 22 | for ( ; varlist != NULL; varlist = varlist->ty_tail) 23 | if (varlist->ty_head->ty_var == n_none) { 24 | varlist->ty_head->ty_pos = FALSE; 25 | varlist->ty_head->ty_neg = FALSE; 26 | } else { 27 | varlist->ty_head->ty_pos = 28 | varlist->ty_head->ty_var != n_neg; 29 | varlist->ty_head->ty_neg = 30 | varlist->ty_head->ty_var != n_pos; 31 | } 32 | } 33 | 34 | global Bool 35 | check_polarities(TypeList *decl_vars, TypeList *def_vars) 36 | { 37 | while (decl_vars != NULL) { 38 | if (def_vars->ty_head->ty_pos && 39 | ! decl_vars->ty_head->ty_pos) { 40 | error(SEMERR, "%s: unexpected positive use", 41 | def_vars->ty_head->ty_var); 42 | return FALSE; 43 | } 44 | if (def_vars->ty_head->ty_neg && 45 | ! decl_vars->ty_head->ty_neg) { 46 | error(SEMERR, "%s: unexpected negative use", 47 | def_vars->ty_head->ty_var); 48 | return FALSE; 49 | } 50 | decl_vars = decl_vars->ty_tail; 51 | def_vars = def_vars->ty_tail; 52 | } 53 | return TRUE; 54 | } 55 | 56 | /* 57 | * Computing polarities of arguments. 58 | * 59 | * We now permit recursive uses to have a permutation of the original 60 | * arguments -- cf check_recursion(). This means: 61 | * - if arg i occurs in position j in a positive context, then args 62 | * i and j will have the same polarity. 63 | * - if arg i occurs in position j in a negative context, then args 64 | * i and j will have opposite polarities. 65 | * Hence we maintain equivalence classes of arguments. 66 | */ 67 | #define MAX_TYCON_ARITY 10 /* max. arity of a type cons. (not checked) */ 68 | #define NIL (-1) 69 | 70 | local struct { 71 | int equiv; /* towards root of class, or NIL if this is the root */ 72 | int dual; /* root: root of dual class if any */ 73 | Bool pos; /* root: any of these variables occur positively */ 74 | Bool neg; /* root: any of these variables occur negatively */ 75 | } ty_arg[MAX_TYCON_ARITY]; 76 | 77 | local DefType *cur_deftype; /* type currently being defined */ 78 | local TypeList *cur_varlist; /* its new formal parameters */ 79 | 80 | local int tycon_find(int n); 81 | local void tycon_union(int n1, int n2); 82 | local void set_equiv(int n1, int n2); 83 | local void set_dual(int n1, int n2); 84 | local void set_pos(int n); 85 | local void set_neg(int n); 86 | local void do_polarities(Type *type, Bool pos, Bool neg); 87 | 88 | global void 89 | start_polarities(DefType *deftype, TypeList *varlist) 90 | { 91 | int i; 92 | 93 | for (i = deftype->dt_arity-1; i >= 0; i--) { 94 | ty_arg[i].equiv = ty_arg[i].dual = NIL; 95 | ty_arg[i].pos = ty_arg[i].neg = FALSE; 96 | } 97 | cur_deftype = deftype; 98 | cur_varlist = varlist; 99 | } 100 | 101 | global void 102 | compute_polarities(Type *type) 103 | { 104 | do_polarities(type, TRUE, FALSE); 105 | } 106 | 107 | local void 108 | do_polarities(Type *type, Bool pos, Bool neg) 109 | /* in a positive and/or negative context */ 110 | { 111 | TypeList *formals; 112 | TypeList *actuals; 113 | 114 | switch (type->ty_class) { 115 | case TY_VAR: 116 | if (pos) 117 | set_pos(type->ty_index); 118 | if (neg) 119 | set_neg(type->ty_index); 120 | when TY_MU: 121 | /* 122 | * BUG: if the var occurs negatively in the body, 123 | * should set both pos and neg. 124 | */ 125 | do_polarities(type->ty_body, pos, neg); 126 | when TY_CONS: 127 | if (type->ty_deftype == cur_deftype) { 128 | for (actuals = type->ty_args, 129 | formals = cur_varlist; 130 | actuals != NULL; 131 | actuals = actuals->ty_tail, 132 | formals = formals->ty_tail) { 133 | if (pos) 134 | set_equiv(formals->ty_head->ty_index, 135 | actuals->ty_head->ty_index); 136 | if (neg) 137 | set_dual(formals->ty_head->ty_index, 138 | actuals->ty_head->ty_index); 139 | } 140 | } else 141 | for (actuals = type->ty_args, 142 | formals = type->ty_deftype->dt_varlist; 143 | actuals != NULL; 144 | actuals = actuals->ty_tail, 145 | formals = formals->ty_tail) 146 | do_polarities(actuals->ty_head, 147 | (pos && formals->ty_head->ty_pos) || 148 | (neg && formals->ty_head->ty_neg), 149 | (neg && formals->ty_head->ty_pos) || 150 | (pos && formals->ty_head->ty_neg)); 151 | otherwise: 152 | NOT_REACHED; 153 | } 154 | } 155 | 156 | global void 157 | finish_polarities(void) 158 | { 159 | TypeList *vp; 160 | int n, nd; 161 | 162 | for (vp = cur_varlist; vp != NULL; vp = vp->ty_tail) { 163 | n = tycon_find(vp->ty_head->ty_index); 164 | nd = ty_arg[n].dual; 165 | vp->ty_head->ty_pos = ty_arg[n].pos || 166 | (nd != NIL && ty_arg[nd].neg); 167 | vp->ty_head->ty_neg = ty_arg[n].neg || 168 | (nd != NIL && ty_arg[nd].pos); 169 | } 170 | } 171 | 172 | /* 173 | * For two roots r1, r2, 174 | * ty_arg[r1].dual == r2 <=> ty_arg[r2].dual == r1 175 | */ 176 | 177 | local int 178 | tycon_find(int n) 179 | { 180 | while (ty_arg[n].equiv != NIL) 181 | n = ty_arg[n].equiv; 182 | return n; 183 | } 184 | 185 | local void 186 | tycon_union(int n1, int n2) 187 | { 188 | n1 = tycon_find(n1); 189 | n2 = tycon_find(n2); 190 | if (n1 != n2) { 191 | ty_arg[n2].equiv = n1; 192 | ty_arg[n1].pos = ty_arg[n1].pos || ty_arg[n2].pos; 193 | ty_arg[n1].neg = ty_arg[n1].neg || ty_arg[n2].neg; 194 | if (ty_arg[n1].dual == NIL) 195 | ty_arg[n1].dual = ty_arg[n2].dual; 196 | else if (ty_arg[n2].dual != NIL) 197 | tycon_union(ty_arg[n1].dual, ty_arg[n2].dual); 198 | } 199 | } 200 | 201 | local void 202 | set_equiv(int n1, int n2) 203 | { 204 | tycon_union(n1, n2); 205 | } 206 | 207 | local void 208 | set_dual(int n1, int n2) 209 | { 210 | n1 = tycon_find(n1); 211 | n2 = tycon_find(n2); 212 | if (ty_arg[n1].dual != NIL) 213 | tycon_union(ty_arg[n1].dual, n2); 214 | else if (ty_arg[n2].dual != NIL) 215 | tycon_union(ty_arg[n2].dual, n1); 216 | else { /* both NIL */ 217 | ty_arg[n1].dual = n2; 218 | ty_arg[n2].dual = n1; 219 | } 220 | } 221 | 222 | local void 223 | set_pos(int n) 224 | { 225 | ty_arg[tycon_find(n)].pos = TRUE; 226 | } 227 | 228 | local void 229 | set_neg(int n) 230 | { 231 | ty_arg[tycon_find(n)].neg = TRUE; 232 | } 233 | -------------------------------------------------------------------------------- /sh/install-sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # install - install a program, script, or datafile 4 | # This comes from X11R5 (mit/util/scripts/install.sh). 5 | # 6 | # Copyright 1991 by the Massachusetts Institute of Technology 7 | # 8 | # Permission to use, copy, modify, distribute, and sell this software and its 9 | # documentation for any purpose is hereby granted without fee, provided that 10 | # the above copyright notice appear in all copies and that both that 11 | # copyright notice and this permission notice appear in supporting 12 | # documentation, and that the name of M.I.T. not be used in advertising or 13 | # publicity pertaining to distribution of the software without specific, 14 | # written prior permission. M.I.T. makes no representations about the 15 | # suitability of this software for any purpose. It is provided "as is" 16 | # without express or implied warranty. 17 | # 18 | # Calling this script install-sh is preferred over install.sh, to prevent 19 | # `make' implicit rules from creating a file called install from it 20 | # when there is no Makefile. 21 | # 22 | # This script is compatible with the BSD install script, but was written 23 | # from scratch. It can only install one file at a time, a restriction 24 | # shared with many OS's install programs. 25 | 26 | 27 | # set DOITPROG to echo to test this script 28 | 29 | # Don't use :- since 4.3BSD and earlier shells don't like it. 30 | doit="${DOITPROG-}" 31 | 32 | 33 | # put in absolute paths if you don't have them in your path; or use env. vars. 34 | 35 | mvprog="${MVPROG-mv}" 36 | cpprog="${CPPROG-cp}" 37 | chmodprog="${CHMODPROG-chmod}" 38 | chownprog="${CHOWNPROG-chown}" 39 | chgrpprog="${CHGRPPROG-chgrp}" 40 | stripprog="${STRIPPROG-strip}" 41 | rmprog="${RMPROG-rm}" 42 | mkdirprog="${MKDIRPROG-mkdir}" 43 | 44 | transformbasename="" 45 | transform_arg="" 46 | instcmd="$mvprog" 47 | chmodcmd="$chmodprog 0755" 48 | chowncmd="" 49 | chgrpcmd="" 50 | stripcmd="" 51 | rmcmd="$rmprog -f" 52 | mvcmd="$mvprog" 53 | src="" 54 | dst="" 55 | dir_arg="" 56 | 57 | while [ x"$1" != x ]; do 58 | case $1 in 59 | -c) instcmd="$cpprog" 60 | shift 61 | continue;; 62 | 63 | -d) dir_arg=true 64 | shift 65 | continue;; 66 | 67 | -m) chmodcmd="$chmodprog $2" 68 | shift 69 | shift 70 | continue;; 71 | 72 | -o) chowncmd="$chownprog $2" 73 | shift 74 | shift 75 | continue;; 76 | 77 | -g) chgrpcmd="$chgrpprog $2" 78 | shift 79 | shift 80 | continue;; 81 | 82 | -s) stripcmd="$stripprog" 83 | shift 84 | continue;; 85 | 86 | -t=*) transformarg=`echo $1 | sed 's/-t=//'` 87 | shift 88 | continue;; 89 | 90 | -b=*) transformbasename=`echo $1 | sed 's/-b=//'` 91 | shift 92 | continue;; 93 | 94 | *) if [ x"$src" = x ] 95 | then 96 | src=$1 97 | else 98 | # this colon is to work around a 386BSD /bin/sh bug 99 | : 100 | dst=$1 101 | fi 102 | shift 103 | continue;; 104 | esac 105 | done 106 | 107 | if [ x"$src" = x ] 108 | then 109 | echo "install: no input file specified" 110 | exit 1 111 | else 112 | true 113 | fi 114 | 115 | if [ x"$dir_arg" != x ]; then 116 | dst=$src 117 | src="" 118 | 119 | if [ -d $dst ]; then 120 | instcmd=: 121 | chmodcmd="" 122 | else 123 | instcmd=mkdir 124 | fi 125 | else 126 | 127 | # Waiting for this to be detected by the "$instcmd $src $dsttmp" command 128 | # might cause directories to be created, which would be especially bad 129 | # if $src (and thus $dsttmp) contains '*'. 130 | 131 | if [ -f $src -o -d $src ] 132 | then 133 | true 134 | else 135 | echo "install: $src does not exist" 136 | exit 1 137 | fi 138 | 139 | if [ x"$dst" = x ] 140 | then 141 | echo "install: no destination specified" 142 | exit 1 143 | else 144 | true 145 | fi 146 | 147 | # If destination is a directory, append the input filename; if your system 148 | # does not like double slashes in filenames, you may need to add some logic 149 | 150 | if [ -d $dst ] 151 | then 152 | dst="$dst"/`basename $src` 153 | else 154 | true 155 | fi 156 | fi 157 | 158 | ## this sed command emulates the dirname command 159 | dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` 160 | 161 | # Make sure that the destination directory exists. 162 | # this part is taken from Noah Friedman's mkinstalldirs script 163 | 164 | # Skip lots of stat calls in the usual case. 165 | if [ ! -d "$dstdir" ]; then 166 | defaultIFS=' 167 | ' 168 | IFS="${IFS-${defaultIFS}}" 169 | 170 | oIFS="${IFS}" 171 | # Some sh's can't handle IFS=/ for some reason. 172 | IFS='%' 173 | set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` 174 | IFS="${oIFS}" 175 | 176 | pathcomp='' 177 | 178 | while [ $# -ne 0 ] ; do 179 | pathcomp="${pathcomp}${1}" 180 | shift 181 | 182 | if [ ! -d "${pathcomp}" ] ; 183 | then 184 | $mkdirprog "${pathcomp}" 185 | else 186 | true 187 | fi 188 | 189 | pathcomp="${pathcomp}/" 190 | done 191 | fi 192 | 193 | if [ x"$dir_arg" != x ] 194 | then 195 | $doit $instcmd $dst && 196 | 197 | if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && 198 | if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && 199 | if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && 200 | if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi 201 | else 202 | 203 | # If we're going to rename the final executable, determine the name now. 204 | 205 | if [ x"$transformarg" = x ] 206 | then 207 | dstfile=`basename $dst` 208 | else 209 | dstfile=`basename $dst $transformbasename | 210 | sed $transformarg`$transformbasename 211 | fi 212 | 213 | # don't allow the sed command to completely eliminate the filename 214 | 215 | if [ x"$dstfile" = x ] 216 | then 217 | dstfile=`basename $dst` 218 | else 219 | true 220 | fi 221 | 222 | # Make a temp file name in the proper directory. 223 | 224 | dsttmp=$dstdir/#inst.$$# 225 | 226 | # Move or copy the file name to the temp name 227 | 228 | $doit $instcmd $src $dsttmp && 229 | 230 | trap "rm -f ${dsttmp}" 0 && 231 | 232 | # and set any options; do chmod last to preserve setuid bits 233 | 234 | # If any of these fail, we abort the whole thing. If we want to 235 | # ignore errors from any of these, just make sure not to ignore 236 | # errors from the above "$doit $instcmd $src $dsttmp" command. 237 | 238 | if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && 239 | if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && 240 | if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && 241 | if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && 242 | 243 | # Now rename the file to the real destination. 244 | 245 | $doit $rmcmd -f $dstdir/$dstfile && 246 | $doit $mvcmd $dsttmp $dstdir/$dstfile 247 | 248 | fi && 249 | 250 | 251 | exit 0 252 | -------------------------------------------------------------------------------- /test/hope_tut.in: -------------------------------------------------------------------------------- 1 | ! examples from "A Hope Tutorial", R. Bailey, Byte, August 1985. 2 | 3 | dec max: num # num -> num; 4 | --- max(x,y) <= if x>y then x else y; 5 | 6 | max(10,20) + max(1,max(2,3)); 7 | 8 | dec MaxOf3: num # num # num -> num; 9 | --- MaxOf3(x,y,z) <= max(x,max(y,z)); 10 | 11 | dec mult1: num # num -> num; 12 | --- mult1(x,y) <= if y=0 then 0 else mult1(x,y-1)+x; 13 | 14 | mult1(3,5); 15 | 16 | infix mult2 : 8; 17 | dec mult2: num # num -> num; 18 | --- x mult2 y <= if y=0 then 0 else x mult2(y-1)+x; 19 | 20 | 3 mult2 5; 21 | 22 | dec time24: num -> num # num # num; 23 | --- time24(s) <= (s div 3600, 24 | s mod 3600 div 60, 25 | s mod 3600 mod 60); 26 | 27 | time24(45756); 28 | 29 | 10 :: [20,30,40]; 30 | 31 | ['c','a','t']; 32 | 33 | dec nats: num -> list(num); 34 | --- nats(n) <= if n=0 then nil else n::nats(n-1); 35 | 36 | nats(10); 37 | 38 | dec revnats: num -> list(num); 39 | --- revnats(n) <= if n=0 then nil else revnats(n-1) <> [n]; 40 | 41 | revnats(10); 42 | 43 | dec sumlist: list(num) -> num; 44 | --- sumlist(x :: y) <= x + sumlist(y); 45 | --- sumlist(nil) <= 0; 46 | 47 | sumlist([1,2,3]); 48 | 49 | infix cat1: 4; 50 | dec cat1: list(num) # list(num) -> list(num); 51 | --- (h :: t) cat1 r <= h :: (t cat1 r); 52 | --- nil cat1 r <= r; 53 | 54 | infix mult3 : 8; 55 | dec mult3: num # num -> num; 56 | --- x mult3 0 <= 0; 57 | --- x mult3 succ(y) <= (x mult3 y) + x; 58 | 59 | 3 mult3 5; 60 | 61 | dec time12: num -> num # num; 62 | --- time12(s) <= (if h>12 then h-12 else h, m) where 63 | (h,m,s) == time24(s); 64 | 65 | time12(45756); 66 | 67 | dec firsttry: list(char) -> list(char); 68 | --- firsttry(nil) <= nil; 69 | --- firsttry(c :: s) <= if c = ' ' 70 | then nil 71 | else c :: firsttry(s); 72 | 73 | firsttry("You may hunt it with forks and Hope"); 74 | 75 | dec firstword: list(char) -> list(char) # list(char); 76 | --- firstword(nil) <= (nil,nil); 77 | --- firstword(c :: s) <= if c = ' ' 78 | then (nil,s) 79 | else ((c :: w),r) where 80 | (w,r) == firstword(s); 81 | 82 | firstword("Hope springs eternal ..."); 83 | 84 | dec wordlist: list(char) -> list(list(char)); 85 | --- wordlist(nil) <= nil; 86 | --- wordlist(c :: s) <= if c = ' ' 87 | then wordlist(s) 88 | else (w :: wordlist(r) where 89 | (w,r) == firstword(c :: s)); 90 | 91 | wordlist(" While there's life there's Hope "); 92 | 93 | typevar alpha; 94 | infix cat2: 4; 95 | dec cat2: list(alpha) -> list(alpha); 96 | 97 | data vague == yes ++ no ++ maybe; 98 | 99 | dec evade: vague -> vague; 100 | --- evade(yes) <= maybe; 101 | --- evade(maybe) <= no; 102 | 103 | data tiptree(alpha) == notree ++ leaf(alpha) ++ 104 | branch(tiptree(alpha) # tiptree(alpha)); 105 | 106 | dec sumtree: tiptree(num) -> num; 107 | --- sumtree(notree) <= 0; 108 | --- sumtree(leaf(n)) <= n; 109 | --- sumtree(branch(l,r)) <= sumtree(l) + sumtree(r); 110 | 111 | sumtree(branch(branch(leaf(1), 112 | branch(leaf(2), 113 | leaf(3))), 114 | branch(branch(notree, 115 | leaf(4)), 116 | leaf(5)))); 117 | 118 | dec flatten: tiptree(alpha) -> list(alpha); 119 | --- flatten(notree) <= nil; 120 | --- flatten(leaf(x)) <= [x]; 121 | --- flatten(branch(l,r)) <= flatten(l) <> flatten(r); 122 | 123 | flatten(branch(leaf(1),branch(leaf(2),leaf(3)))); 124 | 125 | flatten(branch(leaf("one"), 126 | branch(leaf("two"), 127 | leaf("three")))); 128 | 129 | flatten(branch(leaf(leaf('a')), 130 | branch(leaf(notree), 131 | leaf(branch(leaf('c'), 132 | notree))))); 133 | 134 | dec square: num -> num; 135 | --- square(n) <= n*n; 136 | 137 | dec squarelist: list(num) -> list(num); 138 | --- squarelist(nil) <= nil; 139 | --- squarelist(n :: l) <= square(n) :: squarelist(l); 140 | 141 | dec fact: num -> num; 142 | --- fact(0) <= 1; 143 | --- fact(succ(n)) <= succ(n) * fact(n); 144 | 145 | dec factlist: list(num) -> list(num); 146 | --- factlist(nil) <= nil; 147 | --- factlist(n :: l) <= fact(n) :: factlist(l); 148 | 149 | dec alllist: list(num) # (num -> num) -> list(num); 150 | --- alllist(nil, f) <= nil; 151 | --- alllist(n :: l, f) <= f(n) :: alllist(l,f); 152 | 153 | alllist([2,4,6], square); 154 | 155 | alllist([2,4,6], fact); 156 | 157 | typevar alpha, beta; 158 | 159 | dec map: list(alpha) # (alpha -> beta) -> list(beta); 160 | --- map(nil, f) <= nil; 161 | --- map(n :: l, f) <= f(n) :: map(l,f); 162 | 163 | typevar gamma; 164 | 165 | dec len: list(gamma) -> num; 166 | --- len(nil) <= 0; 167 | --- len(n :: l) <= 1 + len(l); 168 | 169 | len([2,4,6,8]) + len("cat"); 170 | 171 | map(wordlist("The form remains, the function never dies"), len); 172 | 173 | dec sum: list(num) -> num; 174 | --- sum(nil) <= 0; 175 | --- sum(n :: l) <= n + sum(l); 176 | 177 | dec reduce: list(alpha) # (alpha # beta -> beta) # beta -> beta; 178 | --- reduce(nil,f,b) <= b; 179 | --- reduce(n :: l,f,b) <= f(n, reduce(l,f,b)); 180 | 181 | reduce([1,2,3],nonop +, 0); 182 | 183 | dec addone: alpha # num -> num; 184 | --- addone(_, n) <= n + 1; 185 | 186 | reduce("a map they could all understand", addone, 0); 187 | 188 | dec insert: alpha # list(alpha) -> list(alpha); 189 | --- insert(i,nil) <= i :: nil; 190 | --- insert(i, h::t) <= if i < h 191 | then i :: (h :: t) 192 | else h :: insert(i,t); 193 | 194 | reduce("All sorts and conditions of men", insert, []); 195 | 196 | data tree(alpha) == empty ++ 197 | node(tree(alpha) # alpha # tree(alpha)); 198 | 199 | dec redtree: tree(alpha) # 200 | (alpha # beta -> beta) # 201 | beta -> beta; 202 | --- redtree(empty, f, b) <= b; 203 | --- redtree(node(l, v, r), f, b) <= redtree(l, f, f(v, redtree(r, f, b))); 204 | 205 | dec instree: alpha # tree(alpha) -> tree(alpha); 206 | --- instree(i, empty) <= node(empty,i,empty); 207 | --- instree(i,node(l,v,r)) <= if i < v 208 | then node(instree(i,l),v,r) 209 | else node(l,v,instree(i,r)); 210 | 211 | dec sort: list(alpha) -> list(alpha); 212 | --- sort(l) <= redtree(reduce(l, instree, empty), (::), []); 213 | 214 | sort("Mad dogs and Englishmen"); 215 | 216 | lambda(x,y) => x + y; 217 | 218 | reduce( [ "toe","tac","tic" ], lambda(a,b) => b <> a, []); 219 | 220 | map([1,0,2,0,3],lambda(0) => 0 | (succ(n)) => 100 div succ(n)); 221 | 222 | dec makestep: num -> (num -> num); 223 | --- makestep(i) <= lambda x => i + x; 224 | 225 | makestep ( 3 ); 226 | 227 | dec twice: (alpha -> alpha) -> (alpha -> alpha); 228 | --- twice(f) <= lambda x => f(f(x)); 229 | 230 | twice(square); 231 | 232 | twice(square)(3); 233 | 234 | twice(twice)(square)(3); 235 | -------------------------------------------------------------------------------- /src/expr.h: -------------------------------------------------------------------------------- 1 | #ifndef EXPR_H 2 | #define EXPR_H 3 | 4 | #include "defs.h" 5 | #include "newstring.h" 6 | #include "table.h" 7 | #include "path.h" 8 | #include "char.h" 9 | #include "num.h" 10 | 11 | typedef Cell *Function(Cell *value); 12 | typedef Num Unary(Num x); 13 | typedef Num Binary(Num x, Num y); 14 | 15 | struct _Func { 16 | TabElt f_linkage; 17 | short f_arity; 18 | SBool f_explicit_dec; /* explicitly declared */ 19 | SBool f_explicit_def; /* explicitly defined */ 20 | union { 21 | QType *fu_qtype; /* for explicitly declared funcs */ 22 | DefType *fu_tycons; /* for implicitly declared funcs */ 23 | } f_union; 24 | Branch *f_branch; 25 | UCase *f_code; 26 | }; 27 | #define f_name f_linkage.t_name 28 | #define f_qtype f_union.fu_qtype 29 | #define f_type f_qtype->qt_type 30 | #define f_ntvars f_qtype->qt_ntvars 31 | #define f_tycons f_union.fu_tycons 32 | 33 | extern void new_fn(String name, QType *qtype); 34 | extern void del_fn(Func *fn); 35 | extern Func *fn_lookup(String name); 36 | extern Func *fn_local(String name); 37 | 38 | extern void decl_value(String name, QType *qtype); 39 | extern void def_value(Expr *formals, Expr *body); 40 | 41 | /* 42 | * Expressions, including patterns. 43 | */ 44 | 45 | enum { 46 | /* kinds of input expression that also appear as patterns */ 47 | E_NUM, /* integer constant */ 48 | E_CHAR, /* character constant */ 49 | E_CONS, /* data structure constructor */ 50 | E_PAIR, /* pair constructor (,) */ 51 | E_APPLY, /* function application */ 52 | /* kinds of input pattern that don't appear in expressions */ 53 | E_VAR, /* variable in pattern */ 54 | E_PLUS, /* p+k pattern */ 55 | /* kinds of input expression that don't appear in patterns */ 56 | E_DEFUN, /* declared function or constant */ 57 | E_LAMBDA, /* anonymous (lambda) function */ 58 | E_PARAM, /* variable in expression */ 59 | E_MU, /* recursive form */ 60 | /* variants on APPLY, LAMBDA for building various constructs */ 61 | E_IF, /* if-then-else (like APPLY) */ 62 | E_WHERE, /* where clause (like APPLY) */ 63 | E_LET, /* let ... in clause (like APPLY) */ 64 | E_RWHERE, /* recursive where clause */ 65 | E_RLET, /* recursive let ... in clause */ 66 | E_EQN, /* let/where equation (like LAMBDA) */ 67 | E_PRESECT, /* (e op) (like LAMBDA) */ 68 | E_POSTSECT, /* (op e) (like LAMBDA) */ 69 | /* expressions used to represent built-in functions */ 70 | E_BUILTIN, /* lower level of built-in function */ 71 | /* Warning: this is misused by chk_argument() */ 72 | /* you should understand it before changing these */ 73 | E_BU_1MATH, /* lower level of unary built-in math function */ 74 | E_BU_2MATH, /* lower level of binary built-in math function */ 75 | /* miscellaneous */ 76 | E_RETURN, /* return from execution */ 77 | /* count of the above */ 78 | E_NCLASSES 79 | }; 80 | 81 | typedef char ExprClass; 82 | 83 | struct _Expr { 84 | ExprClass e_class; 85 | char e_misc_num; /* VAR, PARAM, LAMBDA, APPLY in branch */ 86 | union { /* grab bag -- see the definitions below */ 87 | Num eu_num; /* Num */ 88 | Char eu_char; /* CHAR */ 89 | Cons *eu_const; /* CONS */ 90 | struct { /* VAR */ 91 | String eu_vname; 92 | Path eu_dirs; 93 | } e_v; 94 | struct { /* PARAM */ 95 | Expr *eu_patt; 96 | Path eu_where; 97 | } e_p; 98 | struct { /* PAIR, MU */ 99 | Expr *eu_left; 100 | Expr *eu_right; 101 | } e_pair; 102 | struct { /* APPLY */ 103 | Expr *eu_func; 104 | Expr *eu_arg; 105 | } e_apply; 106 | struct { /* PLUS */ 107 | int eu_incr; 108 | Expr *eu_rest; 109 | } e_plus; 110 | Func *eu_defun; /* DEFUN */ 111 | struct { /* LAMBDA */ 112 | Branch *eu_branch; 113 | UCase *eu_code; 114 | } e_lambda; 115 | Function *eu_fn; /* BUILTIN */ 116 | Unary *eu_1math; /* BU_1MATH */ 117 | Binary *eu_2math; /* BU_2MATH */ 118 | } e_union; 119 | }; 120 | 121 | #define e_num e_union.eu_num /* Num */ 122 | #define e_char e_union.eu_char /* CHAR */ 123 | #define e_const e_union.eu_const /* CONS */ 124 | #define e_vname e_union.e_v.eu_vname /* VAR */ 125 | #define e_var e_misc_num /* VAR */ 126 | #define e_dirs e_union.e_v.eu_dirs /* VAR */ 127 | #define e_patt e_union.e_p.eu_patt /* PARAM */ 128 | #define e_level e_misc_num /* PARAM */ 129 | #define e_where e_union.e_p.eu_where /* PARAM */ 130 | #define e_left e_union.e_pair.eu_left /* PAIR */ 131 | #define e_right e_union.e_pair.eu_right /* PAIR */ 132 | #define e_func e_union.e_apply.eu_func /* APPLY */ 133 | #define e_arg e_union.e_apply.eu_arg /* APPLY */ 134 | #define e_nvars e_misc_num /* APPLY in branch */ 135 | #define e_incr e_union.e_plus.eu_incr /* PLUS */ 136 | #define e_rest e_union.e_plus.eu_rest /* PLUS */ 137 | 138 | #define e_defun e_union.eu_defun /* DEFUN */ 139 | #define e_arity e_misc_num /* LAMBDA */ 140 | #define e_branch e_union.e_lambda.eu_branch /* LAMBDA */ 141 | #define e_code e_union.e_lambda.eu_code /* LAMBDA */ 142 | 143 | #define e_muvar e_union.e_pair.eu_left /* MU */ 144 | #define e_body e_union.e_pair.eu_right /* MU */ 145 | 146 | #define e_fn e_union.eu_fn /* BUILTIN */ 147 | #define e_1math e_union.eu_1math /* BU_1MATH */ 148 | #define e_2math e_union.eu_2math /* BU_2MATH */ 149 | 150 | /* expression constructors */ 151 | extern Expr *char_expr(Char c); 152 | extern Expr *text_expr(const Byte *text, int n); 153 | extern Expr *num_expr(Num n); 154 | extern Expr *cons_expr(Cons *constr); 155 | extern Expr *id_expr(String name); 156 | extern Expr *dir_expr(Path where); 157 | extern Expr *pair_expr(Expr *left, Expr *right); 158 | extern Expr *apply_expr(Expr *func, Expr *arg); 159 | extern Expr *func_expr(Branch *branches); 160 | extern Expr *ite_expr(Expr *if_expr, Expr *then_expr, Expr *else_expr); 161 | extern Expr *let_expr(Expr *pattern, Expr *body, Expr *subexpr, Bool recursive); 162 | extern Expr *where_expr(Expr *subexpr, Expr *pattern, Expr *body, Bool recursive); 163 | extern Expr *mu_expr(Expr *muvar, Expr *body); 164 | extern Expr *presection(String operator, Expr *arg); 165 | extern Expr *postsection(String operator, Expr *arg); 166 | 167 | extern Expr *builtin_expr(Function *fn); 168 | extern Expr *bu_1math_expr(Unary *fn); 169 | extern Expr *bu_2math_expr(Binary *fn); 170 | 171 | extern void init_argv(void); 172 | 173 | /* 174 | * Internal names of some constructor expressions. 175 | */ 176 | 177 | extern Expr *e_true, *e_false; 178 | /* the next two are used for building lists, and force a list type */ 179 | extern Expr *e_cons, *e_nil; 180 | extern Func *f_id; 181 | 182 | struct _Branch { 183 | Expr *br_formals; /* parameters in an APPLY-list */ 184 | Expr *br_expr; /* the body */ 185 | Branch *br_next; /* next branch in lambda or defined fn */ 186 | }; 187 | 188 | /* branch constructors */ 189 | extern Branch *new_branch(Expr *formals, Expr *expr, Branch *next); 190 | extern Branch *new_unary(Expr *pattern, Expr *expr, Branch *next); 191 | 192 | /* the following are checked by nr_branch() */ 193 | #define MAX_VARIABLES 80 /* max. no. of variables visible */ 194 | #define MAX_SCOPES 40 /* max. no. of nested lambdas */ 195 | 196 | #endif 197 | -------------------------------------------------------------------------------- /src/builtin.c: -------------------------------------------------------------------------------- 1 | #include "defs.h" 2 | #include "builtin.h" 3 | #include "deftype.h" 4 | #include "cons.h" 5 | #include "value.h" 6 | #include "expr.h" 7 | #include "cases.h" 8 | #include "interpret.h" 9 | #include "stream.h" 10 | #include "output.h" 11 | #include "error.h" 12 | 13 | #define MAX_TMP_STRING 1024 14 | 15 | #ifndef REALS 16 | # define int_div divide 17 | #endif 18 | 19 | local void def_builtin(const char *name, Function *fn); 20 | local void def_1math(const char *name, Unary *fn); 21 | local void def_2math(const char *name, Binary *fn); 22 | local Bool check_arity(Type *type, int n); 23 | 24 | local Cell *ord(Cell *arg); 25 | local Cell *chr(Cell *arg); 26 | local Cell *num2str(Cell *arg); 27 | local Cell *str2num(Cell *arg); 28 | local Cell *user_error(Cell *arg); 29 | 30 | local Num plus(Num x, Num y); 31 | local Num minus(Num x, Num y); 32 | local Num times(Num x, Num y); 33 | local Num divide(Num x, Num y); 34 | local Num int_div(Num x, Num y); 35 | local Num mod(Num x, Num y); 36 | 37 | global void 38 | init_builtins(void) 39 | { 40 | def_builtin("ord", ord ); 41 | def_builtin("chr", chr ); 42 | def_builtin("read", open_stream ); 43 | def_builtin("num2str", num2str ); 44 | def_builtin("str2num", str2num ); 45 | def_builtin("error", user_error ); 46 | 47 | def_builtin("print", print_value ); 48 | def_builtin("write_element", write_value ); 49 | 50 | def_2math("+", plus ); 51 | def_2math("-", minus ); 52 | def_2math("*", times ); 53 | def_2math("/", divide ); 54 | def_2math("div", int_div ); 55 | def_2math("mod", mod ); 56 | 57 | #ifdef REALS 58 | #ifdef HAVE_LIBM 59 | def_1math("acos", acos ); 60 | def_1math("asin", asin ); 61 | def_1math("atan", atan ); 62 | def_2math("atan2", atan2 ); 63 | def_1math("ceil", ceil ); 64 | def_1math("cos", cos ); 65 | def_1math("cosh", cosh ); 66 | def_1math("exp", exp ); 67 | def_1math("abs", fabs ); 68 | def_1math("floor", floor ); 69 | def_1math("log", log ); 70 | def_1math("log10", log10 ); 71 | def_2math("pow", pow ); 72 | def_1math("sin", sin ); 73 | def_1math("sinh", sinh ); 74 | def_1math("sqrt", sqrt ); 75 | def_1math("tanh", tanh ); 76 | #endif 77 | #ifdef HAVE_ATANH 78 | def_1math("acosh", acosh ); 79 | def_1math("asinh", asinh ); 80 | def_1math("atanh", atanh ); 81 | #endif 82 | #ifdef HAVE_ERF 83 | def_1math("erf", erf ); 84 | def_1math("erfc", erfc ); 85 | #endif 86 | #ifdef HAVE_HYPOT 87 | def_2math("hypot", hypot ); 88 | #endif 89 | #endif 90 | } 91 | 92 | local void 93 | def_builtin(const char *name, Function *fn) 94 | { 95 | Func *bu; 96 | 97 | bu = fn_lookup(newstring(name)); 98 | if (bu == NULL) 99 | error(LIBERR, "'%s': undeclared built-in", name); 100 | bu->f_code = strict(builtin_expr(fn)); 101 | bu->f_arity = 1; 102 | bu->f_branch = NULL; 103 | } 104 | 105 | local void 106 | def_1math(const char *name, Unary *fn) 107 | { 108 | Func *bu; 109 | 110 | bu = fn_lookup(newstring(name)); 111 | if (bu == NULL) 112 | error(LIBERR, "'%s': undeclared built-in", name); 113 | if (! check_arity(bu->f_type, 1)) 114 | error(LIBERR, "'%s': built-in has wrong type", name); 115 | bu->f_code = strict(bu_1math_expr(fn)); 116 | bu->f_arity = 1; 117 | bu->f_branch = NULL; 118 | } 119 | 120 | local void 121 | def_2math(const char *name, Binary *fn) 122 | { 123 | Func *bu; 124 | 125 | bu = fn_lookup(newstring(name)); 126 | if (bu == NULL) 127 | error(LIBERR, "'%s': undeclared built-in", name); 128 | if (! check_arity(bu->f_type, 2)) 129 | error(LIBERR, "'%s': built-in has wrong type", name); 130 | bu->f_code = strict(bu_2math_expr(fn)); 131 | bu->f_arity = 1; 132 | bu->f_branch = NULL; 133 | } 134 | 135 | local Bool 136 | check_arity(Type *type, int n) 137 | { 138 | if (! (type->ty_class == TY_CONS && 139 | type->ty_deftype == function && 140 | type->ty_secondarg->ty_deftype == num)) 141 | return FALSE; 142 | for (type = type->ty_firstarg; n-- > 1; type = type->ty_secondarg) 143 | if (! (type->ty_class == TY_CONS && 144 | type->ty_deftype == product && 145 | type->ty_firstarg->ty_deftype == num)) 146 | return FALSE; 147 | return type->ty_class == TY_CONS && type->ty_deftype == num; 148 | } 149 | 150 | /* 151 | * Implementations of built-in functions. 152 | */ 153 | 154 | local Cell * 155 | ord(Cell *arg) 156 | { 157 | return new_num((Num)(arg->c_char)); 158 | } 159 | 160 | local Cell * 161 | chr(Cell *arg) 162 | { 163 | if (arg->c_num < Zero || arg->c_num > (Num)MaxChar) { 164 | start_err_line(); 165 | (void)fprintf(errout, " %s(", cur_function); 166 | (void)fprintf(errout, NUMfmt, arg->c_num); 167 | (void)fprintf(errout, ")\n"); 168 | error(EXECERR, "value out of range"); 169 | } 170 | return new_char((Char)(arg->c_num)); 171 | } 172 | 173 | local Cell * 174 | num2str(Cell *arg) 175 | { 176 | Byte strval[MAX_TMP_STRING]; 177 | 178 | (void)sprintf((char *)strval, NUMfmt, arg->c_num); 179 | return c2hope(strval); 180 | } 181 | 182 | local Cell * 183 | str2num(Cell *arg) 184 | { 185 | Byte strval[MAX_TMP_STRING]; 186 | 187 | hope2c(strval, MAX_TMP_STRING, arg); 188 | return new_num(atoNUM((char *)strval)); 189 | } 190 | 191 | local Cell * 192 | user_error(Cell *arg) 193 | { 194 | char strval[MAX_TMP_STRING]; 195 | 196 | hope2c((Byte *)strval, MAX_TMP_STRING, arg); 197 | error(USERERR, "%s", strval); 198 | NOT_REACHED; 199 | } 200 | 201 | /* 202 | * Convert a C string to a string value. 203 | */ 204 | global Cell * 205 | c2hope(const Byte *str) 206 | { 207 | const Byte *sp; 208 | Cell *cp; 209 | int len; 210 | 211 | len = strlen((const char *)str); 212 | chk_heap(NOCELL, 3*len+1); 213 | cp = new_cnst(nil); 214 | for (sp = str+len-1; sp >= str; sp--) 215 | cp = new_cons(cons, new_pair(new_char(*sp), cp)); 216 | return cp; 217 | } 218 | 219 | /* 220 | * Convert a string value to a C string. 221 | * It is an error if the string has more than n-1 characters. 222 | */ 223 | global void 224 | hope2c(Byte *s, int n, Cell *arg) 225 | { 226 | for ( ; n > 0 && arg->c_class == C_CONS; arg = arg->c_arg->c_right) { 227 | *s++ = arg->c_arg->c_left->c_char; 228 | n--; 229 | } 230 | if (n == 0) 231 | error(EXECERR, "%s: string too long", cur_function); 232 | *s = '\0'; 233 | } 234 | 235 | /* 236 | * Arithmetic operators. 237 | */ 238 | 239 | local Num plus(Num x, Num y) { return x + y; } 240 | local Num minus(Num x, Num y) { return x - y; } 241 | local Num times(Num x, Num y) { return x * y; } 242 | 243 | local Num 244 | divide(Num x, Num y) 245 | { 246 | if (y == Zero) 247 | error(EXECERR, "attempt to divide by zero"); 248 | return x / y; 249 | } 250 | 251 | #ifdef REALS 252 | local Num 253 | int_div(Num x, Num y) 254 | { 255 | if (y == Zero) 256 | error(EXECERR, "attempt to divide by zero"); 257 | return floor(x/y); 258 | } 259 | 260 | local Num 261 | mod(Num x, Num y) 262 | { 263 | if (y == Zero) 264 | error(EXECERR, "attempt to divide by zero"); 265 | return fmod(x, y); 266 | } 267 | #else 268 | local Num 269 | mod(Num x, Num y) 270 | { 271 | if (y == Zero) 272 | error(EXECERR, "attempt to divide by zero"); 273 | return x % y; 274 | } 275 | #endif 276 | --------------------------------------------------------------------------------