rb-scheme 0.3.5

checksums.yaml

@@ -0,0 +1,7 @@
+---
+SHA1:
+  metadata.gz: 0544689173026c8cb44f2dec68fad23ff1e98a59
+  data.tar.gz: c3e23e29b7f1bc84bf829cefd42b902b47a233df
+SHA512:
+  metadata.gz: b35a2ace04fc9111600fe6d954ab880cdb6cae38f3099297e0660ff39fa4611a99961c5baed47a20fd81eca1e51f793016c17c38abcf185816d9d7622c9cd41f
+  data.tar.gz: 777d0df0d518ceebdab8c8eb64885ee6cadb1b7f9cf8be89f9abd1139c592f963fdc5d9c867dd79ce79d3c1b847fb4e3f5e7946940973d7ff131a087621ca4a9

data/.gitignore

@@ -0,0 +1,37 @@
+*.gem
+*.rbc
+/.config
+/coverage/
+/InstalledFiles
+/pkg/
+/spec/reports/
+/spec/examples.txt
+/test/tmp/
+/test/version_tmp/
+/tmp/
+
+## Specific to RubyMotion:
+.dat*
+.repl_history
+build/
+
+## Documentation cache and generated files:
+/.yardoc/
+/_yardoc/
+/doc/
+/rdoc/
+
+## Environment normalization:
+/.bundle/
+/vendor/bundle
+/lib/bundler/man/
+
+# for a library or gem, you might want to ignore these files since the code is
+# intended to run in multiple environments; otherwise, check them in:
+# Gemfile.lock
+# .ruby-version
+# .ruby-gemset
+
+# unless supporting rvm < 1.11.0 or doing something fancy, ignore this:
+.rvmrc
+.ruby-version

data/Gemfile

@@ -0,0 +1,4 @@
+# A sample Gemfile
+source "https://rubygems.org"
+
+gemspec

data/Gemfile.lock

@@ -0,0 +1,22 @@
+PATH
+  remote: .
+  specs:
+    rb-scheme (0.3.5)
+
+GEM
+  remote: https://rubygems.org/
+  specs:
+    minitest (5.10.1)
+    rake (10.4.2)
+
+PLATFORMS
+  ruby
+
+DEPENDENCIES
+  bundler (~> 1.13)
+  minitest (~> 5.10)
+  rake (~> 10.0)
+  rb-scheme!
+
+BUNDLED WITH
+   1.13.6

data/LICENSE.txt

@@ -0,0 +1,21 @@
+The MIT License (MIT)
+
+Copyright (c) 2017 tkhsh
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.

data/README.md

@@ -0,0 +1,65 @@
+[![CircleCI](https://circleci.com/gh/tkhsh/rb-scheme/tree/master.svg?style=svg&circle-token=7033e7916629278437dfafc29e10f40973ee5cd3)](https://circleci.com/gh/tkhsh/rb-scheme/tree/master)
+
+# RbScheme
+
+An implementation of Scheme subset written in Ruby. It's based on the Stack-Based model introduced in [Three Implementation Models for Scheme](http://www.cs.indiana.edu/~dyb/papers/3imp.pdf) by R. Kent Dybvig. The model is implemented by a compiler and virtual machine.
+
+# Features
+
+- first class closures
+- global variables
+- integers/symbols/cons cell/true/false
+- variadic function
+- call/cc(limitation exists)
+- if
+- basic arithmetic functions(+ - * /)
+- set!
+- tail call optimization
+
+# Install
+
+```
+$ git clone https://github.com/tkhsh/rb-scheme.git
+```
+
+# Usage
+
+## Run
+
+### repl
+```
+$ bin/rb-scheme
+```
+
+You can use  [rlwrap](https://github.com/hanslub42/rlwrap) for readline
+```
+$ rlwrap bin/rb-scheme
+```
+
+### with file
+```
+$ bin/rb-scheme examples/nqueen.scm
+```
+
+## primitives
+
+- numeric(`+`, `-`, `*`, `/`)
+- predicate(`=`, `<`, `>`, `null?`)
+- lisp operations(`cons`, `car`, `cdr`, `list`)
+- print(`display`, `newline`, `print`)
+
+## examples
+
+see `examples` folder
+
+# Test
+
+[bundler](http://bundler.io/) required
+```
+$ bundle install
+$ rake test
+```
+
+# License
+
+The gem is available as open source under the terms of the [MIT License](http://opensource.org/licenses/MIT).

data/Rakefile

@@ -0,0 +1,11 @@
+require "bundler/gem_tasks"
+require 'rake/testtask'
+
+desc 'Run test'
+Rake::TestTask.new do |t|
+  t.libs << 'test'
+  t.test_files = FileList['test/**/test*.rb']
+  t.verbose = true
+end
+
+task :default => [:test]

data/circle.yml

@@ -0,0 +1,6 @@
+machine:
+  ruby:
+    version: 2.2.3
+test:
+  post:
+    - bundle exec rake test

data/examples/nqueen.scm

@@ -0,0 +1,120 @@
+; n queen solver
+(define nil '())
+
+(define caddr
+  (lambda (lst)
+    (car (cddr lst))))
+
+(define append
+  (lambda (lst1 lst2)
+    (if (null? lst1)
+      lst2
+      (cons (car lst1)
+            (append (cdr lst1) lst2)))))
+
+(define accumulate
+  (lambda (op initial sequence)
+    (if (null? sequence)
+      initial
+      (op (car sequence)
+          (accumulate op initial (cdr sequence))))))
+
+(define map
+  (lambda (proc lst)
+    (if (null? lst)
+      nil
+      (cons (proc (car lst))
+            (map proc (cdr lst))))))
+
+(define map2
+  (lambda (proc lst1 lst2)
+    (if (null? lst1)
+      nil
+      (if (null? lst2)
+        nil
+        (cons (proc (car lst1) (car lst2))
+              (map2 proc (cdr lst1) (cdr lst2)))))))
+
+(define filter
+  (lambda (pred lst)
+    (if (null? lst)
+      nil
+      (if (pred (car lst))
+        (cons (car lst) (filter pred (cdr lst)))
+        (filter pred (cdr lst))))))
+
+(define flatmap
+  (lambda (proc seq)
+    (accumulate append nil (map proc seq))))
+
+(define enumerate-interval
+  (lambda (low high)
+    (if (> low high)
+      nil
+      (cons low (enumerate-interval (+ low 1) high)))))
+
+(define make-board-from-y
+  (lambda (y rest n)
+    (if (null? rest)
+      nil
+      (cons (+ y n) (make-board-from-y (+ y n) (cdr rest) n)))))
+
+(define make-board
+  (lambda (board n)
+    (if (null? board)
+      nil
+      (cons nil (make-board-from-y (car board) (cdr board) n)))))
+
+(define make-wrong-board
+  (lambda (board)
+    (cons (make-board board 1)
+          (cons (make-board board 0)
+                (cons (make-board board -1) nil)))))
+
+(define compare-board-pair
+  (lambda (wrong-board board)
+    (if (null? (filter
+                 (lambda (b) b)
+                 (map2 (lambda (e1 e2)
+                         (if (null? e1)
+                           #f
+                           (= e1 e2)))
+                       wrong-board
+                       board)))
+      #t
+      #f)))
+
+(define safe?
+  (lambda (k positions)
+    ((lambda (wrong-board)
+       (if (compare-board-pair (car wrong-board) positions)
+         (if (compare-board-pair (cadr wrong-board) positions)
+           (compare-board-pair (caddr wrong-board) positions)
+           #f)
+         #f))
+     (make-wrong-board positions))))
+
+(define empty-board nil)
+
+(define adjoin-position
+  (lambda (new-row k rest-of-queens)
+    (cons new-row rest-of-queens)))
+
+(define queen-cols
+  (lambda (k board-size)
+    (if (= k 0)
+      (cons empty-board nil)
+      (filter
+        (lambda (positions) (safe? k positions))
+        (flatmap
+          (lambda (rest-of-queens)
+            (map (lambda (new-row)
+                   (adjoin-position new-row k rest-of-queens))
+                 (enumerate-interval 1 board-size)))
+          (queen-cols (- k 1) board-size))))))
+
+(define queens
+  (lambda (board-size)
+    (queen-cols board-size board-size)))
+
+(print (queens 4))

data/examples/y_combinator.scm

@@ -0,0 +1,12 @@
+(print ((lambda (y)
+          ((y (lambda (fn)
+                (lambda (n)
+                  (if (< n 1)
+                    1
+                    (+ n (fn (- n 1)))))))
+           10))
+        (lambda (f)
+          ((lambda (g)
+             (f (lambda (arg) ((g g) arg))))
+           (lambda (g)
+             (f (lambda (arg) ((g g) arg))))))))

data/exe/rb-scheme

@@ -0,0 +1,8 @@
+#!/usr/bin/env ruby
+
+lib = File.expand_path('../../lib', __FILE__)
+$LOAD_PATH.unshift(lib) unless $LOAD_PATH.include?(lib)
+
+require 'rb-scheme'
+
+RbScheme::Executer.run(ARGF.file)

data/lib/rb-scheme.rb

@@ -0,0 +1,18 @@
+require "forwardable"
+require "set"
+
+require 'rb-scheme/lisp-objects'
+require 'rb-scheme/helpers'
+require 'rb-scheme/symbol'
+require 'rb-scheme/global'
+require 'rb-scheme/parser'
+require 'rb-scheme/printer'
+require 'rb-scheme/evaluator'
+require 'rb-scheme/primitive'
+require 'rb-scheme/primitive/procedure'
+require 'rb-scheme/extension'
+require 'rb-scheme/compiler'
+require 'rb-scheme/vm/box'
+require 'rb-scheme/vm/stack'
+require 'rb-scheme/vm'
+require 'rb-scheme/executer'

data/lib/rb-scheme/compiler.rb

@@ -0,0 +1,280 @@
+module RbScheme
+  class Compiler
+    include Helpers
+    include Symbol
+
+    def compile(exp, env, sets, nxt)
+      case exp
+      when LSymbol
+        compile_refer(exp,
+                      env,
+                      sets.member?(exp) ? list(intern("indirect"), nxt) : nxt)
+      when LCell
+        case exp.car
+        when intern("quote")
+          check_length!(exp.cdr, 1, "quote")
+          obj = exp.cadr
+
+          list(intern("constant"), obj, nxt)
+        when intern("lambda")
+          check_min_length!(exp.cdr, 2, "lambda")
+          param_info = parse_parameters(exp.cadr)
+          vars = param_info[:vars]
+          *body = exp.cddr.to_a
+
+          local_bound = Set.new(vars)
+          global_bound = Set.new(Global.variables)
+          free = convert_to_list(find_free_body(body, local_bound.union(global_bound)))
+          sets_body = find_sets_body(body, Set.new(vars))
+          c = compile_lambda_body(body,
+                                  cons(vars, free),
+                                  sets_body.union(sets.intersection(free)),
+                                  list(intern("return"), vars.count))
+          collect_free(free,
+                       env,
+                       list(intern("close"),
+                            vars.count,
+                            param_info[:variadic?] ? 1 : 0,
+                            free.count,
+                            make_boxes(sets_body, vars, c),
+                            nxt))
+        when intern("begin")
+          check_min_length!(exp.cdr, 1, "begin")
+          *body = exp.cdr.to_a
+
+          compile_lambda_body(body, env, sets, nxt)
+        when intern("if")
+          check_length!(exp.cdr, 3, "if")
+          test, then_exp, else_exp = exp.cdr.to_a
+
+          thenc = compile(then_exp, env, sets, nxt)
+          elsec = compile(else_exp, env, sets, nxt)
+          compile(test, env, sets, list(intern("test"), thenc, elsec))
+        when intern("set!")
+          check_length!(exp.cdr, 2, "set!")
+          var, x = exp.cdr.to_a
+
+          compile_lookup(var,
+                         env,
+                         lambda { |n| compile(x, env, sets, list(intern("assign-local"), n, nxt)) },
+                         lambda { |n| compile(x, env, sets, list(intern("assign-free"), n, nxt)) },
+                         lambda { |k| compile(x, env, sets, list(intern("assign-global"), k, nxt)) })
+        when intern("define")
+          check_length!(exp.cdr, 2, "define")
+          var, x = exp.cdr.to_a
+
+          Global.put(var, nil)
+          compile(x, env, sets, list(intern("assign-global"), var, nxt))
+        when intern("call/cc")
+          check_length!(exp.cdr, 1, "call/cc")
+          x = exp.cadr
+
+          cn = tail?(nxt) ?
+            list(intern("shift"), 1, nxt.cadr, list(intern("apply"), 1)) :
+            list(intern("apply"), 1)
+          c = list(intern("conti"),
+                   list(intern("argument"),
+                        compile(x, env, sets, cn)))
+          tail?(nxt) ? c : list(intern("frame"), nxt, c)
+        else
+          args = exp.cdr
+          cn = tail?(nxt) ?
+            list(intern("shift"), exp.cdr.count, nxt.cadr, list(intern("apply"), args.count)) :
+            list(intern("apply"), args.count)
+          c = compile(exp.car, env, sets, cn)
+
+          args.each do |arg|
+            c = compile(arg, env, sets, list(intern("argument"), c))
+          end
+          tail?(nxt) ? c : list(intern("frame"), nxt, c)
+        end
+      else
+        list(intern("constant"), exp, nxt)
+      end
+    end
+
+    def tail?(nxt)
+      nxt.car == intern("return")
+    end
+
+    def parse_parameters(param)
+      case param
+      when LSymbol
+        return { vars: list(param), variadic?: true }
+      when LCell
+        return { vars: list, variadic?: false } if param.null?
+        result = []
+        target = param
+        loop do
+          result.push(target.car)
+          target = target.cdr
+          if !target.is_a?(LCell)
+            result.push(target)
+            return { vars: convert_to_list(result), variadic?: true }
+          elsif target.null?
+            return { vars: convert_to_list(result), variadic?: false }
+          end
+        end
+      else
+        raise "error"
+      end
+    end
+
+    def compile_lambda_body(body, env, sets, ret)
+      c = ret
+      body.reverse_each do |exp|
+        c = compile(exp, env, sets, c)
+      end
+      c
+    end
+
+    def find_sets_body(body, sets_vars)
+      body.reduce(Set.new) do |whole_sets, exp|
+        whole_sets.union(find_sets(exp, sets_vars))
+      end
+    end
+
+    def find_sets(exp, vars)
+      case exp
+      when LSymbol
+        Set.new
+      when LCell
+        case exp.car
+        when intern("quote")
+          Set.new
+        when intern("lambda")
+          check_min_length!(exp.cdr, 2, "find_sets(lambda)")
+          new_vars, *body = exp.cdr.to_a
+
+          find_sets_body(body, vars.subtract(new_vars))
+        when intern("if")
+          check_length!(exp.cdr, 3, "find_sets(if)")
+          test, then_x, else_x = exp.cdr.to_a
+
+          [test, then_x, else_x].inject(Set.new) do |res, x|
+            res.union(find_sets(x, vars))
+          end
+        when intern("set!")
+          check_length!(exp.cdr, 2, "find_sets(set!)")
+          var, x = exp.cdr.to_a
+
+          s = vars.member?(var) ? Set.new([var]) : Set.new
+          s.union(find_sets(x, vars))
+        when intern("define")
+          raise "Only top level define is supported"
+        when intern("call/cc")
+          check_length!(exp.cdr, 1, "find_sets(call/cc)")
+          x = exp.cadr
+
+          find_sets(x, vars)
+        else
+          exp.inject(Set.new) do |res, x|
+            res.union(find_sets(x, vars))
+          end
+        end
+      else
+        Set.new
+      end
+    end
+
+    def make_boxes(sets, vars, nxt)
+      n = vars.count - 1
+      res = nxt
+
+      vars.reverse_each do |v|
+        if sets.member?(v)
+          res = list(intern("box"), n, res)
+        end
+        n -= 1
+      end
+      res
+    end
+
+    def find_free_body(body, bound_variables)
+      body.reduce(Set.new) do |whole_free, exp|
+        whole_free.union(find_free(exp, bound_variables))
+      end
+    end
+
+    def find_free(exp, bound_variables)
+      case exp
+      when LSymbol
+        bound_variables.member?(exp) ? Set.new : Set.new(list(exp))
+      when LCell
+        case exp.car
+        when intern("quote")
+          Set.new
+        when intern("lambda")
+          check_min_length!(exp.cdr, 2, "find_free")
+          vars, *body = exp.cdr.to_a
+
+          find_free_body(body, bound_variables.union(Set.new(vars)))
+        when intern("if")
+          check_length!(exp.cdr, 3, "find_free(if)")
+          test_x, then_x, else_x = exp.cdr.to_a
+
+          find_free(test_x, bound_variables)
+            .union(find_free(then_x, bound_variables))
+            .union(find_free(else_x, bound_variables))
+        when intern("set!")
+          check_length!(exp.cdr, 2, "find_free(set!)")
+          var, exp = exp.cdr.to_a
+
+          free = find_free(exp, bound_variables)
+          bound_variables.member?(var) ? free : Set[var].union(free)
+        when intern("define")
+          raise "Only top level define is supported"
+        when intern("call/cc")
+          check_length!(exp.cdr, 1, "find_free(call/cc)")
+          x = exp.cadr
+
+          find_free(x, bound_variables)
+        else
+          exp.inject(Set.new) do |result, item|
+            result.union(find_free(item, bound_variables))
+          end
+        end
+      else
+        Set.new
+      end
+    end
+
+    def collect_free(vars, env, nxt)
+      return nxt if vars.null?
+
+      collect_free(vars.cdr,
+                   env,
+                   compile_refer(vars.car,
+                                 env,
+                                 list(intern("argument"), nxt)))
+    end
+
+    def compile_refer(var, env, nxt)
+      compile_lookup(var,
+                     env,
+                     lambda { |n| list(intern("refer-local"), n, nxt) },
+                     lambda { |n| list(intern("refer-free"), n, nxt) },
+                     lambda { |k| list(intern("refer-global"), k, nxt) })
+    end
+
+    def compile_lookup(var, env, return_local, return_free, return_global)
+      unless env.null?
+        locals = env.car
+        locals.each_with_index do |l, n|
+          return return_local.call(n) if l == var
+        end
+
+        free = env.cdr
+        free.each_with_index do |f, n|
+          return return_free.call(n) if f == var
+        end
+      end
+
+      if Global.defined?(var)
+        return return_global.call(var)
+      end
+
+      raise "#{var.name} isn't found in environment"
+    end
+  end # Compiler
+end # RbScheme