├── LICENSE
├── Makefile
├── README.md
├── demos
    ├── d8-3404-d8-8424.html
    ├── d8-3404.cc
    ├── d8-8424.cc
    ├── demo1-demo2.html
    ├── demo1.html
    ├── demo1.yin
    ├── demo2.html
    ├── demo2.yin
    ├── diff-s.css
    ├── diff.css
    ├── diff1-diff2.html
    ├── diff1.rkt
    ├── diff2.rkt
    ├── ikarus1.ss
    ├── ikarus2.ss
    ├── mk1.ss
    ├── mk2.ss
    ├── paredit20-paredit22.html
    ├── paredit20.el
    ├── paredit22-paredit23.html
    ├── paredit22.el
    ├── paredit23.el
    ├── pass1-pass2.html
    ├── simulator-arm.cc
    ├── simulator-mips-simulator-arm.html
    ├── simulator-mips.cc
    ├── typed-clojure1-typed-clojure2.html
    ├── typed-clojure1.clj
    └── typed-clojure2.clj
├── diff-cpp.rkt
├── diff-js.rkt
├── diff-lisp.rkt
├── diff-yin.rkt
├── diff.css
├── diff.rkt
├── htmlize.rkt
├── nav.js
├── parse-cpp.rkt
├── parse-js.rkt
├── parse-lisp.rkt
├── parse-yin.rkt
├── parsec.rkt
├── structs.rkt
└── utils.rkt


/Makefile:
--------------------------------------------------------------------------------
1 | all:
2 | 	raco exe diff-lisp.rkt
3 | 	raco exe diff-cpp.rkt
4 | 	raco exe diff-js.rkt
5 | 	raco exe diff-yin.rkt
6 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | ydiff
 2 | =======
 3 | 
 4 | *a structural comparison tool for Lisp programs*
 5 | 
 6 | 
 7 | ### Demo
 8 | 
 9 | <a href="http://www.yinwang.org/resources/mk1-mk2.html"><img src="http://www.yinwang.org/images/ydiff3.gif"></a>
10 | 
11 | ### Features
12 | 
13 | * _Language-aware_. ydiff parses programs, understands basic language constructs and will not make non-sensical comparisons. For example it will not compare a string "10000" with an integer 10000 even though they look very similar. Also, it tries to match functions with the same name before it attempts to destruct and compare functions of different names.
14 | 
15 | * _Format insensitive_. The comparison result will not be affected by different number of white spaces, line breaks or indentation. For example, ydiff will not produce a large diff just because you surrounded a block of code with if (condition) {...}.
16 | 
17 | * _Moved code detection_. ydiff can find refactored code -- renamed, moved, reordered, wrapped, lifted, combined or fragmented code. Refactored code can be detected however deep they are into the structures.
18 | 
19 | * _Human-friendly output_. The output of ydiff is designed for human understanding. The interactive UI helps the user navigate and understand changes efficiently.
20 | 
21 | 
22 | ### No longer supported Languages
23 | 
24 | ydiff originally aim to support multiple languages, but I found that the parsers
25 | are very boring and tedious to get right. I hate languages with complicated
26 | syntax which makes parsing hard, so I decided to stop developing parsers for
27 | languages except the Lisp family. The C++ parser here is just to demonstrate how
28 | a mostly-right C++ can be constructed within two days of work ;-) You are
29 | welcome to take the code and extend to complete parsing C++ and JavaScript, but
30 | I can't provide any assistance.
31 | 
32 | 
33 | ### Installation
34 | 
35 | ydiff is implemented in Racket. You can get Racket from
36 | 
37 |     http://racket-lang.org
38 | 
39 | To build ydiff, go to the directory containing the source and run
40 | 
41 |     make
42 | 
43 | It should compile to several executables, such as `diff-lisp`,
44 | `diff-cpp`, `diff-js` etc. Copy those files to some directory in your
45 | PATH.
46 | 
47 | 
48 | 
49 | ### Usage
50 | 
51 | 1. Run commands like this example:
52 | 
53 |         diff-lisp demos/mk1.ss demos/mk2.ss
54 | 
55 |    It will produce a HTML file named "mk1-mk2.html" in the current
56 |    directory.
57 | 
58 | 
59 | 2. Use your browser to open the HTML file. That is basically it.
60 | 
61 | 
62 | 
63 | ### Caveats
64 | 
65 | 
66 | 1. The HTML file needs the support files `nav.js` and `diff.css` to be
67 |    present in the same directory. You must copy those files to the
68 |    directory where you ran the commands. This is not a good user
69 |    experience design and may be improved later.
70 | 
71 | 
72 | 
73 | ### Contact
74 | 
75 | Yin Wang (yinwang0@gmail.com)
76 | 
77 | 
78 | 
79 | #### License (GPLv3)
80 | 
81 | ydiff - a structural comparison tool for Lisp programs
82 | 
83 | Copyright (c) 2011-2014 Yin Wang
84 | 
85 | This program is free software: you can redistribute it and/or modify
86 | it under the terms of the GNU General Public License as published by
87 | the Free Software Foundation, either version 3 of the License, or
88 | (at your option) any later version.
89 | 
90 | This program is distributed in the hope that it will be useful,
91 | but WITHOUT ANY WARRANTY; without even the implied warranty of
92 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
93 | GNU General Public License for more details.
94 | 
95 | You should have received a copy of the GNU General Public License
96 | along with this program.  If not, see <http://www.gnu.org/licenses/>.
97 | 


--------------------------------------------------------------------------------
/demos/d8-3404.cc:
--------------------------------------------------------------------------------
  1 | // Copyright 2009 the V8 project authors. All rights reserved.
  2 | // Redistribution and use in source and binary forms, with or without
  3 | // modification, are permitted provided that the following conditions are
  4 | // met:
  5 | //
  6 | //     * Redistributions of source code must retain the above copyright
  7 | //       notice, this list of conditions and the following disclaimer.
  8 | //     * Redistributions in binary form must reproduce the above
  9 | //       copyright notice, this list of conditions and the following
 10 | //       disclaimer in the documentation and/or other materials provided
 11 | //       with the distribution.
 12 | //     * Neither the name of Google Inc. nor the names of its
 13 | //       contributors may be used to endorse or promote products derived
 14 | //       from this software without specific prior written permission.
 15 | //
 16 | // THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 17 | // "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 18 | // LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 19 | // A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 20 | // OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 21 | // SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 22 | // LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 23 | // DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 24 | // THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 25 | // (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 26 | // OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 27 | 
 28 | 
 29 | #include <stdlib.h>
 30 | #include <errno.h>
 31 | 
 32 | #include "d8.h"
 33 | #include "d8-debug.h"
 34 | #include "debug.h"
 35 | #include "api.h"
 36 | #include "natives.h"
 37 | #include "platform.h"
 38 | 
 39 | 
 40 | namespace v8 {
 41 | 
 42 | 
 43 | const char* Shell::kHistoryFileName = ".d8_history";
 44 | const char* Shell::kPrompt = "d8> ";
 45 | 
 46 | 
 47 | LineEditor *LineEditor::first_ = NULL;
 48 | 
 49 | 
 50 | LineEditor::LineEditor(Type type, const char* name)
 51 |     : type_(type),
 52 |       name_(name),
 53 |       next_(first_) {
 54 |   first_ = this;
 55 | }
 56 | 
 57 | 
 58 | LineEditor* LineEditor::Get() {
 59 |   LineEditor* current = first_;
 60 |   LineEditor* best = current;
 61 |   while (current != NULL) {
 62 |     if (current->type_ > best->type_)
 63 |       best = current;
 64 |     current = current->next_;
 65 |   }
 66 |   return best;
 67 | }
 68 | 
 69 | 
 70 | class DumbLineEditor: public LineEditor {
 71 |  public:
 72 |   DumbLineEditor() : LineEditor(LineEditor::DUMB, "dumb") { }
 73 |   virtual i::SmartPointer<char> Prompt(const char* prompt);
 74 | };
 75 | 
 76 | 
 77 | static DumbLineEditor dumb_line_editor;
 78 | 
 79 | 
 80 | i::SmartPointer<char> DumbLineEditor::Prompt(const char* prompt) {
 81 |   static const int kBufferSize = 256;
 82 |   char buffer[kBufferSize];
 83 |   printf("%s", prompt);
 84 |   char* str = fgets(buffer, kBufferSize, stdin);
 85 |   return i::SmartPointer<char>(str ? i::StrDup(str) : str);
 86 | }
 87 | 
 88 | 
 89 | CounterMap* Shell::counter_map_;
 90 | i::OS::MemoryMappedFile* Shell::counters_file_ = NULL;
 91 | CounterCollection Shell::local_counters_;
 92 | CounterCollection* Shell::counters_ = &local_counters_;
 93 | Persistent<Context> Shell::utility_context_;
 94 | Persistent<Context> Shell::evaluation_context_;
 95 | 
 96 | 
 97 | bool CounterMap::Match(void* key1, void* key2) {
 98 |   const char* name1 = reinterpret_cast<const char*>(key1);
 99 |   const char* name2 = reinterpret_cast<const char*>(key2);
100 |   return strcmp(name1, name2) == 0;
101 | }
102 | 
103 | 
104 | // Converts a V8 value to a C string.
105 | const char* ToCString(const v8::String::Utf8Value& value) {
106 |   return *value ? *value : "<string conversion failed>";
107 | }
108 | 
109 | 
110 | // Executes a string within the current v8 context.
111 | bool Shell::ExecuteString(Handle<String> source,
112 |                           Handle<Value> name,
113 |                           bool print_result,
114 |                           bool report_exceptions) {
115 |   HandleScope handle_scope;
116 |   TryCatch try_catch;
117 |   if (i::FLAG_debugger) {
118 |     // When debugging make exceptions appear to be uncaught.
119 |     try_catch.SetVerbose(true);
120 |   }
121 |   Handle<Script> script = Script::Compile(source, name);
122 |   if (script.IsEmpty()) {
123 |     // Print errors that happened during compilation.
124 |     if (report_exceptions && !i::FLAG_debugger)
125 |       ReportException(&try_catch);
126 |     return false;
127 |   } else {
128 |     Handle<Value> result = script->Run();
129 |     if (result.IsEmpty()) {
130 |       // Print errors that happened during execution.
131 |       if (report_exceptions && !i::FLAG_debugger)
132 |         ReportException(&try_catch);
133 |       return false;
134 |     } else {
135 |       if (print_result && !result->IsUndefined()) {
136 |         // If all went well and the result wasn't undefined then print
137 |         // the returned value.
138 |         v8::String::Utf8Value str(result);
139 |         const char* cstr = ToCString(str);
140 |         printf("%s\n", cstr);
141 |       }
142 |       return true;
143 |     }
144 |   }
145 | }
146 | 
147 | 
148 | Handle<Value> Shell::Print(const Arguments& args) {
149 |   Handle<Value> val = Write(args);
150 |   printf("\n");
151 |   return val;
152 | }
153 | 
154 | 
155 | Handle<Value> Shell::Write(const Arguments& args) {
156 |   for (int i = 0; i < args.Length(); i++) {
157 |     HandleScope handle_scope;
158 |     if (i != 0) {
159 |       printf(" ");
160 |     }
161 |     v8::String::Utf8Value str(args[i]);
162 |     int n = fwrite(*str, sizeof(**str), str.length(), stdout);
163 |     if (n != str.length()) {
164 |       printf("Error in fwrite\n");
165 |       exit(1);
166 |     }
167 |   }
168 |   return Undefined();
169 | }
170 | 
171 | 
172 | Handle<Value> Shell::Read(const Arguments& args) {
173 |   String::Utf8Value file(args[0]);
174 |   if (*file == NULL) {
175 |     return ThrowException(String::New("Error loading file"));
176 |   }
177 |   Handle<String> source = ReadFile(*file);
178 |   if (source.IsEmpty()) {
179 |     return ThrowException(String::New("Error loading file"));
180 |   }
181 |   return source;
182 | }
183 | 
184 | 
185 | Handle<Value> Shell::ReadLine(const Arguments& args) {
186 |   i::SmartPointer<char> line(i::ReadLine(""));
187 |   if (*line == NULL) {
188 |     return Null();
189 |   }
190 |   size_t len = strlen(*line);
191 |   if (len > 0 && line[len - 1] == '\n') {
192 |     --len;
193 |   }
194 |   return String::New(*line, len);
195 | }
196 | 
197 | 
198 | Handle<Value> Shell::Load(const Arguments& args) {
199 |   for (int i = 0; i < args.Length(); i++) {
200 |     HandleScope handle_scope;
201 |     String::Utf8Value file(args[i]);
202 |     if (*file == NULL) {
203 |       return ThrowException(String::New("Error loading file"));
204 |     }
205 |     Handle<String> source = ReadFile(*file);
206 |     if (source.IsEmpty()) {
207 |       return ThrowException(String::New("Error loading file"));
208 |     }
209 |     if (!ExecuteString(source, String::New(*file), false, false)) {
210 |       return ThrowException(String::New("Error executing file"));
211 |     }
212 |   }
213 |   return Undefined();
214 | }
215 | 
216 | 
217 | Handle<Value> Shell::Yield(const Arguments& args) {
218 |   v8::Unlocker unlocker;
219 |   return Undefined();
220 | }
221 | 
222 | 
223 | Handle<Value> Shell::Quit(const Arguments& args) {
224 |   int exit_code = args[0]->Int32Value();
225 |   OnExit();
226 |   exit(exit_code);
227 |   return Undefined();
228 | }
229 | 
230 | 
231 | Handle<Value> Shell::Version(const Arguments& args) {
232 |   return String::New(V8::GetVersion());
233 | }
234 | 
235 | 
236 | void Shell::ReportException(v8::TryCatch* try_catch) {
237 |   HandleScope handle_scope;
238 |   v8::String::Utf8Value exception(try_catch->Exception());
239 |   const char* exception_string = ToCString(exception);
240 |   Handle<Message> message = try_catch->Message();
241 |   if (message.IsEmpty()) {
242 |     // V8 didn't provide any extra information about this error; just
243 |     // print the exception.
244 |     printf("%s\n", exception_string);
245 |   } else {
246 |     // Print (filename):(line number): (message).
247 |     v8::String::Utf8Value filename(message->GetScriptResourceName());
248 |     const char* filename_string = ToCString(filename);
249 |     int linenum = message->GetLineNumber();
250 |     printf("%s:%i: %s\n", filename_string, linenum, exception_string);
251 |     // Print line of source code.
252 |     v8::String::Utf8Value sourceline(message->GetSourceLine());
253 |     const char* sourceline_string = ToCString(sourceline);
254 |     printf("%s\n", sourceline_string);
255 |     // Print wavy underline (GetUnderline is deprecated).
256 |     int start = message->GetStartColumn();
257 |     for (int i = 0; i < start; i++) {
258 |       printf(" ");
259 |     }
260 |     int end = message->GetEndColumn();
261 |     for (int i = start; i < end; i++) {
262 |       printf("^");
263 |     }
264 |     printf("\n");
265 |   }
266 | }
267 | 
268 | 
269 | Handle<Array> Shell::GetCompletions(Handle<String> text, Handle<String> full) {
270 |   HandleScope handle_scope;
271 |   Context::Scope context_scope(utility_context_);
272 |   Handle<Object> global = utility_context_->Global();
273 |   Handle<Value> fun = global->Get(String::New("GetCompletions"));
274 |   static const int kArgc = 3;
275 |   Handle<Value> argv[kArgc] = { evaluation_context_->Global(), text, full };
276 |   Handle<Value> val = Handle<Function>::Cast(fun)->Call(global, kArgc, argv);
277 |   return handle_scope.Close(Handle<Array>::Cast(val));
278 | }
279 | 
280 | 
281 | #ifdef ENABLE_DEBUGGER_SUPPORT
282 | Handle<Object> Shell::DebugMessageDetails(Handle<String> message) {
283 |   Context::Scope context_scope(utility_context_);
284 |   Handle<Object> global = utility_context_->Global();
285 |   Handle<Value> fun = global->Get(String::New("DebugMessageDetails"));
286 |   static const int kArgc = 1;
287 |   Handle<Value> argv[kArgc] = { message };
288 |   Handle<Value> val = Handle<Function>::Cast(fun)->Call(global, kArgc, argv);
289 |   return Handle<Object>::Cast(val);
290 | }
291 | 
292 | 
293 | Handle<Value> Shell::DebugCommandToJSONRequest(Handle<String> command) {
294 |   Context::Scope context_scope(utility_context_);
295 |   Handle<Object> global = utility_context_->Global();
296 |   Handle<Value> fun = global->Get(String::New("DebugCommandToJSONRequest"));
297 |   static const int kArgc = 1;
298 |   Handle<Value> argv[kArgc] = { command };
299 |   Handle<Value> val = Handle<Function>::Cast(fun)->Call(global, kArgc, argv);
300 |   return val;
301 | }
302 | #endif
303 | 
304 | 
305 | int32_t* Counter::Bind(const char* name, bool is_histogram) {
306 |   int i;
307 |   for (i = 0; i < kMaxNameSize - 1 && name[i]; i++)
308 |     name_[i] = static_cast<char>(name[i]);
309 |   name_[i] = '\0';
310 |   is_histogram_ = is_histogram;
311 |   return ptr();
312 | }
313 | 
314 | 
315 | void Counter::AddSample(int32_t sample) {
316 |   count_++;
317 |   sample_total_ += sample;
318 | }
319 | 
320 | 
321 | CounterCollection::CounterCollection() {
322 |   magic_number_ = 0xDEADFACE;
323 |   max_counters_ = kMaxCounters;
324 |   max_name_size_ = Counter::kMaxNameSize;
325 |   counters_in_use_ = 0;
326 | }
327 | 
328 | 
329 | Counter* CounterCollection::GetNextCounter() {
330 |   if (counters_in_use_ == kMaxCounters) return NULL;
331 |   return &counters_[counters_in_use_++];
332 | }
333 | 
334 | 
335 | void Shell::MapCounters(const char* name) {
336 |   counters_file_ = i::OS::MemoryMappedFile::create(name,
337 |     sizeof(CounterCollection), &local_counters_);
338 |   void* memory = (counters_file_ == NULL) ?
339 |       NULL : counters_file_->memory();
340 |   if (memory == NULL) {
341 |     printf("Could not map counters file %s\n", name);
342 |     exit(1);
343 |   }
344 |   counters_ = static_cast<CounterCollection*>(memory);
345 |   V8::SetCounterFunction(LookupCounter);
346 |   V8::SetCreateHistogramFunction(CreateHistogram);
347 |   V8::SetAddHistogramSampleFunction(AddHistogramSample);
348 | }
349 | 
350 | 
351 | int CounterMap::Hash(const char* name) {
352 |   int h = 0;
353 |   int c;
354 |   while ((c = *name++) != 0) {
355 |     h += h << 5;
356 |     h += c;
357 |   }
358 |   return h;
359 | }
360 | 
361 | 
362 | Counter* Shell::GetCounter(const char* name, bool is_histogram) {
363 |   Counter* counter = counter_map_->Lookup(name);
364 | 
365 |   if (counter == NULL) {
366 |     counter = counters_->GetNextCounter();
367 |     if (counter != NULL) {
368 |       counter_map_->Set(name, counter);
369 |       counter->Bind(name, is_histogram);
370 |     }
371 |   } else {
372 |     ASSERT(counter->is_histogram() == is_histogram);
373 |   }
374 |   return counter;
375 | }
376 | 
377 | 
378 | int* Shell::LookupCounter(const char* name) {
379 |   Counter* counter = GetCounter(name, false);
380 | 
381 |   if (counter != NULL) {
382 |     return counter->ptr();
383 |   } else {
384 |     return NULL;
385 |   }
386 | }
387 | 
388 | 
389 | void* Shell::CreateHistogram(const char* name,
390 |                              int min,
391 |                              int max,
392 |                              size_t buckets) {
393 |   return GetCounter(name, true);
394 | }
395 | 
396 | 
397 | void Shell::AddHistogramSample(void* histogram, int sample) {
398 |   Counter* counter = reinterpret_cast<Counter*>(histogram);
399 |   counter->AddSample(sample);
400 | }
401 | 
402 | 
403 | void Shell::Initialize() {
404 |   Shell::counter_map_ = new CounterMap();
405 |   // Set up counters
406 |   if (i::FLAG_map_counters != NULL)
407 |     MapCounters(i::FLAG_map_counters);
408 |   if (i::FLAG_dump_counters) {
409 |     V8::SetCounterFunction(LookupCounter);
410 |     V8::SetCreateHistogramFunction(CreateHistogram);
411 |     V8::SetAddHistogramSampleFunction(AddHistogramSample);
412 |   }
413 | 
414 |   // Initialize the global objects
415 |   HandleScope scope;
416 |   Handle<ObjectTemplate> global_template = ObjectTemplate::New();
417 |   global_template->Set(String::New("print"), FunctionTemplate::New(Print));
418 |   global_template->Set(String::New("write"), FunctionTemplate::New(Write));
419 |   global_template->Set(String::New("read"), FunctionTemplate::New(Read));
420 |   global_template->Set(String::New("readline"),
421 |                        FunctionTemplate::New(ReadLine));
422 |   global_template->Set(String::New("load"), FunctionTemplate::New(Load));
423 |   global_template->Set(String::New("quit"), FunctionTemplate::New(Quit));
424 |   global_template->Set(String::New("version"), FunctionTemplate::New(Version));
425 | 
426 |   Handle<ObjectTemplate> os_templ = ObjectTemplate::New();
427 |   AddOSMethods(os_templ);
428 |   global_template->Set(String::New("os"), os_templ);
429 | 
430 |   utility_context_ = Context::New(NULL, global_template);
431 |   utility_context_->SetSecurityToken(Undefined());
432 |   Context::Scope utility_scope(utility_context_);
433 | 
434 |   i::JSArguments js_args = i::FLAG_js_arguments;
435 |   i::Handle<i::FixedArray> arguments_array =
436 |       i::Factory::NewFixedArray(js_args.argc());
437 |   for (int j = 0; j < js_args.argc(); j++) {
438 |     i::Handle<i::String> arg =
439 |         i::Factory::NewStringFromUtf8(i::CStrVector(js_args[j]));
440 |     arguments_array->set(j, *arg);
441 |   }
442 |   i::Handle<i::JSArray> arguments_jsarray =
443 |       i::Factory::NewJSArrayWithElements(arguments_array);
444 |   global_template->Set(String::New("arguments"),
445 |                        Utils::ToLocal(arguments_jsarray));
446 | 
447 | #ifdef ENABLE_DEBUGGER_SUPPORT
448 |   // Install the debugger object in the utility scope
449 |   i::Debug::Load();
450 |   i::JSObject* debug = i::Debug::debug_context()->global();
451 |   utility_context_->Global()->Set(String::New("$debug"),
452 |                                   Utils::ToLocal(&debug));
453 | #endif
454 | 
455 |   // Run the d8 shell utility script in the utility context
456 |   int source_index = i::NativesCollection<i::D8>::GetIndex("d8");
457 |   i::Vector<const char> shell_source
458 |       = i::NativesCollection<i::D8>::GetScriptSource(source_index);
459 |   i::Vector<const char> shell_source_name
460 |       = i::NativesCollection<i::D8>::GetScriptName(source_index);
461 |   Handle<String> source = String::New(shell_source.start(),
462 |                                       shell_source.length());
463 |   Handle<String> name = String::New(shell_source_name.start(),
464 |                                     shell_source_name.length());
465 |   Handle<Script> script = Script::Compile(source, name);
466 |   script->Run();
467 | 
468 |   // Mark the d8 shell script as native to avoid it showing up as normal source
469 |   // in the debugger.
470 |   i::Handle<i::JSFunction> script_fun = Utils::OpenHandle(*script);
471 |   i::Handle<i::Script> script_object =
472 |       i::Handle<i::Script>(i::Script::cast(script_fun->shared()->script()));
473 |   script_object->set_type(i::Smi::FromInt(i::Script::TYPE_NATIVE));
474 | 
475 |   // Create the evaluation context
476 |   evaluation_context_ = Context::New(NULL, global_template);
477 |   evaluation_context_->SetSecurityToken(Undefined());
478 | 
479 | #ifdef ENABLE_DEBUGGER_SUPPORT
480 |   // Set the security token of the debug context to allow access.
481 |   i::Debug::debug_context()->set_security_token(i::Heap::undefined_value());
482 | 
483 |   // Start the debugger agent if requested.
484 |   if (i::FLAG_debugger_agent) {
485 |     v8::Debug::EnableAgent("d8 shell", i::FLAG_debugger_port);
486 |   }
487 | 
488 |   // Start the in-process debugger if requested.
489 |   if (i::FLAG_debugger && !i::FLAG_debugger_agent) {
490 |     v8::Debug::SetDebugEventListener(HandleDebugEvent);
491 |   }
492 | #endif
493 | }
494 | 
495 | 
496 | void Shell::OnExit() {
497 |   if (i::FLAG_dump_counters) {
498 |     ::printf("+----------------------------------------+-------------+\n");
499 |     ::printf("| Name                                   | Value       |\n");
500 |     ::printf("+----------------------------------------+-------------+\n");
501 |     for (CounterMap::Iterator i(counter_map_); i.More(); i.Next()) {
502 |       Counter* counter = i.CurrentValue();
503 |       if (counter->is_histogram()) {
504 |         ::printf("| c:%-36s | %11i |\n", i.CurrentKey(), counter->count());
505 |         ::printf("| t:%-36s | %11i |\n",
506 |                  i.CurrentKey(),
507 |                  counter->sample_total());
508 |       } else {
509 |         ::printf("| %-38s | %11i |\n", i.CurrentKey(), counter->count());
510 |       }
511 |     }
512 |     ::printf("+----------------------------------------+-------------+\n");
513 |   }
514 |   if (counters_file_ != NULL)
515 |     delete counters_file_;
516 | }
517 | 
518 | 
519 | static char* ReadChars(const char* name, int* size_out) {
520 |   v8::Unlocker unlocker;  // Release the V8 lock while reading files.
521 |   FILE* file = i::OS::FOpen(name, "rb");
522 |   if (file == NULL) return NULL;
523 | 
524 |   fseek(file, 0, SEEK_END);
525 |   int size = ftell(file);
526 |   rewind(file);
527 | 
528 |   char* chars = new char[size + 1];
529 |   chars[size] = '\0';
530 |   for (int i = 0; i < size;) {
531 |     int read = fread(&chars[i], 1, size - i, file);
532 |     i += read;
533 |   }
534 |   fclose(file);
535 |   *size_out = size;
536 |   return chars;
537 | }
538 | 
539 | 
540 | static char* ReadToken(char* data, char token) {
541 |   char* next = i::OS::StrChr(data, token);
542 |   if (next != NULL) {
543 |     *next = '\0';
544 |     return (next + 1);
545 |   }
546 | 
547 |   return NULL;
548 | }
549 | 
550 | 
551 | static char* ReadLine(char* data) {
552 |   return ReadToken(data, '\n');
553 | }
554 | 
555 | 
556 | static char* ReadWord(char* data) {
557 |   return ReadToken(data, ' ');
558 | }
559 | 
560 | 
561 | // Reads a file into a v8 string.
562 | Handle<String> Shell::ReadFile(const char* name) {
563 |   int size = 0;
564 |   char* chars = ReadChars(name, &size);
565 |   if (chars == NULL) return Handle<String>();
566 |   Handle<String> result = String::New(chars);
567 |   delete[] chars;
568 |   return result;
569 | }
570 | 
571 | 
572 | void Shell::RunShell() {
573 |   LineEditor* editor = LineEditor::Get();
574 |   printf("V8 version %s [console: %s]\n", V8::GetVersion(), editor->name());
575 |   editor->Open();
576 |   while (true) {
577 |     Locker locker;
578 |     HandleScope handle_scope;
579 |     Context::Scope context_scope(evaluation_context_);
580 |     i::SmartPointer<char> input = editor->Prompt(Shell::kPrompt);
581 |     if (input.is_empty())
582 |       break;
583 |     editor->AddHistory(*input);
584 |     Handle<String> name = String::New("(d8)");
585 |     ExecuteString(String::New(*input), name, true, true);
586 |   }
587 |   editor->Close();
588 |   printf("\n");
589 | }
590 | 
591 | 
592 | class ShellThread : public i::Thread {
593 |  public:
594 |   ShellThread(int no, i::Vector<const char> files)
595 |     : no_(no), files_(files) { }
596 |   virtual void Run();
597 |  private:
598 |   int no_;
599 |   i::Vector<const char> files_;
600 | };
601 | 
602 | 
603 | void ShellThread::Run() {
604 |   // Prepare the context for this thread.
605 |   Locker locker;
606 |   HandleScope scope;
607 |   Handle<ObjectTemplate> global_template = ObjectTemplate::New();
608 |   global_template->Set(String::New("print"),
609 |                        FunctionTemplate::New(Shell::Print));
610 |   global_template->Set(String::New("write"),
611 |                        FunctionTemplate::New(Shell::Write));
612 |   global_template->Set(String::New("read"),
613 |                        FunctionTemplate::New(Shell::Read));
614 |   global_template->Set(String::New("readline"),
615 |                        FunctionTemplate::New(Shell::ReadLine));
616 |   global_template->Set(String::New("load"),
617 |                        FunctionTemplate::New(Shell::Load));
618 |   global_template->Set(String::New("yield"),
619 |                        FunctionTemplate::New(Shell::Yield));
620 |   global_template->Set(String::New("version"),
621 |                        FunctionTemplate::New(Shell::Version));
622 | 
623 |   char* ptr = const_cast<char*>(files_.start());
624 |   while ((ptr != NULL) && (*ptr != '\0')) {
625 |     // For each newline-separated line.
626 |     char* next_line = ReadLine(ptr);
627 | 
628 |     if (*ptr == '#') {
629 |       // Skip comment lines.
630 |       ptr = next_line;
631 |       continue;
632 |     }
633 | 
634 |     Persistent<Context> thread_context = Context::New(NULL, global_template);
635 |     thread_context->SetSecurityToken(Undefined());
636 |     Context::Scope context_scope(thread_context);
637 | 
638 |     while ((ptr != NULL) && (*ptr != '\0')) {
639 |       char* filename = ptr;
640 |       ptr = ReadWord(ptr);
641 | 
642 |       // Skip empty strings.
643 |       if (strlen(filename) == 0) {
644 |         break;
645 |       }
646 | 
647 |       Handle<String> str = Shell::ReadFile(filename);
648 |       if (str.IsEmpty()) {
649 |         printf("WARNING: %s not found\n", filename);
650 |         break;
651 |       }
652 | 
653 |       Shell::ExecuteString(str, String::New(filename), false, false);
654 |     }
655 | 
656 |     thread_context.Dispose();
657 |     ptr = next_line;
658 |   }
659 | }
660 | 
661 | 
662 | int Shell::Main(int argc, char* argv[]) {
663 |   i::FlagList::SetFlagsFromCommandLine(&argc, argv, true);
664 |   if (i::FLAG_help) {
665 |     return 1;
666 |   }
667 |   Initialize();
668 |   bool run_shell = (argc == 1);
669 | 
670 |   // Default use preemption if threads are created.
671 |   bool use_preemption = true;
672 | 
673 |   // Default to use lowest possible thread preemption interval to test as many
674 |   // edgecases as possible.
675 |   int preemption_interval = 1;
676 | 
677 |   i::List<i::Thread*> threads(1);
678 | 
679 |   {
680 |     // Acquire the V8 lock once initialization has finished. Since the thread
681 |     // below may spawn new threads accessing V8 holding the V8 lock here is
682 |     // mandatory.
683 |     Locker locker;
684 |     Context::Scope context_scope(evaluation_context_);
685 |     for (int i = 1; i < argc; i++) {
686 |       char* str = argv[i];
687 |       if (strcmp(str, "--shell") == 0) {
688 |         run_shell = true;
689 |       } else if (strcmp(str, "--preemption") == 0) {
690 |         use_preemption = true;
691 |       } else if (strcmp(str, "--no-preemption") == 0) {
692 |         use_preemption = false;
693 |       } else if (strcmp(str, "--preemption-interval") == 0) {
694 |         if (i + 1 < argc) {
695 |           char* end = NULL;
696 |           preemption_interval = strtol(argv[++i], &end, 10);  // NOLINT
697 |           if (preemption_interval <= 0 || *end != '\0' || errno == ERANGE) {
698 |             printf("Invalid value for --preemption-interval '%s'\n", argv[i]);
699 |             return 1;
700 |           }
701 |         } else {
702 |           printf("Missing value for --preemption-interval\n");
703 |           return 1;
704 |        }
705 |       } else if (strcmp(str, "-f") == 0) {
706 |         // Ignore any -f flags for compatibility with other stand-alone
707 |         // JavaScript engines.
708 |         continue;
709 |       } else if (strncmp(str, "--", 2) == 0) {
710 |         printf("Warning: unknown flag %s.\nTry --help for options\n", str);
711 |       } else if (strcmp(str, "-e") == 0 && i + 1 < argc) {
712 |         // Execute argument given to -e option directly.
713 |         v8::HandleScope handle_scope;
714 |         v8::Handle<v8::String> file_name = v8::String::New("unnamed");
715 |         v8::Handle<v8::String> source = v8::String::New(argv[i + 1]);
716 |         if (!ExecuteString(source, file_name, false, true)) {
717 |           OnExit();
718 |           return 1;
719 |         }
720 |         i++;
721 |       } else if (strcmp(str, "-p") == 0 && i + 1 < argc) {
722 |         int size = 0;
723 |         const char* files = ReadChars(argv[++i], &size);
724 |         if (files == NULL) return 1;
725 |         ShellThread* thread =
726 |             new ShellThread(threads.length(),
727 |                             i::Vector<const char>(files, size));
728 |         thread->Start();
729 |         threads.Add(thread);
730 |       } else {
731 |         // Use all other arguments as names of files to load and run.
732 |         HandleScope handle_scope;
733 |         Handle<String> file_name = v8::String::New(str);
734 |         Handle<String> source = ReadFile(str);
735 |         if (source.IsEmpty()) {
736 |           printf("Error reading '%s'\n", str);
737 |           return 1;
738 |         }
739 |         if (!ExecuteString(source, file_name, false, true)) {
740 |           OnExit();
741 |           return 1;
742 |         }
743 |       }
744 |     }
745 | 
746 |     // Start preemption if threads have been created and preemption is enabled.
747 |     if (threads.length() > 0 && use_preemption) {
748 |       Locker::StartPreemption(preemption_interval);
749 |     }
750 | 
751 | #ifdef ENABLE_DEBUGGER_SUPPORT
752 |     // Run the remote debugger if requested.
753 |     if (i::FLAG_remote_debugger) {
754 |       RunRemoteDebugger(i::FLAG_debugger_port);
755 |       return 0;
756 |     }
757 | #endif
758 |   }
759 |   if (run_shell)
760 |     RunShell();
761 |   for (int i = 0; i < threads.length(); i++) {
762 |     i::Thread* thread = threads[i];
763 |     thread->Join();
764 |     delete thread;
765 |   }
766 |   OnExit();
767 |   return 0;
768 | }
769 | 
770 | 
771 | }  // namespace v8
772 | 
773 | 
774 | int main(int argc, char* argv[]) {
775 |   return v8::Shell::Main(argc, argv);
776 | }
777 | 


--------------------------------------------------------------------------------
/demos/demo1-demo2.html:
--------------------------------------------------------------------------------
1 | <frameset cols="50%,50%">
2 | <frame name="left" src="demo1.html">
3 | <frame name="right" src="demo2.html">
4 | </frameset>
5 | 


--------------------------------------------------------------------------------
/demos/demo1.yin:
--------------------------------------------------------------------------------
 1 | (define even
 2 |   (fun ([x Int] [-> Bool])
 3 |     (if (= x 0)
 4 |         true
 5 |         (if (= x 1)
 6 |             false
 7 |             (odd (- x 1))))))
 8 | 
 9 | 
10 | 
11 | 
12 | 
13 | 
14 | 
15 | 
16 | (define odd
17 |   (fun ([x Int] [-> Bool])
18 |     (if (= x 0)
19 |         false
20 |         (if (= x 1)
21 |             true
22 |             (even (- x 1))))))
23 | 
24 | 
25 | 
26 | 
27 | 
28 | 
29 | 
30 | 
31 | (even 10)  -- true
32 | (even 11)  -- false
33 | (odd 10)   -- false
34 | (odd 11)   -- true
35 | 
36 | 
37 | 
38 | 
39 | 
40 | 
41 | (define fact
42 |   (fun ([x Int] [-> Int])
43 |     (if (= x 0) 1 (* x (fact (- x 1))))))
44 | 
45 | 
46 | 
47 | (fact 5)                -- 120
48 | 


--------------------------------------------------------------------------------
/demos/demo2.yin:
--------------------------------------------------------------------------------
 1 | (define fact
 2 |   (fun ([x Int] [-> Int])
 3 |     (if (= x 0) 1 (* x (fact (- x 1))))))
 4 | 
 5 | (fact 5)                                -- 120
 6 | 
 7 | 
 8 | 
 9 | 
10 | 
11 | 
12 | (define odd
13 | 
14 |  (fun ([x Int]
15 |        [-> Float])
16 | 
17 |     (if (= x 0) false
18 |         (if (= x 1)
19 |             (even (- x 1))
20 |             true))))
21 | 
22 | 
23 | 
24 | 
25 | 
26 | 
27 | (define even
28 |   (fun ([x Int] [-> Bool])
29 |     (if (= x 0)
30 | 
31 |             true
32 |          (if (= x 1)
33 |             false
34 |       (odd (- x 1))))))
35 | 
36 | 
37 | 
38 | 
39 | 
40 | (even 10)   -- true
41 | 
42 | 
43 | 
44 | (even 11)            -- false
45 | (odd 11)   -- true
46 | 


--------------------------------------------------------------------------------
/demos/diff-s.css:
--------------------------------------------------------------------------------
  1 | /* yDiff - a language-aware tool for comparing programs */
  2 | /* Copyright (C) 2011 Yin Wang (yinwang0@gmail.com) */
  3 | 
  4 | 
  5 | /* This program is free software: you can redistribute it and/or modify */
  6 | /* it under the terms of the GNU General Public License as published by */
  7 | /* the Free Software Foundation, either version 3 of the License, or */
  8 | /* (at your option) any later version. */
  9 | 
 10 | /* This program is distributed in the hope that it will be useful, */
 11 | /* but WITHOUT ANY WARRANTY; without even the implied warranty of */
 12 | /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the */
 13 | /* GNU General Public License for more details. */
 14 | 
 15 | /* You should have received a copy of the GNU General Public License */
 16 | /* along with this program.  If not, see <http://www.gnu.org/licenses/>. */
 17 | 
 18 | 
 19 | 
 20 | .d {
 21 |     border: solid 1px #CC929A;
 22 |     /* border: solid 1px #E6A4AE; */
 23 |     background-color: LightPink;
 24 | }
 25 | 
 26 | .i {
 27 |     border: solid 1px #73BE73;
 28 |     /* border: solid 1px #82D682; */
 29 |     background-color: LightGreen;
 30 | }
 31 | 
 32 | .c {
 33 |     border: solid 1px #8AADB8;
 34 |     /* border: solid 1px #9CC2CF; */
 35 |     background-color: LightBlue;
 36 |     cursor: pointer;
 37 | }
 38 | 
 39 | .m {
 40 |     border: solid 1px LightPink;
 41 |     /* border: solid 1px #BEBEBE; */
 42 |     cursor: pointer;
 43 | }
 44 | 
 45 | .mc {
 46 |     border: solid 1px LightPink;
 47 |     background-color: LightBlue;
 48 |     /* border: solid 1px #BEBEBE; */
 49 |     cursor: pointer;
 50 | }
 51 | 
 52 | .u {
 53 |     border: solid 1px #A9A9A9;
 54 |     /* border: solid 1px #BEBEBE; */
 55 |     cursor: pointer;
 56 | }
 57 | 
 58 | span.lineno {
 59 |     color: lightgrey;
 60 |     -webkit-user-select: none;
 61 |     -moz-user-select: none;
 62 | }
 63 | 
 64 | span.keyword {
 65 |     /* color: #007070; */
 66 |     font-weight: 700;
 67 | }
 68 | 
 69 | div.line {
 70 | }
 71 | 
 72 | div.src {
 73 |     width:48%;
 74 |     height:98%;
 75 |     overflow:scroll;
 76 |     border:1px solid;
 77 |     float:left;
 78 |     padding:0.5%;
 79 | }
 80 | 
 81 | 
 82 | div.stats {
 83 |     border: solid 1px grey;
 84 |     z-index: 1000;
 85 |     width: 80%;
 86 |     padding-left: 5%;
 87 | }
 88 | 
 89 | pre.stats {
 90 |     color: grey;
 91 |     -webkit-user-select: none;
 92 |     -moz-user-select: none;
 93 | }
 94 | 
 95 | pre {
 96 |     line-height: 200%;
 97 | }
 98 | 
 99 | p {
100 |     line-height: 200%;
101 | }
102 | 


--------------------------------------------------------------------------------
/demos/diff.css:
--------------------------------------------------------------------------------
 1 | .deletion {
 2 |     border: solid 1px #CC929A;
 3 |     /* border: solid 1px #E6A4AE; */
 4 |     background-color: LightPink;
 5 | }
 6 | 
 7 | .insertion {
 8 |     border: solid 1px #73BE73;
 9 |     /* border: solid 1px #82D682; */
10 |     background-color: LightGreen;
11 | }
12 | 
13 | .change {
14 |     border: solid 1px #8AADB8;
15 |     /* border: solid 1px #9CC2CF; */
16 |     background-color: LightBlue;
17 |     cursor: pointer;
18 | }
19 | 
20 | .move {
21 |     border: solid 1px LightPink;
22 |     /* border: solid 1px #BEBEBE; */
23 |     cursor: pointer;
24 | }
25 | 
26 | .move-change {
27 |     border: solid 1px LightPink;
28 |     background-color: LightBlue;
29 |     /* border: solid 1px #BEBEBE; */
30 |     cursor: pointer;
31 | }
32 | 
33 | .unchanged {
34 |     border: solid 1px #A9A9A9;
35 |     /* border: solid 1px #BEBEBE; */
36 |     cursor: pointer;
37 | }
38 | 
39 | span.lineno {
40 |     color: lightgrey;
41 |     -webkit-user-select: none;
42 |     -moz-user-select: none;
43 | }
44 | 
45 | span.keyword {
46 |     /* color: #007070; */
47 |     font-weight: 700;
48 | }
49 | 
50 | div.line {
51 | }
52 | 
53 | div.stats {
54 |     border: solid 1px grey;
55 |     z-index: 1000;
56 |     width: 80%;
57 |     padding-left: 5%;
58 | }
59 | 
60 | pre.stats {
61 |     color: grey;
62 |     -webkit-user-select: none;
63 |     -moz-user-select: none;
64 | }
65 | 
66 | pre {
67 | 
68 | }
69 | 


--------------------------------------------------------------------------------
/demos/diff2.rkt:
--------------------------------------------------------------------------------
  1 | ;; ydiff - a language-aware tool for comparing programs
  2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
  3 | 
  4 | 
  5 | ;; This program is free software: you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation, either version 3 of the License, or
  8 | ;; (at your option) any later version.
  9 | 
 10 | ;; This program is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | #lang racket
 19 | 
 20 | (require "structs.rkt")
 21 | (require "utils.rkt")
 22 | 
 23 | 
 24 | (provide (all-defined-out))
 25 | 
 26 | 
 27 | ;-------------------------------------------------------------
 28 | ;                      parameters
 29 | ;-------------------------------------------------------------
 30 | 
 31 | ;; The minimum size of a node to be considered as moved. Shouldn't be
 32 | ;; too small, otherwise small deleted names may appear in a very
 33 | ;; distant place!
 34 | (define *move-size* 5)
 35 | 
 36 | 
 37 | ;; Similar to *move-size*, but this number is used for internal moves inside a
 38 | ;; named body (for example a function). This number can be smaller than
 39 | ;; *move-size*, usually set to 2 for maxmum accuracy without much noise.
 40 | (define *inner-move-size* 2)
 41 | 
 42 | 
 43 | ;; How long must a string be in order for us to use string-dist
 44 | ;; function, which is costly when used on long strings but the most
 45 | ;; accurate method to use. Currently this parameter is set to 0,
 46 | ;; effective disables all LCS string comparison. This improves
 47 | ;; performance while not sacrificing accuracy because the algorithm is
 48 | ;; AST based.
 49 | (define *max-string-len* 0)
 50 | 
 51 | 
 52 | ;; Only memoize the diff of nodes of size larger than this number.
 53 | ;; This effectively reduces memory usage.
 54 | (define *memo-node-size* 2)
 55 | 
 56 | 
 57 | 
 58 | 
 59 | ;;------------------ frames utils --------------------
 60 | (define deframe
 61 |   (lambda (node)
 62 |     (match node
 63 |       [(Node 'frame _ _ elts _ _)
 64 |        (apply append (map deframe elts))]
 65 |      [else (list node)])))
 66 | 
 67 | 
 68 | (define deframe-change
 69 |   (lambda (change)
 70 |     (cond
 71 |      [(ins? change)
 72 |       (apply append
 73 |              (map ins (deframe (Change-new change))))]
 74 |      [(del? change)
 75 |       (apply append
 76 |              (map del (deframe (Change-old change))))]
 77 |      [else (list change)])))
 78 | 
 79 | 
 80 | (define extract-frame
 81 |   (lambda (node1 node2 type)
 82 |     (match node1
 83 |       [(Node type1 start1 end1 elts1 size ctx)
 84 |        (let ([frame-elts (filter (lambda (x)
 85 |                                    (not (eq? x node2)))
 86 |                                  elts1)])
 87 |          (type (Node 'frame start1 start1 frame-elts (- size (node-size node2)) ctx)))]
 88 |       [_ fatal 'extract-frame "I only accept Node"])))
 89 | 
 90 | 
 91 | ;; (define n1 (Token "ok" 0 1))
 92 | ;; (define n2 (Expr 'ok 0 2 (list n1 (Token "bar" 1 2))))
 93 | ;; (map deframe-change (extract-frame n2 n1 ins))
 94 | 
 95 | 
 96 | 
 97 | ;-------------------------------------------------------------
 98 | ;                       diff proper
 99 | ;-------------------------------------------------------------
100 | 
101 | ; 2-D memoization table
102 | (define make-table
103 |   (lambda (dim1 dim2)
104 |     (let ([vec (make-vector (add1 dim1))])
105 |       (let loop ([n 0])
106 |         (cond
107 |          [(= n (vector-length vec)) vec]
108 |          [else
109 |           (vector-set! vec n (make-vector (add1 dim2) #f))
110 |           (loop (add1 n))])))))
111 | 
112 | 
113 | (define table-ref
114 |   (lambda (t x y)
115 |     (let ([row (vector-ref t x)])
116 |       (vector-ref row y))))
117 | 
118 | 
119 | (define table-set!
120 |   (lambda (t x y v)
121 |     (let ([row (vector-ref t x)])
122 |       (vector-set! row y v))))
123 | 
124 | 
125 | 
126 | ;---------------- string distance function -----------------
127 | 
128 | ;; string distance is no longer used because string=? saffice to
129 | ;; compare strings in ASTs. Retain it here for possible later uses.
130 | (define string-dist
131 |   (lambda (s1 s2)
132 |     (let* ([len1 (string-length s1)]
133 |            [len2 (string-length s2)]
134 |            [t (make-table len1 len2)]
135 |            [char-dist (dist1 t s1 0 s2 0)])
136 |       (cond
137 |        [(= 0 (+ len1 len2)) 0]
138 |        [else
139 |         (/ (* 2.0 char-dist) (+ len1 len2))]))))
140 | 
141 | 
142 | (define dist1
143 |   (lambda (table s1 start1 s2 start2)
144 |     (define memo
145 |       (lambda (value)
146 |         (table-set! table start1 start2 value)
147 |         value))
148 |     (cond
149 |      [(table-ref table start1 start2)
150 |       => (lambda (cached) cached)]
151 |      [(= start1 (string-length s1))
152 |       (memo (- (string-length s2) start2))]
153 |      [(= start2 (string-length s2))
154 |       (memo (- (string-length s1) start1))]
155 |      [else
156 |       (let* ([c1 (string-ref s1 start1)]
157 |              [c2 (string-ref s2 start2)]
158 |              [d0 (cond
159 |                   [(char=? c1 c2) 0]
160 |                   [(char=? (char-downcase c1)
161 |                            (char-downcase c2)) 1]
162 |                   [else 2])]
163 |              [d1 (+ d0 (dist1 table s1 (add1 start1) s2 (add1 start2)))]
164 |              [d2 (+ 1 (dist1 table s1 (add1 start1) s2 start2))]
165 |              [d3 (+ 1 (dist1 table s1 start1 s2 (add1 start2)))])
166 |         (memo (min d1 d2 d3)))])))
167 | 
168 | 
169 | 
170 | 
171 | 
172 | ;--------------------- the primary diff function -------------------
173 | (define diff-node
174 |   (lambda (node1 node2 move?)
175 | 
176 |     (define memo
177 |       (lambda (v1 v2)
178 |         (and (> (node-size node1) *memo-node-size*)
179 |              (> (node-size node2) *memo-node-size*)
180 |              (hash-put! *diff-hash* node1 node2 (cons v1 v2)))
181 |         (values v1 v2)))
182 | 
183 |     (define try-extract
184 |       (lambda (changes cost)
185 |         (cond
186 |          [(or (not move?)
187 |               (zero? cost))
188 |           (memo changes cost)]
189 |          [else
190 |           (letv ([(m c) (diff-extract node1 node2 move?)])
191 |             (cond
192 |              [(not m)
193 |               (memo changes cost)]
194 |              [else
195 |               (memo m c)]))])))
196 | 
197 | 
198 |     (diff-progress 1) ;; progress bar
199 | 
200 |     (cond
201 |      [(hash-get *diff-hash* node1 node2)
202 |       => (lambda (cached)
203 |            (values (car cached) (cdr cached)))]
204 |      [(and (character? node1) (character? node2))
205 |       (diff-string (char->string (Node-elts node1))
206 |                    (char->string (Node-elts node2))
207 |                    node1 node2)]
208 |      [(and (str? node1) (str? node2))
209 |       (diff-string (Node-elts node1) (Node-elts node2) node1 node2)]
210 |      [(and (comment? node1) (comment? node2))
211 |       (diff-string (Node-elts node1) (Node-elts node2) node1 node2)]
212 |      [(and (token? node1) (token? node2))
213 |       (diff-string (Node-elts node1) (Node-elts node2) node1 node2)]
214 |      [(and (Node? node1) (Node? node2)
215 |            (eq? (get-type node1) (get-type node2)))
216 |       (letv ([(m c) (diff-list (Node-elts node1) (Node-elts node2) move?)])
217 |         (try-extract m c))]
218 |      [(and (pair? node1) (not (pair? node2)))
219 |       (diff-list node1 (list node2) move?)]
220 |      [(and (not (pair? node1)) (pair? node2))
221 |       (diff-list (list node1) node2 move?)]
222 |      [(and (pair? node1) (pair? node2))
223 |       (diff-list node1 node2 move?)]
224 |      [else
225 |       (letv ([(m c) (total node1 node2)])
226 |         (try-extract m c))])))
227 | 
228 | 
229 | 
230 | 
231 | ;; helper for nodes with string contents (Str, Comment, Token etc.)
232 | (define diff-string
233 |   (lambda (string1 string2 node1 node2)
234 |     (cond
235 |      [(or (> (string-length string1) *max-string-len*)
236 |           (> (string-length string2) *max-string-len*))
237 |       (cond
238 |        [(string=? string1 string2)
239 |         (values (mod node1 node2 0) 0)]
240 |        [else
241 |         (total node1 node2)])]
242 |      [else
243 |       (let ([cost (string-dist string1 string2)])
244 |         (values (mod node1 node2 cost) cost))])))
245 | 
246 | 
247 | 
248 | 
249 | 
250 | ;; global 2-D hash for storing known diffs
251 | (define *diff-hash* (make-hasheq))
252 | 
253 | (define diff-list
254 |   (lambda (ls1 ls2 move?)
255 |     (let ([ls1 (sort ls1 node-sort-fn)]
256 |           [ls2 (sort ls2 node-sort-fn)])
257 |       (diff-list1 (make-hasheq) ls1 ls2 move?))))
258 | 
259 | 
260 | (define diff-list1
261 |   (lambda (table ls1 ls2 move?)
262 | 
263 |     (define memo
264 |       (lambda (v1 v2)
265 |         (hash-put! table ls1 ls2 (cons v1 v2))
266 |         (values v1 v2)))
267 | 
268 |     (define guess
269 |       (lambda (ls1  ls2)
270 |         (letv ([(m0 c0) (diff-node (car ls1) (car ls2) move?)]
271 |                [(m1 c1) (diff-list1 table (cdr ls1) (cdr ls2) move?)]
272 |                [cost1 (+ c0 c1)])
273 |           (cond
274 |            [(or (same-def? (car ls1) (car ls2))
275 |                 (zero? c0))
276 |             (memo (append m0 m1) cost1)]
277 |            [else
278 |             (letv ([(m2 c2) (diff-list1 table (cdr ls1) ls2  move?)]
279 |                    [(m3 c3) (diff-list1 table ls1 (cdr ls2) move?)]
280 |                    [cost2 (+ c2 (node-size (car ls1)))]
281 |                    [cost3 (+ c3 (node-size (car ls2)))])
282 |               (cond
283 |                [(<= cost2 cost3)
284 |                 (memo (append (del (car ls1)) m2) cost2)]
285 |                [else
286 |                 (memo (append (ins (car ls2)) m3) cost3)]))]))))
287 | 
288 |     (cond
289 |      [(hash-get table ls1 ls2)
290 |       => (lambda (cached)
291 |            (values (car cached) (cdr cached)))]
292 |      [(and (null? ls1) (null? ls2))
293 |       (values '() 0)]
294 |      [(null? ls1)
295 |       (let ([changes (apply append (map ins ls2))])
296 |         (values changes (node-size ls2)))]
297 |      [(null? ls2)
298 |       (let ([changes (apply append (map del ls1))])
299 |         (values changes (node-size ls1)))]
300 |      [else
301 |       (guess ls1 ls2)])))
302 | 
303 | 
304 | 
305 | (define same-ctx?
306 |   (lambda (x y)
307 |     (and (Node? x)
308 |          (Node? y)
309 |          (Node-ctx x)
310 |          (Node-ctx y)
311 |          (>= (node-size x) *inner-move-size*)
312 |          (>= (node-size y) *inner-move-size*)
313 |          (eq? (Node-ctx x) (Node-ctx y)))))
314 | 
315 | 
316 | ;; structure extraction
317 | (define diff-extract
318 |   (lambda (node1 node2 move?)
319 |     (cond
320 |      [(and (Node? node1) (Node? node2)
321 |            (or (same-ctx? node1 node2)
322 |                (and (>= (node-size node1) *move-size*)
323 |                     (>= (node-size node2) *move-size*))))
324 |       (cond
325 |        [(<= (node-size node1) (node-size node2))
326 |         (let loop ([elts2 (Node-elts node2)])
327 |           (cond
328 |            [(pair? elts2)
329 |             (letv ([(m0 c0) (diff-node node1 (car elts2) move?)])
330 |               (cond
331 |                [(or (same-def? node1 (car elts2))
332 |                     (and (zero? c0)
333 |                          (or (> (node-size node1) *move-size*)
334 |                              (same-ctx? node1 (car elts2)))))
335 |                 (let ([frame (extract-frame node2 (car elts2) ins)])
336 |                   (values (append m0 frame) c0))]
337 |                [else
338 |                 (loop (cdr elts2))]))]
339 |            [else
340 |             (values #f #f)]))]
341 |        [else
342 |         (let loop ([elts1 (Node-elts node1)])
343 |           (cond
344 |            [(pair? elts1)
345 |             (letv ([(m0 c0) (diff-node (car elts1) node2 move?)])
346 |               (cond
347 |                [(or (same-def? (car elts1) node2)
348 |                     (and (zero? c0)
349 |                          (or (> (node-size node2) *move-size*)
350 |                              (same-ctx? (car elts1) node2))))
351 |                 (let ([frame (extract-frame node1 (car elts1) del)])
352 |                   (values (append m0 frame) c0))]
353 |                [else
354 |                 (loop (cdr elts1))]))]
355 |            [else
356 |             (values #f #f)]))])]
357 |      [else (values #f #f)])))
358 | 
359 | 
360 | 
361 | 
362 | 
363 | ;-------------------------------------------------------------
364 | ;                    finding moves
365 | ;-------------------------------------------------------------
366 | 
367 | (define big-node?
368 |   (lambda (node)
369 |     (>= (node-size node) *move-size*)))
370 | 
371 | 
372 | (define big-change?
373 |   (lambda (c)
374 |     (cond
375 |      [(ins? c)
376 |       (big-node? (Change-new c))]
377 |      [(del? c)
378 |       (big-node? (Change-old c))]
379 |      [(mod? c)
380 |       (or (big-node? (Change-old c))
381 |           (big-node? (Change-new c)))])))
382 | 
383 | 
384 | (define node-sort-fn
385 |   (lambda (x y)
386 |     (let ([name1 (get-name x)]
387 |           [name2 (get-name y)])
388 |       (cond
389 |        [(and name1 name2)
390 |         (string<? (symbol->string name1)
391 |                   (symbol->string name2))]
392 |        [(and name1 (not name2)) #t]
393 |        [(and (not name1) name2) #f]
394 |        [else
395 |         (< (Node-start x) (Node-start y))]))))
396 | 
397 | 
398 | 
399 | ;; iterate diff-list on the list of changes
400 | (define find-moves
401 |   (lambda (changes)
402 |     (set! *diff-hash* (make-hasheq))
403 |     (let loop ([changes changes] [closed '()] [count 1])
404 |       (letv ([dels (filter (predand del? big-change?) changes)]
405 |              [adds (filter (predand ins? big-change?) changes)]
406 |              [rest (set- changes (append dels adds))]
407 |              [ls1 (sort (map Change-old dels) node-sort-fn)]
408 |              [ls2 (sort (map Change-new adds) node-sort-fn)]
409 |              [(m c) (diff-list ls1 ls2 #t)]
410 |              [new-moves (map mod->mov (filter mod? m))])
411 |         (cond
412 |          [(null? new-moves)
413 |           (let ([all-changes (append m rest closed)])
414 |             (apply append (map deframe-change all-changes)))]
415 |          [else
416 |           (let ([new-changes (filter (negate mod?) m)])
417 |             (loop new-changes
418 |                   (append new-moves rest closed)
419 |                   (add1 count)))])))))
420 | 
421 | 
422 | ;; poor man's progress bar
423 | (define diff-progress
424 |   (new-progress 10000))
425 | 
426 | 
427 | (define cleanup
428 |   (lambda ()
429 |     (set! *diff-hash* (make-hasheq))))
430 | 
431 | 
432 | ;; main diff function
433 | ;; returns all changes after diffing and moving
434 | (define diff
435 |   (lambda (node1 node2)
436 |     (letv ([start (current-seconds)]    ; start timer
437 |            [size1 (node-size node1)]
438 |            [size2 (node-size node2)])
439 | 
440 |       (printf "[info] size of program 1: ~a~n" size1)
441 |       (printf "[info] size of program 2: ~a~n" size2)
442 | 
443 |       (set-node-context node1 'top)
444 |       (set-node-context node2 'top)
445 | 
446 |       (printf "[diffing]~n")
447 | 
448 |       (letv ([(changes cost) (diff-node node1 node2 #f)])
449 |         (diff-progress 'reset)
450 |         (printf "~n[moving]~n")
451 |         (letv ([changes (find-moves changes)]
452 |                [end (current-seconds)])
453 |           (printf "~n[finished] ~a seconds~n" (- end start))
454 |           (cleanup)
455 |           changes)))))
456 | 


--------------------------------------------------------------------------------
/demos/mk1.ss:
--------------------------------------------------------------------------------
  1 | ;;; This file was generated by writeminikanren.pl
  2 | ;;; Generated at 2007-10-25 15:24:42
  3 | 
  4 | (define-syntax lambdag@
  5 |   (syntax-rules ()
  6 |     ((_ (p) e) (lambda (p) e))))
  7 | 
  8 | (define-syntax lambdaf@
  9 |   (syntax-rules ()
 10 |     ((_ () e) (lambda () e))))
 11 | 
 12 | (define-syntax run*
 13 |   (syntax-rules ()
 14 |     ((_ (x) g ...) (run #f (x) g ...))))
 15 | 
 16 | (define-syntax rhs
 17 |   (syntax-rules ()
 18 |     ((_ x) (cdr x))))
 19 | 
 20 | (define-syntax lhs
 21 |   (syntax-rules ()
 22 |     ((_ x) (car x))))
 23 | 
 24 | (define-syntax size-s
 25 |   (syntax-rules ()
 26 |     ((_ x) (length x))))
 27 | 
 28 | (define-syntax var
 29 |   (syntax-rules ()
 30 |     ((_ x) (vector x))))
 31 | 
 32 | (define-syntax var?
 33 |   (syntax-rules ()
 34 |     ((_ x) (vector? x))))
 35 | 
 36 | 
 37 | (define empty-s '())
 38 | 
 39 | (define walk
 40 |   (lambda (v s)
 41 |     (cond
 42 |       ((var? v)
 43 |        (let ((a (assq v s)))
 44 |          (cond
 45 |            (a (walk (rhs a) s))
 46 |            (else v))))
 47 |       (else v))))
 48 | 
 49 | (define ext-s
 50 |   (lambda (x v s)
 51 |     (cons `(,x . ,v) s)))
 52 | 
 53 | (define unify
 54 |   (lambda (v w s)
 55 |     (let ((v (walk v s))
 56 |           (w (walk w s)))
 57 |       (cond
 58 |         ((eq? v w) s)
 59 |         ((var? v) (ext-s v w s))
 60 |         ((var? w) (ext-s w v s))
 61 |         ((and (pair? v) (pair? w))
 62 |          (let ((s (unify (car v) (car w) s)))
 63 |            (and s (unify (cdr v) (cdr w) s))))
 64 |         ((equal? v w) s)
 65 |         (else #f)))))
 66 | 
 67 | (define unify-check
 68 |   (lambda (u v s)
 69 |     (let ((u (walk u s))
 70 |           (v (walk v s)))
 71 |       (cond
 72 |         ((eq? u v) s)
 73 |         ((var? u) (ext-s-check u v s))
 74 |         ((var? v) (ext-s-check v u s))
 75 |         ((and (pair? u) (pair? v))
 76 |          (let ((s (unify-check 
 77 |                     (car u) (car v) s)))
 78 |            (and s (unify-check 
 79 |                     (cdr u) (cdr v) s))))
 80 |         ((equal? u v) s)
 81 |         (else #f)))))
 82 | 
 83 |  
 84 | (define ext-s-check
 85 |   (lambda (x v s)
 86 |     (cond
 87 |       ((occurs-check x v s) #f)
 88 |       (else (ext-s x v s)))))
 89 | 
 90 | (define occurs-check
 91 |   (lambda (x v s)
 92 |     (let ((v (walk v s)))
 93 |       (cond
 94 |         ((var? v) (eq? v x))
 95 |         ((pair? v) 
 96 |          (or 
 97 |            (occurs-check x (car v) s)
 98 |            (occurs-check x (cdr v) s)))
 99 |         (else #f)))))
100 | 
101 | (define walk*
102 |   (lambda (w s)
103 |     (let ((v (walk w s)))
104 |       (cond
105 |         ((var? v) v)
106 |         ((pair? v)
107 |          (cons
108 |            (walk* (car v) s)
109 |            (walk* (cdr v) s)))
110 |         (else v)))))
111 | 
112 | (define reify-s
113 |   (lambda (v s)
114 |     (let ((v (walk v s)))
115 |       (cond
116 |         ((var? v)
117 |          (ext-s v (reify-name (size-s s)) s))
118 |         ((pair? v) (reify-s (cdr v)
119 |                      (reify-s (car v) s)))
120 |         (else s)))))
121 | 
122 | (define reify-name
123 |   (lambda (n)
124 |     (string->symbol
125 |       (string-append "_" "." (number->string n)))))
126 | 
127 | (define reify
128 |   (lambda (v s)
129 |     (let ((v (walk* v s)))
130 |       (walk* v (reify-s v empty-s)))))
131 | 
132 | (define == 
133 |   (lambda (u v)
134 |     (lambdag@ (s) (unify u v s))))
135 | 
136 | (define ==-check
137 |   (lambda (v w)
138 |     (lambdag@ (s)
139 |       (unify-check v w s))))
140 | 
141 | (define-syntax mzero 
142 |   (syntax-rules () ((_) #f)))
143 | 
144 | (define-syntax inc 
145 |   (syntax-rules () ((_ e) (lambdaf@ () e))))
146 | 
147 | (define-syntax unit 
148 |   (syntax-rules () ((_ a) a)))
149 | 
150 | (define-syntax choice 
151 |   (syntax-rules () ((_ a f) (cons a f))))
152 |  
153 | (define-syntax case-inf
154 |   (syntax-rules ()
155 |     ((_ e (() e0) ((f^) e1) ((a^) e2) ((a f) e3))
156 |      (let ((a-inf e))
157 |        (cond
158 |          ((not a-inf) e0)
159 |          ((procedure? a-inf) (let ((f^ a-inf)) e1))
160 |          ((not (and (pair? a-inf)
161 |                     (procedure? (cdr a-inf))))
162 |           (let ((a^ a-inf)) e2))
163 |          (else (let ((a (car a-inf)) (f (cdr a-inf))) 
164 |                  e3)))))))
165 | 
166 | (define-syntax run
167 |   (syntax-rules ()
168 |     ((_ n (x) g0 g ...)
169 |      (take n
170 |        (lambdaf@ ()
171 |          ((exist (x) g0 g ... 
172 |             (lambdag@ (s)
173 |               (cons (reify x s) '())))
174 |           empty-s))))))
175 |  
176 | (define take
177 |   (lambda (n f)
178 |     (if (and n (zero? n)) 
179 |       '()
180 |       (case-inf (f)
181 |         (() '())
182 |         ((f) (take n f))
183 |         ((a) a)
184 |         ((a f)
185 |          (cons (car a)
186 |            (take (and n (- n 1)) f)))))))
187 | 
188 |  
189 | (define-syntax exist
190 |   (syntax-rules ()
191 |     ((_ (x ...) g0 g ...)
192 |      (lambdag@ (s)
193 |        (inc
194 |          (let ((x (var 'x)) ...)
195 |            (bind* (g0 s) g ...)))))))
196 |  
197 | (define-syntax bind*
198 |   (syntax-rules ()
199 |     ((_ e) e)
200 |     ((_ e g0 g ...) (bind* (bind e g0) g ...))))
201 |  
202 | (define bind
203 |   (lambda (a-inf g)
204 |     (case-inf a-inf
205 |       (() (mzero))
206 |       ((f) (inc (bind (f) g)))
207 |       ((a) (g a))
208 |       ((a f) (mplus (g a) (lambdaf@ () (bind (f) g)))))))
209 | 
210 | (define-syntax conde
211 |   (syntax-rules ()
212 |     ((_ (g0 g ...) (g1 g^ ...) ...)
213 |      (lambdag@ (s) 
214 |        (inc 
215 |          (mplus* 
216 |            (bind* (g0 s) g ...)
217 |            (bind* (g1 s) g^ ...) ...))))))
218 |  
219 | (define-syntax mplus*
220 |   (syntax-rules ()
221 |     ((_ e) e)
222 |     ((_ e0 e ...) (mplus e0 
223 |                     (lambdaf@ () (mplus* e ...))))))
224 |  
225 | (define mplus
226 |   (lambda (a-inf f)
227 |     (case-inf a-inf
228 |       (() (f))
229 |       ((f^) (inc (mplus (f) f^)))
230 |       ((a) (choice a f))
231 |       ((a f^) (choice a (lambdaf@ () (mplus (f) f^)))))))
232 | 
233 | (define-syntax conda
234 |   (syntax-rules ()
235 |     ((_ (g0 g ...) (g1 g^ ...) ...)
236 |      (lambdag@ (s)
237 |        (inc
238 |          (ifa ((g0 s) g ...)
239 |               ((g1 s) g^ ...) ...))))))
240 |  
241 | (define-syntax ifa
242 |   (syntax-rules ()
243 |     ((_) (mzero))
244 |     ((_ (e g ...) b ...)
245 |      (let loop ((a-inf e))
246 |        (case-inf a-inf
247 |          (() (ifa b ...))
248 |          ((f) (inc (loop (f))))
249 |          ((a) (bind* a-inf g ...))
250 |          ((a f) (bind* a-inf g ...)))))))
251 | 
252 | (define-syntax condu
253 |   (syntax-rules ()
254 |     ((_ (g0 g ...) (g1 g^ ...) ...)
255 |      (lambdag@ (s)
256 |        (inc
257 |          (ifu ((g0 s) g ...)
258 |               ((g1 s) g^ ...) ...))))))
259 |  
260 | (define-syntax ifu
261 |   (syntax-rules ()
262 |     ((_) (mzero))
263 |     ((_ (e g ...) b ...)
264 |      (let loop ((a-inf e))
265 |        (case-inf a-inf
266 |          (() (ifu b ...))
267 |          ((f) (inc (loop (f))))
268 |          ((a) (bind* a-inf g ...))
269 |          ((a f) (bind* (unit a) g ...)))))))
270 | 
271 | (define-syntax project
272 |   (syntax-rules ()
273 |     ((_ (x ...) g g* ...)
274 |      (lambdag@ (s)
275 |        (let ((x (walk* x s)) ...)
276 |          ((exist () g g* ...) s))))))
277 | 
278 | (define succeed (== #f #f))
279 | 
280 | (define fail (== #f #t))
281 | 
282 | (define onceo
283 |   (lambda (g)
284 |     (condu
285 |       (g succeed)
286 |       (else fail))))
287 | 
288 | 


--------------------------------------------------------------------------------
/demos/mk2.ss:
--------------------------------------------------------------------------------
  1 | ;;; This file was generated by writeminikanren.pl
  2 | ;;; Generated at 2007-10-25 15:24:42
  3 | 
  4 | (define *debug-tags* '())
  5 | (define debug
  6 |   (lambda (tags format . args)
  7 |     (let* ((tags (if (not (pair? tags)) (list tags) tags))
  8 |            (fs (string-append "[" (symbol->string (car tags)) "] " format "\n")))
  9 |       (cond
 10 |        [(null? tags)]
 11 |        [(pair? tags)
 12 |         (if (member (car tags) *debug-tags*)
 13 |             (apply printf fs args)
 14 |             (void))]
 15 |        ))))
 16 | 
 17 | 
 18 | ;; Stream primitives
 19 | (define-syntax lambdag@
 20 |   (syntax-rules ()
 21 |     ((_ (p ...) e ...) (lambda (p ...) e ...))))
 22 | 
 23 | (define-syntax lambdaf@
 24 |   (syntax-rules ()
 25 |     ((_ () e ...) (lambda () e ...))))
 26 | 
 27 | (define-syntax inc
 28 |   (syntax-rules () ((_ e) (lambdaf@ () e))))
 29 | 
 30 | (define defunc
 31 |   (lambda (f)
 32 |     (if (procedure? f) (defunc (f)) f)))
 33 | 
 34 | (define snull 'snull)
 35 | 
 36 | (define snull? 
 37 |   (lambda (s)
 38 |     (eq? s snull)))
 39 | 
 40 | (define-syntax scons
 41 |   (syntax-rules ()
 42 |     ((_ a d) (cons a (lambda () d)))))
 43 | 
 44 | (define scar
 45 |   (lambda (s)
 46 |     (cond
 47 |      [(procedure? s) (scar (s))]
 48 |      [else (car s)])))
 49 | 
 50 | (define scdr
 51 |   (lambda (s)
 52 |     (cond
 53 |      [(procedure? s) (scdr (s))]
 54 |      [else ((cdr s))])))
 55 | 
 56 | (define-syntax sunit
 57 |   (syntax-rules ()
 58 |     ((_ a) (scons a snull))))
 59 | 
 60 | (define slift
 61 |   (lambda (f)
 62 |     (lambda args
 63 |       (sunit (apply f args)))))
 64 | 
 65 | (define-syntax make-stream
 66 |   (syntax-rules ()
 67 |     ((_) snull)
 68 |     ((_ e1 e2 ...) (scons e1 (make-stream e2 ...)))))
 69 | 
 70 | (define take
 71 |   (lambda (n s)
 72 |     (if (and n (zero? n))
 73 |         '()
 74 |         (let ([s (defunc s)])
 75 |           (cond
 76 |            [(snull? s) '()]
 77 |            [else (cons (scar s) (take (and n (- n 1)) (scdr s)))])))))
 78 | 
 79 | (define smerge
 80 |   (lambda (s1 s2)
 81 |     (cond
 82 |      [(snull? s1) s2]
 83 |      [(procedure? s1)
 84 |       (lambda () (smerge s2 (s1)))]
 85 |      [else (scons (scar s1) (smerge s2 (scdr s1)))])))
 86 | 
 87 | (define stream-merge
 88 |   (lambda (ss)
 89 |     (cond
 90 |      [(snull? ss) snull]
 91 |      [(procedure? ss) (lambda () (stream-merge (ss)))]
 92 |      [(snull? (scar ss)) (stream-merge (scdr ss))]
 93 |      [(procedure? (scar ss)) (lambda () 
 94 |                                (smerge (stream-merge (scdr ss))
 95 |                                        (scar ss)))]
 96 |      [else (scons (scar (scar ss)) (smerge (scdr (scar ss))
 97 |                                            (stream-merge (scdr ss))))])))
 98 | 
 99 | (define smap
100 |   (lambda (f s)
101 |     (cond
102 |      [(snull? s) snull]
103 |      [(procedure? s) (lambda () (smap f (s)))]
104 |      [else (scons (f (scar s)) (smap f (scdr s)))])))
105 | 
106 | 
107 | 
108 | ;; Substitution
109 | (define-syntax rhs
110 |   (syntax-rules ()
111 |     ((_ x) (cdr x))))
112 | 
113 | (define-syntax lhs
114 |   (syntax-rules ()
115 |     ((_ x) (car x))))
116 | 
117 | (define-syntax size-s
118 |   (syntax-rules ()
119 |     ((_ x) (length x))))
120 | 
121 | (define-syntax var
122 |   (syntax-rules ()
123 |     ((_ x) (vector x))))
124 | 
125 | (define-syntax var?
126 |   (syntax-rules ()
127 |     ((_ x) (vector? x))))
128 | 
129 | (define empty-s '())
130 | 
131 | (define walk
132 |   (lambda (v s)
133 |     (cond
134 |       ((var? v)
135 |        (let ((a (assq v s)))
136 |          (cond
137 |            (a (walk (rhs a) s))
138 |            (else v))))
139 |       (else v))))
140 | 
141 | (define ext-s
142 |   (lambda (x v s)
143 |     (cons `(,x . ,v) s)))
144 | 
145 | (define unify
146 |   (lambda (v w s env)
147 |     ((env-unify env) v w s env)))
148 | 
149 | (define unify-good
150 |   (lambda (v w s env)
151 | ;    (printf "[unify-good]: ~a <--> ~a :: ~a\n" v w s)
152 |     (let ((v (walk v s))
153 |           (w (walk w s)))
154 |       (cond
155 |         ((eq? v w) s)
156 |         ((var? v) (ext-s v w s))
157 |         ((var? w) (ext-s w v s))
158 |         ((and (pair? v) (pair? w))
159 |          (let ((s (unify-good (car v) (car w) s env)))
160 |            (and s (unify-good (cdr v) (cdr w) s env))))
161 |         ((equal? v w) s)
162 |         (else #f)))))
163 | 
164 | 
165 | (define unify-evil
166 |   (lambda (v w s env)
167 |     (debug '(unify-evil unify) 
168 |            "v=~a, w=~a, cvars: ~a\n  subst:~a" v w (env-cvars env) s)
169 |     (let ((vv (walk v s))
170 |           (ww (walk w s)))
171 |       (cond
172 |        ((eq? vv ww) s)
173 |        ((and (var? vv) (memq v (env-cvars env))) #f)
174 |        ((and (var? ww) (memq w (env-cvars env))) #f)
175 |        ((var? vv) (ext-s vv ww s))
176 |        ((var? ww) (ext-s ww vv s))
177 |        ((and (pair? vv) (pair? ww))
178 |         (let ((s (unify-evil (car vv) (car ww) s env)))
179 |           (and s (unify-evil (cdr vv) (cdr ww) s env))))
180 |        ((equal? vv ww) s)
181 |        (else #f)))))
182 | 
183 | 
184 | (define switch-unify
185 |   (lambda (env)
186 |     (if (eq? (env-unify env) unify-good)
187 |         (change-unify env unify-evil)
188 |         (change-unify env unify-good))))
189 | 
190 | (define unify-pred
191 |   (lambda (v pred s env)
192 |     (let ((v (walk v s)))
193 |       (if (var? v)
194 |           (cond 
195 |            [(eq? pred number?) (ext-s v (random 9999999999) s)]
196 |            [(eq? pred string?) (ext-s v "random string..." s)]
197 |            [(eq? pred symbol?) (ext-s v 'randomstring... s)]
198 |            )
199 |           (cond
200 |            [(pred v) s]
201 |            [else #f])))))
202 | 
203 | (define predo
204 |   (lambda (q pred)
205 |     (lambdag@ (s env)
206 |       (let ((s1 (unify-pred q pred s env)))
207 |         (cond
208 |          [(not s1) snull]
209 |          [else (sunit s1)])))))
210 | 
211 | (define unify-check
212 |   (lambda (u v s)
213 |     (let ((u (walk u s))
214 |           (v (walk v s)))
215 |       (cond
216 |         ((eq? u v) s)
217 |         ((var? u) (ext-s-check u v s))
218 |         ((var? v) (ext-s-check v u s))
219 |         ((and (pair? u) (pair? v))
220 |          (let ((s (unify-check (car u) (car v) s)))
221 |            (and s (unify-check (cdr u) (cdr v) s))))
222 |         ((equal? u v) s)
223 |         (else #f)))))
224 | 
225 |  
226 | (define ext-s-check
227 |   (lambda (x v s)
228 |     (cond
229 |       ((occurs-check x v s) #f)
230 |       (else (ext-s x v s)))))
231 | 
232 | (define occurs-check
233 |   (lambda (x v s)
234 |     (let ((v (walk v s)))
235 |       (cond
236 |         ((var? v) (eq? v x))
237 |         ((pair? v) 
238 |          (or 
239 |            (occurs-check x (car v) s)
240 |            (occurs-check x (cdr v) s)))
241 |         (else #f)))))
242 | 
243 | (define walk*
244 |   (lambda (w s)
245 |     (let ((v (walk w s)))
246 |       (cond
247 |         ((var? v) v)
248 |         ((pair? v)
249 |          (cons
250 |            (walk* (car v) s)
251 |            (walk* (cdr v) s)))
252 |         (else v)))))
253 | 
254 | (define reify-s
255 |   (lambda (v s)
256 |     (debug 'reify-s "v: ~a\ns:~a" v s)
257 |     (let ((v (walk v s)))
258 |       (cond
259 |         ((var? v)
260 |          (ext-s v (reify-name (size-s s)) s))
261 |         ((pair? v) (reify-s (cdr v)
262 |                      (reify-s (car v) s)))
263 |         (else s)))))
264 | 
265 | (define reify-name
266 |   (lambda (n)
267 |     (string->symbol
268 |       (string-append "_" "." (number->string n)))))
269 | 
270 | (define reify
271 |   (lambda (v s)
272 |     (let ((v (walk* v s)))
273 |       (walk* v (reify-s v empty-s)))))
274 | 
275 | 
276 | (define pkg
277 |   (lambda (s c)
278 |     (list s c)))
279 | (define pkg-subst car)                  ; current substitution
280 | (define pkg-constraints cadr)
281 | (define ext-pkg-constraints
282 |   (lambda (p cs ctexts env)
283 |     (let ([newc (map (lambda (g t) 
284 |                        (make-constraint g (env-vars env) t))
285 |                      cs ctexts)])
286 |       (pkg (pkg-subst p) (append newc (pkg-constraints p))))))
287 | 
288 | ;; constraints save the current environment vars
289 | (define make-constraint
290 |   (lambda (g vars text)
291 |     (list g vars text)))
292 | (define constraint-goal car)            ; constraint goal
293 | (define constraint-vars cadr)            ; variables which the constraint care about
294 | (define constraint-text caddr)
295 | 
296 | ;; environment
297 | (define make-env
298 |   (lambda (unify constraints vars cvars)
299 |     (list unify constraints vars cvars)))
300 | (define empty-env (list unify-good '() '() '()))
301 | (define env-unify car)                 ; which unification to use (env)
302 | (define env-constraints cadr)          ; current constraints (env)
303 | (define env-vars caddr)                ; variables at this point (env)
304 | (define env-cvars cadddr)              ; checked variables at this point (env)
305 | (define env-constraint-goals
306 |   (lambda (p)
307 |     (map constraint-goal (env-constraint p))))
308 | 
309 | 
310 | 
311 | (define change-unify
312 |   (lambda (p u)
313 |     (make-env u (env-constraints p) (env-vars p) (env-cvars p))))
314 | 
315 | (define change-constraints
316 |   (lambda (p c)
317 |     (make-env (env-unify p) c (env-vars p) (env-cvars p))))
318 | 
319 | (define change-vars
320 |   (lambda (p v)
321 |     (make-env (env-unify p) (env-constraints p) v (env-cvars p))))
322 | 
323 | (define change-cvars
324 |   (lambda (p cv)
325 |     (env (env-unify p) (env-constraints p) (env-vars p) cv)))
326 | 
327 | (define ext-constraint
328 |   (lambda (env new-cg)
329 |     (let ([newc (map (lambda (g) (make-constraint g (env-vars env) 'a))
330 |                      new-cg)])
331 |       (change-constraints env newc))))
332 | 
333 | (define ext-vars
334 |   (lambda (env new-vars)
335 |     (change-vars env (append new-vars (env-vars env)))))
336 | 
337 | (define ext-cvars
338 |   (lambda (env new-cvars)
339 |     (change-cvars env (append new-cvars (env-cvars env)))))
340 | 
341 | 
342 | 
343 | ;;; miniKanren
344 | 
345 | (define bind
346 |   (lambda (s f env)
347 |     (cond
348 |      [(procedure? s) (lambda () (bind (s) f env))]
349 |      [else
350 |       (stream-merge (smap (lambda (s) (f s env)) s))])))
351 | 
352 | (define bind*
353 |   (lambda (s goals env)
354 |     (cond
355 |      [(null? goals)
356 |       (stream-merge
357 |        (smap (lambda (s) 
358 |                (bind-constraints (sunit s) (pkg-constraints s) env))
359 |              s))]
360 |      [(snull? s) snull]
361 |      [else (bind* (bind s (car goals) env) (cdr goals) env)])))
362 | 
363 | (define bind*
364 |   (lambda (s goals env)
365 |     (cond
366 |      [(null? goals) s]
367 |      [(snull? s) snull]
368 |      [else (bind* (bind s (car goals) env) (cdr goals) env)])))
369 | 
370 | (define bind-constraints
371 |   (lambda (s cs env)
372 |     (cond
373 |      [(null? cs) s]
374 |      [(snull? s) snull]
375 |      [else 
376 |       (debug 'bind-constraints
377 |              "checking constraint: ~a" (constraint-text (car cs)))
378 |       (bind-constraints
379 |             (bind s
380 |                   (constraint-goal (car cs))
381 |                   (make-env (env-unify env)
382 |                             '()                     ; no constraints
383 |                             (env-vars env)
384 |                             (constraint-vars (car cs)))) 
385 |             (cdr cs)
386 |             env)])))
387 | 
388 | (define ==
389 |   (lambda (u v)
390 |     (lambdag@ (s env)
391 |       (let ((s1 ((env-unify env) u v (pkg-subst s) env)))
392 |         (cond
393 |          [(not s1) snull]
394 |          [else (sunit (pkg s1 (pkg-constraints s)))])))))
395 | 
396 | (define ==
397 |   (lambda (u v)
398 |     (lambdag@ (s env)
399 |       (let ((s1 ((env-unify env) u v (pkg-subst s) env)))
400 |         (cond
401 |          [(not s1) snull]
402 |          [else
403 |           (let ([cc (bind-constraints (sunit (pkg s1 '()))
404 |                                       (pkg-constraints s) env)])
405 |             (if (snull? cc)
406 |                 snull
407 |                 (sunit (pkg s1 (filter (lambda (c) 
408 |                                          (not (tautology? c (pkg-subst s))))
409 |                                        (pkg-constraints s))))))])))))
410 | 
411 | (define ando
412 |   (lambda goals
413 |     (lambdag@ (s env)
414 |       (bind* (sunit s) goals env))))
415 | 
416 | (define org2
417 |   (lambda (goals)
418 |     (lambdag@ (s env)
419 |       (cond
420 |        [(null? goals) snull]
421 |        [else
422 |         (scons (bind (sunit s) (car goals) env)
423 |                ((org2 (cdr goals)) s env))]))))
424 | 
425 | (define oro
426 |   (lambda goals
427 |     (lambdag@ (s env)
428 |       (stream-merge ((org2 goals) s env)))))
429 | 
430 | (define noto
431 |   (lambda (g)
432 |     (lambdag@ (s env)
433 |       (inc
434 |         (let ([ans (g s (switch-unify env))])
435 |           (letrec ((negate (lambda (s)
436 |                              (cond
437 |                               [(procedure? s) (lambda () (negate (s)))]
438 |                               [(snull? ans) (succeed s env)]
439 |                               [else (fail s env)]))))
440 |                   (negate ans)))))))
441 | 
442 | (define noto
443 |   (lambda (g)
444 |     (lambdag@ (s env)
445 |       (let ([ans (defunc (g s (switch-unify env)))])
446 |         ((if (snull? ans)
447 |              ;;             (begin (printf "###fail###\n") succeed)
448 |              ;;             (begin (printf "###succeed###\n") fail)
449 |              succeed
450 |              fail
451 |              ) s env)))))
452 | 
453 | 
454 | (define-syntax exist
455 |   (syntax-rules ()
456 |     ((_ (x ...) g0 g ...)
457 |      (lambdag@ (s env)
458 |        (inc
459 |          (let ((x (var 'x)) ...)
460 |            ((ando g0 g ...) s (ext-vars env (list x ...)))))))))
461 | 
462 | (define-syntax forall
463 |   (syntax-rules ()
464 |     ((_ (x ...) g0 g ...)
465 |      (lambdag@ (s env)
466 |        (inc
467 |          (let ((x (var 'x)) ...)
468 |            ((ando g0 g ...)
469 |             (let loop ([ss (pkg-subst s)] [vars (list x ...)])
470 |              (cond
471 |               [(null? vars) ss]
472 |               [else (loop (ext-s (car vars) (gensym) ss) (cdr vars))]))
473 |             (ext-vars env (list x ...)))))))))
474 | 
475 | (define-syntax conde
476 |   (syntax-rules ()
477 |     ((_ (g0 g ...) (g1 g^ ...) ...)
478 |      (lambdag@ (s env)
479 |        (inc
480 |          ((oro (ando g0 g ...)
481 |                (ando g1 g^ ...) ...) s env))))))
482 | 
483 | (define-syntax condc
484 |   (syntax-rules ()
485 |     ((_ (g0 g ...)) (ando g0 g ...))
486 |     ((_ (g0 g ...) g^ ...)
487 |      (lambdag@ (s env)
488 |        (inc
489 |          ((oro (ando g0 g ...)
490 |                (assert ((noto g0))
491 |                        (condc g^ ...))) s env))))))
492 | 
493 | (define reify-constraint
494 |   (lambda (s)
495 |     (lambda (c)
496 |       (let ((ct (constraint-text c)))
497 |         (cond
498 |          [(pair? ct)
499 |           (cons (car ct) 
500 |                 (map (lambda (v) (walk* v (pkg-subst s))) (cdr ct)))]
501 |          [else ct])))))
502 | 
503 | (define format-constraints
504 |   (lambda (s)
505 |     (debug 'format-constraints "subst: ~a\nconstraints: ~a\n" 
506 |            (pkg-subst s)
507 |            (pkg-constraints s))
508 |     (map (reify-constraint s)
509 |          (filter (lambda (c) 
510 |                    (not (tautology? c (pkg-subst s))))
511 |                  (pkg-constraints s)))))
512 | 
513 | 
514 | (define-syntax run
515 |   (syntax-rules ()
516 |     ((_ n (x) g0 g ...)
517 |      (let ((x (var 'x)))
518 |        (let ([ss ((ando g0 g ...) (pkg empty-s '())
519 |                    (make-env unify-good '() (list x) '()))])
520 |          (take n (smap (lambda (s)
521 |                          (let* ((x (walk* x (pkg-subst s)))
522 |                                 (rs (reify-s x empty-s)))
523 |                            (list
524 |                             (walk* x rs)
525 |                             (let ((ctext (walk* (format-constraints s) rs)))
526 |                               (if (null? ctext)
527 |                                   '()
528 |                                   (list 'constraints: ctext))))))
529 |                        ss)))))))
530 | 
531 | (define tautology?
532 |   (lambda (c s)
533 |     (debug 'tautology?
534 |            "constraint: ~a\nvars: ~a\nsubst:~a\n"
535 |            (constraint-text c)
536 |            (constraint-vars c)
537 |            s)
538 |     (not (snull?
539 |           (defunc ((constraint-goal c)
540 |                    (pkg s '())
541 |                    (make-env unify-evil '() '() (constraint-vars c))))))))
542 | 
543 | 
544 | (define-syntax run*
545 |   (syntax-rules ()
546 |     ((_ (x) g ...) (run #f (x) g ...))))
547 | 
548 | (define-syntax make-text
549 |   (syntax-rules (quote quasiquote)
550 |     ((_ (quote a)) (quote a))
551 |     ((_ (quasiquote a)) (quasiquote a))
552 |     ((_ (g a0 ...)) (list 'g (make-text a0) ...))
553 |     ((_ a) a)))
554 | 
555 | (define-syntax make-text*
556 |   (syntax-rules (quote quasiquote)
557 |     ((_) '())
558 |     ((_ (quote a)) (quote a))
559 |     ((_ (quasiquote a)) (quasiquote a))
560 |     ((_ (g0 a ...) g ...)
561 |      (list (make-text (g0 a ...)) (make-text g) ...))
562 |     ((_ a) 'a)))
563 | 
564 | 
565 | ;; (make-text* `b)
566 | ;; (make-text* (noto (== `(,a ,d) (cons u v))) (noto (appendo a b c)))
567 | ;; (define a 1)
568 | ;; (define b 2)
569 | ;; (define c 3)
570 | ;; (define d 4)
571 | ;; (define u 5)
572 | ;; (define v 6)
573 | ;; (make-text* (a b c) `(,c a))
574 | ;; (define q 10)
575 | ; (make-text* (noto (== q 3)))
576 | 
577 | (define-syntax assert
578 |   (syntax-rules ()
579 |     ((_ (c0 c ...) g ...)
580 |      (lambdag@ (s env)
581 |        (inc 
582 |         ((ando g ...)
583 |          (ext-pkg-constraints s (list c0 c ...) (make-text* c0 c ...) env)
584 |          (ext-constraint env (list c0 c ...))))))))
585 | 
586 | (define-syntax conda
587 |   (syntax-rules ()
588 |     ((_ (g0 g ...) (g1 g^ ...) ...)
589 |      (lambdag@ (s)
590 |        (inc
591 |          (ifa ((g0 s) g ...)
592 |               ((g1 s) g^ ...) ...))))))
593 | 
594 | (define-syntax ifa
595 |   (syntax-rules ()
596 |     ((_) snull)
597 |     ((_ (e g ...) b ...)
598 |      (cond
599 |       [(snull? (defunc e)) (ifa b ...)]
600 |       [else (bind* e (list g ...))]))))
601 | 
602 | (define-syntax condu
603 |   (syntax-rules ()
604 |     ((_ (g0 g ...) (g1 g^ ...) ...)
605 |      (lambdag@ (s)
606 |        (inc
607 |          (ifu ((g0 s) g ...)
608 |               ((g1 s) g^ ...) ...))))))
609 |  
610 | (define-syntax ifu
611 |   (syntax-rules ()
612 |     ((_) snull)
613 |     ((_ (e g ...) b ...)
614 |      (cond
615 |       [(snull? (defunc e)) (ifa b ...)]
616 |       [else (bind* (sunit (scar e)) (list g ...))]))))
617 | 
618 | (define-syntax project
619 |   (syntax-rules ()
620 |     ((_ (x ...) g g* ...)
621 |      (lambdag@ (s env)
622 |        (let ((x (walk* x s)) ...)
623 |          ((exist () g g* ...) s env))))))
624 | 
625 | (define succeed (lambda (s env) (sunit s)))
626 | (define fail (lambda (s env) snull))
627 | 
628 | (define prints
629 |   (lambda (s env)
630 |     (begin 
631 |       (printf "#[prints]:: ~s\n" s)
632 |       (succeed s env))))
633 | 
634 | (define print-env
635 |   (lambdag@ (s env)
636 |     (begin 
637 |       (printf "env: ~s\n" env)
638 |       (succeed s env))))
639 | 
640 | (define print-var
641 |   (lambda (name v)
642 |     (lambda (s env)
643 |       (begin 
644 |         (printf "#[print-var] ~a = ~s\n" name (walk v s))
645 |         (succeed s env)))))
646 | 
647 | (define-syntax print-var
648 |   (syntax-rules ()
649 |     ((_ v) (lambda (s env)
650 |              (begin 
651 |                (printf "#[print-var] ~a = ~s\n" 'v (walk* v (pkg-subst s)))
652 |                (succeed s env))))))
653 | 
654 | 
655 | (define print-constraintso
656 |   (lambda (s env)
657 |     (printf "#[constraints] \n~a\n" 
658 |             (map (lambda (s) (format "~a\n" s))
659 |                  (map (reify-constraint s) (pkg-constraints s))))
660 |     (succeed s env)))
661 | 
662 | 


--------------------------------------------------------------------------------
/demos/typed-clojure1.clj:
--------------------------------------------------------------------------------
  1 | (ns clojure.core.typed
  2 |   (:refer-clojure :exclude [defrecord type])
  3 |   (:import (clojure.lang IPersistentList IPersistentVector Symbol Cons Seqable IPersistentCollection
  4 |                          ISeq ASeq ILookup Var Namespace PersistentVector APersistentVector
  5 |                          IFn IPersistentStack Associative IPersistentSet IPersistentMap IMapEntry
  6 |                          Keyword Atom PersistentList IMeta PersistentArrayMap Compiler Named
  7 |                          IRef AReference ARef IDeref IReference APersistentSet PersistentHashSet Sorted
  8 |                          LazySeq APersistentMap))
  9 |   (:require [analyze.core :refer [ast] :as analyze]
 10 |             [analyze.hygienic :as hygienic]
 11 |             [clojure.set :as set]
 12 |             [clojure.reflect :as reflect]
 13 |             [clojure.string :as str]
 14 |             [clojure.repl :refer [pst]]
 15 |             [clojure.pprint :refer [pprint]]
 16 |             [trammel.core :as contracts]
 17 |             [clojure.math.combinatorics :as comb]
 18 |             [clojure.java.io :as io]
 19 |             [cljs
 20 |              [compiler]
 21 |              [analyzer :as cljs]]
 22 |             [clojure.tools.trace :refer [trace-vars untrace-vars
 23 |                                          trace-ns untrace-ns]]))
 24 | 
 25 | (set! *warn-on-reflection* true)
 26 | 
 27 | 
 28 | ; constraint shorthands, other handy functions
 29 | (load "typed/utils")
 30 | 
 31 | ;Note: defrecord is now trammel's defconstrainedrecord
 32 | 
 33 | ;(ann analyze.hygienic/emit-hy [Any -> Any])
 34 | 
 35 | ;AnalysisExpr -> Form
 36 | ;(ann emit-form-fn [Any -> Any])
 37 | (def emit-form-fn hygienic/emit-hy)
 38 | 
 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 40 | ;; Special functions
 41 | 
 42 | ;(ann print-filterset [String Any -> Any])
 43 | (defn print-filterset
 44 |   "Print the filter set attached to form, and debug-string"
 45 |   [debug-string frm] 
 46 |   frm)
 47 | 
 48 | (declare Method->Function unparse-type unparse-filter)
 49 | 
 50 | ;(ann method-type [Symbol -> nil])
 51 | (defn method-type 
 52 |   "Given a method symbol, print the core.typed types assigned to it"
 53 |   [mname]
 54 |   (let [ms (->> (reflect/type-reflect (Class/forName (namespace mname)))
 55 |              :members
 56 |              (filter #(and (instance? clojure.reflect.Method %)
 57 |                            (= (str (:name %)) (name mname))))
 58 |              set)
 59 |         _ (assert (seq ms) (str "Method " mname " not found"))]
 60 |     (prn "Method name:" mname)
 61 |     (doseq [m ms]
 62 |       (prn (unparse-type (Method->Function m))))))
 63 | 
 64 | ;(ann inst-poly [Any Any -> Any])
 65 | (defn inst-poly 
 66 |   [inst-of types-syn]
 67 |   inst-of)
 68 | 
 69 | ;(ann inst-poly-ctor [Any Any -> Any])
 70 | (defn inst-poly-ctor [inst-of types-syn]
 71 |   inst-of)
 72 | 
 73 | (defmacro inst 
 74 |   "Instantiate a polymorphic type with a number of types"
 75 |   [inst-of & types]
 76 |   `(inst-poly ~inst-of '~types))
 77 | 
 78 | (defmacro inst-ctor
 79 |   "Instantiate a call to a constructor with a number of types.
 80 |   First argument must be an immediate call to a constructor."
 81 |   [inst-of & types]
 82 |   `(inst-poly-ctor ~inst-of '~types))
 83 | 
 84 | ;(ann fn>-ann [Any Any -> Any])
 85 | (defn fn>-ann [fn-of param-types-syn]
 86 |   fn-of)
 87 | 
 88 | ;(ann pfn>-ann [Any Any -> Any])
 89 | (defn pfn>-ann [fn-of polys param-types-syn]
 90 |   fn-of)
 91 | 
 92 | ;(ann loop>-ann [Any Any -> Any])
 93 | (defn loop>-ann [loop-of bnding-types]
 94 |   loop-of)
 95 | 
 96 | ;(ann doseq>-ann [Any Any -> Any])
 97 | (defn doseq>-ann [the-doseq bnding-types body]
 98 |   the-doseq)
 99 | 
100 | ;(ann parse-fn> [Any (Seqable Any) ->
101 | ;                '{:poly Any
102 | ;                  :fn Any ;Form
103 | ;                  :parsed-methods (Seqable '{:dom-syntax (Seqable Any)
104 | ;                                             :dom-lhs (Seqable Any)
105 | ;                                             :rng-syntax Any
106 | ;                                             :has-rng? Any
107 | ;                                             :body Any})}])
108 | ;for
109 | (defn- parse-fn>
110 |   "(fn> name? :- type? [[param :- type]* & [param :- type *]?] exprs*)
111 |   (fn> name? (:- type? [[param :- type]* & [param :- type *]?] exprs*)+)"
112 |   [is-poly forms]
113 |   (let [name (when (symbol? (first forms))
114 |                (first forms))
115 |         forms (if name (rest forms) forms)
116 |         poly (when is-poly
117 |                (first forms))
118 |         forms (if poly (rest forms) forms)
119 |         methods (if ((some-fn vector? keyword?) (first forms))
120 |                   (list forms)
121 |                   forms)
122 |         ;(fn> name? (:- type? [[param :- type]* & [param :- type *]?] exprs*)+)"
123 |         ; (HMap {:dom (Seqable TypeSyntax)
124 |         ;        :rng (U nil TypeSyntax)
125 |         ;        :body Any})
126 |         parsed-methods (doall 
127 |                          (for [method methods]
128 |                            (let [[ret has-ret?] (when (not (vector? (first method)))
129 |                                                   (assert (= :- (first method))
130 |                                                           "Return type for fn> must be prefixed by :-")
131 |                                                   [(second method) true])
132 |                                  method (if ret 
133 |                                           (nnext method)
134 |                                           method)
135 |                                  body (rest method)
136 |                                  arg-anns (first method)
137 |                                  [required-params _ [rest-param]] (split-with #(not= '& %) arg-anns)]
138 |                              (assert (sequential? required-params)
139 |                                      "Must provide a sequence of typed parameters to fn>")
140 |                              (assert (not rest-param) "fn> doesn't support rest parameters yet")
141 |                              {:dom-syntax (doall (map (comp second next) required-params))
142 |                               :dom-lhs (doall (map first required-params))
143 |                               :rng-syntax ret
144 |                               :has-rng? has-ret?
145 |                               :body body})))]
146 |     {:poly poly
147 |      :fn `(fn ~@(concat
148 |                   (when name
149 |                     [name])
150 |                   (for [{:keys [body dom-lhs]} parsed-methods]
151 |                     (apply list (vec dom-lhs) body))))
152 |      :parsed-methods parsed-methods}))
153 | 
154 | (defmacro pfn> 
155 |   "Define a polymorphic typed anonymous function.
156 |   (pfn> name? [binder+] :- type? [[param :- type]* & [param :- type *]?] exprs*)
157 |   (pfn> name? [binder+] (:- type? [[param :- type]* & [param :- type *]?] exprs*)+)"
158 |   [& forms]
159 |   (let [{:keys [poly fn parsed-methods]} (parse-fn> true forms)]
160 |     `(pfn>-ann ~fn '~poly '~parsed-methods)))
161 | 
162 | (defmacro fn> 
163 |   "Define a typed anonymous function.
164 |   (fn> name? :- type? [[param :- type]* & [param :- type *]?] exprs*)
165 |   (fn> name? (:- type? [[param :- type]* & [param :- type *]?] exprs*)+)"
166 |   [& forms]
167 |   (let [{:keys [fn parsed-methods]} (parse-fn> false forms)]
168 |     `(fn>-ann ~fn '~parsed-methods)))
169 | 
170 | (defmacro defprotocol> [& body]
171 |   "Define a typed protocol"
172 |   `(tc-ignore
173 |      (defprotocol ~@body)))
174 | 
175 | (defmacro loop>
176 |   "Define a typed loop"
177 |   [bndings* & forms]
178 |   (let [bnds (partition 2 bndings*)
179 |         ; [[lhs :- bnd-ann] rhs]
180 |         lhs (map ffirst bnds)
181 |         rhs (map second bnds)
182 |         bnd-anns (map #(-> % first next second) bnds)]
183 |     `(loop>-ann (loop ~(vec (mapcat vector lhs rhs))
184 |                   ~@forms)
185 |                 '~bnd-anns)))
186 | 
187 | (defmacro declare-datatypes 
188 |   "Declare datatypes, similar to declare but on the type level."
189 |   [& syms]
190 |   `(tc-ignore
191 |   (doseq [sym# '~syms]
192 |     (assert (not (or (some #(= \. %) (str sym#))
193 |                      (namespace sym#)))
194 |             (str "Cannot declare qualified datatype: " sym#))
195 |     (let [qsym# (symbol (str (munge (name (ns-name *ns*))) \. (name sym#)))]
196 |       (declare-datatype* qsym#)))))
197 | 
198 | (defmacro declare-protocols 
199 |   "Declare protocols, similar to declare but on the type level."
200 |   [& syms]
201 |   `(tc-ignore
202 |   (doseq [sym# '~syms]
203 |      (let [qsym# (if (namespace sym#)
204 |                    sym#
205 |                    (symbol (str (name (ns-name *ns*))) (name sym#)))]
206 |        (declare-protocol* qsym#)))))
207 | 
208 | (defmacro declare-alias-kind
209 |   "Declare a kind for an alias, similar to declare but on the kind level."
210 |   [sym ty]
211 |   `(tc-ignore
212 |    (do (ensure-clojure)
213 |      (let [sym# '~sym
214 |            qsym# (if (namespace sym#)
215 |                    sym#
216 |                    (symbol (name (ns-name *ns*)) (name sym#)))
217 |            ty# (parse-type '~ty)]
218 |        (assert (not (namespace sym#)) (str "Cannot declare qualified name " sym#))
219 |        (declare ~sym)
220 |        (declare-names ~sym)
221 |        (declare-alias-kind* qsym# ty#)))))
222 | 
223 | (defmacro declare-names 
224 |   "Declare names, similar to declare but on the type level."
225 |   [& syms]
226 |   `(tc-ignore
227 |   (doseq [sym# '~syms]
228 |      (let [qsym# (if (namespace sym#)
229 |                    sym#
230 |                    (symbol (name (ns-name *ns*)) (name sym#)))]
231 |        (declare-name* qsym#)))))
232 | 
233 | (defmacro def-alias 
234 |   "Define a type alias"
235 |   [sym type]
236 |   `(tc-ignore
237 |   (do (ensure-clojure)
238 |     (let [sym# (if (namespace '~sym)
239 |                  '~sym
240 |                  (symbol (name (ns-name *ns*)) (name '~sym)))
241 |           ty# (parse-type '~type)]
242 |       (add-type-name sym# ty#)
243 |       (declare ~sym)
244 |       (when-let [tfn# (@DECLARED-KIND-ENV sym#)]
245 |         (assert (subtype? ty# tfn#) (error-msg "Declared kind " (unparse-type tfn#)
246 |                                                " does not match actual kind " (unparse-type ty#))))
247 |       [sym# (unparse-type ty#)]))))
248 | 
249 | (declare Type? RClass? PrimitiveArray? RClass->Class parse-type symbol->Class
250 |          requires-resolving? -resolve Nil? Value? Value->Class Union? Intersection?)
251 | 
252 | ;Return a Class that generalises what this Clojure type will look like from Java,
253 | ;suitable  for use as a Java primitive array member type.
254 | ; 
255 | ; (Type->array-member-Class (parse-type 'nil)) => Object
256 | ; (Type->array-member-Class (parse-type '(U nil Number))) => Number
257 | ; (Type->array-member-Class (parse-type '(Array (U nil Number)))) =~> (Array Number)
258 | 
259 | ;(ann Type->array-member-Class (Fn [Type -> (Option Class)]
260 | ;                                  [Type Any -> (Option Class)]))
261 | (defn Type->array-member-Class 
262 |   ([ty] (Type->array-member-Class ty false))
263 |   ([ty nilok?]
264 |    {:pre [(Type? ty)]}
265 |    (cond
266 |      (requires-resolving? ty) (Type->array-member-Class (-resolve ty) nilok?)
267 |      (Nil? ty) (if nilok?
268 |                  nil
269 |                  Object)
270 |      (Value? ty) (Value->Class ty)
271 |      ;; handles most common case of (U nil Type)
272 |      (Union? ty) (let [clss (map #(Type->array-member-Class % true) (:types ty))
273 |                        prim-and-nil? (and (some nil? clss)
274 |                                           (some #(when % (.isPrimitive ^Class %)) clss))
275 |                        nonil-clss (remove nil? clss)]
276 |                    (if (and (= 1 (count nonil-clss))
277 |                             (not prim-and-nil?))
278 |                      (first nonil-clss)
279 |                      Object))
280 |      (Intersection? ty) Object
281 |      (RClass? ty) (RClass->Class ty)
282 |      (PrimitiveArray? ty) (class (make-array (Type->array-member-Class (:jtype ty) false) 0))
283 |      :else Object)))
284 | 
285 | ;(ann into-array>* [Any Any -> Any])
286 | (defn into-array>* 
287 |   ([cljt coll]
288 |    (into-array (-> cljt parse-type Type->array-member-Class) coll))
289 |   ([javat cljt coll]
290 |    (into-array (-> javat parse-type Type->array-member-Class) coll)))
291 | 
292 | (defmacro into-array> 
293 |   "Make a Java array with Java class javat and Typed Clojure type
294 |   cljt. Resulting array will be of type javat, but elements of coll must be under
295 |   cljt. cljt should be a subtype of javat (the same or more specific)."
296 |   ([cljt coll]
297 |    `(into-array>* '~cljt ~coll))
298 |   ([javat cljt coll]
299 |    `(into-array>* '~javat '~cljt ~coll)))
300 | 
301 | (defn ann-form* [form ty]
302 |   form)
303 | 
304 | (defmacro ann-form [form ty]
305 |   `(ann-form* ~form '~ty))
306 | 
307 | ;(ann unsafe-ann-form* [Any Any -> Any])
308 | (defn unsafe-ann-form* [form ty]
309 |   form)
310 | 
311 | (defmacro unsafe-ann-form [form ty]
312 |   `(unsafe-ann-form* ~form '~ty))
313 | 
314 | ;(ann tc-ignore-forms* [Any -> Any])
315 | (defn tc-ignore-forms* [r]
316 |   r)
317 | 
318 | ;; `do` is special at the top level
319 | (defmacro tc-ignore 
320 |   "Ignore forms in body during type checking"
321 |   [& body]
322 |   `(do ~@(map (fn [b] `(tc-ignore-forms* ~b)) body)))
323 | 
324 | (defmacro non-nil-return 
325 |   "Override the return type of method msym to be non-nil.
326 |   Takes a set of relevant arities,
327 |   represented by the number of parameters it takes (rest parameter counts as one),
328 |   or :all which overrides all arities.
329 |   
330 |   eg.  (non-nil-return java.lang.Class/getDeclaredMethod :all)"
331 |   [msym arities]
332 |   `(tc-ignore
333 |   (add-nonnilable-method-return '~msym '~arities)))
334 | 
335 | (defmacro nilable-param 
336 |   "Overrides which parameters in a method may accept
337 |   nilable values. If the parameter is a parameterised type or
338 |   an Array, this also declares the parameterised types and the Array type as nilable.
339 | 
340 |   mmap is a map mapping arity parameter number to a set of parameter
341 |   positions (integers). If the map contains the key :all then this overrides
342 |   other entries. The key can also be :all, which declares all parameters nilable."
343 |   [msym mmap]
344 |   `(tc-ignore
345 |   (add-method-nilable-param '~msym '~mmap)))
346 | 
347 | (declare abstract-many instantiate-many)
348 | 
349 | (load "typed/type_rep"
350 |       "typed/type_ops"
351 |       "typed/filter_rep"
352 |       "typed/filter_ops"
353 |       "typed/path_rep"
354 |       "typed/object_rep")
355 | 
356 | ; must be after type/object/filter definitions
357 | (load "typed/fold")
358 | 
359 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
360 | ;; Annotations
361 | 
362 | (declare TCResult?)
363 | 
364 | ;(ann (predicate (APersistentMap Symbol Any)))
365 | (def lex-env? (hash-c? (every-pred symbol? (complement namespace)) Type?))
366 | 
367 | (defrecord PropEnv [l props]
368 |   "A lexical environment l, props is a list of known propositions"
369 |   [(lex-env? l)
370 |    (every? Filter? props)])
371 | 
372 | (declare ^:dynamic *lexical-env*)
373 | 
374 | (defn print-env [debug-str]
375 |   nil)
376 | 
377 | (defn print-env*
378 |   ([] (print-env* *lexical-env*))
379 |   ([e]
380 |    {:pre [(PropEnv? e)]}
381 |    ;; DO NOT REMOVE
382 |    (prn {:env (into {} (for [[k v] (:l e)]
383 |                          [k (unparse-type v)]))
384 |          :props (map unparse-filter (:props e))})))
385 | 
386 | (defonce VAR-ANNOTATIONS (atom {}))
387 | (def ^:dynamic *lexical-env* (->PropEnv {} []))
388 | 
389 | (defmacro with-lexical-env [env & body]
390 |   `(binding [*lexical-env* ~env]
391 |      ~@body))
392 | 
393 | (set-validator! VAR-ANNOTATIONS #(and (every? (every-pred symbol? namespace) (keys %))
394 |                                       (every? Type? (vals %))))
395 | (set-validator! #'*lexical-env* PropEnv?)
396 | 
397 | (defmacro ann [varsym typesyn]
398 |   `(tc-ignore
399 |  (do (ensure-clojure)
400 |    (let [t# (parse-type '~typesyn)
401 |          s# (if (namespace '~varsym)
402 |               '~varsym
403 |               (symbol (-> *ns* ns-name str) (str '~varsym)))]
404 |      (do (add-var-type s# t#)
405 |        [s# (unparse-type t#)])))))
406 | 
407 | (declare parse-type alter-class*)
408 | 
409 | (defn parse-field [[n _ t]]
410 |   [n (parse-type t)])
411 | 
412 | (defn gen-datatype* [provided-name fields variances args ancests]
413 |   `(do (ensure-clojure)
414 |   (let [provided-name-str# (str '~provided-name)
415 |          ;_# (prn "provided-name-str" provided-name-str#)
416 |          munged-ns-str# (if (some #(= \. %) provided-name-str#)
417 |                           (apply str (butlast (apply concat (butlast (partition-by #(= \. %) provided-name-str#)))))
418 |                           (str (munge (-> *ns* ns-name))))
419 |          ;_# (prn "munged-ns-str" munged-ns-str#)
420 |          demunged-ns-str# (str (clojure.repl/demunge munged-ns-str#))
421 |          ;_# (prn "demunged-ns-str" demunged-ns-str#)
422 |          local-name# (if (some #(= \. %) provided-name-str#)
423 |                        (symbol (apply str (last (partition-by #(= \. %) (str provided-name-str#)))))
424 |                        provided-name-str#)
425 |          ;_# (prn "local-name" local-name#)
426 |          s# (symbol (str munged-ns-str# \. local-name#))
427 |          fs# (apply array-map (apply concat (with-frees (mapv make-F '~args)
428 |                                               (mapv parse-field (partition 3 '~fields)))))
429 |          as# (set (with-frees (mapv make-F '~args)
430 |                     (mapv parse-type '~ancests)))
431 |          _# (add-datatype-ancestors s# as#)
432 |          pos-ctor-name# (symbol demunged-ns-str# (str "->" local-name#))
433 |          args# '~args
434 |          vs# '~variances
435 |          dt# (if args#
436 |                (Poly* args# (repeat (count args#) no-bounds)
437 |                       (->DataType s# vs# (map make-F args#) fs#)
438 |                       args#)
439 |                (->DataType s# nil nil fs#))
440 |          pos-ctor# (if args#
441 |                      (Poly* args# (repeat (count args#) no-bounds)
442 |                             (make-FnIntersection
443 |                               (make-Function (vec (vals fs#)) (->DataType s# vs# (map make-F args#) fs#)))
444 |                             args#)
445 |                      (make-FnIntersection
446 |                        (make-Function (vec (vals fs#)) dt#)))]
447 |      (do 
448 |        (when vs#
449 |          (let [f# (mapv make-F (repeatedly (count vs#) gensym))]
450 |            (alter-class* s# (RClass* (map :name f#) vs# f# s# {}))))
451 |        (add-datatype s# dt#)
452 |        (add-var-type pos-ctor-name# pos-ctor#)
453 |        [[s# (unparse-type dt#)]
454 |         [pos-ctor-name# (unparse-type pos-ctor#)]]))))
455 | 
456 | (defmacro ann-datatype [dname fields & {ancests :unchecked-ancestors rplc :replace}]
457 |   (assert (not rplc) "Replace NYI")
458 |   (assert (symbol? dname)
459 |           (str "Must provide name symbol: " dname))
460 |   `(tc-ignore
461 |      ~(gen-datatype* dname fields nil nil ancests)))
462 | 
463 | (defmacro ann-pdatatype [dname vbnd fields & {ancests :unchecked-ancestors rplc :replace}]
464 |   (assert (not rplc) "Replace NYI")
465 |   (assert (symbol? dname)
466 |           (str "Must provide local symbol: " dname))
467 |   `(tc-ignore
468 |      ~(gen-datatype* dname fields (map second vbnd) (map first vbnd) ancests)))
469 | 
470 | (defn gen-protocol* [local-varsym variances args mths]
471 |   `(do (ensure-clojure)
472 |   (let [local-vsym# '~local-varsym
473 |          s# (symbol (-> *ns* ns-name str) (str local-vsym#))
474 |          on-class# (symbol (str (munge (namespace s#)) \. local-vsym#))
475 |          ; add a Name so the methods can be parsed
476 |          _# (declare-protocol* s#)
477 |          args# '~args
478 |          fs# (when args# 
479 |                (map make-F args#))
480 |          ms# (into {} (for [[knq# v#] '~mths]
481 |                         (do
482 |                           (assert (not (namespace knq#))
483 |                                   "Protocol method should be unqualified")
484 |                           [knq# (with-frees fs# (parse-type v#))])))
485 |          t# (if fs#
486 |               (Poly* (map :name fs#) (repeat (count fs#) no-bounds) 
487 |                      (->Protocol s# '~variances fs# on-class# ms#)
488 |                      (map :name fs#))
489 |               (->Protocol s# nil nil on-class# ms#))]
490 |      (do
491 |        (add-protocol s# t#)
492 |        (doseq [[kuq# mt#] ms#]
493 |          ;qualify method names when adding methods as vars
494 |          (let [kq# (symbol (-> *ns* ns-name str) (str kuq#))]
495 |            (add-var-type kq# mt#)))
496 |        [s# (unparse-type t#)]))))
497 | 
498 | (defmacro ann-protocol [local-varsym & {:as mth}]
499 |   (assert (not (or (namespace local-varsym)
500 |                    (some #{\.} (str local-varsym))))
501 |           (str "Must provide local var name for protocol: " local-varsym))
502 |   `(tc-ignore
503 |      ~(gen-protocol* local-varsym nil nil mth)))
504 | 
505 | (defmacro ann-pprotocol [local-varsym vbnd & {:as mth}]
506 |   (assert (not (or (namespace local-varsym)
507 |                    (some #{\.} (str local-varsym))))
508 |           (str "Must provide local var name for protocol: " local-varsym))
509 |   `(tc-ignore
510 |      ~(gen-protocol* local-varsym (mapv second vbnd) (mapv first vbnd) mth)))
511 | 
512 | (defmacro override-constructor [ctorsym typesyn]
513 |   `(tc-ignore
514 |    (do (ensure-clojure)
515 |      (let [t# (parse-type '~typesyn)
516 |            s# '~ctorsym]
517 |        (do (add-constructor-override s# t#)
518 |          [s# (unparse-type t#)])))))
519 | 
520 | (defmacro override-method [methodsym typesyn]
521 |   `(tc-ignore
522 |    (do (ensure-clojure)
523 |      (let [t# (parse-type '~typesyn)
524 |            s# (if (namespace '~methodsym)
525 |                 '~methodsym
526 |                 (throw (Exception. "Method name must be a qualified symbol")))]
527 |        (do (add-method-override s# t#)
528 |          [s# (unparse-type t#)])))))
529 | 
530 | (defn add-var-type [sym type]
531 |   (swap! VAR-ANNOTATIONS #(assoc % sym type))
532 |   nil)
533 | 
534 | (defn lookup-local [sym]
535 |   (-> *lexical-env* :l sym))
536 | 
537 | (def ^:dynamic *var-annotations*)
538 | 
539 | (defn lookup-Var [nsym]
540 |   (assert (contains? @*var-annotations* nsym) 
541 |           (str (when *current-env*
542 |                  (str (:line *current-env*) ": "))
543 |             "Untyped var reference: " nsym))
544 |   (@*var-annotations* nsym))
545 | 
546 | (defn merge-locals [env new]
547 |   (-> env
548 |     (update-in [:l] #(merge % new))))
549 | 
550 | (defmacro with-locals [locals & body]
551 |   `(binding [*lexical-env* (merge-locals *lexical-env* ~locals)]
552 |      ~@body))
553 | 
554 | (declare ^:dynamic *current-env*)
555 | 
556 | (defn type-of [sym]
557 |   {:pre [(symbol? sym)]
558 |    :post [(or (Type? %)
559 |               (TCResult? %))]}
560 |   (cond
561 |     (not (namespace sym)) (if-let [t (lookup-local sym)]
562 |                             t
563 |                             (throw (Exception. (str (when *current-env*
564 |                                                       (str (:line *current-env*) ": "))
565 |                                                     "Reference to untyped binding: " sym))))
566 |     :else (lookup-Var sym)))
567 | 
568 | 
569 | (derive ::clojurescript ::default)
570 | (derive ::clojure ::default)
571 | 
572 | (def TYPED-IMPL (atom ::clojure))
573 | (set-validator! TYPED-IMPL #(isa? % ::default))
574 | 
575 | (defn ensure-clojure []
576 |   (reset! TYPED-IMPL ::clojure))
577 | 
578 | (defn ensure-clojurescript []
579 |   (reset! TYPED-IMPL ::clojurescript))
580 | 
581 | (defn checking-clojure? []
582 |   (= ::clojure @TYPED-IMPL))
583 | 
584 | (defn checking-clojurescript? []
585 |   (= ::clojurescript @TYPED-IMPL))
586 | 
587 | (load "typed/dvar_env"
588 |       "typed/datatype_ancestor_env"
589 |       "typed/datatype_env"
590 |       "typed/protocol_env"
591 |       "typed/method_override_env"
592 |       "typed/ctor_override_env"
593 |       "typed/method_return_nilables"
594 |       "typed/method_param_nilables"
595 |       "typed/declared_kind_env"
596 |       "typed/name_env"
597 |       "typed/rclass_env"
598 |       "typed/mm_env")
599 | 
600 | (load "typed/constant_type"
601 |       "typed/parse"
602 |       "typed/unparse"
603 |       "typed/frees"
604 |       "typed/promote_demote"
605 |       "typed/cs_gen"
606 |       "typed/subst_dots"
607 |       "typed/infer"
608 |       "typed/tvar_rep"
609 |       "typed/subst"
610 |       "typed/trans"
611 |       "typed/inst"
612 |       "typed/subtype"
613 |       "typed/alter"
614 |       "typed/ann"
615 |       "typed/check"
616 |       "typed/check_cljs")
617 | 
618 | ;emit something that CLJS can display ie. a quoted unparsed typed
619 | (defmacro cf-cljs
620 |   "Type check a Clojurescript form and return its type"
621 |   ([form]
622 |    (let [t
623 |          (do (ensure-clojurescript)
624 |            (-> (ana-cljs {:locals {} :context :expr :ns {:name cljs/*cljs-ns*}} form) check-cljs expr-type unparse-TCResult))]
625 |      `'~t))
626 |   ([form expected]
627 |    (let [t
628 |          (do (ensure-clojurescript)
629 |            (-> (ana-cljs {:locals {} :context :expr :ns {:name cljs/*cljs-ns*}}
630 |                          (list `ann-form-cljs form expected))
631 |              (#(check-cljs % (ret (parse-type expected)))) expr-type unparse-TCResult))]
632 |      `'~t)))
633 | 
634 | (defmacro cf 
635 |   "Type check a Clojure form and return its type"
636 |   ([form]
637 |   `(do (ensure-clojure)
638 |      (tc-ignore
639 |        (-> (ast ~form) hygienic/ast-hy check expr-type unparse-TCResult))))
640 |   ([form expected]
641 |   `(do (ensure-clojure)
642 |      (tc-ignore
643 |        (-> (ast (ann-form ~form ~expected)) hygienic/ast-hy (#(check % (ret (parse-type '~expected)))) expr-type unparse-TCResult)))))
644 | 
645 | (defn analyze-file-asts
646 |   [^String f]
647 |   (let [res (if (re-find #"^file://" f) (java.net.URL. f) (io/resource f))]
648 |     (assert res (str "Can't find " f " in classpath"))
649 |     (with-altered-specials
650 |       (binding [cljs/*cljs-ns* 'cljs.user
651 |                 cljs/*cljs-file* (.getPath ^java.net.URL res)
652 |                 *ns* cljs/*reader-ns*]
653 |         (with-open [r (io/reader res)]
654 |           (let [env (cljs/empty-env)
655 |                 pbr (clojure.lang.LineNumberingPushbackReader. r)
656 |                 eof (Object.)]
657 |             (loop [r (read pbr false eof false)
658 |                    asts []]
659 |               (let [env (assoc env :ns (cljs/get-namespace cljs/*cljs-ns*))]
660 |                 (if-not (identical? eof r)
661 |                   (let [ast1 (cljs/analyze env r)]
662 |                     (recur (read pbr false eof false) (conj asts ast1)))
663 |                   asts)))))))))
664 | 
665 | (defn check-cljs-ns*
666 |   "Type check a CLJS namespace. If not provided default to current namespace"
667 |   ([] (check-cljs-ns* cljs/*cljs-ns*))
668 |   ([nsym]
669 |    (ensure-clojurescript)
670 |    (let [asts (analyze-file-asts (cljs/ns->relpath nsym))]
671 |      (doseq [ast asts]
672 |        (check-cljs ast)))))
673 | 
674 | (defmacro check-cljs-ns
675 |   ([] (check-cljs-ns*) `'~'success)
676 |   ([nsym] (check-cljs-ns* nsym) `'~'success))
677 | 
678 | (defn check-ns 
679 |   "Type check a namespace. If not provided default to current namespace"
680 |   ([] (check-ns (ns-name *ns*)))
681 |   ([nsym]
682 |    (ensure-clojure)
683 |    (with-open [^clojure.lang.LineNumberingPushbackReader pbr (analyze/pb-reader-for-ns nsym)]
684 |      (let [[_ns-decl_ & asts] (->> (analyze/analyze-ns pbr (analyze/uri-for-ns nsym) nsym)
685 |                                 (map hygienic/ast-hy))]
686 |        (doseq [ast asts]
687 |          (check-expr ast))))))
688 | 
689 | (defn trepl []
690 |   (clojure.main/repl 
691 |     :eval (fn [f] 
692 |             (let [t (do (ensure-clojure)
693 |                       (-> (analyze/analyze-form f) hygienic/ast-hy
694 |                         check expr-type unparse-TCResult))]
695 |               (prn t) 
696 |               (eval f)))))
697 | 
698 | (comment 
699 |   (check-ns 'typed.test.example)
700 | 
701 |   ; very slow because of update-composite
702 |   (check-ns 'typed.test.rbt)
703 | 
704 |   (check-ns 'typed.test.macro)
705 |   (check-ns 'typed.test.conduit)
706 |   (check-ns 'typed.test.person)
707 |   (check-ns 'typed.test.core-logic)
708 |   (check-ns 'typed.test.ckanren)
709 | 
710 |   (check-cljs-ns 'typed.test.logic)
711 |   )
712 | 


--------------------------------------------------------------------------------
/diff-cpp.rkt:
--------------------------------------------------------------------------------
 1 | ;; ydiff - a language-aware tool for comparing programs
 2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
 3 | 
 4 | ;; This program is free software: you can redistribute it and/or modify
 5 | ;; it under the terms of the GNU General Public License as published by
 6 | ;; the Free Software Foundation, either version 3 of the License, or
 7 | ;; (at your option) any later version.
 8 | 
 9 | ;; This program is distributed in the hope that it will be useful,
10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 | ;; GNU General Public License for more details.
13 | 
14 | ;; You should have received a copy of the GNU General Public License
15 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
16 | 
17 | 
18 | #lang racket
19 | 
20 | (require "structs.rkt")
21 | (require "utils.rkt")
22 | (require "parse-cpp.rkt")
23 | (require "diff.rkt")
24 | (require "htmlize.rkt")
25 | 
26 | 
27 | 
28 | ;-------------------------------------------------------------
29 | ;                      overrides
30 | ;-------------------------------------------------------------
31 | 
32 | (set-get-name
33 |   (lambda (node)
34 |     (let ([id-exp (match-tags node '(name identifier id))])
35 |       (and id-exp (get-symbol (car (Node-elts id-exp)))))))
36 | 
37 | ;; (get-name (car (parse1 $statement "int f(int x) {}")))
38 | 
39 | 
40 | ;; (same-def? (car (parse1 $statement "int f(int x) {}"))
41 | ;;            (car (parse1 $statement "int f(int x) {}")))
42 | 
43 | 
44 | ;; command line interface
45 | (let* ([args (current-command-line-arguments)]
46 |        [file1 (vector-ref args 0)]
47 |        [file2 (vector-ref args 1)]
48 |        [text1 (read-file file1)]
49 |        [text2 (read-file file2)]
50 |        [node1 (parse-cpp text1)]
51 |        [node2 (parse-cpp text2)]
52 |        [changes (diff node1 node2)])
53 |   (htmlize changes file1 file2 text1 text2))
54 | 
55 | 
56 | ;---------------------------------------------
57 | ; (diff-cpp "tests/simulator-mips.cc" "tests/simulator-arm.cc")
58 | ; (diff-cpp "tests/d8-3404.cc" "tests/d8-8424.cc")
59 | 


--------------------------------------------------------------------------------
/diff-js.rkt:
--------------------------------------------------------------------------------
 1 | ;; ydiff - a language-aware tool for comparing programs
 2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
 3 | 
 4 | ;; This program is free software: you can redistribute it and/or modify
 5 | ;; it under the terms of the GNU General Public License as published by
 6 | ;; the Free Software Foundation, either version 3 of the License, or
 7 | ;; (at your option) any later version.
 8 | 
 9 | ;; This program is distributed in the hope that it will be useful,
10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 | ;; GNU General Public License for more details.
13 | 
14 | ;; You should have received a copy of the GNU General Public License
15 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
16 | 
17 | 
18 | 
19 | #lang racket
20 | 
21 | (require "structs.rkt")
22 | (require "utils.rkt")
23 | (require "parse-js.rkt")
24 | (require "diff.rkt")
25 | (require "htmlize.rkt")
26 | 
27 | 
28 | 
29 | ;-------------------------------------------------------------
30 | ;                         overrides
31 | ;-------------------------------------------------------------
32 | 
33 | (set-get-name
34 |   (lambda (node)
35 |     (let ([name (match-tags node '(name))])
36 |       (cond
37 |        [(not name) #f]
38 |        [(pair? (Node-elts name))
39 |         (get-symbol (car (Node-elts name)))]
40 |        [else #f]))))
41 | 
42 | ;; (same-def? (car (parse1 $statement "function f(x) {}"))
43 | ;;            (car (parse1 $statement "function f(x) {}")))
44 | 
45 | 
46 | ;; command line interface
47 | (let* ([args (current-command-line-arguments)]
48 |        [file1 (vector-ref args 0)]
49 |        [file2 (vector-ref args 1)]
50 |        [text1 (read-file file1)]
51 |        [text2 (read-file file2)]
52 |        [node1 (parse-js text1)]
53 |        [node2 (parse-js text2)]
54 |        [changes (diff node1 node2)])
55 |   (htmlize changes file1 file2 text1 text2))
56 | 


--------------------------------------------------------------------------------
/diff-lisp.rkt:
--------------------------------------------------------------------------------
 1 | ;; ydiff - a language-aware tool for comparing programs
 2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
 3 | 
 4 | ;; This program is free software: you can redistribute it and/or modify
 5 | ;; it under the terms of the GNU General Public License as published by
 6 | ;; the Free Software Foundation, either version 3 of the License, or
 7 | ;; (at your option) any later version.
 8 | 
 9 | ;; This program is distributed in the hope that it will be useful,
10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 | ;; GNU General Public License for more details.
13 | 
14 | ;; You should have received a copy of the GNU General Public License
15 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
16 | 
17 | 
18 | #lang racket
19 | 
20 | (require "structs.rkt")
21 | (require "utils.rkt")
22 | (require "parse-lisp.rkt")
23 | (require "diff.rkt")
24 | (require "htmlize.rkt")
25 | 
26 | 
27 | (define *keywords*
28 |   '(define defun defvar lambda cond if else
29 |      let let* let-values let*-values
30 |      while for define-syntax syntax-rules
31 |      define-minor-mode defmacro defn))
32 | 
33 | (define *defs*
34 |   '(define defun defvar define-syntax define-minor-mode
35 |     defmacro defn))
36 | 
37 | 
38 | (define get-keyword
39 |   (lambda (node)
40 |     (match node
41 |       [(Node type _ _ elts _ _)
42 |        (cond
43 |         [(pair? elts)
44 |          (let ([sym (get-symbol (car elts))])
45 |            (cond
46 |             [(memq sym *keywords*) sym]
47 |             [else #f]))]
48 |         [else #f])]
49 |       [_ #f])))
50 | 
51 | 
52 | ;; Try to get the keyword of the sexp if it is not token, comment, str
53 | ;; and char.
54 | (set-get-type
55 |   (lambda (node)
56 |     (cond
57 |      [(token? node) 'token]
58 |      [(comment? node) 'comment]
59 |      [(str? node) 'str]
60 |      [(character? node) 'char]
61 |      [else
62 |       (get-keyword node)])))
63 | 
64 | 
65 | (set-get-name
66 |   (lambda (node)
67 |     (let ([key (get-keyword node)])
68 |       (cond
69 |        [(and key
70 |              (memq key *defs*)
71 |              (pair? (Node-elts node))
72 |              (not (null? (cdr (Node-elts node)))))
73 |         (get-symbol (cadr (Node-elts node)))]
74 |        [else #f]))))
75 | 
76 | 
77 | ;; function interface
78 | (define diff-lisp
79 |   (lambda (file1 file2)
80 |     (let* ([text1 (read-file file1)]
81 |            [text2 (read-file file2)]
82 |            [node1 (parse-lisp text1)]
83 |            [node2 (parse-lisp text2)]
84 |            [changes (diff node1 node2)])
85 |       (htmlize changes file1 file2 text1 text2))))
86 | 
87 | ;; (diff-lisp "demos/mk1.ss" "demos/mk2.ss")
88 | 
89 | 
90 | ;; command line interface
91 | (let* ([args (current-command-line-arguments)]
92 |        [file1 (vector-ref args 0)]
93 |        [file2 (vector-ref args 1)])
94 |   (diff-lisp file1 file2))
95 | 


--------------------------------------------------------------------------------
/diff-yin.rkt:
--------------------------------------------------------------------------------
 1 | ;; ydiff - a language-aware tool for comparing programs
 2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
 3 | 
 4 | ;; This program is free software: you can redistribute it and/or modify
 5 | ;; it under the terms of the GNU General Public License as published by
 6 | ;; the Free Software Foundation, either version 3 of the License, or
 7 | ;; (at your option) any later version.
 8 | 
 9 | ;; This program is distributed in the hope that it will be useful,
10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 | ;; GNU General Public License for more details.
13 | 
14 | ;; You should have received a copy of the GNU General Public License
15 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
16 | 
17 | 
18 | #lang racket
19 | 
20 | (require "structs.rkt")
21 | (require "utils.rkt")
22 | (require "parse-yin.rkt")
23 | (require "diff.rkt")
24 | (require "htmlize.rkt")
25 | 
26 | 
27 | (define *keywords*
28 |   '(define defun defvar lambda cond if else
29 |      let let* let-values let*-values
30 |      while for define-syntax syntax-rules
31 |      define-minor-mode defmacro defn))
32 | 
33 | (define *defs*
34 |   '(define defun defvar define-syntax define-minor-mode
35 |     defmacro defn))
36 | 
37 | 
38 | (define get-keyword
39 |   (lambda (node)
40 |     (match node
41 |       [(Node type _ _ elts _ _)
42 |        (cond
43 |         [(pair? elts)
44 |          (let ([sym (get-symbol (car elts))])
45 |            (cond
46 |             [(memq sym *keywords*) sym]
47 |             [else #f]))]
48 |         [else #f])]
49 |       [_ #f])))
50 | 
51 | 
52 | ;; Try to get the keyword of the sexp if it is not token, comment, str
53 | ;; and char.
54 | (set-get-type
55 |   (lambda (node)
56 |     (cond
57 |      [(token? node) 'token]
58 |      [(comment? node) 'comment]
59 |      [(str? node) 'str]
60 |      [(character? node) 'char]
61 |      [else
62 |       (get-keyword node)])))
63 | 
64 | 
65 | (set-get-name
66 |   (lambda (node)
67 |     (let ([key (get-keyword node)])
68 |       (cond
69 |        [(and key
70 |              (memq key *defs*)
71 |              (pair? (Node-elts node))
72 |              (not (null? (cdr (Node-elts node)))))
73 |         (get-symbol (cadr (Node-elts node)))]
74 |        [else #f]))))
75 | 
76 | 
77 | ;; function interface
78 | (define diff-yin
79 |   (lambda (file1 file2)
80 |     (let* ([text1 (read-file file1)]
81 |            [text2 (read-file file2)]
82 |            [node1 (parse-yin text1)]
83 |            [node2 (parse-yin text2)]
84 |            [changes (diff node1 node2)])
85 |       (htmlize changes file1 file2 text1 text2))))
86 | 
87 | ;; (diff-yin "demos/mk1.ss" "demos/mk2.ss")
88 | 
89 | 
90 | ;; command line interface
91 | (let* ([args (current-command-line-arguments)]
92 |        [file1 (vector-ref args 0)]
93 |        [file2 (vector-ref args 1)])
94 |   (diff-yin file1 file2))
95 | 


--------------------------------------------------------------------------------
/diff.css:
--------------------------------------------------------------------------------
  1 | /* ydiff - a language-aware tool for comparing programs */
  2 | /* Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com) */
  3 | 
  4 | 
  5 | /* This program is free software: you can redistribute it and/or modify */
  6 | /* it under the terms of the GNU General Public License as published by */
  7 | /* the Free Software Foundation, either version 3 of the License, or */
  8 | /* (at your option) any later version. */
  9 | 
 10 | /* This program is distributed in the hope that it will be useful, */
 11 | /* but WITHOUT ANY WARRANTY; without even the implied warranty of */
 12 | /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the */
 13 | /* GNU General Public License for more details. */
 14 | 
 15 | /* You should have received a copy of the GNU General Public License */
 16 | /* along with this program.  If not, see <http://www.gnu.org/licenses/>. */
 17 | 
 18 | 
 19 | .d {                            /* deleted */
 20 |     border: solid 1px #CC929A;
 21 |     border-radius: 3px;
 22 |     background-color: #FCBFBA;
 23 | }
 24 | 
 25 | .i {                            /* inserted */
 26 |     border: solid 1px #73BE73;
 27 |     border-radius: 3px;
 28 |     background-color: #98FB98;
 29 | }
 30 | 
 31 | .c {                            /* changed */
 32 |     border: solid 1px #8AADB8;
 33 |     background-color: LightBlue;
 34 |     border-radius: 3px;
 35 |     cursor: pointer;
 36 | }
 37 | 
 38 | .m {                            /* moved */
 39 |     border: solid 1px #A9A9A9;
 40 |     border-radius: 3px;
 41 |     cursor: crosshair;
 42 | }
 43 | 
 44 | .mc {
 45 |     border: solid 1px LightPink;
 46 |     background-color: LightBlue;
 47 |     cursor: pointer;
 48 | }
 49 | 
 50 | .u {                            /* unchanged */
 51 |     border: solid 1px #A9A9A9;
 52 |     border-radius: 4px;
 53 |     cursor: crosshair;
 54 | }
 55 | 
 56 | span.lineno {
 57 |     color: lightgrey;
 58 |     -webkit-user-select: none;
 59 |     -moz-user-select: none;
 60 | }
 61 | 
 62 | span.keyword {
 63 |     /* color: #007070; */
 64 |     font-weight: 700;
 65 | }
 66 | 
 67 | div.line {
 68 | }
 69 | 
 70 | div.src {
 71 |     width:48%;
 72 |     height:98%;
 73 |     overflow:scroll;
 74 |     float:left;
 75 |     padding:0.5%;
 76 |     border: solid 2px LightGrey;
 77 |     border-radius: 5px;
 78 | }
 79 | 
 80 | 
 81 | div.stats {
 82 |     border: solid 1px grey;
 83 |     z-index: 1000;
 84 |     width: 80%;
 85 |     padding-left: 5%;
 86 | }
 87 | 
 88 | pre.stats {
 89 |     color: grey;
 90 |     -webkit-user-select: none;
 91 |     -moz-user-select: none;
 92 | }
 93 | 
 94 | pre {
 95 |     line-height: 200%;
 96 | }
 97 | 
 98 | p {
 99 |     line-height: 200%;
100 | }
101 | 
102 | ::-webkit-scrollbar {
103 |     width: 10px;
104 | }
105 | 
106 | ::-webkit-scrollbar-track {
107 |     -webkit-box-shadow: inset 0 0 6px rgba(0,0,0,0.3);
108 |     border-radius: 10px;
109 | }
110 | 
111 | ::-webkit-scrollbar-thumb {
112 |     border-radius: 10px;
113 |     -webkit-box-shadow: inset 0 0 6px rgba(0,0,0,0.5);
114 | }
115 | 


--------------------------------------------------------------------------------
/diff.rkt:
--------------------------------------------------------------------------------
  1 | ;; ydiff - a language-aware tool for comparing programs
  2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
  3 | 
  4 | 
  5 | ;; This program is free software: you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation, either version 3 of the License, or
  8 | ;; (at your option) any later version.
  9 | 
 10 | ;; This program is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | #lang racket
 19 | 
 20 | (require "structs.rkt")
 21 | (require "utils.rkt")
 22 | 
 23 | 
 24 | (provide (all-defined-out))
 25 | 
 26 | 
 27 | ;-------------------------------------------------------------
 28 | ;                      parameters
 29 | ;-------------------------------------------------------------
 30 | 
 31 | ;; The minimum size of a node to be considered as moved. Shouldn't be
 32 | ;; too small, otherwise small deleted names may appear in a very
 33 | ;; distant place!
 34 | (define *move-size* 5)
 35 | 
 36 | 
 37 | ;; Similar to *move-size*, but this number is used for internal moves inside a
 38 | ;; named body (for example a function). This number can be smaller than
 39 | ;; *move-size*, usually set to 2 for maxmum accuracy without much noise.
 40 | (define *inner-move-size* 2)
 41 | 
 42 | 
 43 | ;; Only memoize the diff of nodes of size larger than this number.
 44 | ;; This effectively reduces memory usage.
 45 | (define *memo-node-size* 2)
 46 | 
 47 | 
 48 | ;; Are we in moving phase?
 49 | ;; This is internal switch used by the diff algorithm.
 50 | ;; Do not modify by handl.
 51 | (define *moving* #f)
 52 | 
 53 | 
 54 | 
 55 | ;;------------------ frames utils --------------------
 56 | (define deframe
 57 |   (lambda (node)
 58 |     (match node
 59 |       [(Node 'frame _ _ elts _ _)
 60 |        (apply append (map deframe elts))]
 61 |      [else (list node)])))
 62 | 
 63 | 
 64 | (define deframe-change
 65 |   (lambda (change)
 66 |     (cond
 67 |      [(ins? change)
 68 |       (apply append
 69 |              (map ins (deframe (Change-new change))))]
 70 |      [(del? change)
 71 |       (apply append
 72 |              (map del (deframe (Change-old change))))]
 73 |      [else (list change)])))
 74 | 
 75 | 
 76 | (define extract-frame
 77 |   (lambda (node1 node2 type)
 78 |     (match node1
 79 |       [(Node type1 start1 end1 elts1 size ctx)
 80 |        (let ([frame-elts (filter (lambda (x)
 81 |                                    (not (eq? x node2)))
 82 |                                  elts1)])
 83 |          (type (Node 'frame start1 start1 frame-elts (- size (node-size node2)) ctx)))]
 84 |       [_ fatal 'extract-frame "I only accept Node"])))
 85 | 
 86 | 
 87 | ;; (define n1 (Token "ok" 0 1))
 88 | ;; (define n2 (Expr 'ok 0 2 (list n1 (Token "bar" 1 2))))
 89 | ;; (map deframe-change (extract-frame n2 n1 ins))
 90 | 
 91 | 
 92 | 
 93 | ;-------------------------------------------------------------
 94 | ;                       diff proper
 95 | ;-------------------------------------------------------------
 96 | 
 97 | ; 2-D memoization table
 98 | (define make-table
 99 |   (lambda (dim1 dim2)
100 |     (let ([vec (make-vector (add1 dim1))])
101 |       (let loop ([n 0])
102 |         (cond
103 |          [(= n (vector-length vec)) vec]
104 |          [else
105 |           (vector-set! vec n (make-vector (add1 dim2) #f))
106 |           (loop (add1 n))])))))
107 | 
108 | 
109 | (define table-ref
110 |   (lambda (t x y)
111 |     (let ([row (vector-ref t x)])
112 |       (vector-ref row y))))
113 | 
114 | 
115 | (define table-set!
116 |   (lambda (t x y v)
117 |     (let ([row (vector-ref t x)])
118 |       (vector-set! row y v))))
119 | 
120 | 
121 | 
122 | ;---------------- string distance function -----------------
123 | 
124 | ;; string distance is no longer used because string=? saffice to
125 | ;; compare strings in ASTs. Retain it here for possible later uses.
126 | (define string-dist
127 |   (lambda (s1 s2)
128 |     (let* ([len1 (string-length s1)]
129 |            [len2 (string-length s2)]
130 |            [t (make-table len1 len2)]
131 |            [char-dist (dist1 t s1 0 s2 0)])
132 |       (cond
133 |        [(= 0 (+ len1 len2)) 0]
134 |        [else
135 |         (/ (* 2.0 char-dist) (+ len1 len2))]))))
136 | 
137 | 
138 | (define dist1
139 |   (lambda (table s1 start1 s2 start2)
140 |     (define memo
141 |       (lambda (value)
142 |         (table-set! table start1 start2 value)
143 |         value))
144 |     (cond
145 |      [(table-ref table start1 start2)
146 |       => (lambda (cached) cached)]
147 |      [(= start1 (string-length s1))
148 |       (memo (- (string-length s2) start2))]
149 |      [(= start2 (string-length s2))
150 |       (memo (- (string-length s1) start1))]
151 |      [else
152 |       (let* ([c1 (string-ref s1 start1)]
153 |              [c2 (string-ref s2 start2)]
154 |              [d0 (cond
155 |                   [(char=? c1 c2) 0]
156 |                   [(char=? (char-downcase c1)
157 |                            (char-downcase c2)) 1]
158 |                   [else 2])]
159 |              [d1 (+ d0 (dist1 table s1 (add1 start1) s2 (add1 start2)))]
160 |              [d2 (+ 1 (dist1 table s1 (add1 start1) s2 start2))]
161 |              [d3 (+ 1 (dist1 table s1 start1 s2 (add1 start2)))])
162 |         (memo (min d1 d2 d3)))])))
163 | 
164 | 
165 | 
166 | ;--------------------- the primary diff function -------------------
167 | 
168 | ;; global 2-D hash for storing known diffs
169 | (define *diff-hash* (make-hasheq))
170 | 
171 | (define diff-node
172 |   (lambda (node1 node2)
173 | 
174 |     (define memo
175 |       (lambda (v1 v2)
176 |         (and (> (node-size node1) *memo-node-size*)
177 |              (> (node-size node2) *memo-node-size*)
178 |              (hash-put! *diff-hash* node1 node2 (cons v1 v2)))
179 |         (values v1 v2)))
180 | 
181 |     (define try-extract
182 |       (lambda (changes cost)
183 |         (cond
184 |          [(or (not *moving*)
185 |               (zero? cost))
186 |           (memo changes cost)]
187 |          [else
188 |           (letv ([(m c) (diff-extract node1 node2)])
189 |             (cond
190 |              [(not m)
191 |               (memo changes cost)]
192 |              [else
193 |               (memo m c)]))])))
194 | 
195 | 
196 |     (diff-progress 1) ;; progress bar
197 | 
198 |     (cond
199 |      [(hash-get *diff-hash* node1 node2)
200 |       => (lambda (cached)
201 |            (values (car cached) (cdr cached)))]
202 |      [(and (character? node1) (character? node2))
203 |       (diff-string (char->string (Node-elts node1))
204 |                    (char->string (Node-elts node2))
205 |                    node1 node2)]
206 |      [(and (str? node1) (str? node2))
207 |       (diff-string (Node-elts node1) (Node-elts node2) node1 node2)]
208 |      [(and (comment? node1) (comment? node2))
209 |       (diff-string (Node-elts node1) (Node-elts node2) node1 node2)]
210 |      [(and (token? node1) (token? node2))
211 |       (diff-string (Node-elts node1) (Node-elts node2) node1 node2)]
212 |      [(and (Node? node1) (Node? node2)
213 |            (eq? (get-type node1) (get-type node2)))
214 |       (letv ([(m c) (diff-list (Node-elts node1) (Node-elts node2))])
215 |         (try-extract m c))]
216 |      [(and (pair? node1) (not (pair? node2)))
217 |       (diff-list node1 (list node2))]
218 |      [(and (not (pair? node1)) (pair? node2))
219 |       (diff-list (list node1) node2)]
220 |      [(and (pair? node1) (pair? node2))
221 |       (diff-list node1 node2)]
222 |      [else
223 |       (letv ([(m c) (total node1 node2)])
224 |         (try-extract m c))])))
225 | 
226 | 
227 | 
228 | 
229 | ;; helper for nodes with string contents (Str, Comment, Token etc.)
230 | (define diff-string
231 |   (lambda (string1 string2 node1 node2)
232 |     (cond
233 |      [(string=? string1 string2)
234 |       (values (mov node1 node2 0) 0)]
235 |      [else
236 |       (total node1 node2)])))
237 | 
238 | 
239 | (define diff-list
240 |   (lambda (ls1 ls2)
241 |     (let ([ls1 (sort ls1 node-sort-fn)]
242 |           [ls2 (sort ls2 node-sort-fn)])
243 |       (diff-list1 (make-hasheq) ls1 ls2))))
244 | 
245 | 
246 | (define diff-list1
247 |   (lambda (table ls1 ls2)
248 | 
249 |     (define memo
250 |       (lambda (v1 v2)
251 |         (hash-put! table ls1 ls2 (cons v1 v2))
252 |         (values v1 v2)))
253 | 
254 |     (define guess
255 |       (lambda (ls1  ls2)
256 |         (letv ([(m0 c0) (diff-node (car ls1) (car ls2))]
257 |                [(m1 c1) (diff-list1 table (cdr ls1) (cdr ls2))])
258 |           (cond
259 |            [(or (zero? c0)
260 |                 (same-def? (car ls1) (car ls2)))
261 |             (memo (append m0 m1) (+ c0 c1))]
262 |            [else
263 |             (letv ([(m2 c2) (diff-list1 table (cdr ls1) ls2 )]
264 |                    [(m3 c3) (diff-list1 table ls1 (cdr ls2))]
265 |                    [cost2 (+ c2 (node-size (car ls1)))]
266 |                    [cost3 (+ c3 (node-size (car ls2)))])
267 |               (cond
268 |                [(<= cost2 cost3)
269 |                 (memo (append (del (car ls1)) m2) cost2)]
270 |                [else
271 |                 (memo (append (ins (car ls2)) m3) cost3)]))]))))
272 | 
273 |     (cond
274 |      [(hash-get table ls1 ls2)
275 |       => (lambda (cached)
276 |            (values (car cached) (cdr cached)))]
277 |      [(and (null? ls1) (null? ls2))
278 |       (values '() 0)]
279 |      [(null? ls1)
280 |       (let ([changes (apply append (map ins ls2))])
281 |         (values changes (node-size ls2)))]
282 |      [(null? ls2)
283 |       (let ([changes (apply append (map del ls1))])
284 |         (values changes (node-size ls1)))]
285 |      [else
286 |       (guess ls1 ls2)])))
287 | 
288 | 
289 | 
290 | (define same-ctx?
291 |   (lambda (x y)
292 |     (and (Node? x)
293 |          (Node? y)
294 |          (Node-ctx x)
295 |          (Node-ctx y)
296 |          (>= (node-size x) *inner-move-size*)
297 |          (>= (node-size y) *inner-move-size*)
298 |          (eq? (Node-ctx x) (Node-ctx y)))))
299 | 
300 | 
301 | ;; structure extraction
302 | (define diff-extract
303 |   (lambda (node1 node2)
304 |     (cond
305 |      [(and (Node? node1) (Node? node2)
306 |            (or (same-ctx? node1 node2)
307 |                (and (big-node? node1)
308 |                     (big-node? node2))))
309 |       (cond
310 |        [(<= (node-size node1) (node-size node2))
311 |         (let loop ([elts2 (Node-elts node2)])
312 |           (cond
313 |            [(pair? elts2)
314 |             (letv ([(m0 c0) (diff-node node1 (car elts2))])
315 |               (cond
316 |                [(or (same-def? node1 (car elts2))
317 |                     (and (zero? c0)
318 |                          (or (big-node? node1)
319 |                              (same-ctx? node1 (car elts2)))))
320 |                 (let ([frame (extract-frame node2 (car elts2) ins)])
321 |                   (values (append m0 frame) c0))]
322 |                [else
323 |                 (loop (cdr elts2))]))]
324 |            [else
325 |             (values #f #f)]))]
326 |        [else
327 |         (let loop ([elts1 (Node-elts node1)])
328 |           (cond
329 |            [(pair? elts1)
330 |             (letv ([(m0 c0) (diff-node (car elts1) node2)])
331 |               (cond
332 |                [(or (same-def? (car elts1) node2)
333 |                     (and (zero? c0)
334 |                          (or (big-node? node2)
335 |                              (same-ctx? (car elts1) node2))))
336 |                 (let ([frame (extract-frame node1 (car elts1) del)])
337 |                   (values (append m0 frame) c0))]
338 |                [else
339 |                 (loop (cdr elts1))]))]
340 |            [else
341 |             (values #f #f)]))])]
342 |      [else (values #f #f)])))
343 | 
344 | 
345 | 
346 | ;-------------------------------------------------------------
347 | ;                    finding moves
348 | ;-------------------------------------------------------------
349 | 
350 | (define big-node?
351 |   (lambda (node)
352 |     (>= (node-size node) *move-size*)))
353 | 
354 | 
355 | (define big-change?
356 |   (lambda (c)
357 |     (cond
358 |      [(ins? c)
359 |       (big-node? (Change-new c))]
360 |      [(del? c)
361 |       (big-node? (Change-old c))]
362 |      [(mov? c)
363 |       (or (big-node? (Change-old c))
364 |           (big-node? (Change-new c)))])))
365 | 
366 | 
367 | (define node-sort-fn
368 |   (lambda (x y)
369 |     (let ([name1 (get-name x)]
370 |           [name2 (get-name y)])
371 |       (cond
372 |        [(and name1 name2)
373 |         (string<? (symbol->string name1)
374 |                   (symbol->string name2))]
375 |        [(and name1 (not name2)) #t]
376 |        [(and (not name1) name2) #f]
377 |        [else
378 |         (< (Node-start x) (Node-start y))]))))
379 | 
380 | 
381 | 
382 | ;; iterate diff-list on the list of changes
383 | (define find-moves
384 |   (lambda (changes)
385 |     (set! *moving* #t)
386 |     (set! *diff-hash* (make-hasheq))
387 |     (let loop ([workset changes]
388 |                [finished '()])
389 |       (diff-progress "|")
390 |       (letv ([dels (filter (predand del? big-change?) workset)]
391 |              [adds (filter (predand ins? big-change?) workset)]
392 |              [rest (set- workset (append dels adds))]
393 |              [ls1 (sort (map Change-old dels) node-sort-fn)]
394 |              [ls2 (sort (map Change-new adds) node-sort-fn)]
395 |              [(m c) (diff-list ls1 ls2)]
396 |              [new-moves (filter mov? m)])
397 |         (cond
398 |          [(null? new-moves)
399 |           (let ([all-changes (append workset finished)])
400 |             (apply append (map deframe-change all-changes)))]
401 |          [else
402 |           (let ([new-changes (filter (negate mov?) m)])
403 |             (loop new-changes
404 |                   (append new-moves rest finished)))])))))
405 | 
406 | 
407 | ;; poor man's progress bar
408 | (define diff-progress
409 |   (new-progress 10000))
410 | 
411 | 
412 | (define cleanup
413 |   (lambda ()
414 |     (set! *diff-hash* #f)))
415 | 
416 | 
417 | ;; main diff function
418 | ;; returns all changes after diffing and moving
419 | (define diff
420 |   (lambda (node1 node2)
421 |     (letv ([start (current-seconds)]    ; start timer
422 |            [size1 (node-size node1)]
423 |            [size2 (node-size node2)])
424 | 
425 |       (printf "[info] size of program 1: ~a~n" size1)
426 |       (printf "[info] size of program 2: ~a~n" size2)
427 | 
428 |       (set-node-context node1 'top)
429 |       (set-node-context node2 'top)
430 | 
431 |       (printf "[diffing]~n")
432 | 
433 |       (letv ([(changes cost) (diff-node node1 node2)])
434 |         (diff-progress 'reset)
435 |         (printf "~n[moving]~n")
436 |         (letv ([changes (find-moves changes)]
437 |                [end (current-seconds)])
438 |           (printf "~n[finished] ~a seconds~n" (- end start))
439 |           (printf "~n[info] count: ~a~n" (diff-progress 'get))
440 |           (cleanup)
441 |           changes)))))
442 | 


--------------------------------------------------------------------------------
/htmlize.rkt:
--------------------------------------------------------------------------------
  1 | ;; ydiff - a language-aware tool for comparing programs
  2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
  3 | 
  4 | 
  5 | ;; This program is free software: you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation, either version 3 of the License, or
  8 | ;; (at your option) any later version.
  9 | 
 10 | ;; This program is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | #lang racket
 19 | 
 20 | (require "utils.rkt")
 21 | (require "structs.rkt")
 22 | 
 23 | (provide (all-defined-out))
 24 | 
 25 | 
 26 | 
 27 | ;-------------------------------------------------------------
 28 | ;                      HTML generation
 29 | ;-------------------------------------------------------------
 30 | 
 31 | ;----------------- utils ----------------
 32 | (define qs
 33 |   (lambda (x)
 34 |     (let ([x (cond
 35 |               [(symbol? x) (symbol->string x)]
 36 |               [(number? x) (number->string x)]
 37 |               [(string? x) x])])
 38 |       (string-append "'" x "'"))))
 39 | 
 40 | 
 41 | (define line
 42 |   (lambda (port . s)
 43 |     (display (string-append (apply string-append s) "\n") port)))
 44 | 
 45 | 
 46 | 
 47 | (define change-tags
 48 |   (lambda (changes side)
 49 |     (let loop ([cs changes] [tags '()])
 50 |       (cond
 51 |        [(null? cs) tags]
 52 |        [else
 53 |         (let ([key (if (eq? side 'left)
 54 |                        (Change-old (car cs))
 55 |                        (Change-new (car cs)))])
 56 |           (cond
 57 |            [(or (not key)
 58 |                 (= (Node-start key) (Node-end key)))
 59 |             (loop (cdr cs) tags)]
 60 |            [(and (Change-old (car cs)) (Change-new (car cs)))
 61 |             (let ([startTag (Tag (link-start (car cs) side)
 62 |                                  (Node-start key) -1)]
 63 |                   [endTag (Tag "</a>" (Node-end key) (Node-start key))])
 64 |               (loop (cdr cs) (cons endTag (cons startTag tags))))]
 65 |            [else
 66 |             (let ([startTag (Tag (span-start (car cs) side)
 67 |                                  (Node-start key) -1)]
 68 |                   [endTag (Tag "</span>" (Node-end key) (Node-start key))])
 69 |               (loop (cdr cs) (cons endTag (cons startTag tags))))]))]))))
 70 | 
 71 | 
 72 | (define apply-tags
 73 |   (lambda (s tags)
 74 |     (let ([tags (sort tags tag-sort-fn)])
 75 |       (let loop ([tags tags] [curr 0] [out '()])
 76 |         (cond
 77 |          [(null? tags)
 78 |           (cond
 79 |            [(< curr (string-length s))
 80 |             (loop tags (add1 curr) (cons (escape (string-ref s curr)) out))]
 81 |            [else
 82 |             (apply string-append (reverse out))])]
 83 |          [else
 84 |           (cond
 85 |            [(< curr (Tag-idx (car tags)))
 86 |             (loop tags (add1 curr) (cons (escape (string-ref s curr)) out))]
 87 |            [else
 88 |             (loop (cdr tags) curr (cons (Tag-tag (car tags)) out))])])))))
 89 | 
 90 | 
 91 | 
 92 | ;; get the CSS class for the change
 93 | (define change-class
 94 |   (lambda (change)
 95 |     (cond
 96 |      [(mov? change) "m"]                        ; move
 97 |      [(del? change) "d"]
 98 |      [(ins? change) "i"]
 99 |      [else "u"])))                              ; unchanged
100 | 
101 | 
102 | 
103 | (define link-start
104 |   (lambda (change side)
105 |     (let ([cls (change-class change)]
106 |           [me (if (eq? side 'left)
107 |                   (Change-old change)
108 |                   (Change-new change))]
109 |           [other (if (eq? side 'left)
110 |                      (Change-new change)
111 |                      (Change-old change))])
112 |       (string-append
113 |        "<a id="  (qs (uid me))
114 |        " tid="   (qs (uid other))
115 |        " class=" (qs cls)
116 |        ">"))))
117 | 
118 | 
119 | (define span-start
120 |   (lambda (change side)
121 |     (string-append "<span class=" (qs (change-class change)) ">")))
122 | 
123 | 
124 | (define tag-sort-fn
125 |   (lambda (t1 t2)
126 |     (cond
127 |      [(= (Tag-idx t1) (Tag-idx t2))
128 |       (> (Tag-start t1) (Tag-start t2))]
129 |      [else
130 |       (< (Tag-idx t1) (Tag-idx t2))])))
131 | 
132 | 
133 | (define *escape-table*
134 |   '((#\"  .   "&quot;")
135 |     (#\'  .    "&#39;")
136 |     (#\<  .    "&lt;")
137 |     (#\>  .    "&gt;")))
138 | 
139 | 
140 | (define escape
141 |   (lambda (c)
142 |     (cond
143 |      [(assq c *escape-table*) => cdr]
144 |      [else (char->string c)])))
145 | 
146 | 
147 | 
148 | ; getting the base name of a path/file name
149 | ; (base-name "mk/mk-c.scm") => mk-c
150 | (define base-name
151 |   (lambda (fn)
152 |     (let loop ([i (- (string-length fn) 1)]
153 |                [start -1]
154 |                [end (- (string-length fn) 1)])
155 |       (cond
156 |        [(= i 0)
157 |         (substring fn i end)]
158 |        [(eq? (string-ref fn i) #\.)
159 |         (loop (sub1 i) start i)]
160 |        [(eq? (string-ref fn i) #\/)
161 |         (substring fn (add1 i) end)]
162 |        [else
163 |         (loop (sub1 i) start end)]))))
164 | 
165 | 
166 | 
167 | (define html-header
168 |   (lambda (port)
169 |       (line port "<html>")
170 |       (line port "<head>")
171 |       (line port "<META http-equiv=\"Content-Type\""
172 |                       " content=\"text/html; charset=utf-8\">")
173 |       (line port "<LINK href=\"diff.css\""
174 |                       " rel=\"stylesheet\" type=\"text/css\">")
175 |       (line port "<script type=\"text/javascript\""
176 |                         " src=\"nav.js\"></script>")
177 |       (line port "</head>")
178 |       (line port "<body>")))
179 | 
180 | 
181 | 
182 | (define html-footer
183 |   (lambda (port)
184 |     (line port "</body>")
185 |     (line port "</html>")))
186 | 
187 | 
188 | 
189 | (define write-html
190 |   (lambda (port text side)
191 |     (line port (string-append "<div id=\"" side "\" class=\"src\">"))
192 |     (line port "<pre>")
193 |     (if (string=? side "left")
194 |         (line port "<a id='leftstart' tid='rightstart'></a>")
195 |         (line port "<a id='rightstart' tid='leftstart'></a>"))
196 |     (line port text)
197 |     (line port "</pre>")
198 |     (line port "</div>")))
199 | 
200 | 
201 | (define htmlize
202 |   (lambda (changes file1 file2 text1 text2)
203 |     (letv ([tags1 (change-tags changes 'left)]
204 |            [tags2 (change-tags changes 'right)]
205 |            [tagged-text1 (apply-tags text1 tags1)]
206 |            [tagged-text2 (apply-tags text2 tags2)]
207 |            [out-file (string-append (base-name file1) "-"
208 |                                     (base-name file2) ".html")]
209 |            [port (open-output-file out-file
210 |                                    #:mode 'text
211 |                                    #:exists 'replace)])
212 |       (html-header port)
213 |       (write-html port tagged-text1 "left")
214 |       (write-html port tagged-text2 "right")
215 |       (html-footer port)
216 |       (close-output-port port))))
217 | 
218 | 


--------------------------------------------------------------------------------
/nav.js:
--------------------------------------------------------------------------------
  1 | // convenience function for document.getElementById().
  2 | window['$']=function(a){return document.getElementById(a)};
  3 | 
  4 | 
  5 | /////////////////////// debug flag ////////////////////////
  6 | var debug = false;
  7 | 
  8 | 
  9 | /////////////////////// adjustable parameters //////////////////
 10 | var minStep = 10;
 11 | var nSteps = 30;
 12 | var stepInterval = 10;
 13 | var blockRange = 5;                    // how far consider one page blocked
 14 | var nodeHLColor = '#C9B0A9';
 15 | var lineHLColor = '#FFFF66';
 16 | var lineBlockedColor = '#E9AB17';
 17 | var bgColor = '';
 18 | var bodyBlockedColor = '#FAF0E6';
 19 | 
 20 | 
 21 | ///////////////////////// globals ////////////////////////
 22 | var eventCount = { 'left' : 0, 'right' : 0};
 23 | var moving = false;
 24 | var matchId1 = 'leftstart';
 25 | var matchId2 = 'rightstart';
 26 | var matchLineId1 = -1;
 27 | var matchLineId2 = -1;
 28 | var cTimeout;
 29 | 
 30 | 
 31 | ///////////////////////// utilities ///////////////////////
 32 | 
 33 | // No Math.sign() in JS?
 34 | function sign(x) {
 35 |     if (x > 0) {
 36 |         return 1;
 37 |     } else if (x < 0) {
 38 |         return -1;
 39 |     } else {
 40 |         return 0;
 41 |     }
 42 | }
 43 | 
 44 | 
 45 | function log(msg) {
 46 |     if (debug) {
 47 |         console.log(msg);
 48 |     }
 49 | }
 50 | 
 51 | 
 52 | 
 53 | function elementPosition(id) {
 54 |     obj = $(id);
 55 |     var curleft = 0, curtop = 0;
 56 | 
 57 |     if (obj && obj.offsetParent) {
 58 |         curleft = obj.offsetLeft;
 59 |         curtop = obj.offsetTop;
 60 | 
 61 |         while (obj = obj.offsetParent) {
 62 |             curleft += obj.offsetLeft;
 63 |             curtop += obj.offsetTop;
 64 |         }
 65 |     }
 66 | 
 67 |     return { x: curleft, y: curtop };
 68 | }
 69 | 
 70 | 
 71 | /*
 72 |  * Scroll the window to relative position, detecting blocking positions.
 73 |  */
 74 | function scrollWithBlockCheck(container, distX, distY) {
 75 |     var oldTop = container.scrollTop;
 76 |     var oldLeft = container.scrollLeft;
 77 | 
 78 |     container.scrollTop += distY;      // the ONLY place for actual scrolling
 79 |     container.scrollLeft += distX;
 80 | 
 81 |     var actualX = container.scrollLeft - oldLeft;
 82 |     var actualY = container.scrollTop - oldTop;
 83 |     log("distY=" + distY + ", actualY=" + actualY);
 84 |     log("distX=" + distX + ", actualX=" + actualX);
 85 | 
 86 |     // extra leewaw here because Chrome scrolling is horribly inacurate
 87 |     if ((Math.abs(distX) > blockRange && actualX === 0)
 88 |         || Math.abs(distY) > blockRange && actualY === 0) {
 89 |         log("blocked");
 90 |         container.style.backgroundColor = bodyBlockedColor;
 91 |         return true;
 92 |     } else {
 93 |         eventCount[container.id] += 1;
 94 |         container.style.backgroundColor = bgColor;
 95 |         return false;
 96 |     }
 97 | }
 98 | 
 99 | 
100 | function getContainer(elm) {
101 |     while (elm && elm.tagName !== 'DIV') {
102 |         elm = elm.parentElement || elm.parentNode;
103 |     }
104 |     return elm;
105 | }
106 | 
107 | 
108 | /*
109 |  * timed animation function for scrolling the current window
110 |  */
111 | function matchWindow(linkId, targetId, n)
112 | {
113 |     moving = true;
114 | 
115 |     var link = $(linkId);
116 |     var target = $(targetId);
117 |     var linkContainer = getContainer(link);
118 |     var targetContainer = getContainer(target);
119 | 
120 |     var linkPos = elementPosition(linkId).y - linkContainer.scrollTop;
121 |     var targetPos = elementPosition(targetId).y - targetContainer.scrollTop;
122 |     var distY = targetPos - linkPos;
123 |     var distX = linkContainer.scrollLeft - targetContainer.scrollLeft;
124 | 
125 | 
126 |     log("matching window... " + n + " distY=" + distY + " distX=" + distX);
127 | 
128 |     if (distY === 0 && distX === 0) {
129 |         clearTimeout(cTimeout);
130 |         moving = false;
131 |     } else if (n <= 1) {
132 |         scrollWithBlockCheck(targetContainer, distX, distY);
133 |         moving = false;
134 |     } else {
135 |         var stepSize = Math.floor(Math.abs(distY) / n);
136 |         actualMinStep = Math.min(minStep, Math.abs(distY));
137 |         if (Math.abs(stepSize) < minStep) {
138 |             var step = actualMinStep * sign(distY);
139 |         } else {
140 |             var step = stepSize * sign(distY);
141 |         }
142 |         var blocked = scrollWithBlockCheck(targetContainer, distX, step);
143 |         var rest = Math.floor(distY / step) - 1;
144 |         log("blocked?" + blocked + ", rest steps=" + rest);
145 |         if (!blocked) {
146 |             cTimeout = setTimeout(function () {
147 |                 return matchWindow(linkId, targetId, rest);
148 |             }, stepInterval);
149 |         } else {
150 |             clearTimeout(cTimeout);
151 |             moving = false;
152 |         }
153 |     }
154 | }
155 | 
156 | 
157 | 
158 | ////////////////////////// highlighting /////////////////////////////
159 | 
160 | var highlighted = []
161 | function putHighlight(id, color) {
162 |     var elm = $(id);
163 |     if (elm !== null) {
164 |         elm.style.backgroundColor = color;
165 |         if (color !== bgColor) {
166 |             highlighted.push(id);
167 |         }
168 |     }
169 | }
170 | 
171 | 
172 | function clearHighlight() {
173 |     for (i = 0; i < highlighted.length; i += 1) {
174 |         putHighlight(highlighted[i], bgColor);
175 |     }
176 |     highlighted = [];
177 | }
178 | 
179 | 
180 | 
181 | /*
182 |  * Highlight the link, target nodes and their lines,
183 |  * then start animation to move the other window to match.
184 |  */
185 | function highlight(me, linkId, targetId)
186 | {
187 |     clearHighlight();
188 |     putHighlight(linkId, nodeHLColor);
189 |     putHighlight(targetId, nodeHLColor);
190 | }
191 | 
192 | 
193 | function instantMoveOtherWindow (me) {
194 |     log("me=" + me.id + ", eventcount=" + eventCount[me.id]);
195 |     log("matchId1=" + matchId1 + ", matchId2=" + matchId2);
196 | 
197 |     me.style.backgroundColor = bgColor;
198 | 
199 |     if (!moving && eventCount[me.id] === 0) {
200 |         if (me.id === 'left') {
201 |             matchWindow(matchId1, matchId2, 1);
202 |         } else {
203 |             matchWindow(matchId2, matchId1, 1);
204 |         }
205 |     }
206 |     if (eventCount[me.id] > 0) {
207 |         eventCount[me.id] -= 1;
208 |     }
209 | }
210 | 
211 | 
212 | function getTarget(x){
213 |     x = x || window.event;
214 |     return x.target || x.srcElement;
215 | }
216 | 
217 | 
218 | window.onload =
219 |     function (e) {
220 |         var tags = document.getElementsByTagName("A")
221 |         for (var i = 0; i < tags.length; i++) {
222 |             tags[i].onmouseover =
223 |                 function (e) {
224 |                     var t = getTarget(e)
225 |                     var lid = t.id
226 |                     var tid = t.getAttribute('tid')
227 |                     var container = getContainer(t)
228 |                     highlight(container, lid, tid)
229 |                 }
230 |             tags[i].onclick =
231 |                 function (e) {
232 |                     var t = getTarget(e)
233 |                     var lid = t.id
234 |                     var tid = t.getAttribute('tid')
235 |                     var container = getContainer(t)
236 |                     highlight(container, lid, tid)
237 | 
238 |                     // lock left and right side
239 |                     if (container.id === 'left') {
240 |                         matchId1 = lid;
241 |                         matchId2 = tid;
242 |                     } else {
243 |                         matchId1 = tid;
244 |                         matchId2 = lid;
245 |                     }
246 | 
247 |                     matchWindow(lid, tid, nSteps)
248 |                 }
249 |         }
250 | 
251 |         tags = document.getElementsByTagName("DIV")
252 |         for (var i = 0; i < tags.length; i++) {
253 |             tags[i].onscroll =
254 |                 function (e) {
255 |                     instantMoveOtherWindow(getTarget(e))
256 |                 }
257 |         }
258 | 
259 |     }
260 | 


--------------------------------------------------------------------------------
/parse-cpp.rkt:
--------------------------------------------------------------------------------
  1 | ;; ydiff - a language-aware tool for comparing programs
  2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
  3 | 
  4 | ;; This program is free software: you can redistribute it and/or modify
  5 | ;; it under the terms of the GNU General Public License as published by
  6 | ;; the Free Software Foundation, either version 3 of the License, or
  7 | ;; (at your option) any later version.
  8 | 
  9 | ;; This program is distributed in the hope that it will be useful,
 10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 12 | ;; GNU General Public License for more details.
 13 | 
 14 | ;; You should have received a copy of the GNU General Public License
 15 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 16 | 
 17 | 
 18 | #lang racket
 19 | 
 20 | (require "structs.rkt")
 21 | (require "utils.rkt")
 22 | (require "parsec.rkt")
 23 | 
 24 | (provide parse-cpp)
 25 | 
 26 | 
 27 | 
 28 | 
 29 | ;-------------------------------------------------------------
 30 | ;                     scanner settings
 31 | ;-------------------------------------------------------------
 32 | 
 33 | (define set-parameters
 34 |   (lambda ()
 35 |     (set-delims (list "("  ")"  "["  "]"  "{"  "}" ","  "`"  ";" "#"))
 36 | 
 37 |     (set-operators
 38 |      (list
 39 |       "<<="  ">>="   "->*"  "..."
 40 |       "&&"  "||"  ">>"  "<<"  "++"  "--"
 41 |       "=="  "!="  ">="  "<="  "+="  "-="  "*="  "/="  "^="  "&="  "|="
 42 |       "->"  ".*"  "::"
 43 |       "="  "+"  "-"  "*"  "/"  "%"  "<"  ">"  "!"  ":"  "?"  "."
 44 |       "^"  "|"  "&"  "~"
 45 |       ))
 46 | 
 47 |     (set-line-comment  (list "//"))
 48 |     (set-comment-start  "/*")
 49 |     (set-comment-end    "*/")
 50 |     (set-quotation-marks  '(#\" #\'))
 51 |     (set-significant-whitespaces
 52 |      (list #\newline #\linefeed #\u2028 #\u2029))))
 53 | 
 54 | 
 55 | 
 56 | 
 57 | ;-------------------------------------------------------------
 58 | ;                          parsers
 59 | ;-------------------------------------------------------------
 60 | 
 61 | ;; literals
 62 | (:: $id
 63 |     ($pred
 64 |      (lambda (t)
 65 |        (and (token? t)
 66 |             (id? (Node-elts t))))))
 67 | 
 68 | 
 69 | (::= $identifier 'identifier
 70 |      (@? ($$ "::"))
 71 |      (@* $id (@* $type-parameter) ($$ "::"))
 72 |      (@= 'id (@? ($$ "~")) $id))
 73 | 
 74 | 
 75 | ;; (::= $identifier 'identifier
 76 | ;;      (@? ($$ "::")) $scope-resolution (@? ($$ "~")) $id)
 77 | 
 78 | 
 79 | (:: $numeral-literal
 80 |     ($pred
 81 |      (lambda (t)
 82 |        (and (token? t)
 83 |             (numeral? (Node-elts t))))))
 84 | 
 85 | (:: $char-literal ($pred character?))
 86 | (:: $string-literal ($pred str?))
 87 | (:: $newline ($pred newline?))
 88 | (:: $comment ($pred comment?))
 89 | 
 90 | 
 91 | ;; delimeters
 92 | (::  |,|   (@_ ","))
 93 | (::  |;|   (@~ ";"))
 94 | (::  |:|   (@_ ":"))
 95 | (::  |(|   (@~ "("))
 96 | (::  |)|   (@~ ")"))
 97 | (::  |[|   (@~ "["))
 98 | (::  |]|   (@~ "]"))
 99 | (::  |{|   (@~ "{"))
100 | (::  |}|   (@~ "}"))
101 | 
102 | (::  |\n|  ($glob^ (@*^ $newline)))
103 | (::  |;\n| (@or |;| |\n|))
104 | 
105 | 
106 | (define old-seq @seq)
107 | 
108 | (set-seq
109 |   (lambda ps
110 |     (let ([psj (join ps |\n|)])
111 |       (apply old-seq `(,|\n| ,@psj ,|\n|)))))
112 | 
113 | 
114 | 
115 | ;; a hacky definition for macros
116 | ;; will fix later
117 | (::= $macro-defintion 'macro
118 |      (@~ "#")
119 |      (@*^ (old-seq (@*^ (@and (@!^ ($$ "\\")) (@!^ $newline))) ($$ "\\") (@*^ $newline)))
120 |      (old-seq (@*^ (@!^ $newline)) ($glob^ $newline) ($glob^ (@*^ $newline)))
121 | )
122 | 
123 | 
124 | (:: $directive
125 |     (@or ($$ "ifdef")
126 |          ($$ "define")
127 |          ($$ "undef")
128 |          ($$ "endif")))
129 | 
130 | 
131 | ;;------------------ starting point -----------------
132 | (::= $program 'program
133 |      (@* $statement)
134 | )
135 | 
136 | 
137 | 
138 | (:: $statement
139 |     (@or $macro-defintion
140 |          $empty-statement
141 |          $access-label
142 |          $statement-block
143 | 
144 |          $if-statement
145 |          $switch-statement
146 |          $do-while-statement
147 |          $while-statement
148 |          $for-statement
149 |          $continue-statement
150 |          $break-statement
151 | 
152 |          $return-statement
153 |          $labelled-statement
154 |          $try-statement
155 | 
156 |          $namespace-definition
157 |          $using-namespace
158 | 
159 |          $class-definition
160 |          $function-definition
161 |          $function-declaration
162 |          $variable-definition
163 |          $enum-declaration
164 | 
165 |          $extended-assembly
166 |          $inline-assembly
167 | 
168 |          $expression-statement
169 | ))
170 | 
171 | 
172 | (:: $empty-statement |;|)
173 | 
174 | 
175 | (::= $enum-declaration 'enum
176 |      (@~ "enum") (@? $identifier)
177 |      |{|
178 |        (@? (@.@  (@= 'name-value $identifier  (@? $initializer))  |,|))
179 |      |}|
180 |      |;|
181 | )
182 | 
183 | 
184 | (::= $access-label 'access-label
185 |      $access-specifier (@~ ":"))
186 | 
187 | 
188 | (::= $statement-block 'block
189 |      |{|  (@* $statement)  |}|
190 | )
191 | 
192 | 
193 | (::= $namespace-definition 'namespace
194 |      ($$ "namespace") $identifier
195 |      |{|  (@* $statement)  |}|
196 | )
197 | 
198 | (::= $using-namespace 'using-namespace
199 |      ($$ "using") ($$ "namespace") $identifier)
200 | 
201 | 
202 | 
203 | ;;--------------------------------------------
204 | (::= $class-definition 'class
205 | 
206 |      (@or ($$ "class")
207 |           ($$ "struct")
208 |           ($$ "union"))
209 | 
210 |      (@* (@= 'declspec
211 |              (@or ($$ "_declspec") ($$ "__declspec")) |(|  $expression  |)|))
212 | 
213 |      (@or (@= 'name $identifier |;| )
214 | 
215 |           (@...
216 |            (@= 'name (@? $identifier)) (@? (@... (@_ ":") $base-clause))
217 |            (@= 'body  |{|  (@* $statement)  |}|) )
218 |           ))
219 | 
220 | 
221 | (::= $base-clause 'bases
222 |      (@.@ $base-specifier |,|)
223 | )
224 | 
225 | 
226 | (::= $base-specifier 'base-specifier
227 |      (@? $access-specifier) $identifier)
228 | 
229 | 
230 | (::= $access-specifier 'access-specifier
231 |      (@or ($$ "public")
232 |           ($$ "protected")
233 |           ($$ "private")
234 |           ($$ "virtual")))
235 | 
236 | 
237 | ;;---------- function definition and declaration ------------
238 | 
239 | (::= $function-declaration 'function-declaration
240 |      (@? ($$ "typedef"))
241 |      (@? $access-specifier) (@? $modifiers) (@? $type)
242 |      (@= 'name (@or $identifier
243 |                     (@... |(| ($$ "*") $identifier |)|)) )
244 |      $formal-parameter-list
245 |      (@? ($$ "const"))
246 |      (@? $initializer)
247 | )
248 | 
249 | 
250 | (::= $function-definition 'function
251 |      (@or (@... (@? $modifiers) $type
252 |                 (@= 'name $identifier ) $formal-parameter-list)
253 | 
254 |           (@... (@= 'name $identifier ) $formal-parameter-list))
255 |      (@? $initializer)
256 |      $function-body)
257 | 
258 | 
259 | (::= $type 'type
260 |      (@? $modifiers) (@or $primitive-type
261 |                           $ctype
262 |                           $identifier)
263 |      (@* $type-parameter) (@* $ptr-suffix))
264 | 
265 | 
266 | (::= $type-parameter 'type-parameter
267 |      (@~ "<") (@.@ (@or $type $numeral-literal) |,|) (@~ ">"))
268 | 
269 | 
270 | (::= $ptr-suffix 'suffix
271 |      (@or ($$ "*")
272 |           ($$ "&")))
273 | 
274 | 
275 | (::= $formal-parameter-list 'parameters
276 |      |(|  (@? (@.@ $type-variable |,|)) (@? |,| ($$ "..."))  |)|
277 | )
278 | 
279 | 
280 | (::= $type-variable 'type-variable
281 |      (@? $modifiers) $type (@? $identifier) (@? $array-suffix))
282 | 
283 | 
284 | (::= $function-body 'body
285 |      |{|  (@* $statement)  |}|
286 | )
287 | 
288 | 
289 | 
290 | (::= $variable-definition 'variable-definition
291 |      $variable-declaration-list |;|
292 | )
293 | 
294 | 
295 | (:: $variable-declaration-list
296 |     (@... (@? $modifiers) $type (@.@ $variable-declaration |,|)))
297 | 
298 | 
299 | (::= $variable-declaration 'variable-declaration
300 |      $identifier (@? $variable-declaration-suffix)
301 |      (@? $initializer))
302 | 
303 | 
304 | (::= $modifiers 'modifiers
305 |      (@+ (@or ($$ "const")
306 |               ($$ "static")
307 |               ($$ "inline"))))
308 | 
309 | (:: $primitive-type
310 |      (@or (@...
311 |            (@or ($$ "signed")
312 |                 ($$ "unsigned"))
313 |            (@or ($$ "int")
314 |                 ($$ "char")
315 |                 ($$ "long")
316 |                 ($$ "double")
317 |                 ($$ "float")))
318 |           (@or ($$ "signed")
319 |                ($$ "unsigned"))))
320 | 
321 | (::= $ctype 'ctype
322 |      (@or ($$ "struct")
323 |           ($$ "enum"))
324 |      $identifier
325 | )
326 | 
327 | 
328 | (::= $variable-declaration-suffix 'suffix
329 |      (@or (@... |[|  $expression  |]|))
330 | )
331 | 
332 | (::= $initializer 'initializer
333 |      (@or (@... (@_ "=") $expression)
334 |           (@... (@_ ":") $expression)
335 |           (@... (@_ "(") $expression (@_ ")"))))
336 | 
337 | 
338 | 
339 | 
340 | (::= $if-statement 'if
341 |      ($$ "if")  (@= 'test |(| $expression |)|) $statement
342 |      (@? (@= 'else ($$ "else") $statement))
343 | )
344 | 
345 | 
346 | 
347 | (::= $do-while-statement 'do-while
348 |     ($$ "do") $statement
349 |     (@= 'while-do ($$ "while")  (@= 'test |(| $expression |)|   ))
350 |     |;|
351 | )
352 | 
353 | 
354 | (::= $while-statement 'while
355 |      ($$ "while")  (@= 'test |(| $expression |)|   )
356 |      $statement
357 | )
358 | 
359 | 
360 | (::= $for-statement 'for
361 |      ($$ "for") (@= 'iter
362 |                     |(| (@? $for-initaliser) |;|
363 |                     (@? $expression)     |;|
364 |                     (@? $expression)
365 |                     |)|
366 |                     )
367 |      $statement
368 | )
369 | 
370 | 
371 | (::= $for-initaliser 'for-initializer
372 |      (@or (@= 'variable-declaration
373 |               $variable-declaration-list)
374 | 
375 |           $expression
376 | ))
377 | 
378 | 
379 | (::= $continue-statement 'continue
380 |      ($$ "continue") (@= 'label (@? $identifier)) |;|
381 | )
382 | 
383 | 
384 | (::= $break-statement 'break
385 |      ($$ "break") (@= 'label (@? $identifier)) |;|
386 | )
387 | 
388 | 
389 | (::= $return-statement 'return
390 |      ($$ "return") (@= 'value (@? $expression)) |;|
391 | )
392 | 
393 | 
394 | 
395 | (::= $labelled-statement 'labelled-statement
396 |      $identifier |:| $statement
397 | )
398 | 
399 | 
400 | (::= $switch-statement 'switch
401 |      ($$ "switch")  |(| $expression |)|
402 |      |{|  (@* $case-clause)
403 |           (@? (@... $default-clause
404 |                     (@* $case-clause)))
405 |      |}|
406 | )
407 | 
408 | 
409 | (::= $case-clause 'case-clause
410 |      ($$ "case") $expression |:| (@* $statement)
411 | )
412 | 
413 | 
414 | (::= $default-clause 'default-clause
415 |     ($$ "default") |:| (@* $statement)
416 | )
417 | 
418 | 
419 | ;; throw is an expression in C++
420 | ;; (::= $throw-statement 'throw
421 | ;;      ($$ "throw") $expression  |;|
422 | ;; )
423 | 
424 | 
425 | (::= $try-statement 'try
426 |      ($$ "try") $statement-block
427 |      (@or $finally-clause
428 |           (@... $catch-clause (@? $finally-clause))))
429 | 
430 | 
431 | (::= $catch-clause 'catch
432 |      ($$ "catch") |(| $identifier |)| $statement-block)
433 | 
434 | 
435 | (::= $finally-clause 'finally
436 |      ($$ "finally") $statement-block)
437 | 
438 | 
439 | (::= $expression-statement 'expression-statement
440 |      $expression |;|)
441 | 
442 | 
443 | 
444 | 
445 | ;-------------------------------------------------------------
446 | ;                       expressions
447 | ;-------------------------------------------------------------
448 | 
449 | ;; utility for constructing operators
450 | (define op
451 |   (lambda (s)
452 |     (@= 'op ($$ s))))
453 | 
454 | 
455 | (:: $expression
456 |     $comma-expression
457 |     )
458 | 
459 | 
460 | 
461 | ;; 18. comma
462 | ;;--------------------------------------------
463 | (::= $comma-expression 'comma
464 |      (@.@ $assignment-expression |,|))
465 | 
466 | 
467 | 
468 | ;; 17. throw
469 | ;;--------------------------------------------
470 | (::= $throw-expression 'throw
471 |      (@or (@... (@~ "throw")) $expression
472 |           $assignment-expression)
473 | )
474 | 
475 | 
476 | ;; 16. assignment
477 | ;;--------------------------------------------
478 | (:: $assignment-expression
479 |     (@or (@= 'assignment
480 |              $conditional-expression
481 |              $assignment-operator
482 |              $assignment-expression)
483 | 
484 |          $conditional-expression
485 |          ))
486 | 
487 | 
488 | (:: $assignment-operator
489 |      (@or (op "=")
490 |           (op "*=")
491 |           (op "/=")
492 |           (op "%=")
493 |           (op "+=")
494 |           (op "-=")
495 |           (op "<<=")
496 |           (op ">>=")
497 |           (op "&=")
498 |           (op "^=")
499 |           (op "|=")))
500 | 
501 | 
502 | 
503 | ;; 15.	?:	 Ternary conditional
504 | ;;--------------------------------------------
505 | (:: $conditional-expression
506 |     (@or (@= 'conditional-expression
507 |              (@= 'test $logical-or-expression)
508 |              (@~ "?") (@= 'then $conditional-expression)
509 |              (@~ ":") (@= 'else $conditional-expression))
510 | 
511 |          $logical-or-expression
512 |          ))
513 | 
514 | 
515 | ; ($eval $conditional-expression (scan "x > 0? x-1 : x"))
516 | 
517 | 
518 | 
519 | 
520 | ;; 14.	||	 Logical OR
521 | ;;--------------------------------------------
522 | (:: $logical-or-expression
523 |      (@or (@infix-left 'binop
524 |                        $logical-and-expression
525 |                        (op "||"))
526 | 
527 |           $logical-and-expression
528 |           ))
529 | 
530 | 
531 | 
532 | ;; 13.	&&	 Logical AND
533 | ;;--------------------------------------------
534 | (:: $logical-and-expression
535 |      (@or (@infix-left 'binop
536 |                        $bitwise-or-expression
537 |                        (op "&&"))
538 | 
539 |           $bitwise-or-expression
540 |           ))
541 | 
542 | 
543 | 
544 | ;; 12.	|	 Bitwise OR (inclusive or)
545 | ;;--------------------------------------------
546 | (:: $bitwise-or-expression
547 |      (@or (@infix-left 'binop
548 |                        $bitwise-xor-expression
549 |                        (op "|"))
550 | 
551 |           $bitwise-xor-expression
552 |           ))
553 | 
554 | 
555 | 
556 | ;; 11.	^	 Bitwise XOR (exclusive or)
557 | ;;--------------------------------------------
558 | (:: $bitwise-xor-expression
559 |      (@or (@infix-left 'binop
560 |                        $bitwise-and-expression
561 |                        (op "^"))
562 | 
563 |           $bitwise-and-expression
564 |           ))
565 | 
566 | 
567 | 
568 | ;; 10.	&	 Bitwise AND
569 | ;;--------------------------------------------
570 | (:: $bitwise-and-expression
571 |      (@or (@infix-left 'binop
572 |                        $equality-expression
573 |                        (op "&"))
574 | 
575 |        $equality-expression
576 |        ))
577 | 
578 | 
579 | 
580 | ;; 9. equality
581 | ;;--------------------------------------------
582 | (:: $equality-expression
583 |      (@or (@infix-left 'binop
584 |                        $relational-expression
585 |                        $equality-operator)
586 | 
587 |           $relational-expression
588 |           ))
589 | 
590 | (:: $equality-operator
591 |      (@or (op "==")
592 |           (op "!=")
593 |           (op "!=")
594 | ))
595 | 
596 | 
597 | 
598 | ;; 8. relational
599 | ;;--------------------------------------------
600 | (:: $relational-expression
601 |      (@or (@infix-left 'binop
602 |                        $bitwise-shift-expression
603 |                        $relational-operator)
604 | 
605 |           $bitwise-shift-expression
606 |           ))
607 | 
608 | (:: $relational-operator
609 |      (@or (op "<")
610 |           (op "<=")
611 |           (op ">")
612 |           (op ">=")
613 |           (op "instanceof")
614 |           (op "in")
615 |           ))
616 | 
617 | 
618 | 
619 | ;; 7. bitwise shift
620 | ;;--------------------------------------------
621 | (:: $bitwise-shift-expression
622 |     (@or (@infix-left 'binop
623 |                       $additive-expression
624 |                       $bitwise-shift-operator)
625 | 
626 |          $additive-expression
627 | ))
628 | 
629 | 
630 | (:: $bitwise-shift-operator
631 |     (@or (op "<<")
632 |          (op ">>")
633 |          ))
634 | 
635 | 
636 | 
637 | ;; 6. additive
638 | ;;--------------------------------------------
639 | (:: $additive-expression
640 |     (@or (@infix-left 'binop
641 |                       $multiplicative-expression
642 |                       $additive-operator)
643 | 
644 |          $multiplicative-expression
645 | ))
646 | 
647 | 
648 | (:: $additive-operator
649 |     (@or (op "+")
650 |          (op "-")))
651 | 
652 | 
653 | ;; ($eval $additive-expression (scan "x + y + z"))
654 | 
655 | 
656 | 
657 | 
658 | ;; 5. multiplicative
659 | ;;--------------------------------------------
660 | (:: $multiplicative-expression
661 |     (@or (@infix-left 'binop
662 |                       $unary-expression
663 |                       $multiplicative-operator)
664 | 
665 |          $unary-expression))
666 | 
667 | (:: $multiplicative-operator
668 |     (@or (op "*")
669 |          (op "/")
670 |          (op "%")))
671 | 
672 | 
673 | 
674 | 
675 | ;; unary =
676 | ;; 3. prefix
677 | ;; 2. postfix
678 | ;;--------------------------------------------
679 | (:: $unary-expression
680 |     $prefix-expression)
681 | 
682 | 
683 | 
684 | ;; 3. prefix
685 | ;;--------------------------------------------
686 | (:: $prefix-expression
687 |     (@or (@prefix 'prefix
688 |                   $postfix-expression
689 |                   $prefix-operator)
690 |          $postfix-expression))
691 | 
692 | 
693 | (:: $prefix-operator
694 |      (@or (@= 'new (op "new") (@? $array-suffix))
695 |           (@= 'delete (op "delete") (@? $array-suffix))
696 |           (@= 'cast |(|  $type  |)| )
697 |           (op "void")
698 |           (op "sizeof")
699 |           (op "++")
700 |           (op "--")
701 |           (op "+")
702 |           (op "-")
703 |           (op "~")
704 |           (op "!")
705 |           (op "*")                      ; indirection
706 |           (op "&")                      ; address of
707 |           (op "::")
708 | ))
709 | 
710 | 
711 | (::= $array-suffix 'array-suffix
712 |      |[| |]|)
713 | 
714 | 
715 | 
716 | 
717 | ;; 2. postfix
718 | ;;--------------------------------------------
719 | (:: $postfix-expression
720 |     (@or (@postfix 'postfix
721 |                    $primary-expression
722 |                    $postfix-operator)
723 |          $primary-expression))
724 | 
725 | 
726 | (:: $postfix-operator
727 |      (@or (op "++")
728 |           (op "--")
729 |           $index-suffix
730 |           $property-reference-suffix
731 |           $type-parameter
732 |           $arguments))
733 | 
734 | 
735 | (::= $arguments 'argument
736 |      |(|  (@? (@.@ $expression |,|))  |)|
737 | )
738 | 
739 | 
740 | (::= $index-suffix 'index
741 |     |[|  $expression  |]|
742 | )
743 | 
744 | 
745 | (::= $property-reference-suffix 'field-access
746 |      (@or (@~ ".") (@~ "->")) $identifier)
747 | 
748 | 
749 | 
750 | ;; scope resolution ::
751 | ;---------------------------------------------
752 | (:: $scope-resolution
753 |     (@or (@infix-left 'scope
754 |                       $id
755 |                       ($$ "::"))
756 | 
757 |          $primary-expression
758 | ))
759 | 
760 | 
761 | 
762 | ;; 1. primary
763 | ;;--------------------------------------------
764 | (:: $primary-expression
765 |     (@or (@= 'this ($$ "this"))
766 |          $type-cast
767 |          $ctype                         ; could be used in a macro argument
768 |          $identifier
769 |          $literal
770 |          $array-literal
771 |          $object-literal
772 |          (@= #f |(|  $expression  |)|)
773 | ))
774 | 
775 | 
776 | (::= $type-cast 'type-cast
777 |      (@or ($$ "typeid")
778 |           ($$ "const_cast")
779 |           ($$ "dynamic_cast")
780 |           ($$ "reinterpret_cast")
781 |           ($$ "static_cast")))
782 | 
783 | 
784 | 
785 | ;; literal
786 | ;;--------------------------------------------
787 | (:: $literal
788 |      (@or ($$ "null")
789 |           ($$ "true")
790 |           ($$ "false")
791 |           $string-concat
792 |           $float-literal
793 |           $numeral-literal
794 |           $string-literal
795 |           $char-literal))
796 | 
797 | 
798 | (::= $array-literal 'array-literal
799 |      |{|  (@? (@.@ $expression |,|))  |}|
800 | )
801 | 
802 | 
803 | (::= $object-literal 'object-literal
804 |      |{|  $property-name-value (@* (@... |,| $property-name-value))  |}|
805 | )
806 | 
807 | 
808 | (::= $property-name-value 'property-name-value
809 |      $property-name |:| $assignment-expression)
810 | 
811 | 
812 | (:: $property-name
813 |      (@or $identifier
814 |           $string-literal
815 |           $numeral-literal))
816 | 
817 | 
818 | (::= $float-literal 'float-literal
819 |      $numeral-literal ($$ ".") $numeral-literal)
820 | 
821 | 
822 | (::= $string-concat 'string-concat
823 |      $string-literal (@* (@or $string-literal $expression)))
824 | 
825 | 
826 | 
827 | ;-------------------------------------------------------------
828 | ;                    inline assembly
829 | ;-------------------------------------------------------------
830 | (::= $inline-assembly 'inline-assembly
831 |      (@or (@~ "asm")
832 |           (@~ "__asm__"))
833 |      (@? (@or ($$ "volatile")
834 |               ($$ "__volatile__")))
835 |      |(|   $string-concat  |)|
836 |      |;|
837 | )
838 | 
839 | 
840 | (::= $extended-assembly 'extended-assembly
841 |      (@or (@~ "asm")
842 |           (@~ "__asm__"))
843 |      (@? (@or ($$ "volatile")
844 |               ($$ "__volatile__")))
845 |      |(|  $string-concat
846 |      |:|  (@= 'output-operands (@* $string-literal |(| $identifier |)|  ))
847 |      |:|  (@= 'input-operands (@* $string-literal |(| $identifier |)|   ))
848 |      |:|  (@= 'clobbered-registers (@? (@.@ $string-literal |,|)))
849 |      |)|
850 |      |;|
851 | )
852 | 
853 | 
854 | 
855 | 
856 | 
857 | (define parse-cpp
858 |   (lambda (s)
859 |     (set-parameters)
860 |     (first-val
861 |      ($eval $program
862 |             (filter (lambda (x) (not (comment? x)))
863 |                     (scan s))))))
864 | 
865 | 
866 | 
867 | 
868 | ;-------------------------------------------------------------
869 | ;                          tests
870 | ;-------------------------------------------------------------
871 | 
872 | ;; (test-file "tests/simulator-arm.cc"
873 | ;;            "tests/simulator-mips.cc"
874 | ;;            "tests/d8-3404.cc"
875 | ;;            "tests/d8-8424.cc"
876 | ;;            "tests/assembler-arm-2.cc"
877 | ;;            "tests/assembler-arm-7.cc"
878 | ;;            "tests/assembler-arm-8309.cc"
879 | ;; )
880 | 


--------------------------------------------------------------------------------
/parse-js.rkt:
--------------------------------------------------------------------------------
  1 | ;; ydiff - a language-aware tool for comparing programs
  2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
  3 | 
  4 | ;; This program is free software: you can redistribute it and/or modify
  5 | ;; it under the terms of the GNU General Public License as published by
  6 | ;; the Free Software Foundation, either version 3 of the License, or
  7 | ;; (at your option) any later version.
  8 | 
  9 | ;; This program is distributed in the hope that it will be useful,
 10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 12 | ;; GNU General Public License for more details.
 13 | 
 14 | ;; You should have received a copy of the GNU General Public License
 15 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 16 | 
 17 | 
 18 | 
 19 | #lang racket
 20 | 
 21 | (require "structs.rkt")
 22 | (require "utils.rkt")
 23 | (require "parsec.rkt")
 24 | 
 25 | 
 26 | (provide parse-js)
 27 | 
 28 | 
 29 | 
 30 | ;-------------------------------------------------------------
 31 | ;                     scanner settings
 32 | ;-------------------------------------------------------------
 33 | 
 34 | (define set-parameters
 35 |   (lambda ()
 36 |     (set-delims (list "("  ")"  "["  "]"  "{"  "}" ","  "`"  ";"))
 37 | 
 38 |     (set-operators
 39 |      (list
 40 |       ">>>="
 41 | 
 42 |       "<<=" ">>=" ">>>" "===" "!=="
 43 | 
 44 |       "==" "!="  ">=" "<=" "&&" "||" ">>" "<<" "++" "--"
 45 |       "+=" "-=" "*=" "/=" "%=" "&=" "^=" "|="
 46 | 
 47 |       "=" "+" "-" "*" "/" "%" "~" "!" ":" "?" "." ">" "<"
 48 |       ))
 49 | 
 50 | 
 51 |     (set-line-comment (list "//"))
 52 |     (set-comment-start  "/*")
 53 |     (set-comment-end    "*/")
 54 |     (set-quotation-marks  '(#\" #\'))
 55 |     (set-significant-whitespaces
 56 |      (list #\newline #\linefeed #\u2028 #\u2029))))
 57 | 
 58 | 
 59 | (set-alpha
 60 |   (predor char-alphabetic?
 61 |           (lambda (x) (char=? x #\$))))
 62 | 
 63 | 
 64 | 
 65 | 
 66 | ;-------------------------------------------------------------
 67 | ;                     primitive parsers
 68 | ;-------------------------------------------------------------
 69 | 
 70 | (:: $identifier
 71 |   ($pred
 72 |    (lambda (t)
 73 |      (and (token? t)
 74 |           (id? (Node-elts t))))))
 75 | 
 76 | 
 77 | (:: $numeral-literal
 78 |   ($pred
 79 |    (lambda (t)
 80 |      (and (token? t)
 81 |           (numeral? (Node-elts t))))))
 82 | 
 83 | 
 84 | (:: $string-literal ($pred str?))
 85 | (:: $newline ($pred newline?))
 86 | (:: $comment ($pred comment?))
 87 | 
 88 | 
 89 | ;; delimeters
 90 | (::  |,|   (@_ ","))
 91 | (::  |;|   (@~ ";"))
 92 | (::  |:|   (@_ ":"))
 93 | (::  |(|   (@~ "("))
 94 | (::  |)|   (@~ ")"))
 95 | (::  |[|   (@~ "["))
 96 | (::  |]|   (@~ "]"))
 97 | (::  |{|   (@~ "{"))
 98 | (::  |}|   (@~ "}"))
 99 | 
100 | 
101 | ;; $glob^ and $*^ needed to define |\n|, because the
102 | ;; definition of |\n| must not contain any call to @seq
103 | ;; otherwise the parser will go into infinite loop
104 | (::  |\n|  ($glob^ (@*^ $newline)))
105 | (::  |;\n| (@or |;| |\n|))
106 | 
107 | 
108 | ;; Redefine sequence to get over newlines
109 | (define old-seq @seq)
110 | (set-seq
111 |   (lambda ps
112 |     (let ([psj (join ps |\n|)])
113 |       (apply old-seq `(,|\n| ,@psj ,|\n|)))))
114 | 
115 | 
116 | ;; ($eval (@seq ($$ "foo") ($$ "bar"))
117 | ;; (scan "
118 | ;; foo
119 | ;;  bar "))
120 | 
121 | 
122 | 
123 | 
124 | ;-------------------------------------------------------------
125 | ;                       compound parsers
126 | ;-------------------------------------------------------------
127 | 
128 | (::= $program 'program
129 |      (@* $statement))
130 | 
131 | 
132 | 
133 | (:: $statement
134 |     (@or $statement-block
135 |          $empty-statement
136 |          $function-definition
137 |          $variable-statement
138 |          $with-statement
139 | 
140 |          $if-statement
141 |          $switch-statement
142 |          $do-while-statement
143 |          $while-statement
144 |          $for-statement
145 |          $for-in-statement
146 |          $continue-statement
147 |          $break-statement
148 |          $try-statement
149 |          $throw-statement
150 |          $return-statement
151 | 
152 |          $labelled-statement
153 |          $expression-statement
154 | ))
155 | 
156 | 
157 | 
158 | (::= $statement-block 'block
159 |      |{| (@* $statement) |}|
160 | )
161 | 
162 | 
163 | (:: $empty-statement |;|)
164 | 
165 | 
166 | (::= $function-definition 'function
167 |      ($$ "function") (@= 'name $identifier) $formal-parameter-list
168 |      $function-body)
169 | 
170 | 
171 | ;; function-expression can be unnamed
172 | (::= $function-expression 'function
173 |      ($$ "function") (@= 'name (@? $identifier)) $formal-parameter-list
174 |      $function-body)
175 | 
176 | 
177 | (::= $formal-parameter-list 'parameters
178 |      (@or (@... |(|  (@? (@.@ $identifier |,|))  |)|    )
179 |           $identifier))
180 | 
181 | 
182 | (::= $function-body 'body
183 |      $statement-block
184 | )
185 | 
186 | 
187 | 
188 | ;;---------------- variable statement -----------------
189 | (::= $variable-statement 'variable-declaration
190 |      ($$ "var") (@.@ $variable-declaration |,|) |;\n|
191 | )
192 | 
193 | 
194 | (::= $variable-declaration 'variable-declaration
195 |      $identifier (@? $initializer))
196 | 
197 | 
198 | (::= $initializer 'initializer
199 |      (@... ($$ "=") $assignment-expression))
200 | 
201 | 
202 | ;;--------------------------------------------
203 | (::= $with-statement 'with
204 |      ($$ "with") (@= 'obj |(|  $expression  |)|)
205 |      $statement
206 | )
207 | 
208 | 
209 | ;;--------------------------------------------
210 | (::= $if-statement 'if
211 |      ($$ "if")  (@= 'test |(| $expression |)|)   $statement
212 |      (@? (@= 'else ($$ "else") $statement
213 | )))
214 | 
215 | 
216 | ;;--------------------------------------------
217 | (::= $do-while-statement 'do-while
218 |      ($$ "do") $statement
219 |      (@= 'while-do ($$ "while")  (@= 'test |(| $expression |)|   ))
220 |      |;\n|
221 | )
222 | 
223 | 
224 | ;;--------------------------------------------
225 | (::= $while-statement 'while
226 |      ($$ "while")  (@= 'test |(| $expression |)|   )
227 |      $statement
228 | )
229 | 
230 | 
231 | ;;--------------------------------------------
232 | (::= $for-statement 'for
233 |      ($$ "for") (@= 'iter
234 |                     |(| (@? $for-initaliser) |;|
235 |                         (@? $expression)     |;|
236 |                         (@? $expression)
237 |                     |)|
238 |                  )
239 |      $statement
240 | )
241 | 
242 | 
243 | (::= $for-initaliser 'for-initializer
244 |      (@or (@= 'variable-declaration
245 |               ($$ "var") (@.@ $variable-declaration |,|))
246 | 
247 |           $expression
248 | ))
249 | 
250 | 
251 | ;;--------------------------------------------
252 | (::= $for-in-statement 'for-in
253 |      ($$ "for") (@= 'iter
254 |                     |(|  (@? $for-in-initalizer) ($$ "in") $expression  |)|)
255 |      $statement
256 | )
257 | 
258 | 
259 | (::= $for-in-initalizer 'for-in-initializer
260 |      (@or (@= 'variable-declaration
261 |               ($$ "var") (@.@ $variable-declaration |,|))
262 | 
263 |           $expression
264 | ))
265 | 
266 | 
267 | ;;--------------------------------------------
268 | (::= $continue-statement 'continue
269 |     ($$ "continue") (@= 'label (@? $identifier)) |;\n|
270 | )
271 | 
272 | 
273 | ;;--------------------------------------------
274 | (::= $break-statement 'break
275 |      ($$ "break") (@= 'label (@? $identifier)) |;\n|
276 | )
277 | 
278 | 
279 | ;;--------------------------------------------
280 | (::= $return-statement 'return
281 |     ($$ "return") (@= 'value (@? $expression)) |;\n|
282 | )
283 | 
284 | 
285 | ;;--------------------------------------------
286 | (::= $labelled-statement 'labelled-statement
287 |      $identifier |:| $statement
288 | )
289 | 
290 | 
291 | ;;--------------------------------------------
292 | (::= $switch-statement 'switch-statement
293 |      ($$ "switch")  |(| $expression |)|
294 |      |{|  (@* $case-clause)
295 |           (@? $default-clause
296 |           (@* $case-clause))
297 |      |}|
298 | )
299 | 
300 | 
301 | (::= $case-clause 'case-clause
302 |      ($$ "case") $expression |:| (@* $statement)
303 | )
304 | 
305 | 
306 | (::= $default-clause 'default
307 |      ($$ "default") |:| (@* $statement)
308 | )
309 | 
310 | 
311 | ;;--------------------------------------------
312 | (::= $throw-statement 'throw
313 |     ($$ "throw") $expression  |;\n|
314 | )
315 | 
316 | 
317 | ;;--------------------------------------------
318 | (::= $try-statement 'try
319 |      ($$ "try") $statement-block
320 |      (@or $finally-clause
321 |           (@... $catch-clause (@? $finally-clause)))
322 |      )
323 | 
324 | 
325 | (::= $catch-clause 'catch
326 |      ($$ "catch") |(| $identifier |)| $statement-block
327 |      )
328 | 
329 | 
330 | (::= $finally-clause 'finally
331 |     ($$ "finally") $statement-block
332 |     )
333 | 
334 | 
335 | ;;--------------------------------------------
336 | (::= $expression-statement 'expression-statement
337 |      $expression |;\n|
338 |      )
339 | 
340 | 
341 | 
342 | 
343 | ;-------------------------------------------------------------
344 | ;                       expressions
345 | ;-------------------------------------------------------------
346 | 
347 | ;; utility for constructing operators
348 | (define op
349 |   (lambda (s)
350 |     (@= 'op ($$ s))))
351 | 
352 | 
353 | 
354 | (:: $expression
355 |     $comma-expression)
356 | 
357 | 
358 | 
359 | ;; 18. comma
360 | ;;--------------------------------------------
361 | (::= $comma-expression 'comma
362 |      (@.@ $assignment-expression |,|))
363 | 
364 | 
365 | 
366 | ;; 16. assignment
367 | ;;--------------------------------------------
368 | (:: $assignment-expression
369 |     (@or (@= 'assignment
370 |              $conditional-expression
371 |              $assignment-operator
372 |              $assignment-expression)
373 | 
374 |          $conditional-expression
375 |          ))
376 | 
377 | 
378 | (:: $assignment-operator
379 |      (@or (op "=")
380 |           (op "*=")
381 |           (op "/=")
382 |           (op "%=")
383 |           (op "+=")
384 |           (op "-=")
385 |           (op "<<=")
386 |           (op ">>=")
387 |           (op ">>>=")
388 |           (op "&=")
389 |           (op "^=")
390 |           (op "|=")
391 |           ))
392 | 
393 | 
394 | 
395 | ;; 15.	?:	 Ternary conditional
396 | ;;--------------------------------------------
397 | (:: $conditional-expression
398 |     (@or (@= 'conditional-expression
399 |              (@= 'test $logical-or-expression)
400 |              (@~ "?") (@= 'then $conditional-expression)
401 |              (@~ ":") (@= 'else $conditional-expression))
402 | 
403 |          $logical-or-expression
404 |          ))
405 | 
406 | 
407 | ; ($eval $conditional-expression (scan "x > 0? x-1 : x"))
408 | 
409 | 
410 | 
411 | 
412 | ;; 14.	||	 Logical OR
413 | ;;--------------------------------------------
414 | (:: $logical-or-expression
415 |      (@or (@infix-left 'binop
416 |                        $logical-and-expression
417 |                        (op "||"))
418 | 
419 |           $logical-and-expression
420 |           ))
421 | 
422 | ; ($eval $logical-or-expression (scan "x || y"))
423 | 
424 | 
425 | 
426 | ;; 13.	&&	 Logical AND
427 | ;;--------------------------------------------
428 | (:: $logical-and-expression
429 |      (@or (@infix-left 'binop
430 |                        $bitwise-or-expression
431 |                        (op "&&"))
432 | 
433 |           $bitwise-or-expression
434 |           ))
435 | 
436 | 
437 | ;; 12.	|	 Bitwise OR (inclusive or)
438 | ;;--------------------------------------------
439 | (:: $bitwise-or-expression
440 |      (@or (@infix-left 'binop
441 |                        $bitwise-xor-expression
442 |                        (op "|"))
443 | 
444 |           $bitwise-xor-expression
445 |           ))
446 | 
447 | 
448 | 
449 | ;; 11.	^	 Bitwise XOR (exclusive or)
450 | ;;--------------------------------------------
451 | (:: $bitwise-xor-expression
452 |      (@or (@infix-left 'binop
453 |                        $bitwise-and-expression
454 |                        (op "^"))
455 | 
456 |           $bitwise-and-expression
457 |           ))
458 | 
459 | 
460 | 
461 | ;; 10.	&	 Bitwise AND
462 | ;;--------------------------------------------
463 | (:: $bitwise-and-expression
464 |      (@or (@infix-left 'binop
465 |                        $equality-expression
466 |                        (op "&"))
467 | 
468 |        $equality-expression
469 |        ))
470 | 
471 | 
472 | 
473 | ;; 9. equality
474 | ;;--------------------------------------------
475 | (:: $equality-expression
476 |      (@or (@infix-left 'binop
477 |                        $relational-expression
478 |                        $equality-operator)
479 | 
480 |           $relational-expression
481 |           ))
482 | 
483 | (:: $equality-operator
484 |      (@or (op "==")
485 |           (op "!=")
486 |           (op "===")
487 |           (op "!==")
488 | ))
489 | 
490 | 
491 | 
492 | ;; 8. relational
493 | ;;--------------------------------------------
494 | (:: $relational-expression
495 |      (@or (@infix-left 'binop
496 |                        $bitwise-shift-expression
497 |                        $relational-operator)
498 | 
499 |           $bitwise-shift-expression
500 |           ))
501 | 
502 | (:: $relational-operator
503 |      (@or (op "<")
504 |           (op "<=")
505 |           (op ">")
506 |           (op ">=")
507 |           (op "instanceof")
508 |           (op "in")
509 |           ))
510 | 
511 | 
512 | 
513 | ;; 7. bitwise shift
514 | ;;--------------------------------------------
515 | (:: $bitwise-shift-expression
516 |     (@or (@infix-left 'binop
517 |                       $additive-expression
518 |                       $bitwise-shift-operator)
519 | 
520 |          $additive-expression
521 | ))
522 | 
523 | (:: $bitwise-shift-operator
524 |     (@or (op "<<")
525 |          (op ">>")
526 |          (op ">>>")
527 |          ))
528 | 
529 | 
530 | 
531 | ;; 6. additive
532 | ;;--------------------------------------------
533 | (:: $additive-expression
534 |     (@or (@infix-left 'binop
535 |                       $multiplicative-expression
536 |                       $additive-operator)
537 | 
538 |          $multiplicative-expression
539 | ))
540 | 
541 | 
542 | (:: $additive-operator
543 |     (@or (op "+")
544 |          (op "-")))
545 | 
546 | 
547 | ;; ($eval $additive-expression (scan "x + y + z"))
548 | 
549 | 
550 | 
551 | 
552 | ;; 5. multiplicative
553 | ;;--------------------------------------------
554 | (:: $multiplicative-expression
555 |     (@or (@infix-left 'binop
556 |                       $unary-expression
557 |                       $multiplicative-operator)
558 | 
559 |          $unary-expression))
560 | 
561 | (:: $multiplicative-operator
562 |     (@or (op "*")
563 |          (op "/")
564 |          (op "%")))
565 | 
566 | 
567 | 
568 | 
569 | ;; 3. prefix
570 | ;; 2. postfix
571 | ;;--------------------------------------------
572 | (:: $unary-expression
573 |     $prefix-expression)
574 | 
575 | 
576 | (:: $prefix-expression
577 |     (@or (@prefix 'prefix
578 |                   $postfix-expression
579 |                   $prefix-operator)
580 |          $postfix-expression))
581 | 
582 | 
583 | (:: $postfix-expression
584 |     (@or (@postfix 'postfix
585 |                    $primary-expression
586 |                    $postfix-operator)
587 |          $primary-expression))
588 | 
589 | 
590 | (:: $prefix-operator
591 |     (@or (op "new")
592 |          (op "delete")
593 |          (op "void")
594 |          (op "typeof")
595 |          (op "++")
596 |          (op "--")
597 |          (op "+")
598 |          (op "-")
599 |          (op "~")
600 |          (op "!")
601 |          ))
602 | 
603 | 
604 | (:: $postfix-operator
605 |     (@or $index-suffix
606 |          $property-reference-suffix
607 |          $arguments
608 |          (op "++")
609 |          (op "--")))
610 | 
611 | 
612 | (::= $index-suffix 'index
613 |      |[|  $expression  |]|
614 |      )
615 | 
616 | 
617 | (::= $property-reference-suffix 'property
618 |      (@_ ".") $identifier)
619 | 
620 | 
621 | (::= $arguments 'arguments
622 |      |(|  (@? (@.@ $assignment-expression |,|))  |)|
623 |      )
624 | 
625 | 
626 | (::= $new-expression 'new
627 |      ($$ "new") $postfix-expression)
628 | 
629 | 
630 | 
631 | ;; 1. primary
632 | ;;--------------------------------------------
633 | (:: $primary-expression
634 |     (@or $function-expression
635 |          $identifier
636 |          $literal
637 |          (@= 'expression |(|  $expression  |)|  )
638 |          ))
639 | 
640 | 
641 | 
642 | 
643 | ;;-----------
644 | (::= $array-literal 'array-literal
645 |      |[|  (@? (@.@ $assignment-expression |,|))  |]|
646 |      )
647 | 
648 | 
649 | 
650 | ;;-----------
651 | (::= $object-literal 'object-literal
652 |      |{|  $property-name-value (@* |,| $property-name-value)  |}|
653 |      )
654 | 
655 | 
656 | (::= $property-name-value 'property-name-value
657 |      $property-name |:| $assignment-expression)
658 | 
659 | 
660 | (:: $property-name
661 |     (@or $identifier
662 |          $string-literal
663 |          $numeral-literal))
664 | 
665 | 
666 | 
667 | ;;-----------
668 | (:: $literal
669 |     (@or ($$ "null")
670 |          ($$ "true")
671 |          ($$ "false")
672 |          (@= 'this ($$ "this"))
673 |          $string-literal
674 |          $numeral-literal
675 |          $array-literal
676 |          $object-literal
677 | ))
678 | 
679 | 
680 | 
681 | 
682 | 
683 | ;-------------------------------------------------------------
684 | ;                       parse-js
685 | ;-------------------------------------------------------------
686 | 
687 | (define parse-js
688 |   (lambda (s)
689 |     (set-parameters)
690 |     (first-val
691 |      ($eval $program
692 |             (filter (negate comment?) (scan s))))))
693 | 
694 | 
695 | 
696 | 
697 | ;-------------------------------------------------------------
698 | ;                          tests
699 | ;-------------------------------------------------------------
700 | 
701 | ;; (parse-js (read-file "demos/nav1.js"))
702 | 


--------------------------------------------------------------------------------
/parse-lisp.rkt:
--------------------------------------------------------------------------------
 1 | ;; ydiff - a language-aware tool for comparing programs
 2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
 3 | 
 4 | ;; This program is free software: you can redistribute it and/or modify
 5 | ;; it under the terms of the GNU General Public License as published by
 6 | ;; the Free Software Foundation, either version 3 of the License, or
 7 | ;; (at your option) any later version.
 8 | 
 9 | ;; This program is distributed in the hope that it will be useful,
10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 | ;; GNU General Public License for more details.
13 | 
14 | ;; You should have received a copy of the GNU General Public License
15 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
16 | 
17 | 
18 | #lang racket
19 | 
20 | (require "structs.rkt")
21 | (require "utils.rkt")
22 | (require "parsec.rkt")
23 | 
24 | (provide parse-lisp)
25 | 
26 | 
27 | ;-------------------------------------------------------------
28 | ;                     scanner setttings
29 | ;-------------------------------------------------------------
30 | 
31 | ; single quote is considered a delimeter in s-expression
32 | 
33 | (define set-parameters
34 |   (lambda ()
35 |     (set-delims (list "("  ")"  "["  "]"  "{"  "}" "'"  "`"  "," ))
36 |     (set-line-comment (list ";"))
37 |     (set-comment-start "")
38 |     (set-comment-end "")
39 |     (set-operators  '())
40 |     (set-quotation-marks '(#\"))
41 |     (set-lisp-char (list "#\\" "?\\"))
42 |     (set-significant-whitespaces '())))
43 | 
44 | 
45 | 
46 | ;-------------------------------------------------------------
47 | ;                        parser
48 | ;-------------------------------------------------------------
49 | 
50 | (:: $open
51 |      (@or (@~ "(") (@~ "[")))
52 | 
53 | (:: $close
54 |      (@or (@~ ")") (@~ "]")))
55 | 
56 | (:: $non-parens
57 |      (@and (@! $open) (@! $close)))
58 | 
59 | (::= $parens 'sexp
60 |      (@seq $open (@* $sexp) $close))
61 | 
62 | (:: $sexp
63 |     (@+ (@or $parens $non-parens)))
64 | 
65 | (:: $program $sexp)
66 | 
67 | 
68 | (define parse-lisp
69 |   (lambda (s)
70 |     (set-parameters)
71 |     (first-val ($eval $sexp (scan s)))))
72 | 
73 | 
74 | ;;; command line use only
75 | 
76 | ;; (let ([args (current-command-line-arguments)])
77 | ;;   (cond
78 | ;;    [(null? args) '()]
79 | ;;    [else
80 | ;;     (set-parameters)
81 | ;;     (print (parse-lisp (read-file (vector-ref args 0))))]))
82 | 


--------------------------------------------------------------------------------
/parse-yin.rkt:
--------------------------------------------------------------------------------
 1 | ;; ydiff - a language-aware tool for comparing programs
 2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
 3 | 
 4 | ;; This program is free software: you can redistribute it and/or modify
 5 | ;; it under the terms of the GNU General Public License as published by
 6 | ;; the Free Software Foundation, either version 3 of the License, or
 7 | ;; (at your option) any later version.
 8 | 
 9 | ;; This program is distributed in the hope that it will be useful,
10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 | ;; GNU General Public License for more details.
13 | 
14 | ;; You should have received a copy of the GNU General Public License
15 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
16 | 
17 | 
18 | #lang racket
19 | 
20 | (require "structs.rkt")
21 | (require "utils.rkt")
22 | (require "parsec.rkt")
23 | 
24 | (provide parse-yin)
25 | 
26 | 
27 | ;-------------------------------------------------------------
28 | ;                     scanner setttings
29 | ;-------------------------------------------------------------
30 | 
31 | ; single quote is considered a delimeter in s-expression
32 | 
33 | (define set-parameters
34 |   (lambda ()
35 |     (set-delims (list "("  ")"  "["  "]"  "{"  "}" "'"  "`"  "," ))
36 |     (set-line-comment (list "--"))
37 |     (set-comment-start "")
38 |     (set-comment-end "")
39 |     (set-operators  '())
40 |     (set-quotation-marks '(#\"))
41 |     (set-lisp-char (list "#\\" "?\\"))
42 |     (set-significant-whitespaces '())))
43 | 
44 | 
45 | 
46 | ;-------------------------------------------------------------
47 | ;                        parser
48 | ;-------------------------------------------------------------
49 | 
50 | (:: $open
51 |      (@or (@~ "(") (@~ "[")))
52 | 
53 | (:: $close
54 |      (@or (@~ ")") (@~ "]")))
55 | 
56 | (:: $non-parens
57 |      (@and (@! $open) (@! $close)))
58 | 
59 | (::= $parens 'sexp
60 |      (@seq $open (@* $sexp) $close))
61 | 
62 | (:: $sexp
63 |     (@+ (@or $parens $non-parens)))
64 | 
65 | (:: $program $sexp)
66 | 
67 | 
68 | (define parse-yin
69 |   (lambda (s)
70 |     (set-parameters)
71 |     (first-val ($eval $sexp (scan s)))))
72 | 
73 | 
74 | ;;; command line use only
75 | 
76 | ;; (let ([args (current-command-line-arguments)])
77 | ;;   (cond
78 | ;;    [(null? args) '()]
79 | ;;    [else
80 | ;;     (set-parameters)
81 | ;;     (print (parse-yin (read-file (vector-ref args 0))))]))
82 | 


--------------------------------------------------------------------------------
/structs.rkt:
--------------------------------------------------------------------------------
  1 | ;; ydiff - a language-aware tool for comparing programs
  2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
  3 | 
  4 | 
  5 | ;; This program is free software: you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation, either version 3 of the License, or
  8 | ;; (at your option) any later version.
  9 | 
 10 | ;; This program is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | 
 19 | #lang racket
 20 | 
 21 | (provide (all-defined-out))
 22 | 
 23 | 
 24 | ;-------------------------------------------------------------
 25 | ;                       data types
 26 | ;-------------------------------------------------------------
 27 | 
 28 | 
 29 | ;---------------------------- Node ---------------------------
 30 | (struct Node (type 
 31 |               start 
 32 |               end 
 33 |               elts 
 34 |               [size #:mutable]
 35 |               [ctx #:mutable]) 
 36 |         #:transparent)
 37 | 
 38 | 
 39 | (define comment?
 40 |   (lambda (n)
 41 |     (and (Node? n) (eq? 'comment (Node-type n)))))
 42 | 
 43 | (define phantom?
 44 |   (lambda (n)
 45 |     (and (Node? n) (eq? 'phantom (Node-type n)))))
 46 | 
 47 | (define token?
 48 |   (lambda (n)
 49 |     (and (Node? n) (eq? 'token (Node-type n)))))
 50 | 
 51 | (define str?
 52 |   (lambda (n)
 53 |     (and (Node? n) (eq? 'str (Node-type n)))))
 54 | 
 55 | (define character?
 56 |   (lambda (n)
 57 |     (and (Node? n) (eq? 'char (Node-type n)))))
 58 | 
 59 | (define newline?
 60 |   (lambda (n)
 61 |     (and (Node? n) (eq? 'newline (Node-type n)))))
 62 | 
 63 | 
 64 | ;----------- node size function ------------
 65 | (define node-size
 66 |   (lambda (node)
 67 |     (cond
 68 |      [(and (Node? node) (Node-size node))
 69 |       (Node-size node)]
 70 |      [(pair? node)
 71 |       (apply + (map node-size node))]
 72 |      [(or (token? node) (str? node) (character? node)) 1]
 73 |      [(Node? node)
 74 |       (let ([size (node-size (Node-elts node))])
 75 |         (set-Node-size! node size)
 76 |         size)]
 77 |      [else 0])))
 78 | 
 79 | 
 80 | (define node-depth
 81 |   (lambda (node)
 82 |     (cond
 83 |      [(null? node) 0]
 84 |      [(pair? node)
 85 |       (apply max (map node-depth node))]
 86 |      [(Node? node)
 87 |       (add1 (node-depth (Node-elts node)))]
 88 |      [else 0])))
 89 | 
 90 | 
 91 | ; (node-depth (parse-scheme "(lambda (x (x (y)) (y)) x)"))
 92 | 
 93 | 
 94 | (define set-node-context
 95 |   (lambda (node ctx)
 96 |     (cond
 97 |      [(pair? node)
 98 |       (map (lambda (n) (set-node-context n ctx)) node)]
 99 |      [(Node? node)
100 |       (let ([name (or (get-name node) ctx)])
101 |         (set-Node-ctx! node name)
102 |         (set-node-context (Node-elts node) name))])))
103 | 
104 | 
105 | ;------------------ operations on nodes ---------------------
106 | 
107 | ;; "virtual function" - get definition name
108 | ;; can be overridden by individual languages
109 | (define get-name (lambda (node) #f))
110 | 
111 | (define set-get-name
112 |   (lambda (fun)
113 |     (set! get-name fun)))
114 | 
115 | 
116 | ;; "virtual function" - get node type
117 | ;; can be overridden by individual languages
118 | (define get-type Node-type)
119 | 
120 | (define set-get-type
121 |   (lambda (fun)
122 |     (set! get-type fun)))
123 | 
124 | 
125 | ;; same-def? only depend on get-name, so they need not be overridden
126 | ;; by individual languages.
127 | (define same-def?
128 |   (lambda (e1 e2)
129 |     (cond
130 |      [(not (eq? (get-type e1) (get-type e2)))
131 |       #f]
132 |      [else
133 |       (let ([name1 (get-name e1)]
134 |             [name2 (get-name e2)])
135 |         (and name1 name2 (equal? name1 name2)))])))
136 | 
137 | 
138 | (define set-same-def
139 |   (lambda (fun)
140 |     (set! same-def? fun)))
141 | 
142 | 
143 | 
144 | ;---------------------------- Change ---------------------------
145 | ;; Change - a change in the data structure
146 | ;; - old  : the old version, #f for insertions
147 | ;; - new  : the new version, #f for deletions
148 | ;; - cost : the cost of change from old to new
149 | ;; - type : insertion, deletion, or modification?
150 | (struct Change (old new cost type) #:transparent)
151 | 
152 | (define ins?
153 |   (lambda (c)
154 |     (eq? 'ins (Change-type c))))
155 | 
156 | (define del?
157 |   (lambda (c)
158 |     (eq? 'del (Change-type c))))
159 | 
160 | (define mov?
161 |   (lambda (c)
162 |     (eq? 'mov (Change-type c))))
163 | 
164 | 
165 | ;----------------- utils for creating changes ----------------
166 | (define ins
167 |   (lambda (node)
168 |     (let ([size (node-size node)])
169 |       (list (Change #f node size 'ins)))))
170 | 
171 | (define del
172 |   (lambda (node)
173 |     (let ([size (node-size node)])
174 |       (list (Change node #f size 'del)))))
175 | 
176 | (define mov
177 |   (lambda (node1 node2 cost)
178 |     (list (Change node1 node2 cost 'mov))))
179 | 
180 | 
181 | ;; create a "total change"
182 | ;; (delete node1 completely and then insert node2)
183 | (define total
184 |   (lambda (node1 node2)
185 |     (let ([size1 (node-size node1)]
186 |           [size2 (node-size node2)])
187 |       (values (append (del node1) (ins node2))
188 |               (+ size1 size2)))))
189 | 
190 | 
191 | 
192 | ;---------------------------- Tag ---------------------------
193 | ;; HTML tag structure used HTML generation code
194 | (struct Tag (tag idx start) #:transparent)
195 | 
196 | 
197 | (define get-symbol
198 |   (lambda (node)
199 |     (cond
200 |      [(token? node)
201 |       (string->symbol (Node-elts node))]
202 |      [else #f])))
203 | 
204 | 
205 | ;; Find the first node elements which matches a given tag.
206 | (define get-tag
207 |   (lambda (node tag)
208 |     (cond
209 |      [(not (Node? node)) #f]
210 |      [(not (pair? (Node-elts node))) #f]
211 |      [(null? (Node-elts node)) #f]
212 |      [else
213 |       (let ([matches (filter (lambda (x)
214 |                                (eq? (Node-type x) tag))
215 |                              (Node-elts node))])
216 |         (cond
217 |          [(null? matches) #f]
218 |          [else (car matches)]))])))
219 | 
220 | 
221 | ;; (get-tag (car (parse1 $statement "function f(x) {}"))
222 | ;;          'name)
223 | 
224 | 
225 | ;; Find the first node containing a given path of tags.
226 | ;; For example: '(function parameter) could match a function's parameter
227 | 
228 | (define match-tags
229 |   (lambda (e tags)
230 |     (cond
231 |      [(not (Node? e)) #f]
232 |      [(null? tags) e]
233 |      [else
234 |       (match-tags (get-tag e (car tags)) (cdr tags))])))
235 | 
236 | 
237 | ;; (match-tags (car (parse1 $statement "function f(x) {}"))
238 | ;;             '(function name))
239 | 
240 | 
241 | (define uid
242 |   (let ([count 1]
243 |         [table (box '())])
244 |     (lambda (node)
245 |       (let ([p (assq node (unbox table))])
246 |         (cond
247 |          [(not p)
248 |           (let ([id count])
249 |             (set! count (add1 count))
250 |             (set-box! table (cons `(,node . ,id) (unbox table)))
251 |             id)]
252 |          [else
253 |           (cdr p)])))))
254 | 
255 | 
256 | 
257 | ;; similarity string from a change
258 | (define similarity
259 |   (lambda (change)
260 |     (let ([total (+ (node-size (Change-old change))
261 |                     (node-size (Change-new change)))])
262 |       (cond
263 |        [(or (= 0 total) (= 0 (Change-cost change)))
264 |         "100%"]
265 |        [else
266 |         (string-append
267 |          (real->decimal-string
268 |           (* 100 (- 1.0 (/ (Change-cost change) total))) 1)
269 |          "%")]))))
270 | 


--------------------------------------------------------------------------------
/utils.rkt:
--------------------------------------------------------------------------------
  1 | ;; ydiff - a language-aware tool for comparing programs
  2 | ;; Copyright (C) 2011-2013 Yin Wang (yinwang0@gmail.com)
  3 | 
  4 | 
  5 | ;; This program is free software: you can redistribute it and/or modify
  6 | ;; it under the terms of the GNU General Public License as published by
  7 | ;; the Free Software Foundation, either version 3 of the License, or
  8 | ;; (at your option) any later version.
  9 | 
 10 | ;; This program is distributed in the hope that it will be useful,
 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13 | ;; GNU General Public License for more details.
 14 | 
 15 | ;; You should have received a copy of the GNU General Public License
 16 | ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17 | 
 18 | 
 19 | #lang racket
 20 | 
 21 | (provide (all-defined-out))
 22 | 
 23 | 
 24 | 
 25 | ;-------------------------------------------------------------
 26 | ;                        utilities
 27 | ;-------------------------------------------------------------
 28 | 
 29 | (define-syntax letv
 30 |   (syntax-rules ()
 31 |     [(_ () body ...)
 32 |      (begin body ...)]
 33 |     [(_ ([(e1 e2* ...) e3] bd* ...) body ...)
 34 |      (let-values ([(e1 e2* ...) e3])
 35 |        (letv (bd* ...) body ...))]
 36 |     [(_ ([e1 e2] bd* ...) body ...)
 37 |      (let ([e1 e2])
 38 |        (letv (bd* ...) body ...))]))
 39 | 
 40 | 
 41 | (define-syntax first-val
 42 |   (syntax-rules ()
 43 |     [(_ e)
 44 |      (letv ([(x y) e]) x)]))
 45 | 
 46 | 
 47 | (define-syntax second-val
 48 |   (syntax-rules ()
 49 |     [(_ e)
 50 |      (letv ([(x y) e]) y)]))
 51 | 
 52 | 
 53 | (define *debug* #f)
 54 | (define-syntax peek
 55 |   (syntax-rules ()
 56 |     [(_ name args ...)
 57 |      (if *debug*
 58 |          (begin
 59 |            (printf "~s: ~s = ~s~n" name 'args args)
 60 |            ...)
 61 |          (void))]))
 62 | 
 63 | 
 64 | ;; utility for error reporting
 65 | (define fatal
 66 |   (lambda (who . args)
 67 |     (printf "~s: " who)
 68 |     (for-each display args)
 69 |     (display "\n")
 70 |     (error who "")))
 71 | 
 72 | 
 73 | ; foldl of Racket has a bug!
 74 | ; (foldl (lambda (x y) x) 0 '(1 2 3 4))
 75 | ; => 4
 76 | ; Don't use it!
 77 | (define foldl2
 78 |   (lambda (f x ls)
 79 |     (cond
 80 |      [(null? ls) x]
 81 |      [else
 82 |        (foldl2 f (f x (car ls)) (cdr ls))])))
 83 | 
 84 | 
 85 | ; (foldl2 + 0 '(1 2 3 4 ))
 86 | 
 87 | 
 88 | 
 89 | (define orf
 90 |   (lambda (a b)
 91 |     (or a b)))
 92 | 
 93 | 
 94 | 
 95 | 
 96 | (define char->string string)
 97 | 
 98 | 
 99 | (define read-file
100 |   (lambda (filename)
101 |     (let ([port (open-input-file filename #:mode 'text)])
102 |       (let loop ([line (read-line port)]
103 |                  [all ""])
104 |         (cond
105 |          [(eof-object? line) all]
106 |          [else
107 |           (loop (read-line port)
108 |                 (string-append all line "\n"))])))))
109 | 
110 | 
111 | 
112 | (define new-progress
113 |   (lambda (size)
114 |     (let* ([counter 0]
115 |            [dots 0]
116 |            [print-mark
117 |             (lambda (sym)
118 |               (display sym)
119 |               (set! dots (+ dots 1))
120 |               (cond
121 |                [(= 0 (modulo dots 60))
122 |                 (display "\n")])
123 |               (flush-output))])
124 |       (lambda (x)
125 |         (cond
126 |          [(eq? x 'reset)
127 |           (set! counter 0)
128 |           (set! dots 0)]
129 |          [(eq? x 'get)
130 |           counter]
131 |          [(string? x)
132 |           (print-mark x)]
133 |          [(= 0 (remainder counter size))
134 |           (set! counter (+ x counter))
135 |           (print-mark ".")]
136 |          [else
137 |           (set! counter (+ x counter))])))))
138 | 
139 | 
140 | 
141 | ;;----------------- multi dimensional eq hash --------------------
142 | 
143 | (define hash-put!
144 |   (lambda (hash key1 key2 v)
145 |     (cond
146 |      [(hash-has-key? hash key2)
147 |       (let ([inner (hash-ref hash key2)])
148 |         (hash-set! inner key1 v))]
149 |      [else
150 |       (let ([inner (make-hasheq)])
151 |         (hash-set! inner key1 v)
152 |         (hash-set! hash key2 inner))])))
153 | 
154 | (define hash-get
155 |   (lambda (hash key1 key2)
156 |     (cond
157 |      [(hash-has-key? hash key2)
158 |       (let ([inner (hash-ref hash key2)])
159 |         (cond
160 |          [(hash-has-key? inner key1)
161 |           (hash-ref inner key1)]
162 |          [else #f]))]
163 |      [else #f])))
164 | 
165 | 
166 | (define hash-put2!
167 |   (lambda (hash key1 key2 v)
168 |     (cond
169 |      [(hash-has-key? hash key2)
170 |       (let ([inner (hash-ref hash key2)])
171 |         (hash-set! inner key1 v))]
172 |      [else
173 |       (let ([inner (make-hash)])
174 |         (hash-set! inner key1 v)
175 |         (hash-set! hash key2 inner))])))
176 | 
177 | (define hash-get2
178 |   (lambda (hash key1 key2)
179 |     (cond
180 |      [(hash-has-key? hash key2)
181 |       (let ([inner (hash-ref hash key2)])
182 |         (cond
183 |          [(hash-has-key? inner key1)
184 |           (hash-ref inner key1)]
185 |          [else #f]))]
186 |      [else #f])))
187 | 
188 | 
189 | (define predand
190 |   (lambda preds
191 |     (lambda (x)
192 |       (cond
193 |        [(null? preds) #t]
194 |        [((car preds) x) 
195 |         ((apply predand (cdr preds)) x)]
196 |        [else #f]))))
197 | 
198 | 
199 | (define predor
200 |   (lambda preds
201 |     (lambda (x)
202 |       (cond
203 |        [(null? preds) #f]
204 |        [((car preds) x) #t]
205 |        [else
206 |         ((apply predor (cdr preds)) x)]))))
207 | 
208 | 
209 | (define set-
210 |   (lambda (s1 s2)
211 |     (cond
212 |      [(null? s1) '()]
213 |      [(memq (car s1) s2)
214 |       (set- (cdr s1) s2)]
215 |      [else
216 |       (cons (car s1) (set- (cdr s1) s2))])))
217 | 
218 | 
219 | 
220 | (define string-join
221 |   (lambda (ls sep)
222 |     (cond
223 |      [(null? ls) ""]
224 |      [else 
225 |       (string-append (car ls) sep (string-join (cdr ls) sep))])))
226 | 
227 | ; (string-join (list "a" "b" "c") ",")
228 | 
229 | 


--------------------------------------------------------------------------------