From 5c4e9900e27e8362e5478e80d1870c251cf5b277 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Thu, 30 Dec 2010 12:33:12 +0000 Subject: [PATCH] New language: Dylan. I'm using Gwydion Dylan (from CMU); I don't know how much weirder OpenDylan is, but the Dylan hackers are trying to converge the two. Dylan is annoying for small projects because we need /three/ source files. Oh, well. --- .gitignore | 2 + Makefile | 14 +++ dylan-fringe-exports.dylan | 20 +++++ dylan-fringe.dylan | 216 +++++++++++++++++++++++++++++++++++++++++++++ dylan-fringe.lid | 6 ++ 5 files changed, 258 insertions(+) create mode 100644 dylan-fringe-exports.dylan create mode 100644 dylan-fringe.dylan create mode 100644 dylan-fringe.lid diff --git a/.gitignore b/.gitignore index f5b66db..16dbd27 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,5 @@ test.log *.6 *.fasl *.beam +*.mak +dylan-*.c diff --git a/Makefile b/Makefile index 2c43ae8..1335df6 100644 --- a/Makefile +++ b/Makefile @@ -219,6 +219,20 @@ algol68-fringe: algol68-fringe.a68 } >$@.new $(V_HIDE)chmod +x $@.new && mv $@.new $@ +###-------------------------------------------------------------------------- +### Dylan. + +D2C = d2c +CLEANFILES += dylan-*.c *.mak + +LANGS += dylan +TARGETS += dylan-fringe +SOURCES += dylan-fringe.dylan dylan-fringe-exports.dylan +SOURCES += dylan-fringe.lid + +dylan-fringe: dylan-fringe.lid dylan-fringe.dylan dylan-fringe-exports.dylan + $(call v_echo,D2C)d2c -g $< + ###----- That's all, folks -------------------------------------------------- all:: $(TARGETS) diff --git a/dylan-fringe-exports.dylan b/dylan-fringe-exports.dylan new file mode 100644 index 0000000..5ee5d2e --- /dev/null +++ b/dylan-fringe-exports.dylan @@ -0,0 +1,20 @@ +module: dylan-user + +define library dylan-fringe + use dylan; + use streams; + use print; + use standard-io; + use format; + use format-out; +end; + +define module dylan-fringe + use dylan; + use extensions; + use streams; + use print; + use standard-io; + use format; + use format-out; +end; diff --git a/dylan-fringe.dylan b/dylan-fringe.dylan new file mode 100644 index 0000000..fcd256a --- /dev/null +++ b/dylan-fringe.dylan @@ -0,0 +1,216 @@ +module: dylan-fringe +language: infix-dylan +author: Mark Wooding +copyright: (c) 2010 Mark Wooding + +/* -*-dylan-*- + * + * Dylan implementation of a `same-fringe' solver. + */ + +///-------------------------------------------------------------------------- +/// Utilities. + +define macro loop + // loop (ESCAPE) BODY end [loop] + // + // Repeatedly evaluate the BODY, with ESCAPE bound to a procedure which + // causes the loop to end immediately and yield its argument. + + { loop (?escape:variable) ?:body end } + => { block (?escape) while (#t) ?body end end } +end; + +///-------------------------------------------------------------------------- +/// Nodes and trees. + +// We specialize methods on trees, whether leaves or non-leaves, so we need a +// common superclass. +define abstract class () end; + +// A leaf is an empty tree. We don't use #f because we need to specialize +// methods on empty trees too. We only need one leaf, but there's no point +// in being petty about it. +define class () end; +define constant $leaf = make(); + +// A node is a tree which carries data and has subtrees. +define class () + constant slot left :: , required-init-keyword: left:; + constant slot right :: , required-init-keyword: right:; + slot data, init-keyword: data:, init-value: #f; +end; + +// Use method dispatch to decide whether a tree is a leaf. +define generic leaf?(tree) => (p :: ); +define method leaf?(tree :: ) => (p :: ) #t end; +define method leaf?(tree :: ) => (p :: ) #f end; + +define method parse-tree + (string :: , + #key start :: = 0, + end: stop :: = string.size) + => (tree :: ) + // Parse STRING, and return the tree described. + // + // The syntax is simple: + // + // tree ::= empty | `(' tree char tree `)' + // + // The ambigity is resolved by always treating `(' as a tree when a tree is + // expected. + + local method parse(i :: ) => (tree :: , i :: ) + if (i >= stop | string[i] ~= '(') + values($leaf, i) + else + let (left, i) = parse(i + 1); + if (i >= stop) error("no data") end; + let data = string[i]; + let (right, i) = parse(i + 1); + if (i >= stop | string[i] ~= ')') error("missing )") end; + values(make(, left: left, right: right, data: data), i + 1) + end + end; + let (tree, i) = parse(start); + if (i ~= stop) error("trailing junk") end; + tree +end; + +define method print-object(tree :: , stream :: ) => () + // Print a TREE to the given STREAM. No newline is printed. + + local method recur(tree) + unless (tree.leaf?) + write(stream, "("); + recur(tree.left); + write-element(stream, tree.data); + recur(tree.right); + write(stream, ")"); + end + end; + recur(tree) +end; + +///-------------------------------------------------------------------------- +/// Iteration utilities. + +define method iterator(coll :: ) => (iter :: ) + // Return a function which iterates over the collection COLL. + // + // Each call to the function returns two values: ANY? is false if the + // collection is exhausted, or true if a new item was returned; and ITEM is + // the item from the collection. Obviously, ITEM is meaningful only if + // ANY? is true. + + let (state, final, next, finished?, key, item, item-setter, copy) = + forward-iteration-protocol(coll); + method () => (any? :: , item :: ) + if (finished?(coll, state, final)) + values(#f, #f) + else + let this = item(coll, state); + state := next(coll, state); + values(#t, this) + end + end +end; + +define method same-collections? + (coll-a :: , coll-b :: ) => (p :: ) + // Answer whether COLL-A and COLL-B contain the same elements (according to + // `=') in the same order. + + let iter-a = iterator(coll-a); + let iter-b = iterator(coll-b); + loop (done) + let (any-a, item-a) = iter-a(); + let (any-b, item-b) = iter-b(); + case + any-a ~= any-b => done(#f); + ~ any-a => done(#t); + item-a ~= item-b => done(#f); + end + end +end; + +///-------------------------------------------------------------------------- +/// Fringe iteration. + +define class () + // The iteration state for a tree. We remember the current node, and a + // closure which will produce the rest of the iteration. Iteration states + // are immutable. + + constant slot node :: , required-init-keyword: node:; + constant slot next :: , required-init-keyword: next:; +end; + +define method forward-iteration-protocol(tree :: ) + => (state, final, + next :: , finished? :: , + this-key :: , + this-item :: , this-item-setter :: , + copy :: ) + // Iteration protocol implementation for the fringe of a binary tree. + + local method iter(tree, after) + if (tree.leaf?) + after() + else + iter(tree.left, + method () + make(, + node: tree, + next: method () iter(tree.right, after) end) + end) + end + end; + + values(iter(tree, method () #f end), // initial state + #f, // final state + method (tree, state) state.next() end, // next state + method (tree, state, limit) ~ state end, // finished? + method (tree, state) state.node end, // current key + method (tree, state) state.node.data end, // current item + method (new, tree, state) state.node.data := new end, // modify item + identity) // copy state +end; + +///-------------------------------------------------------------------------- +/// Main program. + +define method main(argv0 :: , #rest argv) => () + let prog = begin + let last = 0; + for (i from 0 below argv0.size) + if (argv0[i] = '/') last := i + 1 end + end; + copy-sequence(argv0, start: last) + end; + block () + select (argv.size) + 1 => + let t = parse-tree(argv[0]); + let iter = iterator(t); + loop (done) + let (any?, item) = iter(); + unless (any?) done(#f) end; + write-element(*standard-output*, item); + end; + new-line(*standard-output*); + 2 => + let ta = parse-tree(argv[0]); + let tb = parse-tree(argv[1]); + format(*standard-output*, "%s\n", + if (same-collections?(ta, tb)) "match" else "no match" end); + otherwise + error("bad args"); + end + exception (cond :: ) + format(*standard-error*, "%s: %s\n", prog, cond); + exit(exit-code: 1) + end +end + +///----- That's all, folks -------------------------------------------------- diff --git a/dylan-fringe.lid b/dylan-fringe.lid new file mode 100644 index 0000000..a963232 --- /dev/null +++ b/dylan-fringe.lid @@ -0,0 +1,6 @@ +library: dylan-fringe +executable: dylan-fringe +entry-point: dylan-fringe:%main +files: + dylan-fringe-exports + dylan-fringe -- 2.11.0