├── .gitignore ├── ReadMe.md ├── python ├── ReadMe.md ├── lib │ └── lingy │ │ └── __init__.py ├── .gitignore ├── setup.cfg ├── test │ └── test.py ├── License ├── setup.py └── Makefile ├── ruby ├── ReadMe.md ├── ChangeLog.md ├── Rakefile ├── lib │ ├── lingy │ │ └── version.rb │ └── yamlscript.rb ├── .gitignore ├── bin │ ├── setup │ └── console ├── Gemfile └── lingy.gemspec ├── rust ├── ReadMe.md ├── .gitignore ├── src │ └── main.rs ├── Makefile └── Cargo.toml ├── perl ├── doc │ └── Lingy.md ├── eg │ ├── 99-bottles.ly │ └── fizzbuzz.ly ├── test │ ├── mal │ │ ├── test.txt │ │ ├── incC.mal │ │ ├── inc.mal │ │ ├── incB.mal │ │ ├── computations.mal │ │ ├── step5_tco.yaml │ │ ├── step2_eval.yaml │ │ ├── step3_env.yaml │ │ ├── step8_macros.yaml │ │ ├── step6_file.yaml │ │ ├── stepA_mal.yaml │ │ ├── step7_quote.yaml │ │ ├── step9_try.yaml │ │ └── step4_if_fn_do.yaml │ ├── program1.ly │ ├── lib │ │ ├── Foo │ │ │ ├── Bar.ly │ │ │ ├── BarClass.pm │ │ │ └── Class.pm │ │ ├── test │ │ │ └── lingy.ly │ │ └── DistTestFixer.pm │ ├── 05-clojure.t │ ├── 52-class.t │ ├── 15-character.t │ ├── 10-misc.t │ ├── 38-new.t │ ├── 81-lingy-testing-tap.t │ ├── 65-devel.t │ ├── 00-use-ok.t │ ├── 18-lambda.t │ ├── 40-string.t │ ├── 11-symbol.t │ ├── 35-arity.t │ ├── 71-errors.t │ ├── 12-use.t │ ├── 36-macroexpand.t │ ├── 54-import.t │ ├── 14-vector.t │ ├── 33-dynamic.t │ ├── 23-reader-cond.t │ ├── 22-ignore.t │ ├── 17-seq.t │ ├── 19-hash-set.t │ ├── 55-require.t │ ├── 31-math-ops.t │ ├── 34-loop.t │ ├── 53-dot.t │ ├── 37-special.t │ ├── 13-hash-map.t │ ├── 16-regex.t │ ├── 04-examples.t │ ├── 39-instance.t │ ├── 32-core.t │ ├── 02-reader.t │ ├── 20-meta.t │ ├── 62-from-perl.t │ ├── 51-ns.t │ ├── 21-vars.t │ ├── 03-cli.t │ ├── 01-mal.t │ └── 61-interop.t ├── lib │ ├── Lingy │ │ ├── Var.pm │ │ ├── Sequential.pm │ │ ├── IllegalArgumentException.pm │ │ ├── Atom.pm │ │ ├── Term.pm │ │ ├── Nil.pm │ │ ├── Thread.pm │ │ ├── ListClass.pm │ │ ├── System.pm │ │ ├── List.pm │ │ ├── Macro.pm │ │ ├── Keyword.pm │ │ ├── Symbol.pm │ │ ├── Exception.pm │ │ ├── StringBuilder.pm │ │ ├── ScalarClass.pm │ │ ├── Boolean.pm │ │ ├── Vector.pm │ │ ├── testing │ │ │ └── tap.ly │ │ ├── Regex.pm │ │ ├── Clojure.pm │ │ ├── devel.ly │ │ ├── Character.pm │ │ ├── HashSet.pm │ │ ├── Numbers.pm │ │ ├── String.pm │ │ ├── string.ly │ │ ├── Namespace.pm │ │ ├── Class.pm │ │ ├── Util.pm │ │ ├── HashMap.pm │ │ ├── Number.pm │ │ ├── Fn.pm │ │ ├── Compiler.pm │ │ ├── Env.pm │ │ ├── Printer.pm │ │ ├── ClojureREPL.pm │ │ ├── Test.pm │ │ ├── Main.pm │ │ ├── ReadLine.pm │ │ ├── Common.pm │ │ ├── core.ly │ │ └── nREPL.pm │ └── Lingy.pm ├── bin │ ├── _lingy.pl │ └── lingy ├── .gitignore ├── Meta ├── Makefile ├── tool │ └── compile-clojure-core └── Changes ├── js ├── .gitignore ├── src │ └── lingy │ │ └── index.coffee ├── Changes ├── package.json ├── lib │ └── lingy │ │ └── index.js └── Makefile ├── raku ├── .gitignore ├── lib │ └── Lingy.rakumod ├── META6.json └── t │ └── 00-use.t ├── lua ├── .gitignore └── lingy-0.1.0-0.rockspec ├── .github └── workflows │ └── test.yaml ├── Makefile ├── eg ├── 99-bottles.ly └── fizzbuzz.ly └── License /.gitignore: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /ReadMe.md: -------------------------------------------------------------------------------- 1 | doc/lingy.md -------------------------------------------------------------------------------- /python/ReadMe.md: -------------------------------------------------------------------------------- 1 | ../ReadMe.md -------------------------------------------------------------------------------- /ruby/ReadMe.md: -------------------------------------------------------------------------------- 1 | ../ReadMe.md -------------------------------------------------------------------------------- /rust/ReadMe.md: -------------------------------------------------------------------------------- 1 | ../ReadMe.md -------------------------------------------------------------------------------- /perl/doc/Lingy.md: -------------------------------------------------------------------------------- 1 | ../../doc/lingy.md -------------------------------------------------------------------------------- /python/lib/lingy/__init__.py: -------------------------------------------------------------------------------- 1 | pass 2 | -------------------------------------------------------------------------------- /perl/eg/99-bottles.ly: -------------------------------------------------------------------------------- 1 | ../../eg/99-bottles.ly -------------------------------------------------------------------------------- /perl/eg/fizzbuzz.ly: -------------------------------------------------------------------------------- 1 | ../../eg/fizzbuzz.ly -------------------------------------------------------------------------------- /perl/test/mal/test.txt: -------------------------------------------------------------------------------- 1 | A line of text 2 | -------------------------------------------------------------------------------- /python/.gitignore: -------------------------------------------------------------------------------- 1 | /.venv/ 2 | /.eggs/ 3 | -------------------------------------------------------------------------------- /js/.gitignore: -------------------------------------------------------------------------------- 1 | /package* 2 | /node_modules/ 3 | -------------------------------------------------------------------------------- /raku/.gitignore: -------------------------------------------------------------------------------- 1 | /lib/.precomp/ 2 | /target/ 3 | -------------------------------------------------------------------------------- /rust/.gitignore: -------------------------------------------------------------------------------- 1 | /Cargo.lock 2 | /target/ 3 | -------------------------------------------------------------------------------- /perl/test/mal/incC.mal: -------------------------------------------------------------------------------- 1 | (def mymap {"a" 2 | 1}) 3 | -------------------------------------------------------------------------------- /python/setup.cfg: -------------------------------------------------------------------------------- 1 | [metadata] 2 | description-file = ReadMe.md 3 | -------------------------------------------------------------------------------- /lua/.gitignore: -------------------------------------------------------------------------------- 1 | /luarocks 2 | /lua 3 | /lua_modules 4 | /.luarocks 5 | -------------------------------------------------------------------------------- /perl/test/program1.ly: -------------------------------------------------------------------------------- 1 | (println "program:" *file* "args:" *command-line-args*) 2 | -------------------------------------------------------------------------------- /js/src/lingy/index.coffee: -------------------------------------------------------------------------------- 1 | require 'yaml' 2 | 3 | class lingy 4 | version: '0.0.1' 5 | -------------------------------------------------------------------------------- /ruby/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## [Unreleased] 2 | 3 | ## [0.0.1] - 2023-04-13 4 | 5 | - Initial release 6 | -------------------------------------------------------------------------------- /rust/src/main.rs: -------------------------------------------------------------------------------- 1 | fn main() { 2 | println!("Lingy — A Clojure for Rust — Coming soon…"); 3 | } 4 | -------------------------------------------------------------------------------- /ruby/Rakefile: -------------------------------------------------------------------------------- 1 | # frozen_string_literal: true 2 | 3 | require "bundler/gem_tasks" 4 | task default: %i[] 5 | -------------------------------------------------------------------------------- /ruby/lib/lingy/version.rb: -------------------------------------------------------------------------------- 1 | # frozen_string_literal: true 2 | 3 | module Lingy 4 | VERSION = "0.0.1" 5 | end 6 | -------------------------------------------------------------------------------- /js/Changes: -------------------------------------------------------------------------------- 1 | --- 2 | version: 0.0.1 3 | date: Thu Apr 13 05:54:02 PM PDT 2023 4 | changes: 5 | - First release 6 | -------------------------------------------------------------------------------- /perl/test/lib/Foo/Bar.ly: -------------------------------------------------------------------------------- 1 | (ns Foo.Bar) 2 | 3 | (import Foo.BarClass) 4 | 5 | (defn bar [] (. Foo.BarClass foo)) 6 | -------------------------------------------------------------------------------- /perl/test/lib/test/lingy.ly: -------------------------------------------------------------------------------- 1 | (ns test.lingy) 2 | 3 | (defn foo [] "called test.lingy/foo") 4 | 5 | (defn bar [] nil) 6 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Var.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Var; 3 | 4 | use base 'Lingy::ScalarClass'; 5 | 6 | 1; 7 | -------------------------------------------------------------------------------- /perl/test/mal/inc.mal: -------------------------------------------------------------------------------- 1 | (def inc1 (fn* [a] (+ 1 a))) 2 | (def inc2 (fn* [a] (+ 2 a))) 3 | (def inc3 (fn* [a] 4 | (+ 3 a))) 5 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Sequential.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Sequential; 3 | 4 | use base 'Lingy::Class'; 5 | 6 | 1; 7 | -------------------------------------------------------------------------------- /perl/test/05-clojure.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - (time (clojure-require 'clojure.core)) 5 | - nil 6 | ... 7 | -------------------------------------------------------------------------------- /perl/bin/_lingy.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; use warnings; 4 | 5 | use Lingy::Main; 6 | 7 | Lingy::Main->new->run(@ARGV); 8 | -------------------------------------------------------------------------------- /ruby/.gitignore: -------------------------------------------------------------------------------- 1 | /.bundle/ 2 | /.yardoc 3 | /_yardoc/ 4 | /coverage/ 5 | /doc/ 6 | /pkg/ 7 | /spec/reports/ 8 | /tmp/ 9 | /Gemfile.lock 10 | -------------------------------------------------------------------------------- /rust/Makefile: -------------------------------------------------------------------------------- 1 | SHELL := bash 2 | 3 | default: 4 | 5 | build clean publish test:: 6 | cargo $@ 7 | 8 | clean:: 9 | rm -f Cargo.lock 10 | -------------------------------------------------------------------------------- /perl/.gitignore: -------------------------------------------------------------------------------- 1 | /cpan/ 2 | /Lingy-* 3 | /Notes 4 | /note/ 5 | /.nrepl-log 6 | /.nrepl-pid 7 | /.nrepl-port 8 | /.calva/ 9 | /.clj-kondo/ 10 | /.lsp/ 11 | -------------------------------------------------------------------------------- /perl/lib/Lingy/IllegalArgumentException.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::IllegalArgumentException; 3 | use base 'Lingy::Exception'; 4 | 5 | 1; 6 | -------------------------------------------------------------------------------- /perl/test/lib/Foo/BarClass.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Foo::BarClass; 3 | 4 | sub new {} 5 | 6 | sub foo { 7 | return 43; 8 | } 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /ruby/bin/setup: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -euo pipefail 3 | IFS=$'\n\t' 4 | set -vx 5 | 6 | bundle install 7 | 8 | # Do any other automated setup that you need to do here 9 | -------------------------------------------------------------------------------- /.github/workflows/test.yaml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | 3 | jobs: 4 | ubuntu-2204: 5 | uses: lingy-lang/gha-perl-test-runner/.github/workflows/ubuntu-perl-test-runner.yaml@main 6 | -------------------------------------------------------------------------------- /python/test/test.py: -------------------------------------------------------------------------------- 1 | import pytest 2 | 3 | def modules_compile(): 4 | import lingy 5 | return "ok" 6 | 7 | def test_modules_compile(): 8 | assert modules_compile() == "ok" 9 | -------------------------------------------------------------------------------- /ruby/Gemfile: -------------------------------------------------------------------------------- 1 | # frozen_string_literal: true 2 | 3 | source "https://rubygems.org" 4 | 5 | # Specify your gem's dependencies in lingy.gemspec 6 | gemspec 7 | 8 | gem "rake", "~> 13.0" 9 | -------------------------------------------------------------------------------- /perl/test/52-class.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | use lib './test/lib'; 4 | 5 | test "(class? lingy.lang.Number)", 6 | 'true'; 7 | 8 | test "(class? lingy.core)", 9 | "false"; 10 | -------------------------------------------------------------------------------- /perl/test/mal/incB.mal: -------------------------------------------------------------------------------- 1 | ;; A comment in a file 2 | (def inc4 (fn* [a] (+ 4 a))) 3 | (def inc5 (fn* [a] ;; a comment after code 4 | (+ 5 a))) 5 | 6 | ;; ending comment without final new line 7 | -------------------------------------------------------------------------------- /ruby/lib/yamlscript.rb: -------------------------------------------------------------------------------- 1 | # frozen_string_literal: true 2 | 3 | require_relative "lingy/version" 4 | 5 | module lingy 6 | class Error < StandardError; end 7 | # Your code goes here... 8 | end 9 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Atom.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Atom; 3 | 4 | use base 'Lingy::ScalarClass'; 5 | 6 | sub new { 7 | bless [$_[1] // die], $_[0]; 8 | } 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Term.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Term; 3 | 4 | use Lingy::Common; 5 | 6 | sub clear { 7 | print "\x1b[2J\x1b[H"; 8 | nil; 9 | } 10 | 11 | 1; 12 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Nil.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Nil; 3 | 4 | use Lingy::Common; 5 | use base 'Lingy::ScalarClass'; 6 | 7 | sub _to_seq { 8 | nil; 9 | } 10 | 11 | 1; 12 | -------------------------------------------------------------------------------- /raku/lib/Lingy.rakumod: -------------------------------------------------------------------------------- 1 | unit module YAMLScript; 2 | 3 | class YAMLScript { 4 | has Str $.data; 5 | 6 | method run() { 7 | say "YAMLScript coming to Raku soon"; 8 | } 9 | } 10 | 11 | -------------------------------------------------------------------------------- /perl/test/15-character.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - \A 5 | - \A 6 | 7 | - - (char 65) 8 | - \A 9 | 10 | - - \space 11 | - \space 12 | 13 | - - (char 32) 14 | - \space 15 | ... 16 | -------------------------------------------------------------------------------- /perl/test/10-misc.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - (declare x) 5 | - user/x 6 | 7 | - - (declare a b c) 8 | - user/c 9 | 10 | - - (ns-map *ns*) 11 | - /HashMap lingy.lang.HashMap/ 12 | ... 13 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Thread.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Thread; 3 | 4 | use base 'Lingy::Class'; 5 | 6 | use Lingy::Common; 7 | 8 | use Time::HiRes qw(usleep); 9 | 10 | sub sleep { 11 | usleep $_[1] * 1000; 12 | nil; 13 | } 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /perl/lib/Lingy/ListClass.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::ListClass; 3 | 4 | use base 'Lingy::Class'; 5 | 6 | sub new { 7 | my ($class, $list) = @_; 8 | bless $list, $class; 9 | } 10 | 11 | sub clone { ref($_[0])->new([@{$_[0]}]) } 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /perl/lib/Lingy/System.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::System; 3 | 4 | use Lingy::Common; 5 | 6 | use Time::HiRes qw(gettimeofday); 7 | 8 | sub nanoTime { 9 | my ($s, $m) = gettimeofday; 10 | NUMBER->new(1000 * (1000000 * $s + $m)); 11 | } 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /perl/lib/Lingy/List.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::List; 3 | 4 | use Lingy::Common; 5 | use Lingy::Sequential; 6 | use base 'Lingy::ListClass', 'Lingy::Sequential'; 7 | 8 | sub _to_seq { 9 | my ($list) = @_; 10 | @$list ? $list : nil; 11 | } 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /js/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "lingy", 3 | "version": "0.0.1", 4 | "description": "A Clojure for JavaScript", 5 | "main": "lib/lingy/index.js", 6 | "scripts": { 7 | "test": "echo \"Error: no test specified\" && exit 1" 8 | }, 9 | "author": "Ingy döt Net", 10 | "license": "MIT" 11 | } 12 | -------------------------------------------------------------------------------- /rust/Cargo.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "lingy" 3 | version = "0.0.1" 4 | edition = "2021" 5 | description = "A Clojure for Rust" 6 | license = "MIT" 7 | readme = "ReadMe.md" 8 | 9 | # See more keys and their definitions at https://doc.rust-lang.org/cargo/reference/manifest.html 10 | 11 | [dependencies] 12 | -------------------------------------------------------------------------------- /js/lib/lingy/index.js: -------------------------------------------------------------------------------- 1 | // Generated by CoffeeScript 2.6.1 2 | (function() { 3 | var lingy; 4 | 5 | require('yaml'); 6 | 7 | lingy = (function() { 8 | class lingy {}; 9 | 10 | lingy.prototype.version = '0.0.1'; 11 | 12 | return lingy; 13 | 14 | }).call(this); 15 | 16 | }).call(this); 17 | -------------------------------------------------------------------------------- /perl/test/38-new.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<"..."; 4 | - - (macroexpand '(Foo.Bar. 123)) 5 | - (. Foo.Bar new 123) 6 | # XXX Should be: 7 | # - (. Foo.Bar new 123) 8 | 9 | # TODO 10 | # - - (require Foo.Space) 11 | # - Foo.Class 12 | # - - (XXX (.new Foo.Class 42 43 44 45)) 13 | # - xxx 14 | ... 15 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Macro.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Macro; 3 | 4 | use base 'Lingy::Class'; 5 | 6 | use Lingy::Common; 7 | 8 | sub new { 9 | my ($class, $function) = @_; 10 | XXX $function unless ref($function) eq FUNCTION; 11 | bless sub { goto &$function }, $class; 12 | } 13 | 14 | 1; 15 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Keyword.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Keyword; 3 | 4 | use base 'Lingy::ScalarClass'; 5 | 6 | use overload cmp => \&comp_pair; 7 | 8 | sub new { 9 | my ($class, $scalar) = @_; 10 | $scalar =~ s/^://; 11 | $scalar = ":$scalar"; 12 | bless \$scalar, $class; 13 | } 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Symbol.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Symbol; 3 | 4 | use Lingy::Common; 5 | use Lingy::Evaluator; 6 | use base 'Lingy::ScalarClass'; 7 | 8 | use overload cmp => \&comp_pair; 9 | 10 | sub intern { 11 | $Lingy::Evaluator::ENV->set($_[0], nil); 12 | symbol($_[0]); 13 | } 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /lua/lingy-0.1.0-0.rockspec: -------------------------------------------------------------------------------- 1 | package = "lingy" 2 | version = "0.1.0-0" 3 | source = { 4 | url = "https://github.com/ingydotnet/lingy/tree/main/lua/" 5 | } 6 | description = { 7 | homepage = "https://github.com/ingydotnet/lingy/", 8 | license = "MIT" 9 | } 10 | build = { 11 | type = "builtin", 12 | modules = {} 13 | } 14 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Exception.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Exception; 3 | 4 | use overload '""' => sub { 5 | $_[0]->{msg}; 6 | }; 7 | 8 | sub new { 9 | my ($class, $msg, $data) = @_; 10 | my $self = bless { msg => $msg }, $class; 11 | $self->{data} = $data if $data; 12 | return $self; 13 | } 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /perl/lib/Lingy/StringBuilder.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::StringBuilder; 3 | 4 | use Lingy::Common; 5 | use base 'Lingy::String'; 6 | 7 | sub append { 8 | my ($self, $str) = @_; 9 | STRING->new("$self$str"); 10 | } 11 | 12 | sub reverse { 13 | STRING->new(join '', reverse split '', "$_[0]"); 14 | } 15 | 16 | 1; 17 | -------------------------------------------------------------------------------- /perl/test/81-lingy-testing-tap.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env lingy 2 | 3 | (ns testing 4 | (:use 5 | lingy.devel 6 | lingy.testing.tap)) 7 | 8 | (note "Testing with lingy.test") 9 | 10 | (is (str "f" "oo") "foo" "(is ...) ; works") 11 | (ok "foo" "(ok ...) ; works") 12 | (pass "(pass ...) ; works") 13 | 14 | (done-testing) 15 | 16 | ; vim: ft=clojure: 17 | -------------------------------------------------------------------------------- /raku/META6.json: -------------------------------------------------------------------------------- 1 | { "api": 0 2 | , "name": "Lingy" 3 | , "version": "0.1.0" 4 | , "description": "A Clojure Platform for Raku" 5 | , "auth": "zef:ingy" 6 | , "provides": 7 | { "Lingy": "lib/Lingy.rakumod" 8 | } 9 | , "depends": [] 10 | , "build-depends": [] 11 | , "test-depends": [] 12 | , "tags": 13 | [ "clojure" 14 | , "language" 15 | ] 16 | } 17 | -------------------------------------------------------------------------------- /perl/test/65-devel.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | use lib './test/lib'; 4 | 5 | tests <<'...'; 6 | - [ (use 'lingy.devel), nil ] 7 | 8 | - note: XXX Regression 9 | # - [ (resolve 'WWW), "#'lingy.devel/WWW" ] 10 | 11 | - - (WWW (x-class-names)) 12 | - /- Lingy::Atom/ 13 | - - (WWW (x-core-ns)) 14 | - >- 15 | /cons: .*!perl/code '\{ "DUMMY" }'/ 16 | ... 17 | -------------------------------------------------------------------------------- /perl/lib/Lingy/ScalarClass.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::ScalarClass; 3 | 4 | use base 'Lingy::Class'; 5 | 6 | use overload '""' => sub { ${$_[0]} }; 7 | use overload cmp => sub { "$_[0]" cmp "$_[1]" }; 8 | 9 | sub new { 10 | my ($class, $scalar) = @_; 11 | bless \$scalar, $class; 12 | } 13 | 14 | sub unbox { 15 | ${$_[0]} 16 | } 17 | 18 | 1; 19 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Boolean.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Boolean; 3 | 4 | use Lingy::Common; 5 | use base 'Lingy::ScalarClass'; 6 | 7 | sub new { 8 | my ($class, $scalar) = @_; 9 | my $type = ref($scalar); 10 | (not $type) ? $scalar ? true : false : 11 | $type eq NIL ? false : 12 | $type eq BOOLEAN ? $scalar : 13 | true; 14 | } 15 | 16 | 1; 17 | -------------------------------------------------------------------------------- /perl/test/00-use-ok.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | use File::Find; 4 | 5 | my @modules; 6 | File::Find::find sub { 7 | if ($File::Find::name =~ /\.pm$/) { 8 | my $module = $File::Find::name; 9 | $module =~ s{^lib/(.*)\.pm$}{$1}; 10 | $module =~ s{/}{::}g; 11 | push @modules, $module; 12 | } 13 | }, 'lib'; 14 | 15 | use_ok $_ for sort @modules; 16 | -------------------------------------------------------------------------------- /perl/test/18-lambda.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - (#(%2 %1 %3)) 5 | - Wrong number of args (0) passed to function 6 | 7 | - - (#(%2 %1 %3) 6 * 7) 8 | - 42 9 | 10 | - - (read-string "#(%2 %1 %1)") 11 | - (fn* [p1_12 p2_11] (p2_11 p1_12 p1_12)) 12 | 13 | - - (read-string "#(+ %5 %2)") 14 | - (fn* [p1_13 p2_12 p3_14 p4_15 p5_11] (+ p5_11 p2_12)) 15 | ... 16 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Vector.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Vector; 3 | 4 | use Lingy::Common; 5 | use Lingy::Sequential; 6 | use base 'Lingy::ListClass', 'Lingy::Sequential'; 7 | 8 | use overload cmp => \&comp_pair; 9 | 10 | sub _to_seq { 11 | my ($list) = @_; 12 | @$list ? list([@$list]) : nil; 13 | } 14 | 15 | sub unbox { [ map $_->unbox($_), @{$_[0]} ] } 16 | 17 | 1; 18 | -------------------------------------------------------------------------------- /perl/test/40-string.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...' 4 | - rep: "(use 'lingy.string)" 5 | 6 | - - (ends-with? "foo" "o") 7 | - 'true' 8 | - - (ends-with? "foo" "foo") 9 | - 'true' 10 | - - (ends-with? "foo" "f") 11 | - 'false' 12 | 13 | - - (join ["f" "oo"]) 14 | - '"foo"' 15 | - - (join "-" ["f" "oo"]) 16 | - '"f-oo"' 17 | 18 | - - (reverse "42") 19 | - '"24"' 20 | ... 21 | -------------------------------------------------------------------------------- /js/Makefile: -------------------------------------------------------------------------------- 1 | SHELL := bash 2 | 3 | COFFEE := $(shell find src -type f -name '*.coffee') 4 | JS := $(COFFEE:%.coffee=%.js) 5 | JS := $(JS:src/%=lib/%) 6 | 7 | default: 8 | @printf '%s\n' $(JS) 9 | 10 | build: $(JS) 11 | 12 | lib/%.js: src/%.coffee 13 | @mkdir -p $(dir $@) 14 | coffee -c -p $< > $@ 15 | 16 | publish: build 17 | npm $@ 18 | 19 | clean: 20 | rm -f package* 21 | rm -fr node_modules 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | SHELL := bash 2 | 3 | LANG := \ 4 | perl \ 5 | 6 | BUILD := $(LANG:%=build-%) 7 | TEST := $(LANG:%=test-%) 8 | PUBLISH := $(LANG:%=publish-%) 9 | CLEAN := $(LANG:%=clean-%) 10 | 11 | default: 12 | 13 | build: $(BUILD) 14 | build-%: % 15 | $(MAKE) -C $< build 16 | 17 | test: $(TEST) 18 | test-%: % 19 | $(MAKE) -C $< test 20 | 21 | clean: $(CLEAN) 22 | clean-%: % 23 | $(MAKE) -C $< clean 24 | -------------------------------------------------------------------------------- /perl/test/11-symbol.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | rep '(def aaa 123)'; 4 | 5 | tests <<'...'; 6 | - - "'foo.bar/baz" 7 | - foo.bar/baz 8 | 9 | - - aaa 10 | - 123 11 | - - user/aaa 12 | - 123 13 | 14 | - - not 15 | - '#' 16 | 17 | - - user/abc 18 | - "Unable to resolve symbol: 'user/abc' in this context" 19 | 20 | - - (def foo/bar 42) 21 | - "Can't def a qualified symbol: 'foo/bar'" 22 | ... 23 | 24 | -------------------------------------------------------------------------------- /perl/test/lib/Foo/Class.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Foo::Class; 3 | 4 | use XXX; 5 | 6 | # 'new' makes this a class 7 | sub new { 8 | my $class = shift; 9 | bless {@_}, $class; 10 | } 11 | 12 | use constant foo => 42; 13 | 14 | sub bar { 15 | $_[0]->{bar} = $_[1] if @_ > 1; 16 | return $_[0]->{bar}; 17 | } 18 | 19 | sub add { 20 | my ($self, $x, $y) = @_; 21 | $x + $y; 22 | } 23 | 24 | 1; 25 | -------------------------------------------------------------------------------- /ruby/bin/console: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ruby 2 | # frozen_string_literal: true 3 | 4 | require "bundler/setup" 5 | require "lingy" 6 | 7 | # You can add fixtures and/or initialization code here to make experimenting 8 | # with your gem easier. You can also use a different console, if you like. 9 | 10 | # (If you use this, don't forget to add pry to your Gemfile!) 11 | # require "pry" 12 | # Pry.start 13 | 14 | require "irb" 15 | IRB.start(__FILE__) 16 | -------------------------------------------------------------------------------- /perl/test/35-arity.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - rep: | 5 | (def add1 (fn 6 | [a b] (+ a b))) 7 | 8 | - [ '(add1 2 2)', 4, "Simple 'add' fn" ] 9 | 10 | - rep: | 11 | (def add2 (fn 12 | ([] 0) 13 | ([a] a) 14 | ([a b] (+ a b)) 15 | ([a b & c] (apply add2 (+ a b) c)))) 16 | 17 | - [ '(add2)', 0 ] 18 | - [ '(add2 5)', 5 ] 19 | - [ '(add2 4 5)', 9 ] 20 | - [ '(add2 4 5 6)', 15 ] 21 | - [ '(add2 1 2 3 4 5 6 7 8 9)', 45 ] 22 | ... 23 | -------------------------------------------------------------------------------- /perl/test/71-errors.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - (fn ()) 5 | - fn signature not a vector 6 | - - (fn ([& a]) ([& b])) 7 | - Can't have more than 1 variadic overload 8 | - - (fn ([x]) ([y])) 9 | - Can't have 2 overloads with same arity 10 | - - (fn ([& x]) ([y z])) 11 | - Can't have fixed arity function with more params than variadic function 12 | - - '"a\bc"' 13 | - >- 14 | Unsupported escape character '\b' 15 | - - '"a\ c"' 16 | - >- 17 | Unsupported escape character '\ ' 18 | ... 19 | -------------------------------------------------------------------------------- /perl/test/12-use.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - (foo) 5 | - "Unable to resolve symbol: 'foo' in this context" 6 | 7 | - - (use 'test.lingy) 8 | - nil 9 | 10 | - - (foo) 11 | - '"called test.lingy/foo"' 12 | 13 | - note: XXX Regression 14 | # - - (test.lingy/foo) 15 | # - '"called test.lingy/foo"' 16 | 17 | - - (user/foo) 18 | - '"called test.lingy/foo"' 19 | 20 | - note: XXX Regression 21 | # - - (resolve 'bar) 22 | # - "#'test.lingy/bar" 23 | 24 | - - (use 'lingy.devel) 25 | - nil 26 | ... 27 | -------------------------------------------------------------------------------- /perl/test/36-macroexpand.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - (macroexpand '(defn a ([a b] (+ a b)))) 5 | - (def a (fn* ([a b] (+ a b)))) 6 | 7 | - - (macroexpand '(fn ([a b] (+ a b)))) 8 | - (fn* ([a b] (+ a b))) 9 | 10 | - - (macroexpand '(cond 1 2 3 4 5 6)) 11 | - (if 1 2 (cond 3 4 5 6)) 12 | 13 | - - (macroexpand '(-> 123 prn)) 14 | - (prn 123) 15 | 16 | - - (macroexpand '(-> 42 (/ 6) (* 3) prn)) 17 | - (prn (* (/ 42 6) 3)) 18 | 19 | - - (macroexpand '(->> 42 (/ 6) (* 3) prn)) 20 | - (prn (* 3 (/ 6 42))) 21 | ... 22 | -------------------------------------------------------------------------------- /perl/test/54-import.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | use lib './test/lib'; 4 | 5 | tests <<'...'; 6 | - - (import Scalar.Util) 7 | - nil 8 | - - (import YAML.PP) 9 | - YAML.PP 10 | 11 | - - Foo.Class 12 | - "Class not found: 'Foo.Class'" 13 | - - (import Foo.Class) 14 | - Foo.Class 15 | - - Foo.Class 16 | - Foo.Class 17 | - - (type Foo.Class) 18 | - lingy.lang.Class 19 | - - (. Foo.Class foo) 20 | - 42 21 | - - (find-ns 'Foo.Class) 22 | - nil 23 | - Foo.Class is not a namespace 24 | - - (class? Foo.Class) 25 | - 'true' 26 | ... 27 | -------------------------------------------------------------------------------- /eg/99-bottles.ly: -------------------------------------------------------------------------------- 1 | (defn main [number] 2 | (let [ 3 | paragraphs (map paragraph (range number 0 -1)) ] 4 | (map println paragraphs))) 5 | 6 | (defn paragraph [num] 7 | (str 8 | (bottles num) " of beer on the wall,\n" 9 | (bottles num) " of beer.\n" 10 | "Take one down, pass it around.\n" 11 | (bottles (dec num)) " of beer on the wall.\n")) 12 | 13 | (defn bottles [n] 14 | (cond 15 | (= n 0) "No more bottles" 16 | (= n 1) "1 bottle" 17 | :else (str n " bottles"))) 18 | 19 | (main (nth *command-line-args* 0 99)) 20 | -------------------------------------------------------------------------------- /perl/test/14-vector.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - (def v1 [:foo 123]) 5 | - user/v1 6 | - - v1 7 | - '[:foo 123]' 8 | - - (v1 0) 9 | - :foo 10 | - - (v1 1) 11 | - 123 12 | 13 | - - (v1) 14 | - "Wrong number of args (0) passed to: 'lingy.lang.Vector'" 15 | - - (v1 0 1) 16 | - "Wrong number of args (2) passed to: 'lingy.lang.Vector'" 17 | 18 | - - ((vector 3 6 9) (- 5 4)) 19 | - 6 20 | 21 | - - (let [x ([42] 0)] x) 22 | - 42 23 | 24 | - rep: (defn f1 [v] (let [x (v 0)] x)) 25 | - - (f1 [3 4]) 26 | - 3 27 | ... 28 | -------------------------------------------------------------------------------- /raku/t/00-use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env raku 2 | 3 | use Test; 4 | sub from-j($t) { ::("Rakudo::Internals::JSON").from-json($t); } 5 | 6 | 7 | my @xs = 'lib'.IO; 8 | my %fs; 9 | while @xs { 10 | for @xs.pop.dir -> $f { 11 | %fs{$f} = 1 if $f.extension eq 'rakumod'; 12 | @xs.push($f) if $f.d; 13 | } 14 | } 15 | 16 | plan 1 +%fs.keys; 17 | 18 | my %meta = from-j('META6.json'.IO.slurp); 19 | for %meta.keys -> $dn { 20 | %fs{%meta{$dn}.IO.relative}--; 21 | use-ok $dn; 22 | } 23 | 24 | ok +%fs.grep(*.value != 0) == 0, 'provides 1:1 files in lib'; 25 | -------------------------------------------------------------------------------- /perl/test/mal/computations.mal: -------------------------------------------------------------------------------- 1 | ;; Some inefficient arithmetic computations for benchmarking. 2 | 3 | ;; Unfortunately not yet available in tests of steps 4 and 5. 4 | 5 | ;; Compute n(n+1)/2 with a non tail-recursive call. 6 | (def sumdown 7 | (fn* [n] ; non-negative number 8 | (if (= n 0) 9 | 0 10 | (+ n (sumdown (- n 1)))))) 11 | 12 | ;; Compute a Fibonacci number with two recursions. 13 | (def fib 14 | (fn* [n] ; non-negative number 15 | (if (<= n 1) 16 | n 17 | (+ (fib (- n 1)) (fib (- n 2)))))) 18 | -------------------------------------------------------------------------------- /perl/test/mal/step5_tco.yaml: -------------------------------------------------------------------------------- 1 | - say: Testing recursive tail-call function 2 | mal: (def sum2 (fn* [n acc] (if (= n 0) acc (sum2 (- n 1) (+ n acc))))) 3 | 4 | # TODO: test let*, and do for TCO 5 | 6 | - mal: (sum2 10 0) 7 | out: 55 8 | 9 | - mal: (def res2 nil) 10 | out: user/res2 11 | 12 | - mal: 13 | - (def res2 (sum2 10000 0)) 14 | - res2 15 | out: 50005000 16 | 17 | - say: Test mutually recursive tail-call functions 18 | mal: 19 | - (def foo (fn* [n] (if (= n 0) 0 (bar (- n 1))))) 20 | - (def bar (fn* [n] (if (= n 0) 0 (foo (- n 1))))) 21 | - (foo 10000) 22 | out: 0 23 | -------------------------------------------------------------------------------- /perl/test/33-dynamic.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | use Lingy; 3 | 4 | tests <<"..."; 5 | - - '*lingy-version*' 6 | - '{:major 0, :minor 1, :incremental 19, :qualifier nil}' 7 | - - '*clojure-version*' 8 | - '{:major 1, :minor 11, :incremental 1, :qualifier nil}' 9 | 10 | - - (lingy-version) 11 | - '"$Lingy::VERSION"' 12 | - - (clojure-version) 13 | - '"1.11.1"' 14 | 15 | - - '*HOST*' 16 | - '"perl"' 17 | 18 | - - '*file*' 19 | - '"NO_SOURCE_PATH"' 20 | 21 | - - '*command-line-args*' 22 | - nil 23 | 24 | - - '*command-line-args*' 25 | - nil 26 | 27 | - - '*ns*' 28 | - '#' 29 | ... 30 | -------------------------------------------------------------------------------- /perl/lib/Lingy/testing/tap.ly: -------------------------------------------------------------------------------- 1 | (ns lingy.testing.tap) 2 | 3 | (def counter 0) 4 | 5 | (defn pass [label] 6 | (def counter (inc counter)) 7 | (println (str "ok " counter " - " label))) 8 | 9 | (defn fail [label] 10 | (def counter (inc counter)) 11 | (println (str "not ok " counter " - " label))) 12 | 13 | (defn is [got want label] 14 | (if (= got want) 15 | (pass label) 16 | (fail label))) 17 | 18 | (defn ok [got label] 19 | (if got 20 | (pass label) 21 | (fail label))) 22 | 23 | (defn note [string] (println (str "# " string))) 24 | 25 | (defn done-testing [] (println (str "1.." counter))) 26 | 27 | ; vim: ft=clojure: 28 | -------------------------------------------------------------------------------- /perl/test/23-reader-cond.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - '#?[:clj "clojure" :lingy.pl "perl"]' 5 | - read-cond body must be a list 6 | 7 | - - '#?(:clj "clojure" :lingy.pl "perl" xxxxx)' 8 | - read-cond requires an even number of forms 9 | 10 | - - '#?(foo "bar" :clj "clojure" :lingy.pl "perl")' 11 | - 'Feature should be a keyword: foo' 12 | 13 | - - '#?(:clj "clojure" :lingy.pl "perl")' 14 | - '"perl"' 15 | 16 | - - '#?(:clj "clojure" :pl "perl")' 17 | - '' 18 | 19 | - - '#?(:default "clojure" :lingy.pl "perl")' 20 | - '"clojure"' 21 | 22 | - - | 23 | #?(:default 24 | (+ 1 2) 25 | ) 26 | - 3 27 | ... 28 | -------------------------------------------------------------------------------- /perl/test/22-ignore.t: -------------------------------------------------------------------------------- 1 | 2 | use Lingy::Test; 3 | 4 | tests <<'...'; 5 | - - '#_(foo bar 5)' 6 | - '' 7 | - - '(list 1 2 #_(foo bar 5) 3)' 8 | - '(1 2 3)' 9 | - - '(list 1 #_ #_ #_ 2 3 4 5 6 #_ 7 8 9)' 10 | - '(1 5 6 8 9)' 11 | - - '(+ 2 #_[x y z] 3 #_#_ {:a 1 :a 2} {5} 2)' 12 | - 7 13 | - - '(list 1 #_"x\qb" 2)' 14 | - (1 2) 15 | - - '#_"a\qb" "a\qb"' 16 | - Unsupported escape character '\q' 17 | - - '#_#_"a\qb" {:a 1 :a 2} {:b}' 18 | - Map literal must contain an even number of forms 19 | - - '#_#{a a} #{b b}' 20 | - "Duplicate key: 'b'" 21 | - - '#_[1 2 3]]' 22 | - "Unmatched delimiter: ']'" 23 | - - (comment (throw 123)) 24 | - nil 25 | ... 26 | -------------------------------------------------------------------------------- /perl/test/17-seq.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - (seq { :zero 0 "foo" 1 'bar 2 42 3 }) 5 | - ([:zero 0] ["foo" 1] [bar 2] [42 3]) 6 | 7 | - - (seq "foo") 8 | - (\f \o \o) 9 | 10 | - - (seq '(1 2 3)) 11 | - (1 2 3) 12 | 13 | - - (seq '[4 5 6]) 14 | - (4 5 6) 15 | 16 | - - (seq {}) 17 | - nil 18 | - - (seq "") 19 | - nil 20 | - - (seq '()) 21 | - nil 22 | - - (seq '[]) 23 | - nil 24 | - - (seq nil) 25 | - nil 26 | 27 | - - (seq 42) 28 | - "Don't know how to create ISeq from: lingy.lang.Number" 29 | - - (seq 'x) 30 | - "Don't know how to create ISeq from: lingy.lang.Symbol" 31 | - - (seq :x) 32 | - "Don't know how to create ISeq from: lingy.lang.Keyword" 33 | ... 34 | -------------------------------------------------------------------------------- /perl/test/19-hash-set.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - '(def s1 #{:foo :bar})' 5 | - user/s1 6 | - - s1 7 | - '#{:foo :bar}' 8 | - - (:foo s1) 9 | - :foo 10 | 11 | - - (:baz s1) 12 | - nil 13 | - - '(:foo #{})' 14 | - nil 15 | 16 | - - (:baz s1 42) 17 | - 42 18 | - - '(:foo #{} 42)' 19 | - 42 20 | 21 | - - '(:foo #{} 111 222)' 22 | - "Wrong number of args (3) passed to: ':foo'" 23 | 24 | - - '#{:foo :bar :foo}' 25 | - "Duplicate key: ':foo'" 26 | 27 | - - '(hash-set :foo :bar :foo)' 28 | - '#{:bar :foo}' 29 | 30 | - - '#{ :zero "foo" ''bar 42}' 31 | - '#{:zero "foo" bar 42}' 32 | 33 | - - '(seq #{ :zero "foo" 42 ''bar })' 34 | - (:zero "foo" 42 bar) 35 | ... 36 | -------------------------------------------------------------------------------- /perl/test/55-require.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | use lib './test/lib'; 4 | 5 | tests <<'...'; 6 | - [ (ns-name *ns*), user ] 7 | 8 | - [ (require 'test.lingy), nil ] 9 | - [ (test.lingy/foo), '"called test.lingy/foo"' ] 10 | 11 | - [ (ns-name *ns*), user ] 12 | 13 | - - (foo) 14 | - "Unable to resolve symbol: 'foo' in this context" 15 | - [ (refer 'test.lingy), nil ] 16 | - [ (foo), '"called test.lingy/foo"' ] 17 | 18 | - [ (require 'x.y.z), "Can't find library for (require 'x.y.z)" ] 19 | - [ (refer 'x.y.z), "No namespace: 'x.y.z'" ] 20 | 21 | - [ (require 'Foo.Bar), nil ] 22 | - [ (find-ns 'Foo.Bar), '#' ] 23 | - [ (Foo.Bar/bar), 43 ] 24 | - [ (. Foo.BarClass foo), 43 ] 25 | - [ (Foo.BarClass/foo), 43 ] 26 | ... 27 | -------------------------------------------------------------------------------- /perl/test/31-math-ops.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - [ '5 (+ 3 3) 7', "5\n6\n7", "Multiple expressions on one line works" ] 5 | 6 | - [ '(+)', 0 ] 7 | - [ '(+ 2)', 2 ] 8 | - [ '(+ 2 3)', 5 ] 9 | - [ '(+ 2 3 4)', 9 ] 10 | - [ '(+ 2 3 4 5)', 14 ] 11 | - [ '(+ 2 3 4 5 6)', 20 ] 12 | 13 | - [ '(-)', "Wrong number of args (0) passed to function" ] 14 | - [ '(- 2)', -2 ] 15 | - [ '(- 2 3)', -1 ] 16 | - [ '(- 2 3 4)', -5 ] 17 | - [ '(- 2 3 4 5)', -10 ] 18 | 19 | - [ '(*)', 1 ] 20 | - [ '(* 2)', 2 ] 21 | - [ '(* 2 3)', 6 ] 22 | - [ '(* 2 3 4)', 24 ] 23 | - [ '(* 2 3 4 5)', 120 ] 24 | 25 | - [ '(/)', "Wrong number of args (0) passed to function" ] 26 | - [ '(/ 2)', 0.5 ] 27 | - [ '(/ 360 2)', 180 ] 28 | - [ '(/ 360 2 3)', 60 ] 29 | - [ '(/ 360 2 3 4)', 15 ] 30 | - [ '(/ 360 2 3 4 5)', 3 ] 31 | ... 32 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Regex.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Regex; 3 | 4 | use Lingy::Common; 5 | 6 | # need these things: 7 | # * if-some 8 | # * "sequence destructuring bindings" 9 | 10 | sub new { 11 | my ($class, $scalar) = @_; 12 | bless qr/$scalar/, $class; 13 | } 14 | 15 | sub find { 16 | return nil unless $_[1] =~ $_[0]; 17 | return string($&) unless defined $1; 18 | my ($i, @capture) = (1, string($&)); 19 | { 20 | no strict 'refs'; 21 | while (defined (my $value = ${"$i"})) { 22 | push @capture, string($value); 23 | $i++; 24 | } 25 | } 26 | VECTOR->new([@capture]); 27 | } 28 | 29 | sub matches { 30 | find REGEX->new("\\A$_[0]\\z"), $_[1]; 31 | } 32 | 33 | sub pattern { 34 | __PACKAGE__->new(@_); 35 | } 36 | 37 | 1; 38 | -------------------------------------------------------------------------------- /perl/test/34-loop.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | test_out " 4 | (loop [i 1024] 5 | (when (pos? i) 6 | (prn i) 7 | (recur (quot i 2))))", <<''; 8 | 1024 9 | 512 10 | 256 11 | 128 12 | 64 13 | 32 14 | 16 15 | 8 16 | 4 17 | 2 18 | 1 19 | 20 | test_out " 21 | (loop [i 3, j 42] 22 | (when (pos? i) 23 | (println i j) 24 | (recur (dec i) 5)))", <<''; 25 | 3 42 26 | 2 5 27 | 1 5 28 | 29 | test_out " 30 | (loop [i 3] 31 | (when (pos? i) 32 | (prn i) 33 | (recur (dec i))))", <<''; 34 | 3 35 | 2 36 | 1 37 | 38 | test_out " 39 | (loop [i 3] 40 | (when (pos? i) 41 | (let [j (dec i)] 42 | (prn i) 43 | (recur j))))", <<''; 44 | 3 45 | 2 46 | 1 47 | 48 | test " 49 | (loop [i 3 l ()] 50 | (if (pos? i) 51 | (recur (dec i) (cons i l)) 52 | l))", 53 | "(1 2 3)"; 54 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Clojure.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Clojure; 3 | 4 | use Lingy::Common; 5 | use Lingy::RT; 6 | 7 | sub require { 8 | my ($sym) = @_; 9 | $$sym =~ s/^clojure\./lingy./; 10 | local $Lingy::RT::require_ext = 'clj'; 11 | no warnings 'redefine'; 12 | local *Lingy::RT::rep = \&rep; 13 | Lingy::RT::require($sym); 14 | } 15 | 16 | sub rep { 17 | my (undef, $text) = @_; 18 | my ($expr) = RT->reader->read_str($text); 19 | my ($undef, $file) = @$expr; 20 | my $content = Lingy::RT::slurp("$file"); 21 | my (@forms) = RT->reader->read_str($content); 22 | return; 23 | for my $form (@forms) { 24 | eval { 25 | print "$form->[0] $form->[1]\n"; 26 | }; 27 | print "$form\n" if $@; 28 | #eval { evaluate($form) } 29 | } 30 | } 31 | 32 | 1; 33 | -------------------------------------------------------------------------------- /perl/test/53-dot.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | # TODO All classes in java.lang are automatically imported to every namespace. 4 | 5 | tests <<'...'; 6 | - [ (. "foo" (toUpperCase)), '"FOO"' ] 7 | - [ (. "foo" toUpperCase), '"FOO"' ] 8 | - [ (.toUpperCase "foo"), '"FOO"' ] 9 | 10 | - rep: (def var1 "foo") 11 | - [ (. var1 toUpperCase), '"FOO"' ] 12 | 13 | - [ (. (str "foo" "bar") toUpperCase), '"FOOBAR"' ] 14 | - [ (. (str "foo" "bar") (toUpperCase)), '"FOOBAR"' ] 15 | - [ (.toUpperCase (str "foo" "bar")), '"FOOBAR"' ] 16 | 17 | - [ (. "foo" replaceAll "" "-"), '"-f-o-o-"' ] 18 | - [ (. "foo" (replaceAll "" "-")), '"-f-o-o-"' ] 19 | - [ (.replaceAll "foo" "" "-"), '"-f-o-o-"' ] 20 | - [ (.replaceAll "foo" "o" "-"), '"f--"' ] 21 | 22 | - [ (. lingy.lang.Numbers (remainder 8 3)), 2 ] 23 | 24 | - rep: (def x 8) (def y 3) 25 | - [ (. lingy.lang.Numbers (remainder x y)), 2 ] 26 | ... 27 | -------------------------------------------------------------------------------- /perl/test/37-special.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<"..."; 4 | - - (special-symbol? 'xyz) 5 | - 'false' 6 | - - (special-symbol? 'def) 7 | - 'true' 8 | - - (special-symbol? 'loop*) 9 | - 'true' 10 | - - (resolve 'loop*) # XXX 11 | - nil 12 | - - (special-symbol? 'recur) 13 | - 'true' 14 | - - (special-symbol? 'if) 15 | - 'true' 16 | - - (special-symbol? 'let*) 17 | - 'true' 18 | - - (special-symbol? 'do) 19 | - 'true' 20 | - - (special-symbol? 'fn*) 21 | - 'true' 22 | - - (special-symbol? 'quote) 23 | - 'true' 24 | - - (special-symbol? 'var) 25 | - 'true' 26 | - - (special-symbol? 'import*) 27 | - 'true' 28 | - - (special-symbol? '.) 29 | - 'true' 30 | - - (special-symbol? 'try) 31 | - 'true' 32 | - - (special-symbol? 'throw) 33 | - 'true' 34 | - - (special-symbol? 'catch) 35 | - 'true' 36 | - - (special-symbol? 'new) 37 | - 'true' 38 | ... 39 | -------------------------------------------------------------------------------- /perl/test/13-hash-map.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - (def h1 {:foo 123}) 5 | - user/h1 6 | - - h1 7 | - '{:foo 123}' 8 | - - (:foo h1) 9 | - 123 10 | - - (:foo h1) 11 | - 123 12 | 13 | - - (:bar h1) 14 | - nil 15 | - - (:foo {}) 16 | - nil 17 | 18 | - - (:bar h1 42) 19 | - 42 20 | - - (:foo {} 42) 21 | - 42 22 | 23 | - - (:foo) 24 | - "Wrong number of args (0) passed to: ':foo'" 25 | - - (:foo {} 111 222) 26 | - "Wrong number of args (3) passed to: ':foo'" 27 | 28 | - - '{:foo 1 :bar 2 :foo 3}' 29 | - "Duplicate key: ':foo'" 30 | 31 | - - '(assoc {:foo 1 :bar 2} :foo 3)' 32 | - '{:foo 3, :bar 2}' 33 | 34 | - - '(hash-map :foo 1 :bar 2 :foo 3)' 35 | - '{:bar 2, :foo 3}' 36 | 37 | - - ((keyword "foo") (assoc {} :foo 123) (number 42)) 38 | - 123 39 | 40 | - - '{ :zero 0 "foo" 1 ''bar 2 42 3 }' 41 | - '{:zero 0, "foo" 1, bar 2, 42 3}' 42 | 43 | - - (seq { :zero 0 "foo" 1 'bar 2 42 3 }) 44 | - ([:zero 0] ["foo" 1] [bar 2] [42 3]) 45 | ... 46 | -------------------------------------------------------------------------------- /perl/test/16-regex.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - '#"fo+o"' 5 | - '#"fo+o"' 6 | 7 | - - (re-pattern "fo+o") 8 | - '#"fo+o"' 9 | 10 | - - '(re-find #"foo" "foobar")' 11 | - '"foo"' 12 | 13 | - - '(re-find #"foo" "bar")' 14 | - nil 15 | 16 | - - '(re-find #"(f)(o)(o)" "foobar")' 17 | - '["foo" "f" "o" "o"]' 18 | 19 | - - '(re-matches #"fo*bar" "foooobar")' 20 | - '"foooobar"' 21 | 22 | - - '(re-matches #"f(o*)bar" "foooobar")' 23 | - '["foooobar" "oooo"]' 24 | 25 | - - '(re-matches #"fo*bar" "foooobarbaz")' 26 | - nil 27 | 28 | - - '#"\bfoo\b"' 29 | - '#"\bfoo\b"' 30 | 31 | - - >- 32 | #"\[\]\{\}\(\)\+\*\?\^\$\|" 33 | - >- 34 | #"\[\]\{\}\(\)\+\*\?\^\$\|" 35 | 36 | - - '(re-matches #"\{{3}(\d+)\+(\}*)" "{{{123+}}}")' 37 | - '["{{{123+}}}" "123" "}}}"]' 38 | 39 | # - - > 40 | # #"\a\b\c\d\e\f\h\n\r\s\t\u0000\v\w\x00\z\`\~\!\@\#\$\%\^\&\*\(\)\-\_\=\+\{\}\[\]\|\\\:\;\"\'\<\>\,\.\?\/\000\1\2\3\4\5\6\7\8\9\A\B\G\H\Q\R\S\T\U\V\W\X\Y\Z 41 | ... 42 | -------------------------------------------------------------------------------- /perl/test/mal/step2_eval.yaml: -------------------------------------------------------------------------------- 1 | - say: Testing evaluation of arithmetic operations 2 | mal: (+ 1 2) 3 | out: 3 4 | 5 | - mal: (+ 5 (* 2 3)) 6 | out: 11 7 | 8 | - mal: (- (+ 5 (* 2 3)) 3) 9 | out: 8 10 | 11 | - mal: (/ (- (+ 5 (* 2 3)) 3) 4) 12 | out: 2 13 | 14 | - mal: (/ (- (+ 515 (* 87 311)) 302) 27) 15 | out: 1010 16 | 17 | - mal: (* -3 6) 18 | out: -18 19 | 20 | - mal: (/ (- (+ 515 (* -87 311)) 296) 27) 21 | out: -994 22 | 23 | - say: This should throw an error with no return value 24 | mal: (abc 1 2 3) 25 | err: .+ 26 | 27 | - say: Testing empty list 28 | mal: () 29 | out: () 30 | 31 | # -------- Deferrable Functionality -------- 32 | 33 | - say: Testing evaluation within collection literals 34 | mal: '[1 2 (+ 1 2)]' 35 | out: '[1 2 3]' 36 | 37 | - mal: '{"a" (+ 7 8)}' 38 | out: '{"a" 15}' 39 | 40 | - mal: '{:a (+ 7 8)}' 41 | out: '{:a 15}' 42 | 43 | - say: Check that evaluation hasn't broken empty collections 44 | mal: '[]' 45 | out: '[]' 46 | - mal: '{}' 47 | out: '{}' 48 | -------------------------------------------------------------------------------- /perl/test/04-examples.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | sub cmd { 4 | my ($cmd, $want) = @_; 5 | my ($got) = capture_merged { system $cmd }; 6 | is $got, $want, "Program works: '$cmd'"; 7 | } 8 | 9 | cmd "$lingy $eg/99-bottles.ly 3", <<'...'; 10 | 3 bottles of beer on the wall, 11 | 3 bottles of beer. 12 | Take one down, pass it around. 13 | 2 bottles of beer on the wall. 14 | 15 | 2 bottles of beer on the wall, 16 | 2 bottles of beer. 17 | Take one down, pass it around. 18 | 1 bottle of beer on the wall. 19 | 20 | 1 bottle of beer on the wall, 21 | 1 bottle of beer. 22 | Take one down, pass it around. 23 | No more bottles of beer on the wall. 24 | 25 | ... 26 | 27 | my $want = <<'...'; 28 | 1 29 | 2 30 | Fizz 31 | 4 32 | Buzz 33 | Fizz 34 | 7 35 | 8 36 | Fizz 37 | Buzz 38 | 11 39 | Fizz 40 | 13 41 | 14 42 | FizzBuzz 43 | 16 44 | ... 45 | cmd "$lingy $eg/fizzbuzz.ly 16", $want; 46 | cmd "$lingy $eg/fizzbuzz.ly 16 1", $want; 47 | cmd "$lingy $eg/fizzbuzz.ly 16 2", $want; 48 | # cmd "$lingy $eg/fizzbuzz.ly 16 3", $want; 49 | -------------------------------------------------------------------------------- /perl/test/39-instance.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<"..."; 4 | - - (instance? lingy.lang.Number 42) 5 | - 'true' 6 | - - (instance? Number 42) 7 | - 'true' 8 | - - (instance? Number true) 9 | - 'false' 10 | - - (instance? Boolean true) 11 | - 'true' 12 | - - (boolean? false) 13 | - 'true' 14 | - - (boolean? 42) 15 | - 'false' 16 | - - (boolean? "false") 17 | - 'false' 18 | 19 | - - (boolean nil) 20 | - 'false' 21 | - - (boolean false) 22 | - 'false' 23 | - - (boolean "") 24 | - 'true' 25 | - - (boolean true) 26 | - 'true' 27 | - - (boolean? (boolean false)) 28 | - 'true' 29 | 30 | - - (atom 42) 31 | - (atom 42) 32 | - - (instance? Atom (atom 42)) 33 | - 'true' 34 | - - (instance? Atom 42) 35 | - 'false' 36 | 37 | - - (class? Boolean) 38 | - 'true' 39 | - - (class? lingy.lang.String) 40 | - 'true' 41 | # TODO Need to test more class? things 42 | # - - (class? lingy.lang.Namespace) 43 | # - - (class? 'lingy.lang.Namespace) 44 | 45 | - - (false? nil) 46 | - 'false' 47 | - - (false? false) 48 | - 'true' 49 | ... 50 | -------------------------------------------------------------------------------- /perl/test/32-core.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...' 4 | 5 | - note: Testing (conj ...) 6 | - - (conj {:a 1} {:a 2 :b 3}) 7 | - '{:a 2, :b 3}' 8 | - - (conj {:a 1} {:a 2 :b 3} {:c 4}) 9 | - '{:a 2, :b 3, :c 4}' 10 | 11 | - note: Testing (merge ...) 12 | - - (merge {:a 1} {:a 2 :b 3} {:c 4}) 13 | - '{:a 2, :b 3, :c 4}' 14 | 15 | - note: Testing (list* ...) 16 | - - (list* ()) 17 | - nil 18 | - - (list* 5 ()) 19 | - (5) 20 | - - (list* 5 6 ()) 21 | - (5 6) 22 | - - (list* 5 6 '(2 3)) 23 | - (5 6 2 3) 24 | 25 | - note: Testing classes 26 | - - lingy.lang.String 27 | - lingy.lang.String 28 | - - String 29 | - lingy.lang.String 30 | 31 | - - (type 42) 32 | - lingy.lang.Number 33 | - - (type (type 42)) 34 | - lingy.lang.Class 35 | - - (type Number) 36 | - lingy.lang.Class 37 | 38 | - - (instance? String "") 39 | - 'true' 40 | - - (instance? String (str "x" "y")) 41 | - 'true' 42 | - - (instance? String 123) 43 | - 'false' 44 | 45 | - - (not= 4 (+ 2 2)) 46 | - 'false' 47 | 48 | - - (binding [x 42] x) 49 | - 42 50 | ... 51 | -------------------------------------------------------------------------------- /python/License: -------------------------------------------------------------------------------- 1 | Copyright 2023 Ingy döt Net 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 7 | of the Software, and to permit persons to whom the Software is furnished to do 8 | so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /eg/fizzbuzz.ly: -------------------------------------------------------------------------------- 1 | ; usage: lingy fizzbuzz [] [] 2 | 3 | (defn run-a-fizzbuzz-implementation [] 4 | (let [ 5 | count (number (nth *command-line-args* 0 "100")) 6 | fizzbuzz ( 7 | resolve (symbol (str "fizzbuzz-" (nth *command-line-args* 1 "1")))) 8 | result (fizzbuzz count)] 9 | (if (seq result) 10 | (map println result)))) 11 | 12 | (defn fizzbuzz-1 [n] 13 | (map 14 | (fn [x] 15 | (cond 16 | (zero? (mod x 15)) "FizzBuzz" 17 | (zero? (mod x 5)) "Buzz" 18 | (zero? (mod x 3)) "Fizz" 19 | :else x)) 20 | (range 1 (inc n)))) 21 | 22 | (defn fizzbuzz-2 [n] 23 | (loop [i 1 l []] 24 | (if (<= i n) 25 | (recur (inc i) (conj l 26 | (cond 27 | (zero? (mod i 15)) "FizzBuzz" 28 | (zero? (mod i 5)) "Buzz" 29 | (zero? (mod i 3)) "Fizz" 30 | :else i))) 31 | l))) 32 | 33 | (defn fizzbuzz-3 [n] 34 | (doseq [x (range 1 (inc n))] 35 | (println x 36 | (str 37 | (when (zero? (mod x 3)) "fizz") 38 | (when (zero? (mod x 5)) "buzz"))))) 39 | 40 | (run-a-fizzbuzz-implementation) 41 | -------------------------------------------------------------------------------- /perl/test/02-reader.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | use Lingy::Reader; 4 | use Lingy::Printer; 5 | 6 | my $reader = Lingy::Reader->new; 7 | my $printer = Lingy::Printer->new; 8 | 9 | sub tst { 10 | my ($str, $want) = @_; 11 | $want //= $str; 12 | my ($got) = $printer->pr_str($reader->read_str($str)); 13 | if (ref($want) eq 'Regexp') { 14 | like $got, $want, "'$str' -> '$want'"; 15 | } else { 16 | is $got, $want, "'$str' -> '$want'"; 17 | } 18 | } 19 | 20 | tst '( foo )', 21 | '(foo)'; 22 | tst '42'; 23 | tst ':42'; 24 | tst '"xyz"'; 25 | tst '(fn [x])'; 26 | tst '(defn f1 [x] (prn x))'; 27 | tst '[1, 2,3]', 28 | '[1 2 3]'; 29 | tst '{:foo 1, :bar 2}'; 30 | tst "'(foo#)", 31 | "(quote (foo#))"; 32 | tst '`(foo#)', 33 | qr/^\Q(quasiquote (foo__\E\d+\Q__auto__))\E$/; 34 | 35 | tst "(1) (2)", '(1)'; 36 | tst "(1) (2)", '(1)'; 37 | 38 | test "())", 39 | "Unmatched delimiter: ')'"; 40 | test "foo]", 41 | "Unmatched delimiter: ']'"; 42 | test ",}", 43 | "Unmatched delimiter: '}'"; 44 | 45 | test '111 222 #!/bin/bash 333', 46 | "111\n222", 47 | "Shebang syntax is a comment"; 48 | -------------------------------------------------------------------------------- /License: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2023 Ingy döt Net and contributors 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /perl/lib/Lingy/devel.ly: -------------------------------------------------------------------------------- 1 | (ns lingy.devel) 2 | (import lingy.lang.Util) 3 | 4 | (defn eval-perl 5 | ([perl] (. lingy.lang.Util eval_perl perl)) 6 | ([perl ret] (. lingy.lang.Util eval_perl perl) ret)) 7 | 8 | (defn x-carp-off [] 9 | (eval-perl "no Carp::Always" nil)) 10 | 11 | (defn x-carp-on [] 12 | (eval-perl "use Carp::Always" nil)) 13 | 14 | (defn x-internal [m] (. lingy.lang.Util rt_internal m)) 15 | (defn x-class-names [] (. lingy.lang.Util rt_internal "class_names")) 16 | (defn x-core-ns [] (. lingy.lang.Util rt_internal "core_ns")) 17 | (defn x-env [] (. lingy.lang.Util rt_internal "env")) 18 | (defn x-namespaces [] (. lingy.lang.Util rt_internal "namespaces")) 19 | (defn x-ns-refers [] (. lingy.lang.Util rt_internal "ns_refers")) 20 | (defn x-user-ns [] (. lingy.lang.Util rt_internal "user_ns")) 21 | 22 | (defn x-pp-env [] (. lingy.lang.Util env_data)) 23 | 24 | (defn PPP [& xs] (. lingy.lang.Util applyTo "PPP" xs)) 25 | (defn WWW [& xs] (. lingy.lang.Util applyTo "XXX" xs)) 26 | (defn XXX [& xs] (. lingy.lang.Util applyTo "WWW" xs)) 27 | (defn YYY [& xs] (. lingy.lang.Util applyTo "YYY" xs)) 28 | (defn ZZZ [& xs] (. lingy.lang.Util applyTo "ZZZ" xs)) 29 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Character.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Character; 3 | 4 | use base 'Lingy::ScalarClass'; 5 | 6 | use overload cmp => \&comp_pair; 7 | 8 | use Lingy::Common; 9 | 10 | my %name_to_char = ( 11 | backspace => "\b", 12 | tab => "\t", 13 | newline => "\n", 14 | formfeed => "\f", 15 | return => "\r", 16 | space => " ", 17 | ); 18 | 19 | my %char_to_name = ( reverse %name_to_char ); 20 | 21 | sub read { 22 | my ($class, $char) = @_; 23 | my $type = ref($char); 24 | 25 | if ($type eq '' or 26 | $type eq SYMBOL 27 | ) { 28 | $char =~ s/^\\// or die; 29 | if (length($char) > 1) { 30 | $char = $name_to_char{$char} or 31 | err "Unsupported character: '$_[1]'" 32 | } 33 | return $class->new($char); 34 | } 35 | if ($type eq NUMBER) { 36 | return $class->new(chr(0 + $char)); 37 | } 38 | } 39 | 40 | sub print { 41 | my ($char, $raw) = @_; 42 | return $char if $raw; 43 | if (my $name = $char_to_name{$char}) { 44 | return "\\$name"; 45 | } 46 | return "\\$char"; 47 | } 48 | 49 | sub _to_str { 50 | my ($char) = @_; 51 | } 52 | 53 | 1; 54 | -------------------------------------------------------------------------------- /perl/test/20-meta.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - (def v1 ^{:m 1 :n 2} [:foo 123]) 5 | - user/v1 6 | - - v1 7 | - '[:foo 123]' 8 | - - (meta v1) 9 | - '{:m 1, :n 2}' 10 | 11 | - - (def a [1 2]) 12 | - user/a 13 | - - (def b (with-meta a {:foo 123})) 14 | - user/b 15 | - - (= a b) 16 | - 'true' 17 | - - (meta a) 18 | - nil 19 | - - (meta b) 20 | - '{:foo 123}' 21 | 22 | - - (def x ^{:a 11 :b 22} [(+ 2 2)]) 23 | - user/x 24 | - - x 25 | - '[4]' 26 | - - (meta x) 27 | - '{:a 11, :b 22}' 28 | 29 | - rep: '(def f1 ^{:c 3} #()) (meta f1)' 30 | - - (meta f1) 31 | - '{:c 3}' 32 | 33 | - rep: '(def f2 #())' 34 | - - (meta f2) 35 | - nil 36 | 37 | - rep: (def f3 ^{:d 4} f2) (meta f3) 38 | - - (meta f3) 39 | - '{:d 4}' 40 | - - (meta f2) 41 | - nil 42 | 43 | - rep: (def x ^:foo ^:bar {}) 44 | - - (meta x) 45 | - '{:bar true, :foo true}' 46 | 47 | - rep: (def x ^:foo ^"bar" {}) 48 | - - (meta x) 49 | - '{:tag "bar", :foo true}' 50 | 51 | - rep: (def x ^:foo ^"bar" ^{:a 1 :b 2} ^{:c 3 :d 4} {}) 52 | - - (meta x) 53 | - '{:c 3, :d 4, :a 1, :b 2, :tag "bar", :foo true}' 54 | 55 | # - rep: (def x [^:foo {}]) 56 | # - - (meta (nth x 0)) 57 | # - '{:foo true}' 58 | ... 59 | -------------------------------------------------------------------------------- /perl/test/62-from-perl.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | no Carp::Always; 3 | 4 | use Lingy; 5 | 6 | my $lingy = Lingy->new; 7 | 8 | is $lingy->rep("(+ 1 2 3 4 5)"), 15, 9 | "Eval Lingy from Perl works"; 10 | 11 | is $lingy->rep("(defn add2 [x y] (+ x y))"), 'user/add2', 12 | "Defined Lingy function"; 13 | 14 | is $lingy->rep("(add2 5 6)"), 11, 15 | "Called our defined Lingy function"; 16 | 17 | eval { $lingy->rep("(add2 5)") }; 18 | is $@, "Lingy Error: Wrong number of args (1) passed to function\n", 19 | "Error, too few args to our Lingy function"; 20 | 21 | eval { $lingy->rep("(add2 5 6 7)") }; 22 | is $@, "Lingy Error: Wrong number of args (3) passed to function\n", 23 | "Error, too many args to our Lingy function"; 24 | 25 | my $form = $lingy->read('(+ 1 2 3)'); 26 | 27 | is ref($form), 'Lingy::List', 28 | '$lingy->read works'; 29 | 30 | my $print = $lingy->print($form); 31 | 32 | is $print, '(+ 1 2 3)', 33 | '$lingy->print works'; 34 | 35 | my $result = $lingy->eval($form); 36 | is ref($result), 'Lingy::Number', 37 | '$lingy->eval($form) returns a Lingy form'; 38 | is $lingy->print($result), 6, 39 | '$lingy->eval result is correct'; 40 | 41 | is $result->unbox, 6, 42 | '$lingy->eval result supports ->unbox'; 43 | 44 | done_testing; 45 | -------------------------------------------------------------------------------- /ruby/lingy.gemspec: -------------------------------------------------------------------------------- 1 | # frozen_string_literal: true 2 | 3 | require_relative "lib/lingy/version" 4 | 5 | Gem::Specification.new do |spec| 6 | spec.name = "lingy" 7 | spec.version = Lingy::VERSION 8 | spec.authors = ["Ingy döt Net"] 9 | spec.email = ["ingy@ingy.net"] 10 | 11 | spec.summary = "Program in YAML" 12 | spec.description = "Program in YAML" 13 | spec.homepage = "https://github.com/ingydotnet/lingy" 14 | spec.required_ruby_version = ">= 2.4.0" 15 | 16 | spec.metadata["homepage_uri"] = spec.homepage 17 | spec.metadata["source_code_uri"] = spec.homepage 18 | spec.metadata["changelog_uri"] = "https://github.com/ingydotnet/lingy/tree/main/ruby/ChangeLog.md" 19 | 20 | spec.files = Dir.chdir(File.expand_path(__dir__)) do 21 | `git ls-files -z`.split("\x0").reject { |f| f.match(%r{\A(?:test|spec|features)/}) } 22 | end 23 | spec.bindir = "exe" 24 | spec.executables = spec.files.grep(%r{\Aexe/}) { |f| File.basename(f) } 25 | spec.require_paths = ["lib"] 26 | 27 | # Uncomment to register a new dependency of your gem 28 | # spec.add_dependency "example-gem", "~> 1.0" 29 | 30 | # For more information and examples about making a new gem, checkout our 31 | # guide at: https://bundler.io/guides/creating_gem.html 32 | end 33 | -------------------------------------------------------------------------------- /perl/lib/Lingy/HashSet.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::HashSet; 3 | 4 | use base 'Lingy::Class'; 5 | 6 | use Lingy::Common; 7 | 8 | use Hash::Ordered; 9 | 10 | sub new { 11 | my ($class, $list) = @_; 12 | tie my %hash, 'Hash::Ordered'; 13 | for (my $i = 0; $i < @$list; $i++) { 14 | my $val = $list->[$i]; 15 | my $key = $class->_get_key($val); 16 | delete $hash{$key} if exists $hash{$key}; 17 | $hash{$key} = $val; 18 | } 19 | bless \%hash, $class; 20 | } 21 | 22 | sub clone { 23 | HASHSET->new([ %{$_[0]} ]); 24 | } 25 | 26 | sub _get_key { 27 | my ($self, $key) = @_; 28 | my $type = ref($key); 29 | $type eq '' ? qq<$key> : 30 | $type eq STRING ? qq<"$key> : 31 | $type eq SYMBOL ? qq<$key > : 32 | $type->isa(SCALARTYPE) ? qq<$key> : 33 | ( # Quoted symbol: 34 | $type eq LIST and 35 | ref($key->[0]) eq SYMBOL and 36 | ${$key->[0]} eq 'quote' and 37 | ref($key->[1]) eq SYMBOL 38 | ) ? ${$key->[1]} . ' ' : 39 | err "Type '$type' not supported as a hash-map key"; 40 | } 41 | 42 | sub _to_seq { 43 | my ($map) = @_; 44 | return nil unless %$map; 45 | LIST->new([ 46 | map { 47 | $map->{$_}; 48 | } keys %{$_[0]} 49 | ]); 50 | } 51 | 52 | 1; 53 | -------------------------------------------------------------------------------- /python/setup.py: -------------------------------------------------------------------------------- 1 | version = '0.0.1' 2 | 3 | from setuptools import setup 4 | import pathlib 5 | 6 | root = pathlib.Path(__file__).parent.resolve() 7 | 8 | long_description = \ 9 | (root / '.long_description.md') \ 10 | .read_text(encoding='utf-8') 11 | 12 | setup( 13 | name = 'lingy', 14 | version = version, 15 | description = 'Program in YAML', 16 | license = 'MIT', 17 | url = 'https://github.com/ingydotnet/lingy', 18 | 19 | author = 'Ingy döt Net', 20 | author_email = 'ingy@ingy.net', 21 | 22 | packages = ['lingy'], 23 | package_dir = {'': 'lib'}, 24 | 25 | python_requires = '>=3.6, <4', 26 | install_requires = [ 27 | 'pyyaml', 28 | ], 29 | setup_requires = [ 30 | 'wheel', 31 | ], 32 | 33 | keywords = ['yaml', 'language'], 34 | classifiers = [ 35 | 'Development Status :: 3 - Alpha', 36 | 'Intended Audience :: Developers', 37 | 'License :: OSI Approved :: MIT License', 38 | 'Programming Language :: Python :: 3', 39 | 'Programming Language :: Python :: 3.6', 40 | 'Programming Language :: Python :: 3.7', 41 | 'Programming Language :: Python :: 3.8', 42 | 'Programming Language :: Python :: 3.9', 43 | 'Programming Language :: Python :: 3 :: Only', 44 | ], 45 | 46 | long_description = long_description, 47 | long_description_content_type = 'text/markdown', 48 | ) 49 | -------------------------------------------------------------------------------- /perl/Meta: -------------------------------------------------------------------------------- 1 | =meta: 0.0.2 2 | 3 | name: Lingy 4 | version: 0.1.19 5 | abstract: A Clojure Platform for Perl 6 | homepage: 7 | - http://lingy.org 8 | language: perl 9 | license: perl 10 | copyright: 2023 11 | 12 | author: 13 | name: Ingy döt Net 14 | email: ingy@cpan.org 15 | homepage: http://ingy.net 16 | github: ingydotnet 17 | twitter: ingydotnet 18 | freenode: ingy 19 | 20 | devel: 21 | git: https://github.com/ingydotnet/ 22 | bug: https://github.com/ingydotnet/lingy/issues 23 | irc: irc.freenode.net#yaml 24 | 25 | requires: 26 | perl: 5.16.0 27 | Bencode: 1.502 28 | Capture::Tiny: 0.48 29 | Carp::Always: 0.16 30 | Data::UUID: 1.226 31 | File::Path: 2.18 32 | File::Spec: 3.75 33 | File::Temp: 0.2311 34 | File::Which: 1.27 35 | Getopt::Long: 2.54 36 | Hash::Ordered: 0.014 37 | immutable: 0.0.3 38 | IO::All: 0.87 39 | IO::Select: 1.51 40 | IO::Socket::INET: 1.51 41 | Scalar::Util: 1.63 42 | Sub::Identify: 0.14 43 | Sub::Name: 0.27 44 | Term::ReadLine: 1.17 45 | Test::Simple: 1.302195 46 | Time::HiRes: 1.9764 47 | XXX: 0.38 48 | YAML::PP: 0.036 49 | 50 | recommends: 51 | Term::ReadLine::Gnu: 1.45 52 | 53 | =zild: 54 | no-about: true 55 | no-readme: true 56 | no-travis: true 57 | 58 | dzil: 59 | no-mm: true 60 | postamble: | 61 | [MakeMaker::Awesome] 62 | delimiter = | 63 | footer = |package MY; use lib 't/lib'; use DistTestFixer; 64 | footer = |sub postamble { $_[0]->SUPER::postamble . DistTestFixer->fix('lingy') } 65 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Numbers.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Numbers; 3 | 4 | use Lingy::Common; 5 | 6 | sub add { $_[0] + $_[1] } 7 | 8 | sub dec { $_[0] - 1 } 9 | 10 | sub divide { $_[0] / $_[1] } 11 | 12 | sub equiv { $_[0] == $_[1] } 13 | 14 | sub gt { $_[0] > $_[1] } 15 | 16 | sub gte { $_[0] >= $_[1] } 17 | 18 | sub inc { $_[0] + 1 } 19 | 20 | sub isPos { $_[0] > 0 } 21 | 22 | sub isZero { ${$_[0]} == 0 } 23 | 24 | sub lt { $_[0] < $_[1] } 25 | 26 | sub lte { $_[0] <= $_[1] } 27 | 28 | sub minus { 29 | @_ == 1 30 | ? (0 - ${$_[0]}) 31 | : $_[0] - $_[1]; 32 | } 33 | 34 | sub multiply { $_[0] * $_[1] } 35 | 36 | sub quotient { NUMBER->new(int($_[0] / $_[1])) } 37 | 38 | sub range { 39 | my ($start, $end, $step) = @_; 40 | if (not defined $end) { 41 | $end = $start; 42 | $start = NUMBER->new(0); 43 | } 44 | $step //= NUMBER->new(1); 45 | ($start, $end, $step) = ($$start, $$end, $$step); 46 | return list([]) if $step == 0; 47 | my @range; 48 | if ($step > 0) { 49 | return list([]) if $start > $end; 50 | while ($start < $end) { 51 | push @range, NUMBER->new($start); 52 | $start += $step; 53 | } 54 | } else { 55 | return list([]) if $start < $end; 56 | while ($start > $end) { 57 | push @range, NUMBER->new($start); 58 | $start += $step; 59 | } 60 | } 61 | list([@range]); 62 | } 63 | 64 | sub remainder { 65 | $_[0] % $_[1]; 66 | } 67 | 68 | 1; 69 | -------------------------------------------------------------------------------- /perl/lib/Lingy/String.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::String; 3 | 4 | use Lingy::Common; 5 | use base 'Lingy::ScalarClass'; 6 | 7 | use overload cmp => \&comp_pair; 8 | 9 | sub append { 10 | my ($self, $str) = @_; 11 | STRING->new("$self$str"); 12 | } 13 | 14 | sub endsWith { 15 | my ($str, $substr) = map "$_", @_; 16 | my ($l1, $l2) = map length("$_"), @_; 17 | BOOLEAN->new( 18 | $l1 >= $l2 and 19 | substr($str, $l1 - $l2) eq $substr 20 | ); 21 | } 22 | 23 | sub replaceAll { 24 | my ($str, $pat, $rep) = @_; 25 | $str =~ s/\Q$pat\E/$rep/g; 26 | STRING->new($str); 27 | } 28 | 29 | sub substring { 30 | my ($string, $offset1, $offset2) = @_; 31 | my $length = length $string; 32 | $offset2 //= NUMBER->new($length); 33 | err "Begin index out of range '%d' for string length '%d'", 34 | $offset1, $length 35 | if $offset1 < 0 or $offset1 > $length; 36 | err "End index out of range '%d' for string length '%d'", 37 | $offset2, $length 38 | if $offset2 < $offset1 or $offset2 > $length; 39 | STRING->new(substr("$string", $offset1, $offset2 - $offset1)) 40 | } 41 | 42 | sub toLowerCase { 43 | STRING->new(lc $_[0]); 44 | } 45 | 46 | sub toString { 47 | $_[0]; 48 | } 49 | 50 | sub toUpperCase { 51 | STRING->new(uc $_[0]); 52 | } 53 | 54 | sub _to_seq { 55 | my ($str) = @_; 56 | return nil unless length $str; 57 | list([ 58 | map CHARACTER->read("\\$_"), split //, $$str 59 | ]); 60 | } 61 | 62 | 1; 63 | -------------------------------------------------------------------------------- /perl/test/51-ns.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - [ '*ns*', '#' ] 5 | - [ (the-ns *ns*), '#' ] 6 | - [ (the-ns 'user), '#' ] 7 | - [ (find-ns 'user), '#' ] 8 | - [ (ns-name *ns*), user ] 9 | - [ (type *ns*), lingy.lang.Namespace ] 10 | 11 | - rep: | 12 | (ns foo) 13 | (def x 42) 14 | (ns user) 15 | 16 | - [ foo/x, 42 ] 17 | - [ "(find-ns 'foo)", '#' ] 18 | 19 | - [ (ns foo.bar) (def baz (+ 40 2)), "nil\nfoo.bar/baz" ] 20 | - [ '*ns*', '#' ] 21 | 22 | - rep: (ns ns1) 23 | - [ inc, '#' ] 24 | # XXX should be: 25 | # - [ inc, '#' ] 26 | 27 | - rep: (in-ns 'ns2) 28 | 29 | - note: XXX Regression 30 | # - [ lingy.core/*ns*, "#" ] 31 | - [ (lingy.core/find-ns 'ns2), '#' ] 32 | - [ (lingy.core/the-ns 'ns2), '#' ] 33 | - - inc 34 | - "Unable to resolve symbol: 'inc' in this context" 35 | 36 | - rep: (lingy.core/in-ns 'user) 37 | - [ '*ns*', '#' ] 38 | 39 | - [ (create-ns 'ns3), '#' ] 40 | - [ (find-ns 'ns3), '#' ] 41 | - [ (the-ns 'ns3), '#' ] 42 | - [ (ns-name 'ns3), 'ns3' ] 43 | 44 | - [ (the-ns *ns*), '#' ] 45 | - - (find-ns *ns*) 46 | - Arg 0 for 'Lingy::RT::find_ns' must be 'Lingy::Symbol', not 'Lingy::Namespace' 47 | - [ (ns-name *ns*), user ] 48 | 49 | - [ (the-ns 'lingy.core), '#' ] 50 | - [ (ns-name (the-ns 'lingy.core)), lingy.core ] 51 | 52 | - [ (the-ns 'nope), "No namespace: 'nope' found" ] 53 | - [ (find-ns 'nope), nil ] 54 | ... 55 | -------------------------------------------------------------------------------- /perl/lib/Lingy/string.ly: -------------------------------------------------------------------------------- 1 | (ns lingy.string 2 | ; TODO move the clojure source code into Lingy/string.clj 3 | ; (:use clojure.string) 4 | ) 5 | 6 | ; Parts of clojure/string.clj were copied into the remainder of this file. 7 | ; Those parts are covered by the following license: 8 | 9 | ; Copyright (c) Rich Hickey. All rights reserved. 10 | ; The use and distribution terms for this software are covered by the 11 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 12 | ; which can be found in the file epl-v10.html at the root of this distribution. 13 | ; By using this software in any fashion, you are agreeing to be bound by 14 | ; the terms of this license. 15 | ; You must not remove this notice, or any other, from this software. 16 | 17 | (defn ^String reverse 18 | "Returns s with its characters reversed." 19 | {:added "1.2"} 20 | [^CharSequence s] 21 | (.toString (.reverse (StringBuilder. s)))) 22 | 23 | (defn ^String join 24 | "Returns a string of all elements in coll, as returned by (seq coll), 25 | separated by an optional separator." 26 | {:added "1.2"} 27 | ([coll] 28 | (apply str coll)) 29 | ([separator coll] 30 | (loop [sb (StringBuilder. (str (first coll))) 31 | more (next coll) 32 | sep (str separator)] 33 | (if more 34 | (recur (-> sb (.append sep) (.append (str (first more)))) 35 | (next more) 36 | sep) 37 | (str sb))))) 38 | 39 | (defn ends-with? 40 | "True if s ends with substr." 41 | {:added "1.8"} 42 | [^CharSequence s ^String substr] 43 | (.endsWith (.toString s) substr)) 44 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Namespace.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Namespace; 3 | 4 | use Lingy::Common; 5 | 6 | has '_name'; 7 | 8 | sub new { 9 | my $class = shift; 10 | my $name = shift; 11 | 12 | # XXX Could be a HashMap 13 | my $self = bless {'_name' => $name, @_}, __PACKAGE__; 14 | 15 | return RT->namespaces->{$name} = $self; 16 | } 17 | 18 | sub refer { 19 | my ($self, $refer_ns_name) = @_; 20 | err "'refer' only works with symbols" 21 | unless ref($refer_ns_name) eq SYMBOL; 22 | my $refer_ns = RT->namespaces->{$$refer_ns_name} 23 | or err "No namespace: '$$refer_ns_name'"; 24 | map $self->{$_} = $refer_ns->{$_}, 25 | grep not(/^_/), keys %$refer_ns; 26 | $self->{$refer_ns_name} = $refer_ns; 27 | return $self; 28 | } 29 | 30 | sub current { 31 | my ($self) = @_; 32 | my $name = $self->_name or die; 33 | RT->current_ns_name($name); 34 | RT->namespaces->{$name} = $self; 35 | RT->env->{space} = $self; 36 | # RT->namespaces->{'lingy.core'}{'*ns*'} = $self; 37 | return $self; 38 | } 39 | 40 | sub set { 41 | my ($self, $symbol, $value) = @_; 42 | $self->{$symbol} = $value; 43 | return symbol($self->_name . "/$symbol"); 44 | } 45 | 46 | sub getName { 47 | symbol($_[0]->_name); 48 | } 49 | 50 | sub getImports { 51 | XXX @_, 'TODO - getImports'; 52 | } 53 | 54 | sub getInterns { 55 | my $map = { 56 | %{$_[0]}, 57 | }; 58 | delete $map->{'_name'}; 59 | HASHMAP->new([ %$map ]); 60 | } 61 | 62 | sub getMappings { 63 | my %map = %{$_[0]}; 64 | delete $map{'_name'}; 65 | HASHMAP->new([ %map ]); 66 | } 67 | 68 | 1; 69 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Class.pm: -------------------------------------------------------------------------------- 1 | # This module is a base class for all Lingy object classes and base classes, 2 | # and also a class for 'Lingy::Class' objects. 3 | 4 | use strict; use warnings; 5 | package Lingy::Class; 6 | 7 | # This section is base class support for all Lingy object classes. 8 | # They all inherit from this: 9 | 10 | sub new { 11 | die sprintf "No 'new' method defined for class '%s'.", ref($_[0]); 12 | } 13 | 14 | sub NAME { 15 | my ($self) = @_; 16 | my $class = ref($self) or die; 17 | $class =~ s/^Lingy::/lingy.lang./; 18 | return $class; 19 | } 20 | 21 | my %common = map {($_, 1)} @Lingy::Common::EXPORT; 22 | 23 | sub _method_names { 24 | my ($self) = @_; 25 | my $class = ref($self) || $self; 26 | no strict 'refs'; 27 | grep { 28 | not( 29 | exists($common{$_}) or 30 | /(^_|^[A-Z]+$|can|import|isa|new)/ 31 | ) 32 | } keys %{"$class\::"}; 33 | } 34 | 35 | 36 | # This section is for special Lingy::Class objects, which are needed to 37 | # mimic Clojure class behavior. 38 | 39 | use overload '""' => sub { 40 | ref($_[0]) eq __PACKAGE__ ? ${$_[0]} : $_[0]; 41 | }; 42 | 43 | sub _new { 44 | my (undef, $name) = @_; 45 | bless \$name, __PACKAGE__; 46 | } 47 | 48 | sub _name { 49 | ref($_[0]) eq __PACKAGE__ or 50 | die sprintf "Can't call '_name' on '%s' object", 51 | ref($_[0]); 52 | my $name = ${$_[0]}; 53 | $name =~ s/^Lingy::/lingy.lang./; 54 | return $name; 55 | } 56 | 57 | # Public methods: 58 | sub isInstance { 59 | my ($base_class, $instance) = @_; 60 | my $instance_class = ref($instance); 61 | $instance->isa($base_class) ? Lingy::Common::true() : Lingy::Common::false(); 62 | } 63 | 64 | 1; 65 | -------------------------------------------------------------------------------- /python/Makefile: -------------------------------------------------------------------------------- 1 | SHELL := bash 2 | ROOT := $(shell pwd) 3 | 4 | PYTHON := $(shell command -v python3) 5 | PYTHON ?= $(shell command -v python) 6 | 7 | VERSION := $(shell head -n1 setup.py | cut -d"'" -f2) 8 | 9 | export PYTHONPATH := $(ROOT)/lib 10 | 11 | 12 | default: 13 | @echo $(VERSION) 14 | 15 | .PHONY: test 16 | test: .venv 17 | source .venv/bin/activate && \ 18 | pytest -v test/*.py 19 | 20 | pkg-test: venv 21 | make clean 22 | make test 23 | make dist 24 | pip install dist/lingy-*.tar.gz 25 | tar xzf dist/lingy-*.tar.gz 26 | cat lingy-*/PKG-INFO 27 | 28 | dist: venv MANIFEST.in .long_description.md 29 | $(PYTHON) setup.py sdist 30 | 31 | release: publish tag push 32 | 33 | publish: dist 34 | twine upload -u $${PYPI_USER:-$$USER} dist/* 35 | 36 | tag: 37 | -git add . && git commit -m $(VERSION) 38 | git tag $(VERSION) 39 | 40 | push: 41 | -git push 42 | -git push --tag 43 | 44 | clean: 45 | rm -f MANIFEST* .long_description.md 46 | rm -fr dist/ .pytest_cache/ lingy-0.*/ 47 | rm -fr lib/lingy.egg-info/ .eggs/ 48 | find . -name '__pycache__' | xargs rm -fr 49 | 50 | realclean: clean 51 | rm -fr .venv/ 52 | 53 | venv: .venv 54 | @[[ $$VIRTUAL_ENV == $$PWD/.venv ]] || { \ 55 | echo; \ 56 | echo "Run 'source .venv/bin/activate'"; \ 57 | echo; \ 58 | exit 1; \ 59 | } 60 | 61 | .venv: 62 | $(PYTHON) -mvenv $@ 63 | source .venv/bin/activate && \ 64 | pip install \ 65 | pytest \ 66 | pyyaml \ 67 | twine 68 | 69 | MANIFEST.in: 70 | echo 'include ReadMe.md' > $@ 71 | echo 'include .long_description.md' >> $@ 72 | 73 | .long_description.md: ReadMe.md 74 | cat $< | \ 75 | grep -A999 '## Synopsis' | \ 76 | grep -B999 '## Features' | \ 77 | head -n-2 \ 78 | > $@ 79 | -------------------------------------------------------------------------------- /perl/test/21-vars.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<'...'; 4 | - - (type 42) 5 | - lingy.lang.Number 6 | - - (type "foo") 7 | - lingy.lang.String 8 | - - (type 'cymbal) 9 | - lingy.lang.Symbol 10 | - - (type 'cymbal/monkey) 11 | - lingy.lang.Symbol 12 | - - (type '(cymbal)) 13 | - lingy.lang.List 14 | - - (type '[cymbal]) 15 | - lingy.lang.Vector 16 | - - (type ['cymbal]) 17 | - lingy.lang.Vector 18 | - - (type `(cymbal)) 19 | - lingy.lang.List 20 | - - (type ()) 21 | - lingy.lang.List 22 | - - (type nil) 23 | - lingy.lang.Nil 24 | - - (type false) 25 | - lingy.lang.Boolean 26 | - - (type (fn [])) 27 | - lingy.lang.Fn 28 | - - (do (defmacro x [] ()) (type x)) 29 | - lingy.lang.Macro 30 | - - (type (atom 22)) 31 | - lingy.lang.Atom 32 | - - (type {}) 33 | - lingy.lang.HashMap 34 | - - (type :lala) 35 | - lingy.lang.Keyword 36 | - - (type (type :lala)) 37 | - lingy.lang.Class 38 | 39 | - - (name 'foo) 40 | - '"foo"' 41 | - - (namespace 'foo) 42 | - 'nil' 43 | - - (name 'foo/bar) 44 | - '"bar"' 45 | - - (namespace 'foo/bar) 46 | - '"foo"' 47 | 48 | - - '(gensym)' 49 | - /^G__\d+$/ 50 | - - '(gensym "foo--")' 51 | - /^foo--\d+$/ 52 | 53 | - - (resolve 'lingy.core/+) 54 | - "#'lingy.core/+" 55 | 56 | - note: XXX Regression 57 | # - - (resolve '+) 58 | # - "#'lingy.core/+" 59 | # - - (resolve 'user/+) 60 | # - "#'lingy.core/+" 61 | 62 | - - (resolve 'luser/+) 63 | - nil 64 | - - (resolve 'user/+++) 65 | - nil 66 | - - (resolve '+++) 67 | - nil 68 | - - (resolve 'add) 69 | - nil 70 | - - (resolve 'lingy.lang.Numbers/add) 71 | - nil 72 | 73 | - - (var v1) 74 | - "Unable to resolve var: 'v1' in this context" 75 | - rep: (def v1 123) 76 | - - (var v1) 77 | - "#'v1" 78 | 79 | - - "#'v1" 80 | - "#'user/v1" 81 | ... 82 | -------------------------------------------------------------------------------- /perl/lib/Lingy.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy; 3 | our $VERSION = '0.1.19'; 4 | 5 | my $rt = 0; 6 | 7 | use constant error_prefix => 'Lingy Error:'; 8 | 9 | sub new { 10 | die "Lingy->new() takes no arguments" 11 | unless @_ == 1; 12 | my ($class) = @_; 13 | require Lingy::RT; 14 | my $rt_class = "${class}::RT"; 15 | $rt_class->init unless $Lingy::RT::OK; 16 | return bless { 17 | RT => $rt_class, 18 | }, $class; 19 | } 20 | 21 | sub rep { 22 | die "Lingy->rep(string) takes one argument" 23 | unless @_ == 2; 24 | my ($self, $string) = @_; 25 | local $Lingy::Common::error_prefix = $self->error_prefix; 26 | my ($ret) = $self->{RT}->rep($string); 27 | return $ret; 28 | } 29 | 30 | sub reps { 31 | die "Lingy->rep(string) takes one argument" 32 | unless @_ == 2; 33 | my ($self, $string) = @_; 34 | local $Lingy::Common::error_prefix = $self->error_prefix; 35 | return $self->{RT}->rep($string); 36 | } 37 | 38 | sub read { 39 | die "Lingy->read(string) takes one argument" 40 | unless @_ == 2; 41 | my ($self, $string) = @_; 42 | local $Lingy::Common::error_prefix = $self->error_prefix; 43 | my (@ret) = $self->{RT}->reader->read_str($string); 44 | return wantarray ? @ret : $ret[0]; 45 | } 46 | 47 | sub eval { 48 | die "Lingy->eval(form) takes one argument" 49 | unless @_ == 2; 50 | my ($self, $form) = @_; 51 | local $Lingy::Common::error_prefix = $self->error_prefix; 52 | $self->{RT}->eval($form); 53 | } 54 | 55 | sub print { 56 | die "Lingy->print(form) takes one argument" 57 | unless @_ == 2; 58 | my ($self, $form) = @_; 59 | local $Lingy::Common::error_prefix = $self->error_prefix; 60 | $self->{RT}->printer->pr_str($form); 61 | } 62 | 63 | 1; 64 | -------------------------------------------------------------------------------- /perl/test/mal/step3_env.yaml: -------------------------------------------------------------------------------- 1 | - say: Testing REPL_ENV 2 | mal: (+ 1 2) 3 | out: 3 4 | 5 | - mal: (/ (- (+ 5 (* 2 3)) 3) 4) 6 | out: 2 7 | 8 | 9 | - say: Testing def 10 | mal: (def x 3) 11 | out: user/x 12 | 13 | - mal: x 14 | out: 3 15 | 16 | - mal: (def x 4) 17 | out: user/x 18 | 19 | - mal: x 20 | out: 4 21 | 22 | - mal: (def y (+ 1 7)) 23 | out: user/y 24 | 25 | - mal: y 26 | out: 8 27 | 28 | - say: Verifying symbols are case-sensitive 29 | mal: (def mynum 111) 30 | out: user/mynum 31 | 32 | - mal: (def MYNUM 222) 33 | out: user/MYNUM 34 | 35 | - mal: mynum 36 | out: 111 37 | 38 | - mal: MYNUM 39 | out: 222 40 | 41 | - say: Check env lookup non-fatal error 42 | mal: (abc 1 2 3) 43 | err: "Error: Unable to resolve symbol: 'abc' in this context" 44 | 45 | - say: Check that error aborts def 46 | mal: 47 | - (def w 123) 48 | - (def w (abc)) 49 | - w 50 | out: 123 51 | eok: true 52 | 53 | - say: Testing let* 54 | mal: (let* [z 9] z) 55 | out: 9 56 | 57 | - mal: (let* [x 9] x) 58 | out: 9 59 | 60 | - mal: x 61 | out: 4 62 | 63 | - mal: (let* [z (+ 2 3)] (+ 1 z)) 64 | out: 6 65 | 66 | - mal: (let* [p (+ 2 3) q (+ 2 p)] (+ p q)) 67 | out: 12 68 | 69 | - mal: 70 | - (def y (let* [z 7] z)) 71 | - y 72 | out: 7 73 | 74 | - say: Testing outer environment 75 | mal: (def a 4) 76 | out: user/a 77 | 78 | - mal: (let* [q 9] q) 79 | out: 9 80 | 81 | - mal: (let* [q 9] a) 82 | out: 4 83 | 84 | - mal: (let* [z 2] (let* [q 9] a)) 85 | out: 4 86 | 87 | # -------- Deferrable Functionality -------- 88 | 89 | - say: Testing let* with vector bindings 90 | mal: (let* [z 9] z) 91 | out: 9 92 | 93 | - mal: (let* [p (+ 2 3) q (+ 2 p)] (+ p q)) 94 | out: 12 95 | 96 | - say: Testing vector evaluation 97 | mal: (let* [a 5 b 6] [3 4 a [b 7] 8]) 98 | out: '[3 4 5 [6 7] 8]' 99 | 100 | # -------- Optional Functionality -------- 101 | 102 | - say: Check that last assignment takes priority 103 | mal: (let* [x 2 x 3] x) 104 | out: 3 105 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Util.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Util; 3 | 4 | use Lingy::Common; 5 | 6 | sub identical { 7 | BOOLEAN->new(refaddr($_[0]) == refaddr($_[1])); 8 | } 9 | 10 | #------------------------------------------------------------------------------ 11 | # Devel functions: 12 | #------------------------------------------------------------------------------ 13 | 14 | sub applyTo { 15 | my ($method, $args) = @_; 16 | no strict 'refs'; 17 | &{"$method"}(@$args); 18 | } 19 | 20 | sub eval_perl { 21 | my $ret = eval("$_[0]"); 22 | $_[1] // $ret; 23 | } 24 | 25 | sub rt_internal { my $m = "$_[0]"; RT->$m } 26 | 27 | sub env_data { 28 | my $env = $Lingy::Evaluator::ENV; 29 | my $www = {}; 30 | my $w = $www; 31 | my $e = $env; 32 | while ($e) { 33 | $w->{'+'} = join ' ', sort CORE::keys %{$e->space}; 34 | $w->{'^'} = {}; 35 | $w = $w->{'^'}; 36 | $e = $e->{outer}; 37 | } 38 | bless $www, 'lingy-internal'; 39 | } 40 | 41 | sub equiv { 42 | my ($x, $y) = @_; 43 | return false 44 | unless 45 | ( 46 | $x->isa(LISTTYPE) and 47 | $y->isa(LISTTYPE) 48 | ) or ref($x) eq ref($y); 49 | if ($x->isa(LISTTYPE)) { 50 | return false unless @$x == @$y; 51 | for (my $i = 0; $i < @$x; $i++) { 52 | my $bool = equiv($x->[$i], $y->[$i]); 53 | return false if "$bool" eq '0'; 54 | } 55 | return true; 56 | } 57 | if ($x->isa(HASHMAP)) { 58 | my @xkeys = sort map "$_", keys %$x; 59 | my @ykeys = sort map "$_", keys %$y; 60 | return false unless @xkeys == @ykeys; 61 | my @xvals = map $x->{$_}, @xkeys; 62 | my @yvals = map $y->{$_}, @ykeys; 63 | for (my $i = 0; $i < @xkeys; $i++) { 64 | return false unless "$xkeys[$i]" eq "$ykeys[$i]"; 65 | my $bool = equiv($xvals[$i], $yvals[$i]); 66 | return false if "$bool" eq '0'; 67 | } 68 | return true; 69 | } 70 | BOOLEAN->new($$x eq $$y); 71 | } 72 | 73 | 1; 74 | -------------------------------------------------------------------------------- /perl/test/03-cli.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | note "Testing 'lingy' CLI usages:"; 4 | 5 | run_is qq<$lingy --help>, 6 | qr/\QUsage: lingy [] []\E/; 7 | 8 | run_is qq<$lingy --foo>, 9 | qr/\QError: Error in command line arguments\E/; 10 | 11 | run_is qq<$lingy --version>, 12 | "Lingy [perl] version $Lingy::VERSION"; 13 | 14 | run_is qq<$lingy -e '(prn (+ 2 3))'>, 5; 15 | 16 | run_is qq, 18; 17 | 18 | run_is qq, 18; 19 | 20 | run_is qq<$lingy --ppp -e '(prn (+ 2 3))'>, 21 | qr/--- \(prn \(\+ 2 3\)\)/; 22 | 23 | run_is qq<$lingy --xxx -e '(prn (+ 2 3))'>, 24 | qr/--- !perl\/array:Lingy::List 25 | - !perl\/scalar:Lingy::Symbol 26 | =: prn 27 | - !perl\/array:Lingy::List 28 | - !perl\/scalar:Lingy::Symbol 29 | =: \+ 30 | - !perl\/scalar:Lingy::Number 31 | =: '2' 32 | - !perl\/scalar:Lingy::Number 33 | =: '3'/, 34 | "'\$cmd' produces correct YAML dump"; 35 | 36 | my $test = -d 't' ? 't' : 'test'; 37 | 38 | run_is "$lingy $test/program1.ly", 39 | "program: $ENV{PWD}/$test/program1.ly args: ()"; 40 | 41 | run_is "$lingy $test/program1.ly foo bar", 42 | "program: $ENV{PWD}/$test/program1.ly args: (foo bar)"; 43 | 44 | sub note_repl_input { 45 | note "Lingy REPL input: '$ENV{LINGY_TEST_INPUT}'"; 46 | } 47 | 48 | { 49 | local $ENV{LINGY_TEST_INPUT} = '(prn *file* *command-line-args*)'; 50 | note_repl_input; 51 | 52 | run_is "$lingy", qq<"NO_SOURCE_PATH" ()\nnil> 53 | if -t 0 and $Lingy::Test::gnu_readline; 54 | run_is "$lingy --repl", qq<"NO_SOURCE_PATH" ()\nnil> 55 | if -t 0 and $Lingy::Test::gnu_readline; 56 | 57 | run_is "$lingy --repl foo bar", qq<"NO_SOURCE_PATH" ("foo" "bar")\nnil> 58 | if $Lingy::Test::gnu_readline; 59 | 60 | local $ENV{LINGY_TEST_INPUT} = '(prn *file* *command-line-args* foo)'; 61 | note_repl_input; 62 | 63 | run_is "$lingy -e '(def foo 42)' --repl", qq<"NO_SOURCE_PATH" () 42\nnil> 64 | if -t 0 and $Lingy::Test::gnu_readline; 65 | 66 | run_is "$lingy -e '(def foo 42)'", 'user/foo'; 67 | } 68 | -------------------------------------------------------------------------------- /perl/lib/Lingy/HashMap.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::HashMap; 3 | 4 | use base 'immutable::map', 'Lingy::Class'; 5 | 6 | use Lingy::Common; 7 | 8 | sub new { 9 | my ($class, $list) = @_; 10 | my (@keys, %vals); 11 | for (my $i = @$list - 2; $i >= 0; $i -= 2) { 12 | my $key = $class->_get_key($list->[$i]); 13 | if (not exists $vals{$key}) { 14 | unshift @keys, $key; 15 | $vals{$key} = $list->[$i + 1]; 16 | } 17 | } 18 | my @data = map { ($_, $vals{$_}) } @keys; 19 | my $self = $class->SUPER::new(@data); 20 | return $self; 21 | } 22 | 23 | sub unbox { 24 | my @list = %{$_[0]}; 25 | my $hash = {}; 26 | for (my $i = 0; $i < @list; $i += 2) { 27 | my $key = $list[$i]; 28 | $key =~ s/^"//; 29 | $hash->{$key} = $list[$i+1]->unbox; 30 | } 31 | return $hash; 32 | } 33 | 34 | sub clone { 35 | $_[0]->set(); 36 | } 37 | 38 | sub assoc { 39 | my ($self, $key, $val) = @_; 40 | $key = $self->_get_key($key); 41 | my $new = $self->set($key, $val); 42 | $new; 43 | } 44 | 45 | sub _get_key { 46 | my ($self, $key) = @_; 47 | my $type = ref($key); 48 | $type eq '' ? qq<$key> : 49 | $type eq STRING ? qq<"$key> : 50 | $type eq SYMBOL ? qq<$key > : 51 | $type->isa(SCALARTYPE) ? qq<$key> : 52 | ( # Quoted symbol: 53 | $type eq LIST and 54 | ref($key->[0]) eq SYMBOL and 55 | ${$key->[0]} eq 'quote' and 56 | ref($key->[1]) eq SYMBOL 57 | ) ? ${$key->[1]} . ' ' : 58 | err "Type '$type' not supported as a hash-map key"; 59 | } 60 | 61 | sub _to_seq { 62 | my ($map) = @_; 63 | return nil unless %$map; 64 | LIST->new([ 65 | map { 66 | my $val = $map->{$_}; 67 | my $key = 68 | s/^"// ? STRING->new($_) : 69 | s/^(\S+) $/$1/ ? SYMBOL->new($_) : 70 | s/^:// ? KEYWORD->new($_) : 71 | m/^\d+$/ ? NUMBER->new($_) : 72 | XXX $_; 73 | VECTOR->new([$key, $val]); 74 | } keys %{$_[0]} 75 | ]); 76 | } 77 | 78 | 1; 79 | -------------------------------------------------------------------------------- /perl/Makefile: -------------------------------------------------------------------------------- 1 | SHELL := bash 2 | 3 | ROOT_PERL := $(shell pwd) 4 | 5 | ZILD := \ 6 | cpan \ 7 | cpanshell \ 8 | dist \ 9 | distdir \ 10 | distshell \ 11 | disttest \ 12 | install \ 13 | release \ 14 | update \ 15 | 16 | test ?= test/ 17 | v ?= -v 18 | 19 | export RELEASE_BRANCH := main 20 | 21 | export PATH := $(ROOT_PERL)/bin:$(PATH) 22 | 23 | export LINGY_EXEC := $(ROOT_PERL)/bin/_lingy.pl 24 | 25 | CLOJURE_REPO := https://raw.githubusercontent.com/clojure/clojure 26 | CLOJURE_TAG := clojure-1.11.1 27 | CLOJURE_SOURCE_DIR := $(CLOJURE_REPO)/$(CLOJURE_TAG)/src/clj 28 | CLOJURE_CORE := clojure/core.clj 29 | CLOJURE_CORE_SOURCE := $(CLOJURE_SOURCE_DIR)/$(CLOJURE_CORE) 30 | TMP_CLOJURE_CORE := /tmp/$(CLOJURE_CORE) 31 | LINGY_CLOJURE_CORE := lib/Lingy/core.clj 32 | 33 | NREPL_LOG_FILE := .nrepl-log 34 | NREPL_PID_FILE := .nrepl-pid 35 | NREPL_PORT_FILE := .nrepl-port 36 | 37 | DEPS := \ 38 | $(LINGY_CLOJURE_CORE) 39 | 40 | .DELETE_ON_ERROR: 41 | 42 | #------------------------------------------------------------------------------ 43 | default: 44 | 45 | build: $(DEPS) 46 | 47 | .PHONY: test 48 | test: $(DEPS) 49 | prove -l $v $(test) 50 | 51 | $(ZILD): $(DEPS) 52 | zild $@ 53 | 54 | clean: 55 | $(RM) -r Lingy-* cpan 56 | $(RM) -r .calva/ .clj-kondo/ .lsp/ 57 | $(RM) $(NREPL_LOG_FILE) $(NREPL_PORT_FILE) 58 | $(RM) $(TMP_CLOJURE_CORE) 59 | 60 | #------------------------------------------------------------------------------ 61 | nrepl: nrepl-kill 62 | ifeq (-,$(log)) 63 | LINGY_NREPL_LOG=$(log) lingy --nrepl 64 | else 65 | LINGY_NREPL_LOG=$(log) lingy --nrepl & echo $$! > $(NREPL_PID_FILE) 66 | endif 67 | @echo "*** lingy nREPL Running... (pid $$(< $(NREPL_PID_FILE)))" 68 | @echo 69 | @sleep 0.5 70 | @echo 71 | 72 | nrepl-kill: 73 | ifneq (,$(wildcard $(NREPL_PID_FILE))) 74 | @echo "*** lingy nREPL Stopping... (pid $$(< $(NREPL_PID_FILE)))" 75 | -kill -9 $$(< $(NREPL_PID_FILE)) 76 | $(RM) $(NREPL_PID_FILE) $(NREPL_LOG_FILE) $(NREPL_PORT_FILE) 77 | @echo 78 | endif 79 | 80 | nrepl-tail: 81 | tail -f $(NREPL_LOG_FILE) 82 | 83 | #------------------------------------------------------------------------------ 84 | $(LINGY_CLOJURE_CORE): $(TMP_CLOJURE_CORE) 85 | perl tool/compile-clojure-core $< $(CLOJURE_CORE_SOURCE) > $@ 86 | 87 | $(TMP_CLOJURE_CORE): 88 | mkdir -p $(dir $@) 89 | curl -s $(CLOJURE_CORE_SOURCE) > $@ 90 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Number.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Number; 3 | 4 | use Lingy::Common; 5 | use base 'Lingy::ScalarClass'; 6 | 7 | use overload 8 | '""' => sub { 0 + ${$_[0]} }, 9 | '+' => \&add, 10 | '-' => \&subtract, 11 | '*' => \&multiply, 12 | '/' => \÷, 13 | '==' => \&equal_to, 14 | '>' => \&greater_than, 15 | '>=' => \&greater_equal, 16 | '<' => \&less_than, 17 | '<=' => \&less_equal, 18 | '%' => \&modulo, 19 | cmp => \&comp_pair, 20 | ; 21 | 22 | sub cast { 23 | $_[1]; 24 | } 25 | 26 | sub equal_to { 27 | my ($x, $y) = @_; 28 | $x = ref($x) ? $$x : $x; 29 | $y = ref($y) ? $$y : $y; 30 | BOOLEAN->new($x == $y); 31 | } 32 | 33 | sub greater_than { 34 | my ($x, $y) = @_; 35 | $x = ref($x) ? $$x : $x; 36 | $y = ref($y) ? $$y : $y; 37 | BOOLEAN->new($x > $y); 38 | } 39 | 40 | sub greater_equal { 41 | my ($x, $y) = @_; 42 | $x = ref($x) ? $$x : $x; 43 | $y = ref($y) ? $$y : $y; 44 | BOOLEAN->new($x >= $y); 45 | } 46 | 47 | sub less_than { 48 | my ($x, $y) = @_; 49 | $x = ref($x) ? $$x : $x; 50 | $y = ref($y) ? $$y : $y; 51 | BOOLEAN->new($x < $y); 52 | } 53 | 54 | sub less_equal { 55 | my ($x, $y) = @_; 56 | $x = ref($x) ? $$x : $x; 57 | $y = ref($y) ? $$y : $y; 58 | BOOLEAN->new($x <= $y); 59 | } 60 | 61 | sub add { 62 | my ($x, $y) = @_; 63 | my $class = ref($x); 64 | $x = ref($x) ? $$x : $x; 65 | $y = ref($y) ? $$y : $y; 66 | $class->new($x + $y); 67 | } 68 | 69 | sub subtract { 70 | my ($x, $y) = @_; 71 | my $class = ref($x); 72 | $x = ref($x) ? $$x : $x; 73 | $y = ref($y) ? $$y : $y; 74 | $class->new($x - $y); 75 | } 76 | 77 | sub multiply { 78 | my ($x, $y) = @_; 79 | my $class = ref($x); 80 | $x = ref($x) ? $$x : $x; 81 | $y = ref($y) ? $$y : $y; 82 | $class->new($x * $y); 83 | } 84 | 85 | sub divide { 86 | my ($x, $y) = @_; 87 | my $class = ref($x); 88 | $x = ref($x) ? $$x : $x; 89 | $y = ref($y) ? $$y : $y; 90 | $class->new($x / $y); 91 | } 92 | 93 | sub modulo { 94 | my ($x, $y) = @_; 95 | my $class = ref($x); 96 | $x = ref($x) ? $$x : $x; 97 | $y = ref($y) ? $$y : $y; 98 | $class->new($x % $y); 99 | } 100 | 101 | 1; 102 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Fn.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Fn; 3 | 4 | use base 'Lingy::Class'; 5 | 6 | use Lingy::Common; 7 | 8 | use Sub::Name 'subname'; 9 | 10 | *list = \&Lingy::Common::list; 11 | *symbol = \&Lingy::Common::symbol; 12 | sub err; 13 | *err = \&Lingy::Common::err; 14 | 15 | sub new { 16 | my ($class, $ast, $env) = @_; 17 | 18 | my (undef, @exprs) = @$ast; 19 | 20 | my $name = \'AFn'; 21 | $name = shift @exprs if ref($exprs[0]) eq SYMBOL; 22 | 23 | shift @exprs if ref($exprs[0]) eq STRING; 24 | shift @exprs if ref($exprs[0]) eq HASHMAP; 25 | 26 | @exprs = (list([@exprs])) 27 | if ref($exprs[0]) eq VECTOR; 28 | 29 | my $functions = []; 30 | my $variadic = ''; 31 | 32 | for my $expr (@exprs) { 33 | err "fn expr is not a list" 34 | unless ref($expr) eq LIST; 35 | my ($sig, @body) = @$expr; 36 | err "fn signature not a vector" 37 | unless ref($sig) eq VECTOR; 38 | my $arity = (grep {$$_ eq '&'} @$sig) ? -1 : @$sig; 39 | if ($arity == -1) { 40 | $variadic = @$sig - 1; 41 | } elsif ($variadic) { 42 | err "Can't have fixed arity function " . 43 | "with more params than variadic function" 44 | if @$sig > $variadic; 45 | } 46 | @body = (list([ symbol('do'), @body ])) 47 | if @body > 1; 48 | if (exists $functions->[$arity+1]) { 49 | err $arity == -1 50 | ? "Can't have more than 1 variadic overload" 51 | : "Can't have 2 overloads with same arity"; 52 | } 53 | $functions->[$arity+1] = [$sig, @body]; 54 | } 55 | 56 | subname $name => bless sub { 57 | my $arity = @_; 58 | my $function = 59 | $functions->[$arity+1] ? $functions->[$arity+1] : 60 | $arity >= (@$functions-1) ? $functions->[0] : undef; 61 | err "Wrong number of args ($arity) passed to function" 62 | unless defined $function; 63 | my ($sig, $ast) = @$function; 64 | 65 | return ( 66 | $ast, 67 | Lingy::Env->new( 68 | outer => $env, 69 | binds => $sig, 70 | exprs => \@_, 71 | ), 72 | ); 73 | }, $class; 74 | } 75 | 76 | sub clone { 77 | my ($fn) = @_; 78 | bless sub { goto &$fn }, ref($fn); 79 | } 80 | 81 | sub unbox { $_[0] } 82 | 83 | 1; 84 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Compiler.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Compiler; 3 | 4 | use Lingy::Common; 5 | use Lingy::Symbol; 6 | use Lingy::HashMap; 7 | 8 | use constant DEF => symbol('def'); 9 | use constant LOOP => symbol('loop*'); 10 | use constant RECUR => symbol('recur'); 11 | use constant IF => symbol('if'); 12 | use constant CASE => symbol('case*'); 13 | use constant LET => symbol('let*'); 14 | use constant LETFN => symbol('letfn*'); 15 | use constant DO => symbol('do'); 16 | use constant FN => symbol('fn*'); 17 | use constant QUOTE => symbol('quote'); 18 | use constant THE_VAR => symbol('var'); 19 | use constant IMPORT => symbol('import*'); 20 | use constant DOT => symbol('.'); 21 | use constant ASSIGN => symbol('set!'); 22 | use constant DEFTYPE => symbol('deftype*'); 23 | use constant REIFY => symbol('reify*'); 24 | ### TRY_FINALLY 25 | use constant TRY => symbol('try'); 26 | use constant THROW => symbol('throw'); 27 | use constant MONITOR_ENTER => symbol('monitor-enter'); 28 | use constant MONITOR_EXIT => symbol('monitor-exit'); 29 | ### INSTANCE 30 | ### IDENTICAL 31 | ### THISFN 32 | use constant CATCH => symbol('catch'); 33 | use constant FINALLY => symbol('finally'); 34 | ### CLASS 35 | use constant NEW => symbol('new'); 36 | ### UNQUOTE 37 | ### UNQUOTE_SPLICING 38 | ### SYNTAX_QUOTE 39 | use constant _AMP_ => symbol('&'); 40 | 41 | 42 | use constant specials => HASHMAP->new([ 43 | DEF, nil, 44 | LOOP, nil, # change to loop* 45 | RECUR, nil, 46 | IF, nil, 47 | LET, nil, 48 | # LETFN, nil, 49 | DO, nil, 50 | FN, nil, 51 | QUOTE, nil, 52 | THE_VAR, nil, 53 | IMPORT, nil, 54 | DOT, nil, 55 | # ASSIGN, nil, 56 | # DEFTYPE, nil, 57 | # REIFY, nil, 58 | TRY, nil, 59 | THROW, nil, 60 | # MONITOR_ENTER, nil, 61 | # MONITOR_EXIT, nil, 62 | CATCH, nil, 63 | # FINALLY, nil, 64 | NEW, nil, 65 | # _AMP_, nil, 66 | 67 | # TODO Maybe add these: 68 | ### UNQUOTE 69 | ### UNQUOTE_SPLICING 70 | ### SYNTAX_QUOTE 71 | ]); 72 | 73 | 1; 74 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Env.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Env; 3 | 4 | use Lingy::Common; 5 | 6 | sub new { 7 | my ($class, %args) = @_; 8 | my $self = bless { 9 | outer => $args{outer}, 10 | space => $args{space} // {}, 11 | }, $class; 12 | my $binds = [ @{$args{binds} // []} ]; 13 | my $exprs = $args{exprs} // []; 14 | while (@$binds) { 15 | if ("$binds->[0]" eq '&') { 16 | shift @$binds; 17 | $exprs = [list([@$exprs])]; 18 | } 19 | $self->{space}{shift(@$binds)} = (shift(@$exprs) // nil); 20 | } 21 | if (my $outer = $self->{outer}) { 22 | $self->{LOOP} = $outer->{LOOP} if $outer->{LOOP}; 23 | $self->{RECUR} = $outer->{RECUR} if $outer->{RECUR}; 24 | } 25 | return $self; 26 | } 27 | 28 | sub set { 29 | my ($self, $symbol, $value) = @_; 30 | my $space = $self->{space}; 31 | $space->{$symbol} = $value; 32 | return ref($space) eq 'HASH' 33 | ? $symbol 34 | : symbol($space->_name . "/$symbol"); 35 | } 36 | 37 | sub get { 38 | my ($self, $symbol, $optional) = @_; 39 | 40 | # XXX Temporary hack until Vars 41 | if ("$symbol" eq '*ns*') { 42 | return RT->current_ns; 43 | } 44 | 45 | return $self->get_qualified($symbol, $optional) 46 | if $symbol =~ m{./.}; 47 | 48 | while ($self) { 49 | my $space = $self->{space}; 50 | if (defined(my $value = $space->{$symbol})) { 51 | return $value; 52 | } 53 | $self = $self->{outer}; 54 | } 55 | 56 | if (my $class = RT->current_ns->{"$symbol"}) { 57 | return $class; 58 | } 59 | 60 | return if $optional; 61 | 62 | err "Class not found: '$symbol'" 63 | if $symbol =~ /\w\.\w/; 64 | 65 | err "Unable to resolve symbol: '$symbol' in this context"; 66 | } 67 | 68 | sub get_qualified { 69 | my ($self, $symbol, $optional) = @_; 70 | 71 | $symbol =~ m{^(.*)/(.*)$} or die; 72 | my $space_name = $1; 73 | my $symbol_name = $2; 74 | 75 | if (my $ns = RT->core_ns) { 76 | if (my $class = RT->core_ns->{$space_name}) { 77 | return \&{"${class}::$symbol_name"}; 78 | } 79 | } 80 | if (my $class = RT->current_ns->{$space_name}) { 81 | return \&{"${class}::$symbol_name"}; 82 | } 83 | 84 | my $ns = RT->namespaces->{$space_name} 85 | or err "No such namespace: '$space_name'"; 86 | 87 | if (defined(my $value = $ns->{$symbol_name})) { 88 | return $value; 89 | } 90 | 91 | return if $optional; 92 | 93 | err "Unable to resolve symbol: '$symbol' in this context"; 94 | } 95 | 96 | 1; 97 | -------------------------------------------------------------------------------- /perl/test/lib/DistTestFixer.pm: -------------------------------------------------------------------------------- 1 | package DistTestFixer; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Config; 7 | use File::Spec; 8 | use File::Find; 9 | use File::Path; 10 | 11 | sub fix { 12 | my ($class, $bin_name, $perl_bin_name) = @_; 13 | $perl_bin_name //= $bin_name; 14 | 15 | my $postamble = ''; 16 | if ( $^O eq 'MSWin32' ) { 17 | my $inc = File::Spec->catdir('inc', 'bin'); 18 | if (not -d $inc) { 19 | File::Path::make_path($inc); 20 | 21 | my $perl_path = File::Spec->catfile($Config::Config{'installbin'}, 'perl'); 22 | my $cpan_bin_path = File::Spec->catfile($inc, "$bin_name-cpan"); 23 | my $cpan_cmd_path = File::Spec->catfile($inc, "$bin_name-cpan.cmd"); 24 | my $perl_bin_path = File::Spec->catfile('bin', $perl_bin_name); 25 | 26 | file_write($cpan_cmd_path, qq{if exist "%~dpn0" perl %0 %*$/}); 27 | 28 | my $text = file_read($perl_bin_path); 29 | file_write($cpan_bin_path, "#!$perl_path\n$text", 0777); 30 | 31 | for my $file (file_find('t', qr/\.t$/)) { 32 | my $text = file_read($file); 33 | if ($text =~ /\A.*$bin_name/) { 34 | file_write($file, qq{#!$cpan_bin_path$/$text}); 35 | } 36 | } 37 | } 38 | 39 | $postamble = <<'...'; 40 | export PATH := blib\script;$(PATH) 41 | 42 | PERLPATH := $(FULLPERLRUN:"%"=%) 43 | 44 | pure_all :: 45 | $(NOECHO) $(FULLPERLRUN) -p0i.bak -e "s(\$$PERL\b)($(PERLPATH))" blib\script\$bin_name 46 | ... 47 | } 48 | 49 | else { 50 | $postamble = <<'...'; 51 | PERLPATH := $(FULLPERLRUN:"%"=%) 52 | 53 | FULLPERLRUN := PATH=blib/script:$(PATH) $(PERLPATH) 54 | 55 | pure_all :: 56 | $(NOECHO) $(FULLPERLRUN) -p0i -e 's(\$$PERL\b)($(PERLPATH))' blib/script/$bin_name 57 | ... 58 | } 59 | 60 | $postamble =~ s/\$bin_name/$bin_name/; 61 | 62 | return $postamble; 63 | } 64 | 65 | sub file_find { 66 | my ($dir, $pat) = @_; 67 | my @files; 68 | File::Find::find { 69 | wanted => sub { 70 | if (-f and $_ =~ $pat) { 71 | push @files, $_; 72 | } 73 | }, 74 | no_chdir => 1, 75 | }, $dir; 76 | return @files; 77 | } 78 | 79 | sub file_read { 80 | my ($file) = @_; 81 | open my $fh, '<', $file or die $!; 82 | my $text = do { local $/; <$fh> }; 83 | close $fh; 84 | return $text; 85 | } 86 | 87 | sub file_write { 88 | my ($file, $text, $mode) = @_; 89 | open my $out, '>', $file or die $!; 90 | print $out $text; 91 | close $out; 92 | chmod $mode, $file if $mode; 93 | return 1; 94 | } 95 | 96 | 1; 97 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Printer.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Printer; 3 | 4 | use Lingy::Common; 5 | 6 | use Scalar::Util 'blessed'; 7 | use Sub::Identify 'sub_name'; 8 | 9 | sub new { bless {}, shift } 10 | 11 | my $escape = { 12 | "\n" => "\\n", 13 | "\t" => "\\t", 14 | "\"" => "\\\"", 15 | "\\" => "\\\\", 16 | }; 17 | 18 | sub pr_invalid { 19 | my ($self, $o) = @_; 20 | Dump($o, "Don't know how to print perl (non Lingy::* object) value '$o'"); 21 | } 22 | 23 | sub pr_str { 24 | my ($self, $o, $raw) = (@_, 0); 25 | $o //= ''; 26 | my $type = ref $o; 27 | 28 | # Hack to allow map key strings to print like symbols: 29 | if (not $type and $o =~ /^($symbol_re|$namespace_re)$/) { 30 | $type = 'Lingy::KeySymbol'; 31 | } 32 | 33 | $type or return warn $self->pr_invalid($o); 34 | 35 | $type eq ATOM ? "(atom ${\ $self->pr_str($o->[0], $raw)})" : 36 | $type eq STRING ? $raw ? $$o : 37 | qq{"${local $_ = $$o; s/([\n\t\"\\])/$escape->{$1}/ge; \$_}"} : 38 | $type eq REGEX ? $raw ? $$o : 39 | qq{#"${local $_ = $$o; \ substr($_, 4, length($_) - 5)}"} : 40 | $type eq 'Lingy::KeySymbol' ? $o : 41 | $type eq SYMBOL ? $$o : 42 | $type eq KEYWORD ? $$o : 43 | $type eq NUMBER ? $$o : 44 | $type eq BOOLEAN ? $$o ? 'true' : 'false' : 45 | $type eq NIL ? 'nil' : 46 | $type eq VAR ? ("#'" . $$o) : 47 | $type eq CLASS ? $o->_name : 48 | $type eq CHARACTER ? $o->print($raw) : 49 | $type eq 'CODE' ? "#" : 50 | $type eq FUNCTION ? '#' : 51 | $type eq MACRO ? '#' : 52 | $type eq LIST ? 53 | "(${\ join(' ', map $self->pr_str($_, $raw), @$o)})" : 54 | $type eq VECTOR ? 55 | "[${\ join(' ', map $self->pr_str($_, $raw), @$o)}]" : 56 | $type eq HASHMAP ? 57 | "{${\ join(', ', map { 58 | my ($key, $val) = ($_, $o->{$_}); 59 | $key = 60 | ($key =~ /^:/) ? KEYWORD->new($key) : 61 | ($key =~ s/^\"//) ? STRING->new($key) : 62 | ($key =~ s/^(\S+) $/$1/) ? SYMBOL->new($key) : 63 | $key; 64 | ($self->pr_str($key, $raw) . ' ' . $self->pr_str($val, $raw)) 65 | } keys %$o)}}" : 66 | $type eq HASHSET ? 67 | "#{${\ join(' ', map { 68 | my $val = $o->{$_}; 69 | $self->pr_str($val, $raw); 70 | } keys %$o)}}" : 71 | $type =~ /^(?:(?:quasi|(?:splice_)?un)?quote|deref)$/ ? 72 | "(${$type=~s/_/-/g;\$type} ${\ $self->pr_str($o->[0], $raw)})" : 73 | $type eq 'Lingy::Env' ? '#' : 74 | $type eq 'lingy-internal' ? "" : 75 | (blessed($o) and $o->isa(NAMESPACE)) ? 76 | qq(#_name}>) : 77 | $self->pr_invalid($o); 78 | } 79 | 80 | 1; 81 | -------------------------------------------------------------------------------- /perl/test/01-mal.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | use Lingy::Common; 3 | 4 | my %plan = ( 5 | 2 => 14, # 14 6 | 3 => 28, # 31 7 | 4 => 187, # 178 8 | 5 => 4, # 8 9 | 6 => 53, # 65 10 | 7 => 144, # 147 11 | 8 => 54, # 65 12 | 9 => 137, # 139 13 | A => 91, # 108 14 | ); 15 | 16 | my @files = sort 17 | -d 'test' ? glob("test/mal/*.yaml") : 18 | -d 't' ? glob("t/mal/*.yaml") : 19 | die "Can't find test directory"; 20 | 21 | if (my $step = $ENV{LINGY_TEST_MAL_STEP}) { 22 | @files = grep /$step/, @files; 23 | } 24 | 25 | my $runtime = Lingy::RT->init; 26 | 27 | for my $file (@files) { 28 | $file =~ /step(.)/ or die; 29 | my $n = $1; 30 | 31 | subtest $file => sub { 32 | plan tests => $plan{$n}; 33 | 34 | my @tests = read_yaml_test_file($file); 35 | 36 | for my $test (@tests) { 37 | my ($expr, $got, $want, $like, $out, $err); 38 | if (my $note = $test->{note}) { 39 | note $note; 40 | } 41 | ($out) = capture( 42 | sub { 43 | for (@{$test->{expr}}) { 44 | $expr .= $_; 45 | my @got = eval { $runtime->rep($_) }; 46 | if ($@) { 47 | die $@ if $@ =~ /(^>>|^---\s| via package ")/; 48 | $err .= ref($@) 49 | ? "Error: " . RT->printer->pr_str($@) 50 | : $@; 51 | } 52 | $got = $got[0]; 53 | } 54 | }, 55 | ); 56 | 57 | chomp $expr; 58 | $expr =~ s/\n/\\n/g; 59 | 60 | if (my $like = $test->{like}) { 61 | $like = join '(?s:.*)', map {chomp; $_} @$like; 62 | $like = qr<^$like$>; 63 | 64 | if (defined $err) { 65 | chomp $err; 66 | like $err, $like, 67 | sprintf("e %-40s -> ERROR: '%s'", "'$expr'", $like); 68 | } else { 69 | like $out, $like, 70 | sprintf("o %-40s -> '%s'", "'$expr'", $like); 71 | } 72 | } elsif (defined $err and not $test->{eok}) { 73 | XXX $test, { 74 | expr=>$expr, 75 | got=>$got, 76 | want=>$want, 77 | like=>$like, 78 | out=>$out, 79 | err=>$err, 80 | }; 81 | } 82 | 83 | if (length($got) and $want = $test->{want}) { 84 | $want = $want->[0]; 85 | chomp $want; 86 | is $got, $want, 87 | sprintf("%-40s -> '%s'", "'$expr'", $want); 88 | } 89 | } 90 | } 91 | } 92 | 93 | sub read_yaml_test_file { 94 | require YAML::PP; 95 | my ($file) = @_; 96 | 97 | my $tests = YAML::PP::LoadFile($file); 98 | 99 | map { 100 | my $t = {}; 101 | $t->{note} = $_->{say} if defined $_->{say}; 102 | $t->{expr} = ref($_->{mal}) ? $_->{mal} : [ $_->{mal} ] 103 | if defined $_->{mal}; 104 | $t->{want} = ref($_->{out}) ? $_->{out} : [ $_->{out} ] 105 | if defined $_->{out}; 106 | $t->{like} = ref($_->{err}) ? $_->{err} : [ $_->{err} ] 107 | if defined $_->{err}; 108 | $t->{eok} = defined($_->{eok}); 109 | defined($t->{expr}) ? ($t) : (); 110 | } @$tests; 111 | } 112 | -------------------------------------------------------------------------------- /perl/test/61-interop.t: -------------------------------------------------------------------------------- 1 | use Lingy::Test; 2 | 3 | tests <<"..."; 4 | - rep: | 5 | (use 'lingy.devel) 6 | 7 | - - | 8 | (import Foo.Class) 9 | - Foo.Class 10 | 11 | - - | 12 | (. Foo.Class foo) 13 | - 42 14 | 15 | - - | 16 | (. Foo.Class new) 17 | - /perl/hash:Foo::Class/ 18 | 19 | - - | 20 | (Foo.Class.) 21 | - /perl/hash:Foo::Class/ 22 | 23 | - - | 24 | (Foo.Class/new) 25 | - /perl/hash:Foo::Class/ 26 | 27 | - - | 28 | (.add Foo.Class 3 4) 29 | - 7 30 | 31 | - - | 32 | (def f (Foo.Class. "bar" "haha")) 33 | - user/f 34 | 35 | - - (.bar f) 36 | - '"haha"' 37 | 38 | - - (.sleep Thread 0) 39 | - nil 40 | 41 | - - (macroexpand '(Thread/sleep 100000)) 42 | - (. Thread sleep 100000) 43 | 44 | - - (macroexpand '(lingy.lang.Thread/sleep 100000)) 45 | - (. lingy.lang.Thread sleep 100000) 46 | 47 | - - (require 'Foo.Bar) 48 | - nil 49 | - - (macroexpand '(Foo.Bar/bar)) 50 | - (Foo.Bar/bar) 51 | ... 52 | 53 | __DATA__ 54 | 55 | 56 | # Perl and Lingy Modules 57 | 58 | Modules (files) used by Lingy can be: 59 | 60 | - A Lingy source file (.ly) 61 | - (ns module.name) 62 | - (require 'Foo.Bar) 63 | - (refer 'Foo.Bar) 64 | 65 | - A Class Perl module 66 | - ->can('new') determines if module is a class 67 | - (import Foo.Bar) # Returns a Foo.Bar class 68 | - (Foo.Bar. :x 1 :y 2) # new 69 | 70 | - A Functional (non-OO) Perl module 71 | - Has no ->can('new') 72 | - (import Foo.Bar) # Returns nil 73 | 74 | 75 | # Macro Expansions 76 | 77 | 78 | - If a fully qualified symbol if used as a function and the namespace part is a 79 | class 80 | - (macroexpand '(Long/toString 123)) -> (. Long toString 123) 81 | - If namespace part is not a class is doesn't expand 82 | - (macroexpand '(Wrong/toString 123)) -> (Wrong/toString 123) 83 | - Therefore at runtime we can consider Xyz/fn1 to be a function call in the Xyz 84 | Perl module if 'Xyz' is not a namespace but is a loaded module 85 | - We need to keep a table of such modules 86 | 87 | - Object instantiation 88 | - (Foo.Bar. :x 1 :y 2) -> (new Foo.Bar :x 1 :y 2) 89 | - Method calls 90 | - (.foo xyz 4 5) -> (. xyz foo 4 5) 91 | - Chained method calls 92 | - (.. Float (sum 4 5) toString toUpperCase) -> 93 | (. (. (. Float (sum 4 5)) toString) toUpperCase) 94 | - Multiple calls on same object 95 | - (macroexpand '(doto (java.util.Stack.) (.push 1) (.push 2))) -> 96 | (let* [G__2676 (java.util.Stack.)] (.push G__2676 1) (.push G__2676 2) G__2676) 97 | 98 | - Instance Accessors get and set 99 | - (.x pt) # get 100 | - (set! (.x pt) 10) # set 101 | - In perl we can probabley use a method call for set 102 | (.x pt 10) 103 | - Also: 104 | - (.-instanceField instance) -> (. instance -instanceField) 105 | - Use - (or maybe : ) as prefix for instance fields 106 | - See https://clojure.org/reference/java_interop#_the_dot_special_form 107 | 108 | - These both produce 3.141592653589793 109 | - Math/PI 110 | - (Math/PI) 111 | - Expands to: (. Math PI) 112 | 113 | # Core Functions for Namespaces and Classes 114 | 115 | - new 116 | - instance? 117 | 118 | - class Returns the Class of x 119 | - class? Returns true if x is an instance of Class 120 | - gen-class Generate a Perl "class" 121 | 122 | - *ns* 123 | - all-ns 124 | - create-ns 125 | - find-ns 126 | - in-ns 127 | - ns 128 | - ns-aliases 129 | - ns-imports 130 | - ns-interns 131 | - ns-map 132 | - ns-name 133 | - ns-publics 134 | - ns-refers 135 | - ns-resolve 136 | - ns-unalias 137 | - ns-unmap 138 | - remove-ns 139 | - the-ns 140 | 141 | 142 | 143 | # Imports 144 | - lingy.lang.* classes ar automatically imported 145 | -------------------------------------------------------------------------------- /perl/lib/Lingy/ClojureREPL.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::ClojureREPL; 3 | 4 | use File::Which; 5 | use IO::Select; 6 | use IPC::Open3; 7 | use Symbol 'gensym'; 8 | use Time::HiRes 'usleep'; 9 | use XXX; 10 | 11 | my $done = '3416ebc19a42578b8ebc3f59ea1806266cea4290'; 12 | my $pid; 13 | my ($in, $out, $err); 14 | my ($select_out, $select_err); 15 | 16 | my $Y = "\e[0;33m"; 17 | my $Z = "\e[0m"; 18 | 19 | my $clojure_jar = $ENV{LINGY_CLOJURE_JAR}; 20 | my $already_searched = 0; 21 | my $main_repl = <<'...'; 22 | (require '[clojure.main :as main]) 23 | (use 'clojure.repl 24 | ' clojure.pprint) 25 | (apply main/repl [ 26 | :prompt #() 27 | :caught (fn [e] 28 | (let [ 29 | e-via (binding 30 | [ *data-readers* {'error identity} ] 31 | (let [ err-data (read-string (pr-str e))] 32 | (:via err-data))) 33 | [m1 m2 m3] e-via ] 34 | (if m1 (println (:message m1))) 35 | (if m2 (println (:message m2)))))]) 36 | ... 37 | # ... 38 | my $server_opt = 39 | '-Dclojure.server.repl=' . 40 | '{:port 5555 :accept clojure.core.server/repl}'; 41 | 42 | sub start { 43 | my ($class, $newline) = @_; 44 | if (not $clojure_jar) { 45 | return if $already_searched++; 46 | my $file = which('clojure') or do { 47 | print "${Y}Can't find 'clojure' on this system$Z\n"; 48 | return; 49 | }; 50 | open my $fh, $file or 51 | die "Can't open '$file' for input: $!"; 52 | my $text = do {local $/; <$fh>}; 53 | $text =~ /java -cp +(.+?\.jar)/ or do { 54 | print "${Y}Can't find the Clojure jar file on this system.$Z\n"; 55 | print "${Y}Try setting the LINGY_CLOJURE_JAR env variable.$Z\n"; 56 | return; 57 | }; 58 | $clojure_jar = $1; 59 | } 60 | 61 | $pid = open3( 62 | $in, 63 | $out, 64 | $err = gensym, 65 | ( 66 | 'java', '-cp', $clojure_jar, 67 | $server_opt, 68 | 'clojure.main', 69 | '-e', $main_repl, 70 | ) 71 | ); 72 | 73 | print "\n" if $newline; 74 | print "$Y*** Started Clojure REPL server ($pid)$Z\n\n"; 75 | 76 | $select_out = new IO::Select(); 77 | $select_out->add($out); 78 | $select_err = new IO::Select(); 79 | $select_err->add($err); 80 | } 81 | 82 | sub rep { 83 | my ($class, $input) = @_; 84 | $class->start(1) unless $pid; 85 | return unless $pid; 86 | 87 | return if $input =~ /^\s*\(\s*clojure-repl-on\s*\)\s*$/; 88 | 89 | print $in qq<$input\n"$done"\n>; 90 | 91 | my $output = ''; 92 | my $string = ''; 93 | my $count = 0; 94 | my $rc = 0; 95 | 96 | usleep 500_000; 97 | while (1) { 98 | if ($select_out->can_read(0)) { 99 | sysread($out, $string, 4096); 100 | $output .= $string // ''; 101 | last if $output =~ s/"$done"\n+//; 102 | } 103 | if ($select_err->can_read(0)) { 104 | sysread($err, $string, 4096); 105 | $output .= $string // ''; 106 | last; 107 | } 108 | 109 | if (++$count >= 3) { 110 | $output = 'timeout'; 111 | kill -9, $pid; 112 | print "$Y*** Killed Clojure REPL server ($pid)$Z\n"; 113 | undef $pid; 114 | $rc = 255; 115 | last; 116 | } 117 | 118 | usleep 500_000; 119 | } 120 | 121 | $output =~ s/\n*\z//; 122 | $output .= "\n" if length $output; 123 | 124 | print STDOUT "${Y}Clojure:$Z\n$output\n"; 125 | } 126 | 127 | END { 128 | if (defined $pid) { 129 | print $in '(java.lang.System/exit 0)', "\n"; 130 | waitpid( $pid, 0 ); 131 | my $rc = $? >> 8; 132 | print "$Y*** Stopped Clojure REPL server ($pid)$Z\n"; 133 | exit $rc unless $rc == 0; 134 | } 135 | } 136 | 137 | 1; 138 | -------------------------------------------------------------------------------- /perl/tool/compile-clojure-core: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use lib 'lib'; 7 | 8 | use Lingy::RT; 9 | 10 | use XXX; 11 | 12 | my $want; 13 | 14 | $want = qr/(?: 15 | (?:\A\(defn|defmacro|def) (?=\ |\n) | 16 | (?:\A\#_) 17 | )/x; 18 | 19 | my @def = qw( 20 | first 21 | instance? 22 | map? 23 | nfirst 24 | nnext 25 | rest 26 | second 27 | string? 28 | vector? 29 | ); 30 | 31 | my @defn = qw( 32 | + - * / 33 | < > <= >= 34 | = 35 | == 36 | boolean 37 | boolean? 38 | cast 39 | char 40 | class? 41 | clojure-version 42 | contains? 43 | count 44 | dec 45 | empty? 46 | false? 47 | ffirst 48 | fn? 49 | fnext 50 | identity 51 | inc 52 | keys 53 | keyword? 54 | list? 55 | nil? 56 | not 57 | not= 58 | number? 59 | pos? 60 | quot 61 | read-string 62 | rem 63 | some? 64 | special-symbol? 65 | symbol? 66 | true? 67 | vals 68 | zero? 69 | ); 70 | 71 | my @defmacro = qw( 72 | -> 73 | ->> 74 | and 75 | comment 76 | or 77 | time 78 | when 79 | when-not 80 | ); 81 | 82 | my $want_def = join '|', map { 83 | s/([\?\*\/\+])/\\$1/g; 84 | $_; 85 | } @def; 86 | 87 | my $want_defn = join '|', map { 88 | s/([\?\*\/\+])/\\$1/g; 89 | $_; 90 | } @defn; 91 | 92 | my $want_defmacro = join '|', map { 93 | s/([\?\*\/\+])/\\$1/g; 94 | $_; 95 | } @defmacro; 96 | 97 | $want = qr/\A(?: 98 | \(defn\s+(?:$want_defn)\n 99 | | \(defmacro\s*.*\s+(?:$want_defmacro)\n 100 | | \(def\n[\s\S]*\n\ (?:$want_def)\ \( 101 | )/x; 102 | 103 | sub main { 104 | $ENV{LINGY_BUILDING_CORE} = 1; 105 | 106 | Lingy::RT->init; 107 | 108 | my ($clojure_core_file, $clojure_core_source) = @_; 109 | 110 | my $code = Lingy::RT::slurp('/tmp/clojure/core.clj'); 111 | 112 | my $out = <<"..."; 113 | ; ----------------------------------------------------------------------------- 114 | ; This file contains the current Lingy subset of Clojure's clojure/core.clj. 115 | ; It was generated directly from the original: 116 | ; 117 | ; $clojure_core_source 118 | ; 119 | ; This file contains the parts of clojure.core that Lingy can currently read 120 | ; and evaulate. Lingy will load this file into the lingy.core namespace along 121 | ; with the content of lib/Lingy/core.ly. 122 | ; 123 | ; The original Clojure copyright follows: 124 | ; ----------------------------------------------------------------------------- 125 | 126 | ... 127 | 128 | $code =~ s/\A(.*?\n)\n+(?=\()//s or die; 129 | 130 | $out .= "$1\n"; 131 | 132 | $code =~ s/\t/ /g; 133 | $code =~ s/ +$//gm; 134 | $code =~ s/^(;.*\n+)//gm; 135 | 136 | while (length $code) { 137 | $code =~ s/\A(;.*\n+)*//; 138 | $code =~ s/\A((?:\#_)?\(.*?\)\n+)(?=\(|;|\z)//s or XXX $code; 139 | 140 | my $def = $1; 141 | $def =~ s/\n+\z/\n/; 142 | 143 | if ($def !~ $want) { 144 | $def =~ s/^(.)/; $1/gm; 145 | $def =~ s/^\n/;\n/gm; 146 | #$out .= "\n; Skipping:\n$def"; 147 | next; 148 | } 149 | 150 | $def =~ s/clojure\.lang\.IPersistent(List|Vector)/lingy.lang.$1/g; 151 | $def =~ s/clojure\.lang\.IPersistent(Map|Set)/lingy.lang.Hash$1/g; 152 | $def =~ s/clojure\.(lang|core)([\.\/])/lingy.$1$2/g; 153 | 154 | eval { Lingy::RT->rep($def) }; 155 | my $error = $@; 156 | 157 | if (my $error = $@) { 158 | $def =~ s/^(.)/; $1/gm; 159 | $def =~ s/^\n/;\n/gm; 160 | $error =~ s/\s+\z//; 161 | $error =~ s/\n/\n;/g; 162 | $out .= <<"..."; 163 | 164 | ; *** $error 165 | $def 166 | ... 167 | next; 168 | } 169 | 170 | $out .= "\n$def"; 171 | } 172 | 173 | print $out; 174 | } 175 | 176 | main(@ARGV); 177 | -------------------------------------------------------------------------------- /perl/bin/lingy: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ### 4 | # This `lingy` CLI command tries to call the appropriate implementation. 5 | # Lingy has many implementations in many programming languages. 6 | # Each implementation should install this script along with a uniquely named 7 | # executable file. 8 | # The name should start with `_lingy`. 9 | # 10 | # If only one _lingy* executable is found in your PATH, exec that one. 11 | # Else if LINGY_EXEC is an absolute path to an executable, exec that one. 12 | # Else error with helpful message. 13 | ### 14 | 15 | # Bash strict: 16 | set -e -u -o pipefail 17 | 18 | LINGY_USAGE=" 19 | Usage: lingy [] [] 20 | 21 | Options: 22 | -e, --eval Eval a Lingy source string; print non-nil 23 | --repl Start Lingy REPL (default w/ no args) 24 | --run Run a Lingy program (default w/ file name) 25 | 26 | -D, --dev Load the lingy.devel library 27 | -C, --clj Enable Clojure mode in REPL 28 | 29 | --ppp Compile file and print AST (Lingy) 30 | --xxx Compile file and dump internal AST (YAML) 31 | 32 | --nrepl Start an nREPL server 33 | --execs List executables for setting LINGY_EXEC 34 | 35 | --version Print version 36 | -h, --help Print help and exit 37 | " 38 | 39 | main() { 40 | setup "$@" 41 | 42 | export LINGY_USAGE 43 | 44 | exec "$executable" "$@" 45 | } 46 | 47 | setup() { 48 | # Get the right _lingy in development env: 49 | local root 50 | root=$(cd "$(dirname "$0")/.." && pwd -P) 51 | if [[ -f $root/lib/Lingy.pm ]]; then 52 | export PATH=$root/bin:$root/script:$PATH 53 | export PERL5LIB=${PERL5LIB:+$PERL5LIB:}$root/lib 54 | fi 55 | 56 | for arg; do 57 | if [[ $arg == --execs ]]; then 58 | get-executables 59 | print-executables 60 | exit 0 61 | fi 62 | done 63 | 64 | get-executable 65 | } 66 | 67 | get-executable() { 68 | if [[ ${LINGY_EXEC-} ]]; then 69 | [[ $LINGY_EXEC == /* ]] || 70 | die "LINGY_EXEC set to '$LINGY_EXEC'." \ 71 | "Needs to be an absolute path." 72 | [[ -f $LINGY_EXEC ]] || 73 | die "LINGY_EXEC set to '$LINGY_EXEC'." \ 74 | "File not found." 75 | [[ -x $LINGY_EXEC ]] || 76 | die "LINGY_EXEC set to '$LINGY_EXEC'." \ 77 | "File is not executable." 78 | 79 | executable=$LINGY_EXEC 80 | 81 | return 82 | fi 83 | 84 | if [[ $0 == */* ]]; then 85 | executable=$( 86 | shopt -s nullglob 87 | printf '%s\n' "$(dirname "$0")/_lingy."* 88 | ) 89 | if [[ -f $executable ]]; then 90 | return 0 91 | fi 92 | fi 93 | 94 | get-executables 95 | 96 | [[ ${executables[*]:+"${executables[*]}"} ]] || 97 | die "Can't find any executables named '_lingy*' in your PATH." \ 98 | "You can specify one with 'export LINGY_EXEC=/path/to/_lingy.xxx'." 99 | 100 | if [[ ${#executables[*]} -gt 1 && ! ${LINGY_TEST-} ]]; then 101 | echo "Multiple _lingy* executables found." 102 | echo 103 | echo "Set 'export LINGY_EXEC=/path/to/_lingy.xxx' to one of:" 104 | echo 105 | print-executables 106 | echo 107 | echo "Using the first one..." 108 | echo 109 | fi 110 | 111 | executable=${executables[0]} 112 | } 113 | 114 | get-executables() { 115 | executables=() 116 | local line 117 | while IFS='' read -r line; do executables+=("$line"); done < <( 118 | # shellcheck disable=2046,2086 119 | find $(IFS=:; echo $PATH) \ 120 | -name '_lingy*' \ 121 | -type f \ 122 | 2>/dev/null | 123 | uniq | 124 | grep -v '\.plenv/versions/' | 125 | grep '^/' || true 126 | ) 127 | } 128 | 129 | print-executables() ( 130 | i=1 131 | for executable in "${executables[@]}"; do 132 | printf ' %d) %s\n' $((i++)) "$executable" 133 | done 134 | ) 135 | 136 | # To support CTL-C handling in the Perl Lingy Executable: 137 | export PERL_SIGNALS=unsafe 138 | 139 | # Define a 'die' function, used throughout: 140 | die() { printf '%s\n' "$*" >&2; exit 1; } 141 | 142 | [[ ${BASH_SOURCE[0]} != "$0" ]] || main "$@" 143 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Test.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Test; 3 | 4 | use base 'Exporter'; 5 | 6 | use Test::More; 7 | use YAML::PP; 8 | 9 | use Lingy; 10 | use Lingy::RT; 11 | use Lingy::Common; 12 | use Lingy::ReadLine; 13 | 14 | use Capture::Tiny qw'capture capture_merged'; 15 | use File::Temp 'tempfile'; 16 | 17 | BEGIN { 18 | $ENV{LINGY_TEST} //= 1; 19 | if (defined $INC{'Carp/Always.pm'}) { 20 | eval "no Carp::Always"; 21 | } 22 | } 23 | 24 | use lib 'lib', './test/lib', './t/lib'; 25 | 26 | symlink 't', 'test' if -d 't' and not -e 'test'; 27 | 28 | my $ypp = YAML::PP->new; 29 | 30 | our $gnu_readline = 31 | Term::ReadLine->new('')->ReadLine eq 'Term::ReadLine::Gnu'; 32 | 33 | RT->init; 34 | $Lingy::RT::OK = 0; 35 | 36 | our $lingy = 37 | -f './blib/script/lingy' ? './blib/script/lingy' : 38 | -f './bin/lingy' ? './bin/lingy' : 39 | undef; 40 | 41 | our $eg = 42 | -d 'eg' ? 'eg' : 43 | -d 'example' ? 'example' : 44 | die "Can't find eg/example directory"; 45 | 46 | our @EXPORT = qw< 47 | done_testing 48 | is 49 | like 50 | note 51 | pass 52 | plan 53 | subtest 54 | use_ok 55 | 56 | capture 57 | capture_merged 58 | tempfile 59 | 60 | $lingy 61 | $eg 62 | 63 | rep 64 | run_is 65 | test 66 | test_out 67 | tests 68 | 69 | PPP WWW XXX YYY ZZZ 70 | >; 71 | 72 | sub collapse; 73 | sub line; 74 | 75 | sub import { 76 | strict->import; 77 | warnings->import; 78 | shift->export_to_level(1, @_); 79 | } 80 | 81 | sub rep { 82 | RT->rep(@_); 83 | } 84 | 85 | sub tests { 86 | my ($spec) = @_; 87 | my $list = $ypp->load_string($spec); 88 | for my $elem (@$list) { 89 | if (ref($elem) eq 'HASH'){ 90 | my ($key, $val) = %$elem; 91 | no strict 'refs'; 92 | $key->($val); 93 | } else { 94 | test(@$elem); 95 | } 96 | } 97 | } 98 | 99 | # Test 'rep' for return value or error: 100 | my $test_i = 0; 101 | sub test { 102 | RT->nextID(10); 103 | $test_i++; 104 | if ($ENV{ONLY} and $ENV{ONLY} != $test_i) { 105 | return; 106 | } 107 | my ($input, $want, $label) = @_; 108 | $label //= "'${\ collapse $input}' -> '${\line $want}'"; 109 | 110 | $Lingy::RT::OK = 1; 111 | my $got = eval { join("\n", RT->rep($input)) }; 112 | $got = $@ if $@; 113 | chomp $got; 114 | 115 | $got =~ s/^Error: //; 116 | 117 | if (ref($want) eq 'Regexp') { 118 | like $got, $want, $label; 119 | } elsif ($want =~ s{^/(.*)/$}{$1}) { 120 | like $got, qr/$want/, $label; 121 | } else { 122 | is $got, $want, $label; 123 | } 124 | } 125 | 126 | sub test_out { 127 | my ($input, $want, $label) = @_; 128 | $label //= "'${\ collapse $input}' -> '${\line $want}'"; 129 | my ($got) = Capture::Tiny::capture_merged { 130 | RT->rep($input); 131 | }; 132 | chomp $got; 133 | chomp $want; 134 | 135 | $got =~ s/^Error: //; 136 | 137 | if (ref($want) eq 'Regexp') { 138 | like $got, $want, $label; 139 | } else { 140 | is $got, $want, $label; 141 | } 142 | } 143 | 144 | sub run_is { 145 | my ($cmd, $want, $label) = @_; 146 | $label //= "'$cmd' -> '$want'"; 147 | $label =~ s/\$cmd/$cmd/g; 148 | $label =~ s/\$want/$want/g; 149 | $label =~ s/\n/\\n/g; 150 | my $got = `( $cmd ) 2>&1`; 151 | chomp $got; 152 | if (ref($want) eq 'Regexp') { 153 | like $got, $want, $label; 154 | } else { 155 | chomp $got; 156 | is $got, $want, $label; 157 | } 158 | } 159 | 160 | sub collapse { 161 | local $_ = shift; 162 | s/\s\s+/ /g; 163 | s/^ //; 164 | chomp; 165 | $_; 166 | } 167 | 168 | sub line { 169 | local $_ = shift; 170 | s/\n/\\n/g; 171 | $_; 172 | } 173 | 174 | no warnings 'redefine'; 175 | 176 | my $done_testing = 0; 177 | sub done_testing { 178 | return if $done_testing++; 179 | goto &Test::More::done_testing; 180 | } 181 | 182 | END { 183 | package main; 184 | done_testing(); 185 | } 186 | 187 | 1; 188 | -------------------------------------------------------------------------------- /perl/test/mal/step8_macros.yaml: -------------------------------------------------------------------------------- 1 | - say: Testing trivial macros 2 | mal: 3 | - (defmacro! one (fn* [] 1)) 4 | - (one) 5 | out: 1 6 | 7 | - mal: 8 | - (defmacro! two (fn* [] 2)) 9 | - (two) 10 | out: 2 11 | 12 | 13 | - say: Testing unless macros 14 | mal: 15 | - (defmacro! unless (fn* [pred a b] `(if ~pred ~b ~a))) 16 | - (unless false 7 8) 17 | out: 7 18 | 19 | - mal: (unless true 7 8) 20 | out: 8 21 | 22 | - mal: 23 | - (defmacro! unless2 (fn* [pred a b] (list 'if (list 'not pred) a b))) 24 | - (unless2 false 7 8) 25 | out: 7 26 | 27 | - mal: (unless2 true 7 8) 28 | out: 8 29 | 30 | 31 | - say: Testing macroexpand 32 | mal: (macroexpand '(one)) 33 | out: 1 34 | 35 | - mal: (macroexpand '(unless PRED A B)) 36 | out: (if PRED B A) 37 | 38 | - mal: (macroexpand '(unless2 PRED A B)) 39 | out: (if (not PRED) A B) 40 | 41 | - mal: (macroexpand '(unless2 2 3 4)) 42 | out: (if (not 2) 3 4) 43 | 44 | 45 | - say: Testing evaluation of macro result 46 | mal: 47 | - (defmacro! identity (fn* [x] x)) 48 | - (let* [a 123] (macroexpand '(identity a))) 49 | out: a 50 | 51 | - mal: (let* [a 123] (identity a)) 52 | out: 123 53 | 54 | 55 | - say: Test that macros do not break empty list 56 | mal: () 57 | out: () 58 | 59 | 60 | - say: Test that macros do not break quasiquote 61 | mal: '`(1)' 62 | out: (1) 63 | 64 | 65 | # -------- Deferrable Functionality -------- 66 | 67 | - say: Testing non-macro function 68 | mal: (not (= 1 1)) 69 | out: 'false' 70 | 71 | # This should fail if it is a macro 72 | - mal: (not (= 1 2)) 73 | out: 'true' 74 | 75 | 76 | - say: Testing nth, first and rest functions 77 | mal: (nth (list 1) 0) 78 | out: 1 79 | 80 | - mal: (nth (list 1 2) 1) 81 | out: 2 82 | 83 | - mal: (nth (list 1 2 nil) 2) 84 | out: nil 85 | 86 | - mal: 87 | - (def x "x") 88 | - (def x (nth (list 1 2) 2)) 89 | - x 90 | out: '"x"' 91 | eok: true 92 | 93 | - mal: (first (list)) 94 | out: nil 95 | 96 | - mal: (first (list 6)) 97 | out: 6 98 | 99 | - mal: (first (list 7 8 9)) 100 | out: 7 101 | 102 | - mal: (rest (list)) 103 | out: () 104 | 105 | - mal: (rest (list 6)) 106 | out: () 107 | 108 | - mal: (rest (list 7 8 9)) 109 | out: (8 9) 110 | 111 | 112 | - say: Testing cond macro 113 | mal: (macroexpand '(cond)) 114 | out: nil 115 | 116 | - mal: (cond) 117 | out: nil 118 | 119 | - mal: (macroexpand '(cond X Y)) 120 | out: (if X Y (cond)) 121 | 122 | - mal: (cond true 7) 123 | out: 7 124 | 125 | - mal: (cond false 7) 126 | out: nil 127 | 128 | - mal: (macroexpand '(cond X Y Z T)) 129 | out: (if X Y (cond Z T)) 130 | 131 | - mal: (cond true 7 true 8) 132 | out: 7 133 | 134 | - mal: (cond false 7 true 8) 135 | out: 8 136 | 137 | - mal: (cond false 7 false 8 "else" 9) 138 | out: 9 139 | 140 | - mal: (cond false 7 (= 2 2) 8 "else" 9) 141 | out: 8 142 | 143 | - mal: (cond false 7 false 8 false 9) 144 | out: nil 145 | 146 | 147 | - say: Testing EVAL in let* 148 | mal: (let* [x (cond false "no" true "yes")] x) 149 | out: '"yes"' 150 | 151 | 152 | - say: Testing nth, first, rest with vectors 153 | mal: (nth [1] 0) 154 | out: 1 155 | 156 | - mal: (nth [1 2] 1) 157 | out: 2 158 | 159 | - mal: (nth [1 2 nil] 2) 160 | out: nil 161 | 162 | - mal: 163 | - (def x "x") 164 | - (def x (nth [1 2] 2)) 165 | - x 166 | out: '"x"' 167 | eok: true 168 | 169 | - mal: (first []) 170 | out: nil 171 | 172 | - mal: (first nil) 173 | out: nil 174 | 175 | - mal: (first [10]) 176 | out: 10 177 | 178 | - mal: (first [10 11 12]) 179 | out: 10 180 | 181 | - mal: (rest []) 182 | out: () 183 | 184 | - mal: (rest nil) 185 | out: () 186 | 187 | - mal: (rest [10]) 188 | out: () 189 | 190 | - mal: (rest [10 11 12]) 191 | out: (11 12) 192 | 193 | - mal: (rest (cons 10 [11 12])) 194 | out: (11 12) 195 | 196 | 197 | - say: Testing EVAL in vector let* 198 | mal: (let* [x (cond false "no" true "yes")] x) 199 | out: '"yes"' 200 | 201 | 202 | # ------- Optional Functionality -------------- 203 | 204 | - say: Test that macros use closures 205 | - mal: 206 | - (def x 2) 207 | - (defmacro! a (fn* [] x)) 208 | - (a) 209 | out: 2 210 | 211 | - mal: (let* [x 3] (a)) 212 | out: 2 213 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Main.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Main; 3 | 4 | use Lingy::RT; 5 | use Lingy::Common; 6 | 7 | use Getopt::Long; 8 | 9 | use constant default => '--repl'; 10 | use constant options => +{ 11 | 'clj|C' => 'bool', 12 | 'dev|D' => 'bool', 13 | 'eval|e' => 'str', 14 | nrepl => 'bool', 15 | ppp => 'bool', 16 | repl => 'bool', 17 | run => 'arg', 18 | version => 'bool', 19 | xxx => 'bool', 20 | }; 21 | 22 | 23 | sub new { 24 | my $class = shift; 25 | 26 | bless { 27 | map( ($_, undef), keys %{$class->options} ), 28 | @_, 29 | }, $class; 30 | } 31 | 32 | sub run { 33 | my ($self, @args) = @_; 34 | 35 | $self->getopt(@args); 36 | 37 | my ($repl, $run, $eval, $version, $clj, $dev, $nrepl, $args) = 38 | @{$self}{qw}; 39 | local @ARGV = @$args; 40 | 41 | return $self->do_nrepl if $nrepl; 42 | 43 | RT->init; 44 | RT->rep(qq<(clojure-repl-on)>) if $clj; 45 | RT->rep(qq<(use 'lingy.devel)>) if $dev; 46 | 47 | $version ? $self->do_version : 48 | $eval ? $self->do_eval : 49 | $repl ? $self->do_repl : 50 | $run ? $self->do_run : 51 | $self->do_repl; 52 | } 53 | 54 | sub do_version { 55 | RT->rep( 56 | '(println (str "Lingy [" *HOST* "] version " (lingy-version)))', 57 | ); 58 | } 59 | 60 | sub do_eval { 61 | my ($self) = @_; 62 | my ($repl, $eval, $ppp, $xxx) = 63 | @{$self}{qw}; 64 | 65 | if ($repl) { 66 | RT->rep(qq<(do $eval\n)>); 67 | RT->repl; 68 | } else { 69 | if ($ppp) { 70 | RT->rep(qq<(use 'lingy.devel) (PPP (quote $eval\n))>); 71 | } elsif ($xxx) { 72 | RT->rep(qq<(use 'lingy.devel) (XXX (quote $eval\n))>); 73 | } else { 74 | unshift @ARGV, '-'; 75 | map print("$_\n"), 76 | grep $_ ne 'nil', 77 | RT->rep($eval); 78 | } 79 | } 80 | } 81 | 82 | sub do_nrepl { 83 | my ($self) = @_; 84 | require Lingy::nREPL; 85 | Lingy::nREPL->new->start->run; 86 | } 87 | 88 | sub do_repl { 89 | RT->repl; 90 | } 91 | 92 | sub do_run { 93 | my ($self) = @_; 94 | my $run = $self->{run}; 95 | if ($run ne '/dev/stdin') { 96 | -f $run or err "No such file '$run'"; 97 | } 98 | RT->rep(qq<(load-file "$run")>); 99 | } 100 | 101 | sub from_stdin { 102 | not -t STDIN or exists $ENV{LINGY_TEST_STDIN}; 103 | } 104 | 105 | sub getopt { 106 | my ($self, @args) = @_; 107 | 108 | my $default = $self->default; 109 | 110 | if ($default and not(@args or $self->from_stdin)) { 111 | @args = ($default); 112 | } 113 | 114 | local @ARGV = @args; 115 | 116 | my $spec = {}; 117 | my $opts = $self->options; 118 | for my $key (keys %$opts) { 119 | (my $name = $key) =~ s/\|.*//; 120 | my $type = $opts->{$key}; 121 | if ($type eq 'bool') { 122 | $spec->{$key} = \$self->{$name}; 123 | } 124 | elsif ($type eq 'str') { 125 | $spec->{"$key=s"} = \$self->{$name}; 126 | } 127 | elsif ($type eq 'arg') { 128 | } 129 | else { 130 | err "Option type '$type' not supported"; 131 | } 132 | } 133 | 134 | $spec->{help} = sub { 135 | print $ENV{LINGY_USAGE}; 136 | exit 0; 137 | }; 138 | 139 | Getopt::Long::Configure(qw( 140 | gnu_getopt 141 | no_auto_abbrev 142 | no_ignore_case 143 | )); 144 | eval { 145 | GetOptions (%$spec) or 146 | err "Error in command line arguments"; 147 | }; 148 | die "$@$ENV{LINGY_USAGE}" if $@; 149 | 150 | if (@ARGV) { 151 | if ($self->{repl}) { 152 | unshift @ARGV, 'NO_SOURCE_PATH'; 153 | } else { 154 | $self->{run} = $ARGV[0]; 155 | $self->{run} = '/dev/stdin' 156 | if $self->{run} eq '-'; 157 | } 158 | } else { 159 | if ($self->from_stdin) { 160 | $self->{run} = '/dev/stdin'; 161 | unshift @ARGV, ''; 162 | } else { 163 | unshift @ARGV, 'NO_SOURCE_PATH'; 164 | } 165 | } 166 | 167 | $self->{args} = [@ARGV]; 168 | } 169 | 170 | 1; 171 | -------------------------------------------------------------------------------- /perl/lib/Lingy/ReadLine.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::ReadLine; 3 | 4 | use Lingy::Common; 5 | 6 | BEGIN { $ENV{PERL_RL} = 'Gnu' } 7 | use Term::ReadLine; 8 | 9 | my $home = $ENV{HOME}; 10 | 11 | sub history_file { 12 | my $history_file = "$ENV{PWD}/.lingy_history"; 13 | $history_file = "$home/.lingy_history" 14 | unless -w $history_file; 15 | return $history_file; 16 | } 17 | 18 | my $tty; 19 | my $tested = 0; 20 | my @input; 21 | my $prev_input = ''; 22 | my $sep = "\x01"; 23 | my $readline_class; 24 | my $multi = 0; 25 | 26 | sub multi_start {} 27 | sub multi_stop {} 28 | 29 | sub new { 30 | my ($class) = @_; 31 | my $self = bless {}, $class; 32 | } 33 | 34 | sub setup { 35 | my ($self) = @_; 36 | 37 | local @ENV{qw(HOME EDITOR)}; 38 | local $^W; 39 | undef $tty; 40 | $tty = Term::ReadLine->new('Lingy'); 41 | 42 | die "Please install Term::ReadLine::Gnu from CPAN\n" 43 | if $tty->ReadLine ne 'Term::ReadLine::Gnu'; 44 | 45 | $tty->ReadHistory($self->history_file); 46 | $tty->SetHistory( 47 | map { 48 | s/$sep/\n/g; $prev_input = $_; 49 | } $tty->GetHistory 50 | ); 51 | $tty->MinLine(undef); 52 | 53 | return $self; 54 | } 55 | 56 | $SIG{TSTP} = sub { 57 | warn "\nCTL-Z disabled in this REPL\n"; 58 | }; 59 | 60 | sub input { 61 | return unless @input; 62 | my $input = join "\n", @input; 63 | if ($input =~ s/\ +\z//) { 64 | $input =~ s/\n/ /g; 65 | $input =~ s/\s+/ /g; 66 | } 67 | if ($input =~ /\S/ and $input ne $prev_input) { 68 | $tty->addhistory($input); 69 | $prev_input = $input; 70 | } 71 | return $input; 72 | } 73 | 74 | sub readline { 75 | if (my $test_input = $ENV{LINGY_TEST_INPUT}) { 76 | return if $tested++; 77 | return $test_input; 78 | } 79 | 80 | my ($self, $continue) = @_; 81 | $readline_class = ref($self); 82 | 83 | my $prompt = RT->current_ns_name or die; 84 | if ($continue) { 85 | no warnings 'numeric'; 86 | $prompt = (' ' x (length($prompt) - 2)) . '#_'; 87 | } 88 | else { 89 | @input = (); 90 | } 91 | $prompt .= '=> '; 92 | 93 | $tty->ornaments(0); 94 | 95 | local $SIG{INT} = sub { 96 | print("\n"); 97 | $tty->replace_line('', 0); 98 | $tty->on_new_line; 99 | $tty->redisplay; 100 | }; 101 | 102 | $tty->parse_and_bind($_) for ( 103 | 'set blink-matching-paren on', 104 | 'set show-all-if-ambiguous on', 105 | ); 106 | 107 | $tty->Attribs->{completion_query_items} = 1000; 108 | $tty->Attribs->{completion_function} = \&complete; 109 | 110 | my $line = $tty->readline($prompt); 111 | return unless defined $line; 112 | $line =~ s/\s+\z// unless $line =~ /\ +\z/; 113 | push @input, $line; 114 | 115 | if ($self->multi_start($line)) { 116 | $prompt = (' ' x (length($prompt) - 5)) . '#_=> '; 117 | while (1) { 118 | my $more = $tty->readline($prompt); 119 | return unless defined $more; 120 | push @input, $more; 121 | $line .= "\n$more"; 122 | last if $self->multi_stop($more); 123 | } 124 | } 125 | 126 | return $line; 127 | } 128 | 129 | sub complete { 130 | my ($text, $line, $start) = @_; 131 | 132 | if ($text =~ m{^(\w+(\.\w+)*)/}) { 133 | my $prefix = $1; 134 | if (my $ns = RT->namespaces->{$prefix}) { 135 | return map "$prefix/$_", keys %$ns; 136 | } 137 | return; 138 | } 139 | 140 | my $space = RT->env->{space}; 141 | my @names = 142 | grep {not /^ /} ( 143 | keys(%$space), 144 | keys(%{RT->namespaces}), 145 | map { 146 | my $name = $_; 147 | $name =~ s/^Lingy::/lingy.lang./; 148 | $name =~ s/::/./g; 149 | my $long = $name; 150 | $name =~ s/.*\.//; 151 | ($long, $name); 152 | } @{RT->class_names}, 153 | ); 154 | 155 | grep /^\Q$text/, 156 | map { 157 | /^-\w/ ? () : 158 | ($text eq '' and /^(\w+\.)/) ? $1 : 159 | $_ 160 | } ( 161 | @names, 162 | Lingy::Evaluator->special_symbols, 163 | ); 164 | } 165 | 166 | END { 167 | if ($readline_class) { 168 | $tty->SetHistory(map { s/\n/$sep/g; $_ } $tty->GetHistory); 169 | $tty->WriteHistory($readline_class->history_file) 170 | unless $ENV{LINGY_TEST}; 171 | } 172 | } 173 | 174 | 1; 175 | -------------------------------------------------------------------------------- /perl/test/mal/step6_file.yaml: -------------------------------------------------------------------------------- 1 | # TODO: really a step5 test 2 | - say: Testing that (do (do)) not broken by TCO 3 | mal: (do (do 1 2)) 4 | out: 2 5 | 6 | 7 | - say: Testing read-string, eval and slurp 8 | mal: (read-string "(1 2 (3 4) nil)") 9 | out: (1 2 (3 4) nil) 10 | 11 | - mal: (= nil (read-string "nil")) 12 | out: 'true' 13 | 14 | - mal: (read-string "(+ 2 3)") 15 | out: (+ 2 3) 16 | 17 | - mal: (read-string "\"\n\"") 18 | out: '"\n"' 19 | 20 | - mal: (read-string "7 ;; comment") 21 | out: 7 22 | 23 | 24 | - say: Differing output, but make sure no fatal error 25 | mal: (read-string ";; comment") 26 | 27 | - mal: (eval (read-string "(+ 2 3)")) 28 | out: 5 29 | 30 | - mal: (slurp "test/mal/test.txt") 31 | out: '"A line of text\n"' 32 | 33 | 34 | - say: Load the same file twice. 35 | mal: (slurp "test/mal/test.txt") 36 | out: '"A line of text\n"' 37 | 38 | 39 | - say: Testing load-file 40 | mal: (load-file "test/mal/inc.mal") 41 | out: nil 42 | 43 | - mal: (inc1 7) 44 | out: 8 45 | 46 | - mal: (inc2 7) 47 | out: 9 48 | 49 | - mal: (inc3 9) 50 | out: 12 51 | 52 | 53 | - say: Testing atoms 54 | mal: (def inc3 (fn* [a] (+ 3 a))) 55 | 56 | - mal: (def a (atom 2)) 57 | out: user/a 58 | 59 | # DISABLED (atom? is not Clojure core function) 60 | # - mal: (atom? a) 61 | # out: 'true' 62 | 63 | # - mal: (atom? 1) 64 | # out: 'false' 65 | 66 | - mal: (deref a) 67 | out: 2 68 | 69 | - mal: (reset! a 3) 70 | out: 3 71 | 72 | - mal: (deref a) 73 | out: 3 74 | 75 | - mal: (swap! a inc3) 76 | out: 6 77 | 78 | - mal: (deref a) 79 | out: 6 80 | 81 | - mal: (swap! a (fn* [a] a)) 82 | out: 6 83 | 84 | - mal: (swap! a (fn* [a] (* 2 a))) 85 | out: 12 86 | 87 | - mal: (swap! a (fn* [a b] (* a b)) 10) 88 | out: 120 89 | 90 | - mal: (swap! a + 3) 91 | out: 123 92 | 93 | 94 | - say: Testing swap!/closure interaction 95 | mal: 96 | - (def inc-it (fn* [a] (+ 1 a))) 97 | - (def atm (atom 7)) 98 | - (def f (fn* [] (swap! atm inc-it))) 99 | - (f) 100 | out: 8 101 | 102 | - mal: (f) 103 | out: 9 104 | 105 | 106 | - say: Testing whether closures can retain atoms 107 | mal: 108 | - (def g (let* [atm (atom 0)] (fn* [] (deref atm)))) 109 | - (def atm (atom 1)) 110 | - (g) 111 | out: 0 112 | 113 | 114 | # -------- Deferrable Functionality -------- 115 | 116 | - say: Testing reading of large files 117 | mal: (load-file "test/mal/computations.mal") 118 | out: nil 119 | 120 | - mal: (sumdown 2) 121 | out: 3 122 | 123 | - mal: (fib 2) 124 | out: 1 125 | 126 | 127 | - say: Testing `@` reader macro (short for `deref`) 128 | mal: 129 | - (def atm (atom 9)) 130 | - '@atm' 131 | out: 9 132 | 133 | 134 | # TODO: really a step5 test 135 | - say: Testing that vector params not broken by TCO 136 | mal: 137 | - (def g (fn* [] 78)) 138 | - (g) 139 | out: 78 140 | 141 | - mal: (def g (fn* [a] (+ a 78))) 142 | - mal: (g 3) 143 | out: 81 144 | 145 | 146 | - say: Testing that *command-line-args* exists and is an empty list 147 | mal: (list? *command-line-args*) 148 | # out: 'true' 149 | out: 'false' 150 | 151 | - mal: '*command-line-args*' 152 | # out: () 153 | out: nil 154 | 155 | 156 | - say: Testing that eval sets aa in root scope, and that it is found in nested scope 157 | mal: (let* [b 12] (do (eval (read-string "(def aa 7)")) aa )) 158 | out: 7 159 | 160 | 161 | # -------- Optional Functionality -------- 162 | 163 | - say: Testing comments in a file 164 | mal: (load-file "test/mal/incB.mal") 165 | out: nil 166 | 167 | - mal: (inc4 7) 168 | out: 11 169 | 170 | - mal: (inc5 7) 171 | out: 12 172 | 173 | 174 | - say: Testing map literal across multiple lines in a file 175 | mal: (load-file "test/mal/incC.mal") 176 | out: nil 177 | 178 | - mal: mymap 179 | out: '{"a" 1}' 180 | 181 | 182 | - say: Checking that eval does not use local environments. 183 | mal: (def a 1) 184 | out: user/a 185 | 186 | - mal: (let* [a 2] (eval (read-string "a"))) 187 | out: 1 188 | 189 | 190 | - say: Non alphanumeric characters in comments in read-string 191 | mal: (read-string "1;!") 192 | out: 1 193 | 194 | - mal: (read-string "1;\"") 195 | out: 1 196 | 197 | - mal: (read-string "1;#") 198 | out: 1 199 | 200 | - mal: (read-string "1;$") 201 | out: 1 202 | 203 | - mal: (read-string "1;%") 204 | out: 1 205 | 206 | - mal: (read-string "1;'") 207 | out: 1 208 | 209 | - mal: (read-string "1;\\") 210 | out: 1 211 | 212 | - mal: (read-string "1;\\\\") 213 | out: 1 214 | 215 | - mal: (read-string "1;\\\\\\") 216 | out: 1 217 | 218 | - mal: (read-string "1;`") 219 | out: 1 220 | 221 | - say: Hopefully less problematic characters can be checked together 222 | mal: (read-string "1; &()*+,-./:;<=>?@[]^_{|}~") 223 | out: 1 224 | -------------------------------------------------------------------------------- /perl/Changes: -------------------------------------------------------------------------------- 1 | --- 2 | version: 0.1.19 3 | date: Tue Jul 25 08:20:23 AM PDT 2023 4 | changes: 5 | - Add initial nREPL server support 6 | - Add Peter Strömberg to authors 7 | - Don't run GHA tests twice for PRs pushed here 8 | - Make Term::ReadLine::Gnu an optional dependency 9 | --- 10 | version: 0.1.17 11 | date: Tue Jul 11 07:49:54 AM EDT 2023 12 | changes: 13 | - Add merge (and conj for hashmap) to core 14 | - Add unboxing to HashMap and Vector 15 | - Support LINGY_CLOJURE_JAR for using repl with clojure 16 | - Support boxing hashes and arrays 17 | - Set *file* to an absolute file path 18 | - A few small fixes 19 | --- 20 | version: 0.1.16 21 | date: Fri Jul 7 10:51:07 AM EDT 2023 22 | changes: 23 | - Small doc changes 24 | - Support multiline entries in REPL and history 25 | --- 26 | version: 0.1.15 27 | date: Tue Jun 27 06:01:17 PM EDT 2023 28 | changes: 29 | - Refactor RT in Common for subclassing 30 | --- 31 | version: 0.1.14 32 | date: Sun Jun 25 08:51:44 PM EDT 2023 33 | changes: 34 | - Make Lingy::HashMap subclass immutable::map 35 | --- 36 | version: 0.1.12 37 | date: Thu Jun 22 07:46:05 PM EDT 2023 38 | changes: 39 | - Add support for HashSet type 40 | - Add more legal regex escape sequences 41 | - Add reader support for vars 42 | - Refactor some RT function names 43 | - Fix and test with-meta 44 | - Fix method calls to Perl classes 45 | - Add 'time' macro to time expr evals 46 | - Add #_ reader macro (ignore next form) 47 | - Make bin/lingy smarter about multiples 48 | - Add support for `#?` reader conditionals 49 | - Get rid of non Clojure var *ARGV* (for now) 50 | - Update docs with "Differences from Clojure" section 51 | - Refactor map creation in reader 52 | - iAdd a couple tests 53 | - Implement Lingy.pm to use Lingy from Perl 54 | - Add doc for Lingy<->Perl interop 55 | - Start using Clojure source code in Lingy 56 | - Bash change to appease shellcheck 57 | - Fix file path conversion bug when loading clojure.core 58 | - Fix regex in DistTestFixer 59 | - Add lingy.string library (akin to clojure.string) 60 | - Add a 'binding' function (not quite accurate) 61 | --- 62 | version: 0.1.11 63 | date: Thu Jun 8 08:05:32 AM PDT 2023 64 | changes: 65 | - Error on unsupported escape characters 66 | - Take 'Error:' prefix out of error messages 67 | - Throw any errors from a perl eval 68 | - Return after printing unknown internal value 69 | - Add regexp escaping 70 | - Move all Lingy/Lang/*.pm to Lingy/*.pm 71 | - Refactor = and == to be more correct 72 | - Rename Lingy::Eval to Lingy::Evaluator 73 | - Keep refers pairs in namespace proper 74 | - Overall refactor and code cleanup 75 | --- 76 | version: 0.1.10 77 | date: Sun Jun 4 01:58:29 PM PDT 2023 78 | changes: 79 | - Remove Docker stuffs 80 | - Switch from Tie::IxHash to Tie::Ordered 81 | - Unbox booleans 82 | - Define a 'perl' core function 83 | - Fix bug printing namespace symbol mapping keys 84 | - Add applyTo function to RT 85 | --- 86 | version: 0.1.9 87 | date: Sat Jun 3 03:23:11 PM PDT 2023 88 | changes: 89 | - Improve Perl interop 90 | - Update --help usage text 91 | - Refactor Lingy::Main to better be subclassed 92 | - Fix import of lingy.lang.Foo modules 93 | - Major refactoring of namespacing 94 | - Convert lib/Lingy/Util.pm to lib/Lingy/devel.ly 95 | - Move Lingy::CLI to Lingy::Main 96 | - Move code from Lingy::Main in Lingy::Lang::RT 97 | - Rename Lingy/Lang/Function.pm to Fn.pm 98 | - Add 'declare' to core 99 | - Refactor all core foo? functions to use instance? 100 | - wip Refactor and test instance creation and checking 101 | - wip - interop 102 | - wip - Add 'new' special form 103 | - Add tests to test/55-require.t 104 | - Macroexpand (Foo. 42) to (. Foo new 42) 105 | - Add 'doto' macro to core.ly 106 | - Change --clojure to --clj 107 | - Refactor assoc to use recursive Lingy function 108 | - Make 'import*' be a special form 109 | - Make 'throw' be a special form (to match Clojure) 110 | - Add support for 'special-symbol?' function 111 | - Add support for anonymous lambda function reader macro 112 | - Add `lingy --version` support 113 | - Fixes for hash-map creation and assoc 114 | - Error on duplicate hash keys 115 | - Rework bin/lingy script 116 | - Rename Lingy::RT to Lingy::Main 117 | - Refactor most tests to be written in YAML 118 | - Get *lingy-version* info from $Lingy::VERSION 119 | - Replace def! with def 120 | - Fixes to get clojure-repl-on to work in YAMLScript 121 | --- 122 | version: 0.1.8 123 | date: Sat May 27 11:27:53 PM PDT 2023 124 | changes: 125 | - Update Meta yaml 126 | - Add test_list to Lingy::Test for YAML test specs 127 | - Add option for REPL to also call Clojure REPL 128 | --- 129 | version: 0.1.7 130 | date: Thu May 25 04:15:22 PM PDT 2023 131 | changes: 132 | - Add an eval-perl function to lingy.Util 133 | - Add some more basic core functions 134 | --- 135 | version: 0.1.6 136 | date: Thu May 25 08:49:11 AM PDT 2023 137 | changes: 138 | - Allow load-file to be overridden 139 | - Fix printer for regexes 140 | - Add substring and toLowerCase to Lingy.Lang.String 141 | - Refactor core functions 142 | --- 143 | version: 0.1.5 144 | date: Thu May 18 08:55:57 PM PDT 2023 145 | changes: 146 | - Rename/Reorder test files 147 | - Improve and test - namespaces & require, classes & import 148 | - Improve Perl interop 149 | --- 150 | version: 0.1.4 151 | date: Wed May 17 08:16:58 AM PDT 2023 152 | changes: 153 | - Use constants for class names 154 | - Doc changes 155 | - 99-bottles.ly correct English grammar changes 156 | --- 157 | version: 0.1.3 158 | date: Mon May 15 05:31:39 AM PDT 2023 159 | changes: 160 | - Lots of feature implementation 161 | --- 162 | version: 0.1.2 163 | date: Sun Apr 16 10:45:48 AM PDT 2023 164 | changes: 165 | - Major refactoring of Perl modules 166 | - Remove a 'find' option not supported on Mac 167 | - Adjust PATH for plenv paths 168 | - Fixes and testing for fizzbuzz.ly 169 | - Add list* to core 170 | - Rename class module names to be more like Clojure's 171 | - Improve ReadLine to handle classes and namespaces 172 | - Add lingy.lang.Class object support 173 | - Support keywords and vectors as functions 174 | - Add Character and Thread/sleep support 175 | --- 176 | version: 0.1.1 177 | date: Mon Apr 10 06:18:38 AM PDT 2023 178 | changes: 179 | - Lots of work on the Lingy language 180 | --- 181 | version: 0.1.0 182 | date: Thu Mar 16 09:32:31 AM PDT 2023 183 | changes: 184 | - Initial Release 185 | -------------------------------------------------------------------------------- /perl/lib/Lingy/Common.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::Common; 3 | 4 | use Exporter 'import'; 5 | 6 | use Scalar::Util qw'refaddr reftype'; 7 | 8 | # RT is the RunTime class accessor function. 9 | # 'Lingy::RT' or a subclass like 'YAMLScript::RT'. 10 | BEGIN { 11 | *RT = sub { 'Lingy::RT' } unless defined &RT; 12 | } 13 | 14 | # Base type classes: 15 | use constant LISTTYPE => 'Lingy::ListClass'; 16 | use constant SCALARTYPE => 'Lingy::ScalarClass'; 17 | use constant SEQUENTIAL => 'Lingy::Sequential'; 18 | 19 | # Type classes: 20 | use constant ATOM => 'Lingy::Atom'; 21 | use constant BOOLEAN => 'Lingy::Boolean'; 22 | use constant CHARACTER => 'Lingy::Character'; 23 | use constant CLASS => 'Lingy::Class'; 24 | use constant CLOJURE => 'Lingy::Clojure'; 25 | use constant COMPILER => 'Lingy::Compiler'; 26 | use constant FUNCTION => 'Lingy::Fn'; 27 | use constant HASHMAP => 'Lingy::HashMap'; 28 | use constant HASHSET => 'Lingy::HashSet'; 29 | use constant KEYWORD => 'Lingy::Keyword'; 30 | use constant LIST => 'Lingy::List'; 31 | use constant MACRO => 'Lingy::Macro'; 32 | use constant NIL => 'Lingy::Nil'; 33 | use constant NUMBER => 'Lingy::Number'; 34 | use constant REGEX => 'Lingy::Regex'; 35 | use constant STRBUILD => 'Lingy::StringBuilder'; 36 | use constant STRING => 'Lingy::String'; 37 | use constant SYMBOL => 'Lingy::Symbol'; 38 | use constant SYSTEM => 'Lingy::System'; 39 | use constant UTIL => 'Lingy::Util'; 40 | use constant VECTOR => 'Lingy::Vector'; 41 | use constant VAR => 'Lingy::Var'; 42 | 43 | # Exception classes: 44 | use constant EXCEPTION => 'Lingy::Exception'; 45 | use constant ILLEGALARGUMENTEXCEPTION => 46 | 'Lingy::IllegalArgumentException'; 47 | 48 | # Functionality classes: 49 | use constant NAMESPACE => 'Lingy::Namespace'; 50 | use constant NUMBERS => 'Lingy::Numbers'; 51 | use constant TERM => 'Lingy::Term'; 52 | use constant THREAD => 'Lingy::Thread'; 53 | 54 | BEGIN { 55 | our @EXPORT = qw< 56 | OK 57 | 58 | $symbol_re 59 | $namespace_re 60 | 61 | refaddr 62 | reftype 63 | 64 | RT 65 | 66 | LISTTYPE 67 | SCALARTYPE 68 | SEQUENTIAL 69 | 70 | COMPILER 71 | NAMESPACE 72 | NUMBERS 73 | TERM 74 | THREAD 75 | UTIL 76 | 77 | ATOM 78 | BOOLEAN 79 | CHARACTER 80 | CLASS 81 | CLOJURE 82 | FUNCTION 83 | HASHMAP 84 | HASHSET 85 | KEYWORD 86 | LIST 87 | MACRO 88 | NIL 89 | NUMBER 90 | REGEX 91 | STRBUILD 92 | STRING 93 | SYMBOL 94 | SYSTEM 95 | VAR 96 | VECTOR 97 | 98 | EXCEPTION 99 | ILLEGALARGUMENTEXCEPTION 100 | 101 | list 102 | string 103 | symbol 104 | 105 | has 106 | err 107 | box_val 108 | unbox_val 109 | assert_args 110 | comp_pair 111 | nil 112 | false 113 | true 114 | 115 | Dump 116 | PPP 117 | WWW 118 | XXX 119 | YYY 120 | ZZZ 121 | >; 122 | } 123 | 124 | { 125 | my ($n, $t, $f); 126 | ($n, $t, $f) = (1, 1, 0); 127 | my $nil = bless \$n, 'Lingy::Nil'; 128 | my $true = bless \$t, BOOLEAN; 129 | my $false = bless \$f, BOOLEAN; 130 | sub nil { $nil } 131 | sub true { $true } 132 | sub false { $false } 133 | } 134 | 135 | our $namespace_re = qr{(?: 136 | \w+ 137 | (?:\.\w+)* 138 | )}x; 139 | 140 | our $symbol_re = qr{( 141 | \*?[-\w]+[\?\!\*\#\=]? | 142 | [-+*/<>] | 143 | ==? | 144 | <= | 145 | >=| 146 | ->>? 147 | )}x; 148 | 149 | sub OK { $Lingy::RT::OK } 150 | 151 | sub list { LIST->new(@_) } 152 | sub string { STRING->new(@_) } 153 | sub symbol { SYMBOL->new(@_) } 154 | 155 | sub has { 156 | my ($caller) = caller; 157 | my $name = shift; 158 | my $method = 159 | sub { 160 | $#_ 161 | ? $_[0]{$name} = $_[1] 162 | : $_[0]{$name}; 163 | }; 164 | no strict 'refs'; 165 | *{"${caller}::$name"} = $method; 166 | }; 167 | 168 | our $error_prefix = ''; 169 | sub err { 170 | my $msg = shift; 171 | $msg = sprintf $msg, @_; 172 | 173 | # XXX This is needed to keep the mal tests passing for now. 174 | $error_prefix = 'Error:' if $ENV{LINGY_TEST}; 175 | 176 | if ($error_prefix) { 177 | $msg = $error_prefix . 178 | ($msg =~ /\n./ ? "\n" : ' ') . 179 | $msg; 180 | } 181 | 182 | die "$msg\n"; 183 | } 184 | 185 | sub box_val { 186 | map { 187 | my $o = $_; 188 | my $type = ref($o); 189 | if (not($type)) { 190 | /^\-?\d+$/ ? NUMBER->new($o) : STRING->new($o); 191 | } 192 | elsif ($type eq 'HASH') { 193 | HASHMAP->new([ 194 | map box_val($_), %$o 195 | ]); 196 | } 197 | elsif ($type eq 'ARRAY') { 198 | VECTOR->new([ 199 | map box_val($_), %$o 200 | ]); 201 | } 202 | elsif ($type =~ /^(?:SCALAR|REF|Regexp)$/) { 203 | XXX($o, "Lingy can't box this object yet"); 204 | } else { 205 | $o; 206 | } 207 | } @_; 208 | } 209 | 210 | sub unbox_val { 211 | my ($obj) = @_; 212 | ref($obj) =~ /^ 213 | Lingy::( 214 | String|Number|Boolean|Nil|HashMap|Vector|Fn 215 | ) 216 | $/x ? $obj->unbox : $obj; 217 | } 218 | 219 | sub assert_args { 220 | my $args = shift; 221 | for (my $i = 0; $i < @_; $i++) { 222 | if (ref($args->[$i]) ne $_[$i]) { 223 | my (undef, undef, undef, $fn) = caller(1); 224 | err "Arg %d for '%s' must be '%s', not '%s'", 225 | $i, $fn, $_[$i], ref($args->[$i]); 226 | } 227 | } 228 | } 229 | 230 | sub comp_pair { 231 | my ($x, $y) = @_; 232 | if (ref($x) eq NIL) { 233 | return ref($y) eq NIL ? 0 : -1; 234 | } 235 | return 1 if ref($y) eq NIL; 236 | ref($x) eq ref($y) or 237 | err "Can't compare values of type '%s' and '%s'", 238 | ref($x), ref($y); 239 | if (ref($x) eq VECTOR) { 240 | return @$x cmp @$y unless @$x == @$y; 241 | my $i = 0; 242 | for my $e (@$x) { 243 | return 1 if $i > @$y; 244 | my $r = comp_pair($x->[$i], $y->[$i]); 245 | return $r if $r; 246 | $i++; 247 | } 248 | return 0; 249 | } 250 | "$x" cmp "$y"; 251 | } 252 | 253 | sub Dump { 254 | _dump(@_); 255 | } 256 | sub PPP { 257 | require Lingy::Printer; 258 | die _dump(RT->printer->pr_str(@_)); 259 | } 260 | sub WWW { 261 | warn _dump(@_); 262 | return wantarray ? @_ : $_[0]; 263 | } 264 | sub XXX { 265 | die _dump(@_); 266 | } 267 | sub YYY { 268 | print _dump(@_); 269 | return wantarray ? @_ : $_[0]; 270 | } 271 | sub ZZZ { 272 | require Carp; 273 | Carp::confess _dump(@_); 274 | } 275 | sub _dump { 276 | require YAML::PP; 277 | YAML::PP->new( 278 | schema => ['Core', 'Perl', '-dumpcode'] 279 | )->dump_string(@_) . "...\n"; 280 | } 281 | 282 | 1; 283 | -------------------------------------------------------------------------------- /perl/test/mal/stepA_mal.yaml: -------------------------------------------------------------------------------- 1 | # 2 | # See IMPL/tests/stepA_mal.mal for implementation specific 3 | # interop tests. 4 | # 5 | 6 | # SKIPPING: readline test 7 | # ;; 8 | # ;; Testing readline 9 | # (readline "mal-user> ") 10 | # "hello" 11 | # ;=>"\"hello\"" 12 | 13 | # each impl is different, but this should return false 14 | # rather than throwing an exception 15 | - say: Testing *HOST* 16 | mal: (= "something bogus" *HOST*) 17 | out: 'false' 18 | 19 | 20 | # ------- Deferrable Functionality ---------- 21 | # ------- (Needed for self-hosting) ------- 22 | 23 | - say: Testing hash-map evaluation and atoms (i.e. an env) 24 | mal: 25 | - (def e (atom {"+" +})) 26 | - (swap! e assoc "-" -) 27 | - ( (get @e "+") 7 8) 28 | out: 15 29 | 30 | - mal: ( (get @e "-") 11 8) 31 | out: 3 32 | 33 | - mal: 34 | - (swap! e assoc "foo" (list)) 35 | - (get @e "foo") 36 | out: () 37 | 38 | - mal: 39 | - (swap! e assoc "bar" '(1 2 3)) 40 | - (get @e "bar") 41 | out: (1 2 3) 42 | 43 | - say: Testing for presence of optional functions 44 | mal: (do (list time-ms string? number? seq conj meta with-meta fn?) nil) 45 | out: nil 46 | 47 | - mal: (map symbol? '(nil false true)) 48 | out: (false false false) 49 | 50 | # ------- Optional Functionality -------------- 51 | # ------- (Not needed for self-hosting) ------- 52 | 53 | # Testing metadata on functions 54 | 55 | - say: Testing metadata on mal functions 56 | mal: (meta (fn* [a] a)) 57 | out: nil 58 | 59 | - mal: (meta (with-meta (fn* [a] a) {"b" 1})) 60 | out: '{"b" 1}' 61 | 62 | - mal: (meta (with-meta (fn* [a] a) "abc")) 63 | out: '"abc"' 64 | 65 | - mal: 66 | - (def l-wm (with-meta (fn* [a] a) {"b" 2})) 67 | - (meta l-wm) 68 | out: '{"b" 2}' 69 | 70 | - mal: (meta (with-meta l-wm {"new_meta" 123})) 71 | out: '{"new_meta" 123}' 72 | 73 | - mal: (meta l-wm) 74 | out: '{"b" 2}' 75 | 76 | - mal: 77 | - (def f-wm (with-meta (fn* [a] (+ 1 a)) {"abc" 1})) 78 | - (meta f-wm) 79 | out: '{"abc" 1}' 80 | 81 | - mal: (meta (with-meta f-wm {"new_meta" 123})) 82 | out: '{"new_meta" 123}' 83 | 84 | - mal: (meta f-wm) 85 | out: '{"abc" 1}' 86 | 87 | - mal: 88 | - (def f-wm2 ^{"abc" 1} (fn* [a] (+ 1 a))) 89 | - (meta f-wm2) 90 | out: '{"abc" 1}' 91 | 92 | - say: Meta of native functions should return nil (not fail) 93 | mal: (meta +) 94 | out: nil 95 | 96 | - say: Make sure closures and metadata co-exist 97 | mal: 98 | - (def gen-plusX (fn* [x] (with-meta (fn* [b] (+ x b)) {"meta" 1}))) 99 | - (def plus7 (gen-plusX 7)) 100 | - (def plus8 (gen-plusX 8)) 101 | - (plus7 8) 102 | out: 15 103 | 104 | - mal: (meta plus7) 105 | out: '{"meta" 1}' 106 | 107 | - mal: (meta plus8) 108 | out: '{"meta" 1}' 109 | 110 | - mal: (meta (with-meta plus7 {"meta" 2})) 111 | out: '{"meta" 2}' 112 | 113 | - mal: (meta plus8) 114 | out: '{"meta" 1}' 115 | 116 | - say: Testing string? function 117 | mal: (string? "") 118 | out: 'true' 119 | 120 | - mal: (string? 'abc) 121 | out: 'false' 122 | 123 | - mal: (string? "abc") 124 | out: 'true' 125 | 126 | - mal: (string? :abc) 127 | out: 'false' 128 | 129 | - mal: (string? (keyword "abc")) 130 | out: 'false' 131 | 132 | - mal: (string? 234) 133 | out: 'false' 134 | 135 | - mal: (string? nil) 136 | out: 'false' 137 | 138 | - say: Testing number? function 139 | mal: (number? 123) 140 | out: 'true' 141 | 142 | - mal: (number? -1) 143 | out: 'true' 144 | 145 | - mal: (number? nil) 146 | out: 'false' 147 | 148 | - mal: (number? false) 149 | out: 'false' 150 | 151 | - mal: (number? "123") 152 | out: 'false' 153 | 154 | - mal: (def add1 (fn* [x] (+ x 1))) 155 | 156 | - say: Testing fn? function 157 | mal: (fn? +) 158 | out: 'true' 159 | 160 | - mal: (fn? add1) 161 | out: 'true' 162 | 163 | - mal: (fn? cond) 164 | out: 'false' 165 | 166 | - mal: (fn? "+") 167 | out: 'false' 168 | 169 | - mal: (fn? :+) 170 | out: 'false' 171 | 172 | - mal: (fn? ^{"ismacro" true} (fn* [] 0)) 173 | out: 'true' 174 | 175 | - say: Testing macro? function 176 | mal: (macro? cond) 177 | out: 'true' 178 | 179 | - mal: (macro? +) 180 | out: 'false' 181 | 182 | - mal: (macro? add1) 183 | out: 'false' 184 | 185 | - mal: (macro? "+") 186 | out: 'false' 187 | 188 | - mal: (macro? :+) 189 | out: 'false' 190 | 191 | - mal: (macro? {}) 192 | out: 'false' 193 | 194 | 195 | - say: Testing conj function 196 | mal: (conj (list) 1) 197 | out: (1) 198 | 199 | - mal: (conj (list 1) 2) 200 | out: (2 1) 201 | 202 | - mal: (conj (list 2 3) 4) 203 | out: (4 2 3) 204 | 205 | - mal: (conj (list 2 3) 4 5 6) 206 | out: (6 5 4 2 3) 207 | 208 | - mal: (conj (list 1) (list 2 3)) 209 | out: ((2 3) 1) 210 | 211 | - mal: (conj [] 1) 212 | out: '[1]' 213 | 214 | - mal: (conj [1] 2) 215 | out: '[1 2]' 216 | 217 | - mal: (conj [2 3] 4) 218 | out: '[2 3 4]' 219 | 220 | - mal: (conj [2 3] 4 5 6) 221 | out: '[2 3 4 5 6]' 222 | 223 | - mal: (conj [1] [2 3]) 224 | out: '[1 [2 3]]' 225 | 226 | - say: Testing seq function 227 | mal: (seq "abc") 228 | out: (\a \b \c) 229 | 230 | - mal: (apply str (seq "this is a test")) 231 | out: '"this is a test"' 232 | 233 | - mal: (seq '(2 3 4)) 234 | out: (2 3 4) 235 | 236 | - mal: (seq [2 3 4]) 237 | out: (2 3 4) 238 | 239 | - mal: (seq "") 240 | out: nil 241 | 242 | - mal: (seq '()) 243 | out: nil 244 | 245 | - mal: (seq []) 246 | out: nil 247 | 248 | - mal: (seq nil) 249 | out: nil 250 | 251 | - say: Testing metadata on collections 252 | 253 | - mal: (meta [1 2 3]) 254 | out: nil 255 | 256 | - mal: (with-meta [1 2 3] {"a" 1}) 257 | out: '[1 2 3]' 258 | 259 | - mal: (meta (with-meta [1 2 3] {"a" 1})) 260 | out: '{"a" 1}' 261 | 262 | - mal: (vector? (with-meta [1 2 3] {"a" 1})) 263 | out: 'true' 264 | 265 | - mal: (meta (with-meta [1 2 3] "abc")) 266 | out: '"abc"' 267 | 268 | - mal: (with-meta [] "abc") 269 | out: '[]' 270 | 271 | - mal: (meta (with-meta (list 1 2 3) {"a" 1})) 272 | out: '{"a" 1}' 273 | 274 | - mal: (list? (with-meta (list 1 2 3) {"a" 1})) 275 | out: 'true' 276 | 277 | - mal: (with-meta (list) {"a" 1}) 278 | out: () 279 | 280 | - mal: (empty? (with-meta (list) {"a" 1})) 281 | out: 'true' 282 | 283 | - mal: (meta (with-meta {"abc" 123} {"a" 1})) 284 | out: '{"a" 1}' 285 | 286 | - mal: (map? (with-meta {"abc" 123} {"a" 1})) 287 | out: 'true' 288 | 289 | - mal: (with-meta {} {"a" 1}) 290 | out: '{}' 291 | 292 | - mal: (def l-wm (with-meta [4 5 6] {"b" 2})) 293 | out: user/l-wm 294 | 295 | - mal: (meta l-wm) 296 | out: '{"b" 2}' 297 | 298 | - mal: (meta (with-meta l-wm {"new_meta" 123})) 299 | out: '{"new_meta" 123}' 300 | 301 | - mal: (meta l-wm) 302 | out: '{"b" 2}' 303 | 304 | - say: Testing metadata on builtin functions 305 | mal: (meta +) 306 | out: nil 307 | 308 | - mal: 309 | - (def f-wm3 ^{"def" 2} +) 310 | - (meta f-wm3) 311 | out: '{"def" 2}' 312 | 313 | - mal: (meta +) 314 | out: nil 315 | 316 | - say: Loading sumdown from computations.mal 317 | mal: (load-file "test/mal/computations.mal") 318 | out: nil 319 | 320 | - say: Testing time-ms function 321 | mal: 322 | - (def start-time (time-ms)) 323 | - (= start-time 0) 324 | out: 'false' 325 | 326 | - mal: (sumdown 10) ; Waste some time 327 | out: 55 328 | 329 | - mal: (> (time-ms) start-time) 330 | out: 'true' 331 | 332 | - say: Test that defining a macro does not mutate an existing function. 333 | mal: 334 | - (def f (fn* [x] (number? x))) 335 | - (defmacro! m f) 336 | - (f (+ 1 1)) 337 | out: 'true' 338 | 339 | - mal: (m (+ 1 1)) 340 | out: 'false' 341 | -------------------------------------------------------------------------------- /perl/lib/Lingy/core.ly: -------------------------------------------------------------------------------- 1 | ;------------------------------------------------------------------------------ 2 | ; Define dynamic variables: 3 | ;------------------------------------------------------------------------------ 4 | (def *clojure-repl* false) 5 | (def *print-dup* true) 6 | (def *print-readably* true) 7 | 8 | ;------------------------------------------------------------------------------ 9 | ; Create standard calls from special forms: 10 | ;------------------------------------------------------------------------------ 11 | (defmacro! defmacro 12 | (fn* [name & body] 13 | `(defmacro! ~name 14 | (fn* ~@body)))) 15 | 16 | (defmacro fn [& xs] (cons 'fn* xs)) 17 | 18 | (defmacro defn [name & body] 19 | `(def ~name (fn* ~@body))) 20 | 21 | (defmacro let [& xs] (cons 'let* xs)) 22 | 23 | ; XXX Using the same code as 'let' (for now) which isn't quite right. 24 | (defmacro binding [& xs] (cons 'let* xs)) 25 | 26 | (defmacro import [& xs] (cons 'import* xs)) 27 | 28 | ; (defmacro assert-args 29 | ; [& pairs] 30 | ; `(do (when-not ~(first pairs) 31 | ; (throw (IllegalArgumentException. 32 | ; (str (first ~'&form) " requires " ~(second pairs) " in " ~'*ns* ":" (:line (meta ~'&form)))))) 33 | ; ~(let [more (nnext pairs)] 34 | ; (when more 35 | ; (list* `assert-args more))))) 36 | ; 37 | ; (defmacro let 38 | ; [bindings & body] 39 | ; (assert-args 40 | ; (vector? bindings) "a vector for its binding" 41 | ; (even? (count bindings)) "an even number of forms in binding vector") 42 | ; `(let* ~(destructure bindings) ~@body)) 43 | 44 | (defmacro try [& xs] (cons 'try* xs)) 45 | 46 | ; (defmacro .. 47 | ; ([x form] `(. ~x ~form)) 48 | ; ([x form & more] `(.. (. ~x ~form) ~@more))) 49 | 50 | ;------------------------------------------------------------------------------ 51 | ; Lingy specific functions: 52 | ;------------------------------------------------------------------------------ 53 | (defn clojure-repl-on [] (def *clojure-repl* true ) nil) 54 | (defn clojure-repl-off [] (def *clojure-repl* false) nil) 55 | 56 | ;------------------------------------------------------------------------------ 57 | ; Other macros and functions: 58 | ;------------------------------------------------------------------------------ 59 | ; (defn all-ns [] (lingy.lang.Namespace/all)) 60 | (defn all-ns [] (lingy.lang.RT/all_ns)) 61 | 62 | (defn apply [f & args] (. lingy.lang.RT (apply f args))) 63 | 64 | ; XXX This needs recur in fn 65 | (defn assoc 66 | ([map key val] (lingy.lang.RT/assoc map key val)) 67 | ; XXX use recur when available in fn 68 | ([map key val & kvs] 69 | (let [ret (assoc map key val)] 70 | (apply assoc ret (first kvs) (second kvs) (nnext kvs))))) 71 | 72 | ; XXX This needs special_new 73 | (defn atom [x] (. lingy.lang.RT (atom x))) 74 | ; XXX Should be: 75 | ; (defn atom [x] (new lingy.lang.Atom x)) 76 | 77 | (defn clojure-require [& xs] 78 | (let [ 79 | . Clojure/dot 80 | def Clojure/def] 81 | (apply lingy.lang.Clojure/require xs) 82 | nil)) 83 | 84 | (defn clojure-use [ns] 85 | (clojure-require ns) 86 | (refer ns)) 87 | 88 | (defn concat [& args] (apply lingy.lang.RT/concat args)) 89 | 90 | (defmacro cond [& xs] 91 | (if (> (count xs) 0) 92 | (list 'if (first xs) 93 | (if (> (count xs) 1) 94 | (nth xs 1) 95 | (throw "odd number of forms to cond")) 96 | (cons 'cond (rest (rest xs)))))) 97 | 98 | (defn conj [& args] (apply lingy.lang.RT/conj args)) 99 | 100 | (defn create-ns [symbol] (. lingy.lang.RT (create_ns symbol))) 101 | 102 | (defmacro declare [& names] 103 | `(do 104 | ~@(map 105 | #(list 'def %) 106 | names))) 107 | 108 | (defn deref [x] (. lingy.lang.RT (deref x))) 109 | 110 | (defn dissoc [& args] (apply lingy.lang.RT/dissoc args)) 111 | 112 | (defmacro doto 113 | [x & forms] 114 | (let [gx (gensym)] 115 | `(let [~gx ~x] 116 | ~@(map (fn [f] 117 | (if (seq? f) 118 | `(~(first f) ~gx ~@(next f)) 119 | `(~f ~gx))) 120 | forms) 121 | ~gx))) 122 | 123 | (defn double [n] (* n 1.0)) 124 | 125 | (defn find-ns [name] (. lingy.lang.RT (find_ns name))) 126 | 127 | (defn get [map key & default] (apply lingy.lang.RT/get map key default)) 128 | 129 | (defn getenv [key] (. lingy.lang.RT (getenv key))) 130 | 131 | (defn gensym 132 | ([] (gensym "G__")) 133 | ([prefix-string] 134 | (. lingy.lang.Symbol 135 | (intern 136 | (str 137 | prefix-string 138 | (str (. lingy.lang.RT (nextID)))))))) 139 | 140 | (defn hash-map [& args] (apply lingy.lang.RT/hash_map args)) 141 | 142 | (defn hash-set [& args] (apply lingy.lang.RT/hash_set args)) 143 | 144 | (defn in-ns [name] (. lingy.lang.RT (in_ns name))) 145 | 146 | (defn keyword [string] (. lingy.lang.RT (keyword string))) 147 | 148 | (defn lingy-version [] 149 | (str 150 | (:major *lingy-version*) 151 | "." 152 | (:minor *lingy-version*) 153 | (when-let [i (:incremental *lingy-version*)] 154 | (str "." i)) 155 | (when-let [q (:qualifier *lingy-version*)] 156 | (when (pos? (count q)) (str "-" q))) 157 | (when (:interim *lingy-version*) 158 | "-SNAPSHOT"))) 159 | 160 | (defn list [& args] (apply lingy.lang.RT/list_ args)) 161 | 162 | (defn list* 163 | ([args] (seq args)) 164 | ([a args] (cons a args)) 165 | ([a b args] (cons a (cons b args))) 166 | ([a b c args] (cons a (cons b (cons c args)))) 167 | ([a b c d & more] 168 | (cons a (cons b (cons c (cons d (-spread more))))))) 169 | 170 | (defn load-file [f] (-load-file-ly f)) 171 | 172 | (defn -load-file-ly [f] 173 | (eval 174 | (read-string 175 | (str 176 | "(do " 177 | (slurp f) 178 | "\nnil)")))) 179 | 180 | (defn macro? [x] (instance? lingy.lang.Macro x)) 181 | 182 | (defn macroexpand [macro] (. lingy.lang.RT (macroexpand macro))) 183 | 184 | (defn map [fn list] (. lingy.lang.RT (map fn list))) 185 | 186 | (defn merge [& maps] 187 | (apply conj {} maps)) 188 | 189 | (defn meta [object] (. lingy.lang.RT (meta_get 'object))) 190 | 191 | (defn mod 192 | [num div] 193 | (let [m (rem num div)] 194 | (if (or (zero? m) (= (pos? num) (pos? div))) 195 | m 196 | (+ m div)))) 197 | 198 | (defn name [symbol] (. lingy.lang.RT (name symbol))) 199 | 200 | (defn namespace [symbol] (. lingy.lang.RT (namespace symbol))) 201 | 202 | (defn next [x] (seq (rest x))) 203 | 204 | (defmacro ns [name & xs] `(lingy.lang.RT/ns '~name '~xs)) 205 | 206 | (defn ns-imports [ns] 207 | (.getImports (the-ns ns))) 208 | 209 | (defn ns-interns [ns] 210 | (.getInterns (the-ns ns))) 211 | 212 | (defn ns-map [ns] 213 | (.getMappings (the-ns ns))) 214 | 215 | (defn ns-name [ns] 216 | (.getName (the-ns ns))) 217 | 218 | (defn nth 219 | ([list index] 220 | (if (and (>= index 0) (< index (count list))) 221 | (. lingy.lang.RT (nth list index)) 222 | (throw "Index out of bounds"))) 223 | ([list index default] 224 | (if (and (>= index 0) (< index (count list))) 225 | (nth list index) 226 | default))) 227 | 228 | (defn number [string] (. lingy.lang.RT (number string))) 229 | 230 | (defn perl [string] (. lingy.lang.RT (eval_perl string))) 231 | 232 | (defn pr-str [& xs] (apply lingy.lang.RT/pr_str xs)) 233 | 234 | (defn println [& args] (apply lingy.lang.RT/println args)) 235 | 236 | (defn prn [& args] (apply lingy.lang.RT/prn args)) 237 | 238 | (defn range [& args] (apply lingy.lang.Numbers/range args)) 239 | 240 | (defn readline [] (. lingy.lang.RT (readline))) 241 | 242 | (defn reduce 243 | ([fn coll] 244 | (let [len (count coll)] 245 | (cond 246 | (= len 0) (apply fn []) 247 | (= len 1) (nth coll 0) 248 | :else (apply reduce [fn (first coll) (rest coll)] )))) 249 | ([fn val coll] 250 | (loop [v val, x (first coll), xs (rest coll)] 251 | (let [v1 (apply fn [v x]) 252 | cnt (count xs)] 253 | (if (= 0 cnt) 254 | v1 255 | (recur v1 (first xs) (rest xs))))))) 256 | 257 | (def reduce1 reduce) 258 | 259 | (defn re-find [re s] (lingy.lang.Regex/find re s)) 260 | 261 | (defn re-matches [re s] (lingy.lang.Regex/matches re s)) 262 | 263 | (defn re-pattern [s] (lingy.lang.Regex/pattern s)) 264 | 265 | (defn refer [ns] 266 | (. *ns* refer ns) 267 | nil) 268 | 269 | (defn require [& xs] 270 | (apply lingy.lang.RT/require xs) 271 | nil) 272 | 273 | (defn reset! [var val] (. lingy.lang.RT (reset_BANG var val))) 274 | 275 | (defn resolve [symbol] (. lingy.lang.RT (resolve symbol))) 276 | 277 | (defn seq [list] (. lingy.lang.RT (seq list))) 278 | 279 | (defn seq? [x] (instance? lingy.lang.ListClass x)) 280 | 281 | (defn sequential? [x] (instance? lingy.lang.Sequential x)) 282 | 283 | (defn slurp [file] (. lingy.lang.RT (slurp file))) 284 | 285 | (defn sort [coll] (. lingy.lang.RT (sort (seq coll)))) 286 | 287 | (defn str [& args] (apply lingy.lang.RT/str args)) 288 | 289 | (defn swap! [atom fn & args] (. lingy.lang.RT (swap_BANG atom fn args))) 290 | 291 | (defn symbol [string] (. lingy.lang.RT (symbol_ string))) 292 | 293 | (defn the-ns [ns] (. lingy.lang.RT (the_ns ns))) 294 | 295 | (defn time-ms [] (. lingy.lang.RT (time_ms))) 296 | 297 | (defn type [object] (. lingy.lang.RT (type object))) 298 | 299 | (defn use [ns] 300 | (require ns) 301 | (refer ns)) 302 | 303 | (defn var [value] (. lingy.lang.RT (var value))) 304 | 305 | (defn vec [value] (. lingy.lang.RT (vec value))) 306 | 307 | (defn vector [& args] (apply lingy.lang.RT/vector args)) 308 | 309 | (defmacro when-let [bindings & body] 310 | (let [ 311 | form (nth bindings 0) 312 | tst (nth bindings 1)] 313 | `(let [temp# ~tst] 314 | (when temp# 315 | (let [~form temp#] 316 | ~@body))))) 317 | 318 | (defn with-meta [object meta] 319 | (. lingy.lang.RT (with_meta object meta))) 320 | 321 | ; Private functions: 322 | 323 | ; user=> (apply + 3 4 [5 6]) 324 | ; 18 325 | ; user=> (eval (cons + (spread [3 4 [5 6]]))) 326 | ; 18 327 | (defn -spread [arglist] 328 | (cond 329 | (nil? arglist) nil 330 | (nil? (next arglist)) (seq (first arglist)) 331 | :else (cons (first arglist) (-spread (next arglist))))) 332 | 333 | ; vim: ft=clojure: 334 | -------------------------------------------------------------------------------- /perl/test/mal/step7_quote.yaml: -------------------------------------------------------------------------------- 1 | - say: Testing cons function 2 | mal: (cons 1 (list)) 3 | out: (1) 4 | 5 | - mal: (cons 1 (list 2)) 6 | out: (1 2) 7 | 8 | - mal: (cons 1 (list 2 3)) 9 | out: (1 2 3) 10 | 11 | - mal: (cons (list 1) (list 2 3)) 12 | out: ((1) 2 3) 13 | 14 | - mal: 15 | - (def a (list 2 3)) 16 | - (cons 1 a) 17 | out: (1 2 3) 18 | 19 | - mal: a 20 | out: (2 3) 21 | 22 | 23 | - say: Testing concat function 24 | mal: (concat) 25 | out: () 26 | 27 | - mal: (concat (list 1 2)) 28 | out: (1 2) 29 | 30 | - mal: (concat (list 1 2) (list 3 4)) 31 | out: (1 2 3 4) 32 | 33 | - mal: (concat (list 1 2) (list 3 4) (list 5 6)) 34 | out: (1 2 3 4 5 6) 35 | 36 | - mal: (concat (concat)) 37 | out: () 38 | 39 | - mal: (concat (list) (list)) 40 | out: () 41 | 42 | - mal: (= () (concat)) 43 | out: 'true' 44 | 45 | - mal: 46 | - (def a (list 1 2)) 47 | - (def b (list 3 4)) 48 | - (concat a b (list 5 6)) 49 | out: (1 2 3 4 5 6) 50 | 51 | - mal: a 52 | out: (1 2) 53 | 54 | - mal: b 55 | out: (3 4) 56 | 57 | 58 | - say: Testing regular quote 59 | mal: (quote 7) 60 | out: 7 61 | 62 | - mal: (quote (1 2 3)) 63 | out: (1 2 3) 64 | 65 | - mal: (quote (1 2 (3 4))) 66 | out: (1 2 (3 4)) 67 | 68 | 69 | - say: Testing simple quasiquote 70 | mal: (quasiquote nil) 71 | out: nil 72 | 73 | - mal: (quasiquote 7) 74 | out: 7 75 | 76 | - mal: (quasiquote a) 77 | out: a 78 | 79 | - mal: (quasiquote {"a" b}) 80 | out: '{"a" b}' 81 | 82 | 83 | - say: Testing quasiquote with lists 84 | mal: (quasiquote ()) 85 | out: () 86 | 87 | - mal: (quasiquote (1 2 3)) 88 | out: (1 2 3) 89 | 90 | - mal: (quasiquote (a)) 91 | out: (a) 92 | 93 | - mal: (quasiquote (1 2 (3 4))) 94 | out: (1 2 (3 4)) 95 | 96 | - mal: (quasiquote (nil)) 97 | out: (nil) 98 | 99 | - mal: (quasiquote (1 ())) 100 | out: (1 ()) 101 | 102 | - mal: (quasiquote (() 1)) 103 | out: (() 1) 104 | 105 | - mal: (quasiquote (1 () 2)) 106 | out: (1 () 2) 107 | 108 | - mal: (quasiquote (())) 109 | out: (()) 110 | 111 | - mal: (quasiquote (f () g (h) i (j k) l)) 112 | out: (f () g (h) i (j k) l) 113 | 114 | 115 | - say: Testing unquote 116 | - mal: (quasiquote (unquote 7)) 117 | out: 7 118 | 119 | - mal: (def a 8) 120 | out: user/a 121 | 122 | - mal: (quasiquote a) 123 | out: a 124 | 125 | - mal: (quasiquote (unquote a)) 126 | out: 8 127 | 128 | - mal: (quasiquote (1 a 3)) 129 | out: (1 a 3) 130 | 131 | - mal: (quasiquote (1 (unquote a) 3)) 132 | out: (1 8 3) 133 | 134 | - mal: (def b (quote (1 "b" "d"))) 135 | out: user/b 136 | 137 | - mal: (quasiquote (1 b 3)) 138 | out: (1 b 3) 139 | 140 | - mal: (quasiquote (1 (unquote b) 3)) 141 | out: (1 (1 "b" "d") 3) 142 | 143 | - mal: (quasiquote ((unquote 1) (unquote 2))) 144 | out: (1 2) 145 | 146 | 147 | - say: Quasiquote and environments 148 | - mal: (let* [x 0] (quasiquote (unquote x))) 149 | out: 0 150 | 151 | 152 | - say: Testing splice-unquote 153 | - mal: (def c (quote (1 "b" "d"))) 154 | out: user/c 155 | 156 | - mal: (quasiquote (1 c 3)) 157 | out: (1 c 3) 158 | 159 | - mal: (quasiquote (1 (splice-unquote c) 3)) 160 | out: (1 1 "b" "d" 3) 161 | 162 | - mal: (quasiquote (1 (splice-unquote c))) 163 | out: (1 1 "b" "d") 164 | 165 | - mal: (quasiquote ((splice-unquote c) 2)) 166 | out: (1 "b" "d" 2) 167 | 168 | - mal: (quasiquote ((splice-unquote c) (splice-unquote c))) 169 | out: (1 "b" "d" 1 "b" "d") 170 | 171 | 172 | - say: Testing symbol equality 173 | - mal: (= (quote abc) (quote abc)) 174 | out: 'true' 175 | 176 | - mal: (= (quote abc) (quote abcd)) 177 | out: 'false' 178 | 179 | - mal: (= (quote abc) "abc") 180 | out: 'false' 181 | 182 | - mal: (= "abc" (quote abc)) 183 | out: 'false' 184 | 185 | - mal: (= "abc" (str (quote abc))) 186 | out: 'true' 187 | 188 | - mal: (= (quote abc) nil) 189 | out: 'false' 190 | 191 | - mal: (= nil (quote abc)) 192 | out: 'false' 193 | 194 | 195 | # -------- Deferrable Functionality -------- 196 | 197 | - say: Testing ' (quote) reader macro 198 | mal: "'7" 199 | out: 7 200 | 201 | - mal: "'(1 2 3)" 202 | out: (1 2 3) 203 | 204 | - mal: "'(1 2 (3 4))" 205 | out: (1 2 (3 4)) 206 | 207 | 208 | - say: Testing cons and concat with vectors 209 | 210 | - mal: (cons 1 []) 211 | out: (1) 212 | 213 | - mal: (cons [1] [2 3]) 214 | out: ([1] 2 3) 215 | 216 | - mal: (cons 1 [2 3]) 217 | out: (1 2 3) 218 | 219 | - mal: (concat [1 2] (list 3 4) [5 6]) 220 | out: (1 2 3 4 5 6) 221 | 222 | - mal: (concat [1 2]) 223 | out: (1 2) 224 | 225 | 226 | # -------- Optional Functionality -------- 227 | 228 | - say: Testing ` (quasiquote) reader macro 229 | mal: '`7' 230 | out: 7 231 | 232 | - mal: '`(1 2 3)' 233 | out: (1 2 3) 234 | 235 | - mal: '`(1 2 (3 4))' 236 | out: (1 2 (3 4)) 237 | 238 | - mal: '`(nil)' 239 | out: (nil) 240 | 241 | 242 | - say: Testing ~ (unquote) reader macro 243 | mal: '`~7' 244 | out: 7 245 | 246 | - mal: (def a 8) 247 | out: user/a 248 | 249 | - mal: '`(1 ~a 3)' 250 | out: (1 8 3) 251 | 252 | - mal: (def b '(1 "b" "d")) 253 | out: user/b 254 | 255 | - mal: '`(1 b 3)' 256 | out: (1 b 3) 257 | 258 | - mal: '`(1 ~b 3)' 259 | out: (1 (1 "b" "d") 3) 260 | 261 | 262 | - say: Testing ~@ (splice-unquote) reader macro 263 | - mal: (def c '(1 "b" "d")) 264 | out: user/c 265 | 266 | - mal: '`(1 c 3)' 267 | out: (1 c 3) 268 | 269 | - mal: '`(1 ~@c 3)' 270 | out: (1 1 "b" "d" 3) 271 | 272 | 273 | - say: Testing vec function 274 | 275 | - mal: (vec (list)) 276 | out: '[]' 277 | 278 | - mal: (vec (list 1)) 279 | out: '[1]' 280 | 281 | - mal: (vec (list 1 2)) 282 | out: '[1 2]' 283 | 284 | - mal: (vec []) 285 | out: '[]' 286 | 287 | - mal: (vec [1 2]) 288 | out: '[1 2]' 289 | 290 | 291 | - say: Testing that vec does not mutate the original list 292 | mal: 293 | - (def a (list 1 2)) 294 | - (vec a) 295 | out: '[1 2]' 296 | 297 | - mal: a 298 | out: (1 2) 299 | 300 | 301 | - say: Test quine 302 | mal: ((fn* [q] (quasiquote ((unquote q) (quote (unquote q))))) (quote (fn* [q] (quasiquote ((unquote q) (quote (unquote q))))))) 303 | out: ((fn* [q] (quasiquote ((unquote q) (quote (unquote q))))) (quote (fn* [q] (quasiquote ((unquote q) (quote (unquote q))))))) 304 | 305 | 306 | - say: Testing quasiquote with vectors 307 | mal: (quasiquote []) 308 | out: '[]' 309 | 310 | - mal: (quasiquote [[]]) 311 | out: '[[]]' 312 | 313 | - mal: (quasiquote [()]) 314 | out: '[()]' 315 | 316 | - mal: (quasiquote ([])) 317 | out: ([]) 318 | 319 | - mal: (def a 8) 320 | out: user/a 321 | 322 | - mal: '`[1 a 3]' 323 | out: '[1 a 3]' 324 | 325 | - mal: (quasiquote [a [] b [c] d [e f] g]) 326 | out: '[a [] b [c] d [e f] g]' 327 | 328 | 329 | - say: Testing unquote with vectors 330 | mal: '`[~a]' 331 | out: '[8]' 332 | 333 | - mal: '`[(~a)]' 334 | out: '[(8)]' 335 | 336 | - mal: '`([~a])' 337 | out: ([8]) 338 | 339 | - mal: '`[a ~a a]' 340 | out: '[a 8 a]' 341 | 342 | - mal: '`([a ~a a])' 343 | out: ([a 8 a]) 344 | 345 | - mal: '`[(a ~a a)]' 346 | out: '[(a 8 a)]' 347 | 348 | 349 | - say: Testing splice-unquote with vectors 350 | mal: (def c '(1 "b" "d")) 351 | out: user/c 352 | 353 | - mal: '`[~@c]' 354 | out: '[1 "b" "d"]' 355 | 356 | - mal: '`[(~@c)]' 357 | out: '[(1 "b" "d")]' 358 | 359 | - mal: '`([~@c])' 360 | out: ([1 "b" "d"]) 361 | 362 | - mal: '`[1 ~@c 3]' 363 | out: '[1 1 "b" "d" 3]' 364 | 365 | - mal: '`([1 ~@c 3])' 366 | out: ([1 1 "b" "d" 3]) 367 | 368 | - mal: '`[(1 ~@c 3)]' 369 | out: '[(1 1 "b" "d" 3)]' 370 | 371 | 372 | - say: Misplaced unquote or splice-unquote 373 | mal: '`(0 unquote)' 374 | out: (0 unquote) 375 | 376 | - mal: '`(0 splice-unquote)' 377 | out: (0 splice-unquote) 378 | 379 | - mal: '`[unquote 0]' 380 | out: '[unquote 0]' 381 | 382 | - mal: '`[splice-unquote 0]' 383 | out: '[splice-unquote 0]' 384 | 385 | 386 | - say: Debugging quasiquote 387 | mal: (quasiquoteexpand nil) 388 | out: nil 389 | 390 | - mal: (quasiquoteexpand 7) 391 | out: 7 392 | 393 | - mal: (quasiquoteexpand a) 394 | out: (quote a) 395 | 396 | - mal: (quasiquoteexpand {"a" b}) 397 | out: (quote {"a" b}) 398 | 399 | - mal: (quasiquoteexpand ()) 400 | out: () 401 | 402 | - mal: (quasiquoteexpand (1 2 3)) 403 | out: (cons 1 (cons 2 (cons 3 ()))) 404 | 405 | - mal: (quasiquoteexpand (a)) 406 | out: (cons (quote a) ()) 407 | 408 | - mal: (quasiquoteexpand (1 2 (3 4))) 409 | out: (cons 1 (cons 2 (cons (cons 3 (cons 4 ())) ()))) 410 | 411 | - mal: (quasiquoteexpand (nil)) 412 | out: (cons nil ()) 413 | 414 | - mal: (quasiquoteexpand (1 ())) 415 | out: (cons 1 (cons () ())) 416 | 417 | - mal: (quasiquoteexpand (() 1)) 418 | out: (cons () (cons 1 ())) 419 | 420 | - mal: (quasiquoteexpand (1 () 2)) 421 | out: (cons 1 (cons () (cons 2 ()))) 422 | 423 | - mal: (quasiquoteexpand (())) 424 | out: (cons () ()) 425 | 426 | - mal: (quasiquoteexpand (f () g (h) i (j k) l)) 427 | out: (cons (quote f) (cons () (cons (quote g) (cons (cons (quote h) ()) (cons (quote i) (cons (cons (quote j) (cons (quote k) ())) (cons (quote l) ()))))))) 428 | 429 | - mal: (quasiquoteexpand (unquote 7)) 430 | out: 7 431 | 432 | - mal: (quasiquoteexpand a) 433 | out: (quote a) 434 | 435 | - mal: (quasiquoteexpand (unquote a)) 436 | out: a 437 | 438 | - mal: (quasiquoteexpand (1 a 3)) 439 | out: (cons 1 (cons (quote a) (cons 3 ()))) 440 | 441 | - mal: (quasiquoteexpand (1 (unquote a) 3)) 442 | out: (cons 1 (cons a (cons 3 ()))) 443 | 444 | - mal: (quasiquoteexpand (1 b 3)) 445 | out: (cons 1 (cons (quote b) (cons 3 ()))) 446 | 447 | - mal: (quasiquoteexpand (1 (unquote b) 3)) 448 | out: (cons 1 (cons b (cons 3 ()))) 449 | 450 | - mal: (quasiquoteexpand ((unquote 1) (unquote 2))) 451 | out: (cons 1 (cons 2 ())) 452 | 453 | - mal: (quasiquoteexpand (a (splice-unquote (b c)) d)) 454 | out: (cons (quote a) (concat (b c) (cons (quote d) ()))) 455 | 456 | - mal: (quasiquoteexpand (1 c 3)) 457 | out: (cons 1 (cons (quote c) (cons 3 ()))) 458 | 459 | - mal: (quasiquoteexpand (1 (splice-unquote c) 3)) 460 | out: (cons 1 (concat c (cons 3 ()))) 461 | 462 | - mal: (quasiquoteexpand (1 (splice-unquote c))) 463 | out: (cons 1 (concat c ())) 464 | 465 | - mal: (quasiquoteexpand ((splice-unquote c) 2)) 466 | out: (concat c (cons 2 ())) 467 | 468 | - mal: (quasiquoteexpand ((splice-unquote c) (splice-unquote c))) 469 | out: (concat c (concat c ())) 470 | 471 | - mal: (quasiquoteexpand []) 472 | out: (vec ()) 473 | 474 | - mal: (quasiquoteexpand [[]]) 475 | out: (vec (cons (vec ()) ())) 476 | 477 | - mal: (quasiquoteexpand [()]) 478 | out: (vec (cons () ())) 479 | 480 | - mal: (quasiquoteexpand ([])) 481 | out: (cons (vec ()) ()) 482 | 483 | - mal: (quasiquoteexpand [1 a 3]) 484 | out: (vec (cons 1 (cons (quote a) (cons 3 ())))) 485 | 486 | - mal: (quasiquoteexpand [a [] b [c] d [e f] g]) 487 | out: (vec (cons (quote a) (cons (vec ()) (cons (quote b) (cons (vec (cons (quote c) ())) (cons (quote d) (cons (vec (cons (quote e) (cons (quote f) ()))) (cons (quote g) ())))))))) 488 | 489 | -------------------------------------------------------------------------------- /perl/test/mal/step9_try.yaml: -------------------------------------------------------------------------------- 1 | - say: Testing throw 2 | mal: (throw "err1") 3 | err: .*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*err1.* 4 | 5 | 6 | - say: Testing try*/catch* 7 | mal: (try* 123 (catch* e 456)) 8 | out: 123 9 | 10 | - mal: (try* abc (catch* exc (prn "exc is:" exc))) 11 | err: >- 12 | "exc is:" "Error: Unable to resolve symbol: 'abc' in this context" 13 | out: nil 14 | 15 | - mal: (try* (abc 1 2) (catch* exc (prn "exc is:" exc))) 16 | err: >- 17 | "exc is:" "Error: Unable to resolve symbol: 'abc' in this context" 18 | out: nil 19 | 20 | - say: Make sure error from core can be caught 21 | mal: (try* (nth () 1) (catch* exc (prn "exc is:" exc))) 22 | err: >- 23 | "exc is:".*(length|range|[Bb]ounds|beyond).* 24 | out: nil 25 | 26 | - mal: (try* (throw "my exception") (catch* exc (do (prn "exc:" exc) 7))) 27 | err: >- 28 | "exc:" "my exception" 29 | out: 7 30 | 31 | - say: Test that exception handlers get restored correctly 32 | mal: (try* (do (try* "t1" (catch* e "c1")) (throw "e1")) (catch* e "c2")) 33 | out: '"c2"' 34 | 35 | - mal: (try* (try* (throw "e1") (catch* e (throw "e2"))) (catch* e "c2")) 36 | out: '"c2"' 37 | 38 | # Disable this test because 'throw' is a special form now: 39 | # - say: Test that throw is a function 40 | # mal: (try* (map throw (list "my err")) (catch* exc exc)) 41 | # out: '"my err"' 42 | 43 | 44 | - say: Testing builtin functions 45 | mal: (symbol? 'abc) 46 | out: 'true' 47 | 48 | - mal: (symbol? "abc") 49 | out: 'false' 50 | 51 | - mal: (nil? nil) 52 | out: 'true' 53 | 54 | - mal: (nil? true) 55 | out: 'false' 56 | 57 | - mal: (true? true) 58 | out: 'true' 59 | 60 | - mal: (true? false) 61 | out: 'false' 62 | 63 | - mal: (true? true?) 64 | out: 'false' 65 | 66 | - mal: (false? false) 67 | out: 'true' 68 | 69 | - mal: (false? true) 70 | out: 'false' 71 | 72 | 73 | - say: Testing apply function with core functions 74 | mal: (apply + (list 2 3)) 75 | out: 5 76 | 77 | - mal: (apply + 4 (list 5)) 78 | out: 9 79 | 80 | - mal: (apply prn (list 1 2 "3" (list))) 81 | err: 1 2 "3" \(\) 82 | out: nil 83 | 84 | - mal: (apply prn 1 2 (list "3" (list))) 85 | err: 1 2 "3" \(\) 86 | out: nil 87 | 88 | - mal: (apply list (list)) 89 | out: () 90 | 91 | - mal: (apply symbol? (list (quote two))) 92 | out: 'true' 93 | 94 | 95 | - say: Testing apply function with user functions 96 | mal: (apply (fn* [a b] (+ a b)) (list 2 3)) 97 | out: 5 98 | 99 | - mal: (apply (fn* [a b] (+ a b)) 4 (list 5)) 100 | out: 9 101 | 102 | 103 | - say: Testing map function 104 | mal: 105 | - (def nums (list 1 2 3)) 106 | - (def double (fn* [a] (* 2 a))) 107 | - (double 3) 108 | out: 6 109 | 110 | - mal: (map double nums) 111 | out: (2 4 6) 112 | 113 | - mal: (map (fn* [x] (symbol? x)) (list 1 (quote two) "three")) 114 | out: (false true false) 115 | 116 | - mal: (= () (map str ())) 117 | out: 'true' 118 | 119 | 120 | # ------- Deferrable Functionality ---------- 121 | # ------- (Needed for self-hosting) ------- 122 | 123 | - say: Testing symbol and keyword functions 124 | mal: (symbol? :abc) 125 | out: 'false' 126 | 127 | - mal: (symbol? 'abc) 128 | out: 'true' 129 | 130 | - mal: (symbol? "abc") 131 | out: 'false' 132 | 133 | - mal: (symbol? (symbol "abc")) 134 | out: 'true' 135 | 136 | - mal: (keyword? :abc) 137 | out: 'true' 138 | 139 | - mal: (keyword? 'abc) 140 | out: 'false' 141 | 142 | - mal: (keyword? "abc") 143 | out: 'false' 144 | 145 | - mal: (keyword? "") 146 | out: 'false' 147 | 148 | - mal: (keyword? (keyword "abc")) 149 | out: 'true' 150 | 151 | - mal: (symbol "abc") 152 | out: abc 153 | 154 | - mal: (keyword "abc") 155 | out: :abc 156 | 157 | 158 | - say: Testing sequential? function 159 | mal: (sequential? (list 1 2 3)) 160 | out: 'true' 161 | 162 | - mal: (sequential? [15]) 163 | out: 'true' 164 | 165 | - mal: (sequential? sequential?) 166 | out: 'false' 167 | 168 | - mal: (sequential? nil) 169 | out: 'false' 170 | 171 | - mal: (sequential? "abc") 172 | out: 'false' 173 | 174 | 175 | - say: Testing apply function with core functions and arguments in vector 176 | mal: (apply + 4 [5]) 177 | out: 9 178 | 179 | - mal: (apply prn 1 2 ["3" 4]) 180 | err: 1 2 "3" 4 181 | out: nil 182 | 183 | - mal: (apply list []) 184 | out: () 185 | 186 | 187 | - say: Testing apply function with user functions and arguments in vector 188 | mal: (apply (fn* [a b] (+ a b)) [2 3]) 189 | out: 5 190 | 191 | - mal: (apply (fn* [a b] (+ a b)) 4 [5]) 192 | out: 9 193 | 194 | 195 | - say: Testing map function with vectors 196 | mal: (map (fn* [a] (* 2 a)) [1 2 3]) 197 | out: (2 4 6) 198 | 199 | - mal: (map (fn* [& args] (list? args)) [1 2]) 200 | out: (true true) 201 | 202 | 203 | - say: Testing vector functions 204 | mal: (vector? [10 11]) 205 | out: 'true' 206 | 207 | - mal: (vector? '(12 13)) 208 | out: 'false' 209 | 210 | - mal: (vector 3 4 5) 211 | out: '[3 4 5]' 212 | 213 | - mal: (= [] (vector)) 214 | out: 'true' 215 | 216 | - mal: (map? {}) 217 | out: 'true' 218 | 219 | - mal: (map? '()) 220 | out: 'false' 221 | 222 | - mal: (map? []) 223 | out: 'false' 224 | 225 | - mal: (map? 'abc) 226 | out: 'false' 227 | 228 | - mal: (map? :abc) 229 | out: 'false' 230 | 231 | 232 | - say: Testing hash-maps 233 | mal: (hash-map "a" 1) 234 | out: '{"a" 1}' 235 | 236 | - mal: '{"a" 1}' 237 | out: '{"a" 1}' 238 | 239 | - mal: (assoc {} "a" 1) 240 | out: '{"a" 1}' 241 | 242 | - mal: (get (assoc (assoc {"a" 1 } "b" 2) "c" 3) "a") 243 | out: 1 244 | 245 | - mal: (def hm1 (hash-map)) 246 | out: user/hm1 247 | 248 | - mal: (map? hm1) 249 | out: 'true' 250 | 251 | - mal: (map? 1) 252 | out: 'false' 253 | 254 | - mal: (map? "abc") 255 | out: 'false' 256 | 257 | - mal: (get nil "a") 258 | out: nil 259 | 260 | - mal: (get hm1 "a") 261 | out: nil 262 | 263 | - mal: (contains? hm1 "a") 264 | out: 'false' 265 | 266 | - mal: (def hm2 (assoc hm1 "a" 1)) 267 | out: user/hm2 268 | 269 | - mal: (get hm1 "a") 270 | out: nil 271 | 272 | - mal: (contains? hm1 "a") 273 | out: 'false' 274 | 275 | - mal: (get hm2 "a") 276 | out: 1 277 | 278 | - mal: (contains? hm2 "a") 279 | out: 'true' 280 | 281 | 282 | - say: TODO - fix. Clojure returns nil but this breaks mal impl 283 | mal: (keys hm1) 284 | out: () 285 | 286 | - mal: (= () (keys hm1)) 287 | out: 'true' 288 | 289 | - mal: (keys hm2) 290 | out: ("a") 291 | 292 | - mal: (keys {"1" 1}) 293 | out: ("1") 294 | 295 | - say: TODO - fix. Clojure returns nil but this breaks mal impl 296 | mal: (vals hm1) 297 | out: () 298 | 299 | - mal: (= () (vals hm1)) 300 | out: 'true' 301 | 302 | - mal: (vals hm2) 303 | out: (1) 304 | 305 | - mal: (count (keys (assoc hm2 "b" 2 "c" 3))) 306 | out: 3 307 | 308 | 309 | - say: Testing keywords as hash-map keys 310 | mal: (get {:abc 123} :abc) 311 | out: 123 312 | 313 | - mal: (contains? {:abc 123} :abc) 314 | out: 'true' 315 | 316 | - mal: (contains? {:abcd 123} :abc) 317 | out: 'false' 318 | 319 | - mal: (assoc {} :bcd 234) 320 | out: '{:bcd 234}' 321 | 322 | - mal: (keyword? (nth (keys {:abc 123 :def 456}) 0)) 323 | out: 'true' 324 | 325 | - mal: (keyword? (nth (vals {"a" :abc "b" :def}) 0)) 326 | out: 'true' 327 | 328 | 329 | - say: Testing whether assoc updates properly 330 | mal: 331 | - (def hm4 (assoc {:a 1 :b 2} :a 3 :c 1)) 332 | - (get hm4 :a) 333 | out: 3 334 | 335 | - mal: (get hm4 :b) 336 | out: 2 337 | 338 | - mal: (get hm4 :c) 339 | out: 1 340 | 341 | 342 | - say: Testing nil as hash-map values 343 | mal: (contains? {:abc nil} :abc) 344 | out: 'true' 345 | 346 | - mal: (assoc {} :bcd nil) 347 | out: '{:bcd nil}' 348 | 349 | 350 | - say: Additional str and pr-str tests 351 | mal: (str "A" {:abc "val"} "Z") 352 | out: '"A{:abc val}Z"' 353 | 354 | - mal: (str true "." false "." nil "." :keyw "." 'symb) 355 | out: '"true.false..:keyw.symb"' 356 | 357 | - mal: (pr-str "A" {:abc "val"} "Z") 358 | out: '"\"A\" {:abc \"val\"} \"Z\""' 359 | 360 | - mal: (pr-str true "." false "." nil "." :keyw "." 'symb) 361 | out: '"true \".\" false \".\" nil \".\" :keyw \".\" symb"' 362 | 363 | - mal: 364 | - (def s (str {:abc "val1" :def "val2"})) 365 | - (cond (= s "{:abc val1, :def val2}") true (= s "{:def val2, :abc val1}") true) 366 | out: 'true' 367 | 368 | - mal: 369 | - (def p (pr-str {:abc "val1" :def "val2"})) 370 | - (cond (= p "{:abc \"val1\", :def \"val2\"}") true (= p "{:def \"val2\", :abc \"val1\"}") true) 371 | out: 'true' 372 | 373 | 374 | - say: Test extra function arguments as Mal List (bypassing TCO with apply) 375 | mal: (apply (fn* [& more] (list? more)) [1 2 3]) 376 | out: 'true' 377 | 378 | - mal: (apply (fn* [& more] (list? more)) []) 379 | out: 'true' 380 | 381 | - mal: (apply (fn* [a & more] (list? more)) [1]) 382 | out: 'true' 383 | 384 | 385 | # ------- Optional Functionality -------------- 386 | # ------- (Not needed for self-hosting) ------- 387 | 388 | - say: Testing throwing a hash-map 389 | mal: (throw {:msg "err2"}) 390 | err: .*([Ee][Rr][Rr][Oo][Rr]|[Ee]xception).*msg.*err2.* 391 | 392 | # TODO: fix so long lines don't trigger ANSI escape codes ;;;(try* 393 | # (try* (throw ["data" "foo"]) (catch* exc (do (prn "exc is:" exc) 7))) ;;;; 394 | # "exc is:" ["data" "foo"] ;;;;=>7 395 | # =>7 396 | 397 | 398 | - say: Testing try* without catch* 399 | mal: (try* xyz) 400 | err: >- 401 | Error: Unable to resolve symbol: 'xyz' in this context 402 | 403 | 404 | - say: Testing throwing non-strings 405 | mal: (try* (throw (list 1 2 3)) (catch* exc (do (prn "err:" exc) 7))) 406 | err: >- 407 | "err:" \(1 2 3\) 408 | out: 7 409 | 410 | 411 | - say: Testing dissoc 412 | mal: 413 | - (def hm3 (assoc hm2 "b" 2)) 414 | - (count (keys hm3)) 415 | out: 2 416 | 417 | - mal: (count (vals hm3)) 418 | out: 2 419 | 420 | - mal: (dissoc hm3 "a") 421 | out: '{"b" 2}' 422 | 423 | - mal: (dissoc hm3 "a" "b") 424 | out: '{}' 425 | 426 | - mal: (dissoc hm3 "a" "b" "c") 427 | out: '{}' 428 | 429 | - mal: (count (keys hm3)) 430 | out: 2 431 | 432 | - mal: (dissoc {:cde 345 :fgh 456} :cde) 433 | out: '{:fgh 456}' 434 | 435 | - mal: (dissoc {:cde nil :fgh 456} :cde) 436 | out: '{:fgh 456}' 437 | 438 | 439 | - say: Testing equality of hash-maps 440 | mal: (= {} {}) 441 | out: 'true' 442 | 443 | - mal: (= {} (hash-map)) 444 | out: 'true' 445 | 446 | - mal: (= {:a 11 :b 22} (hash-map :b 22 :a 11)) 447 | out: 'true' 448 | 449 | - mal: (= {:a 11 :b [22 33]} (hash-map :b [22 33] :a 11)) 450 | out: 'true' 451 | 452 | - mal: (= {:a 11 :b {:c 33}} (hash-map :b {:c 33} :a 11)) 453 | out: 'true' 454 | 455 | - mal: (= {:a 11 :b 22} (hash-map :b 23 :a 11)) 456 | out: 'false' 457 | 458 | - mal: (= {:a 11 :b 22} (hash-map :a 11)) 459 | out: 'false' 460 | 461 | - mal: (= {:a [11 22]} {:a (list 11 22)}) 462 | out: 'true' 463 | 464 | - mal: (= {:a 11 :b 22} (list :a 11 :b 22)) 465 | out: 'false' 466 | 467 | - mal: (= {} []) 468 | out: 'false' 469 | 470 | - mal: (= [] {}) 471 | out: 'false' 472 | 473 | - mal: (keyword :abc) 474 | out: :abc 475 | 476 | - mal: (keyword? (first (keys {":abc" 123 ":def" 456}))) 477 | out: 'false' 478 | 479 | 480 | - say: Testing that hashmaps don't alter function ast 481 | mal: 482 | - (def bar (fn* [a] {:foo (get a :foo)})) 483 | - (bar {:foo (fn* [x] x)}) 484 | - (bar {:foo 3}) 485 | # shouldn't give an error 486 | -------------------------------------------------------------------------------- /perl/test/mal/step4_if_fn_do.yaml: -------------------------------------------------------------------------------- 1 | - say: Testing list functions 2 | mal: (list) 3 | out: () 4 | 5 | - mal: (list? (list)) 6 | out: 'true' 7 | 8 | - mal: (empty? (list)) 9 | out: 'true' 10 | 11 | - mal: (empty? (list 1)) 12 | out: 'false' 13 | 14 | - mal: (list 1 2 3) 15 | out: (1 2 3) 16 | 17 | - mal: (count (list 1 2 3)) 18 | out: 3 19 | 20 | - mal: (count (list)) 21 | out: 0 22 | 23 | - mal: (count nil) 24 | out: 0 25 | 26 | - mal: (if (> (count (list 1 2 3)) 3) 89 78) 27 | out: 78 28 | 29 | - mal: (if (>= (count (list 1 2 3)) 3) 89 78) 30 | out: 89 31 | 32 | 33 | - say: Testing if form 34 | mal: (if true 7 8) 35 | out: 7 36 | 37 | - mal: (if false 7 8) 38 | out: 8 39 | 40 | - mal: (if false 7 false) 41 | out: 'false' 42 | 43 | - mal: (if true (+ 1 7) (+ 1 8)) 44 | out: 8 45 | 46 | - mal: (if false (+ 1 7) (+ 1 8)) 47 | out: 9 48 | 49 | - mal: (if nil 7 8) 50 | out: 8 51 | 52 | - mal: (if 0 7 8) 53 | out: 7 54 | 55 | - mal: (if (list) 7 8) 56 | out: 7 57 | 58 | - mal: (if (list 1 2 3) 7 8) 59 | out: 7 60 | 61 | - mal: (= (list) nil) 62 | out: 'false' 63 | 64 | 65 | - say: Testing 1-way if form 66 | mal: (if false (+ 1 7)) 67 | out: nil 68 | 69 | - mal: (if nil 8) 70 | out: nil 71 | 72 | - mal: (if nil 8 7) 73 | out: 7 74 | 75 | - mal: (if true (+ 1 7)) 76 | out: 8 77 | 78 | 79 | - say: Testing basic conditionals 80 | mal: (= 2 1) 81 | out: 'false' 82 | 83 | - mal: (= 1 1) 84 | out: 'true' 85 | 86 | - mal: (= 1 2) 87 | out: 'false' 88 | 89 | - mal: (= 1 (+ 1 1)) 90 | out: 'false' 91 | 92 | - mal: (= 2 (+ 1 1)) 93 | out: 'true' 94 | 95 | - mal: (= nil 1) 96 | out: 'false' 97 | 98 | - mal: (= nil nil) 99 | out: 'true' 100 | 101 | - mal: (> 2 1) 102 | out: 'true' 103 | 104 | - mal: (> 1 1) 105 | out: 'false' 106 | 107 | - mal: (> 1 2) 108 | out: 'false' 109 | 110 | - mal: (>= 2 1) 111 | out: 'true' 112 | 113 | - mal: (>= 1 1) 114 | out: 'true' 115 | 116 | - mal: (>= 1 2) 117 | out: 'false' 118 | 119 | - mal: (< 2 1) 120 | out: 'false' 121 | 122 | - mal: (< 1 1) 123 | out: 'false' 124 | 125 | - mal: (< 1 2) 126 | out: 'true' 127 | 128 | - mal: (<= 2 1) 129 | out: 'false' 130 | 131 | - mal: (<= 1 1) 132 | out: 'true' 133 | 134 | - mal: (<= 1 2) 135 | out: 'true' 136 | 137 | 138 | - say: Testing equality 139 | mal: (= 1 1) 140 | out: 'true' 141 | 142 | - mal: (= 0 0) 143 | out: 'true' 144 | 145 | - mal: (= 1 0) 146 | out: 'false' 147 | 148 | - mal: (= true true) 149 | out: 'true' 150 | 151 | - mal: (= false false) 152 | out: 'true' 153 | 154 | - mal: (= nil nil) 155 | out: 'true' 156 | 157 | - mal: (= (list) (list)) 158 | out: 'true' 159 | 160 | - mal: (= (list) ()) 161 | out: 'true' 162 | 163 | - mal: (= (list 1 2) (list 1 2)) 164 | out: 'true' 165 | 166 | - mal: (= (list 1) (list)) 167 | out: 'false' 168 | 169 | - mal: (= (list) (list 1)) 170 | out: 'false' 171 | 172 | - mal: (= 0 (list)) 173 | out: 'false' 174 | 175 | - mal: (= (list) 0) 176 | out: 'false' 177 | 178 | - mal: (= (list nil) (list)) 179 | out: 'false' 180 | 181 | 182 | - say: Testing builtin and user defined functions 183 | mal: (+ 1 2) 184 | out: 3 185 | 186 | - mal: ( (fn* [a b] (+ b a)) 3 4) 187 | out: 7 188 | 189 | - mal: ( (fn* [] 4) ) 190 | out: 4 191 | 192 | - mal: ( (fn* [f x] (f x)) (fn* [a] (+ 1 a)) 7) 193 | out: 8 194 | 195 | 196 | - say: Testing closures 197 | mal: ( ( (fn* [a] (fn* [b] (+ a b))) 5) 7) 198 | out: 12 199 | 200 | - mal: (def gen-plus5 (fn* [] (fn* [b] (+ 5 b)))) 201 | - mal: (def plus5 (gen-plus5)) 202 | - mal: (plus5 7) 203 | out: 12 204 | 205 | - mal: (def gen-plusX (fn* [x] (fn* [b] (+ x b)))) 206 | - mal: (def plus7 (gen-plusX 7)) 207 | - mal: (plus7 8) 208 | out: 15 209 | 210 | 211 | - say: Testing do form 212 | mal: (do (prn 101)) 213 | err: 101 214 | out: nil 215 | 216 | - mal: (do (prn 102) 7) 217 | err: 102 218 | out: 7 219 | 220 | - mal: (do (prn 101) (prn 102) (+ 1 2)) 221 | err: 222 | - 101 223 | - 102 224 | out: 3 225 | 226 | - mal: (do (def a 6) 7 (+ a 8)) 227 | out: 14 228 | 229 | - mal: a 230 | out: 6 231 | 232 | 233 | - say: Testing special form case-sensitivity 234 | mal: (def DO (fn* [a] 7)) 235 | - mal: (DO 3) 236 | out: 7 237 | 238 | 239 | - say: Testing recursive sumdown function 240 | mal: (def sumdown (fn* [N] (if (> N 0) (+ N (sumdown (- N 1))) 0))) 241 | - mal: (sumdown 1) 242 | out: 1 243 | 244 | - mal: (sumdown 2) 245 | out: 3 246 | 247 | - mal: (sumdown 6) 248 | out: 21 249 | 250 | 251 | - say: Testing recursive fibonacci function 252 | mal: (def fib (fn* [N] (if (= N 0) 1 (if (= N 1) 1 (+ (fib (- N 1)) (fib (- N 2))))))) 253 | - mal: (fib 1) 254 | out: 1 255 | 256 | - mal: (fib 2) 257 | out: 2 258 | 259 | - mal: (fib 4) 260 | out: 5 261 | 262 | 263 | - say: Testing recursive function in environment. 264 | mal: (let* [f (fn* [] x) x 3] (f)) 265 | out: 3 266 | 267 | - mal: (let* [cst (fn* [n] (if (= n 0) nil (cst (- n 1))))] (cst 1)) 268 | out: nil 269 | 270 | - mal: (let* [f (fn* [n] (if (= n 0) 0 (g (- n 1)))) g (fn* [n] (f n))] (f 2)) 271 | out: 0 272 | 273 | 274 | # -------- Deferrable Functionality -------- 275 | 276 | - say: Testing if on strings 277 | mal: (if "" 7 8) 278 | out: 7 279 | 280 | 281 | - say: Testing string equality 282 | mal: (= "" "") 283 | out: 'true' 284 | 285 | - mal: (= "abc" "abc") 286 | out: 'true' 287 | 288 | - mal: (= "abc" "") 289 | out: 'false' 290 | 291 | - mal: (= "" "abc") 292 | out: 'false' 293 | 294 | - mal: (= "abc" "def") 295 | out: 'false' 296 | 297 | - mal: (= "abc" "ABC") 298 | out: 'false' 299 | 300 | - mal: (= (list) "") 301 | out: 'false' 302 | 303 | - mal: (= "" (list)) 304 | out: 'false' 305 | 306 | 307 | - say: Testing variable length arguments 308 | mal: ( (fn* [& more] (count more)) 1 2 3) 309 | out: 3 310 | 311 | - mal: ( (fn* [& more] (list? more)) 1 2 3) 312 | out: 'true' 313 | 314 | - mal: ( (fn* [& more] (count more)) 1) 315 | out: 1 316 | 317 | - mal: ( (fn* [& more] (count more)) ) 318 | out: 0 319 | 320 | - mal: ( (fn* [& more] (list? more)) ) 321 | out: 'true' 322 | 323 | - mal: ( (fn* [a & more] (count more)) 1 2 3) 324 | out: 2 325 | 326 | - mal: ( (fn* [a & more] (count more)) 1) 327 | out: 0 328 | 329 | - mal: ( (fn* [a & more] (list? more)) 1) 330 | out: 'true' 331 | 332 | 333 | - say: Testing language defined not function 334 | mal: (not false) 335 | out: 'true' 336 | 337 | - mal: (not nil) 338 | out: 'true' 339 | 340 | - mal: (not true) 341 | out: 'false' 342 | 343 | - mal: (not "a") 344 | out: 'false' 345 | 346 | - mal: (not 0) 347 | out: 'false' 348 | 349 | 350 | - say: Testing string quoting 351 | mal: '""' 352 | out: '""' 353 | 354 | - mal: '"abc"' 355 | out: '"abc"' 356 | 357 | - mal: '"abc def"' 358 | out: '"abc def"' 359 | 360 | - mal: '"\""' 361 | out: '"\""' 362 | 363 | - mal: '"abc\ndef\nghi"' 364 | out: '"abc\ndef\nghi"' 365 | 366 | - mal: '"abc\\def\\ghi"' 367 | out: '"abc\\def\\ghi"' 368 | 369 | - mal: '"\\n"' 370 | out: '"\\n"' 371 | 372 | 373 | - say: Testing pr-str 374 | mal: (pr-str) 375 | out: '""' 376 | 377 | - mal: (pr-str "") 378 | out: '"\"\""' 379 | 380 | - mal: (pr-str "abc") 381 | out: '"\"abc\""' 382 | 383 | - mal: (pr-str "abc def" "ghi jkl") 384 | out: '"\"abc def\" \"ghi jkl\""' 385 | 386 | - mal: (pr-str "\"") 387 | out: '"\"\\\"\""' 388 | 389 | - mal: (pr-str (list 1 2 "abc" "\"") "def") 390 | out: '"(1 2 \"abc\" \"\\\"\") \"def\""' 391 | 392 | - mal: (pr-str "abc\ndef\nghi") 393 | out: '"\"abc\\ndef\\nghi\""' 394 | 395 | - mal: (pr-str "abc\\def\\ghi") 396 | out: '"\"abc\\\\def\\\\ghi\""' 397 | 398 | - mal: (pr-str (list)) 399 | out: '"()"' 400 | 401 | 402 | - say: Testing str 403 | mal: (str) 404 | out: '""' 405 | 406 | - mal: (str "") 407 | out: '""' 408 | 409 | - mal: (str "abc") 410 | out: '"abc"' 411 | 412 | - mal: (str "\"") 413 | out: '"\""' 414 | 415 | - mal: (str 1 "abc" 3) 416 | out: '"1abc3"' 417 | 418 | - mal: (str "abc def" "ghi jkl") 419 | out: '"abc defghi jkl"' 420 | 421 | - mal: (str "abc\ndef\nghi") 422 | out: '"abc\ndef\nghi"' 423 | 424 | - mal: (str "abc\\def\\ghi") 425 | out: '"abc\\def\\ghi"' 426 | 427 | - mal: (str (list 1 2 "abc" "\"") "def") 428 | out: '"(1 2 abc \")def"' 429 | 430 | - mal: (str (list)) 431 | out: '"()"' 432 | 433 | 434 | - say: Testing prn 435 | mal: (prn) 436 | err: '' 437 | out: nil 438 | 439 | - mal: (prn "") 440 | err: '""' 441 | out: nil 442 | 443 | - mal: (prn "abc") 444 | err: '"abc"' 445 | out: nil 446 | 447 | - mal: (prn "abc def" "ghi jkl") 448 | err: '"abc def" "ghi jkl"' 449 | 450 | - mal: (prn "\"") 451 | err: '"\\""' 452 | out: nil 453 | 454 | - mal: (prn "abc\ndef\nghi") 455 | err: '"abc\\ndef\\nghi"' 456 | out: nil 457 | 458 | - mal: (prn "abc\\def\\ghi") 459 | err: '"abc\\\\def\\\\ghi"' 460 | out: nil 461 | 462 | - mal: (prn (list 1 2 "abc" "\"") "def") 463 | err: \(1 2 "abc" "\\""\) "def" 464 | out: nil 465 | 466 | 467 | - say: Testing println 468 | mal: (println) 469 | err: '' 470 | out: nil 471 | 472 | - mal: (println "") 473 | err: '' 474 | out: nil 475 | 476 | - mal: (println "abc") 477 | err: abc 478 | out: nil 479 | 480 | - mal: (println "abc def" "ghi jkl") 481 | err: abc def ghi jkl 482 | 483 | - mal: (println "\"") 484 | err: '"' 485 | out: nil 486 | 487 | - mal: (println "abc\ndef\nghi") 488 | err: 489 | - abc 490 | - def 491 | - ghi 492 | out: nil 493 | 494 | - mal: (println "abc\\def\\ghi") 495 | err: abc\\def\\ghi 496 | out: nil 497 | 498 | - mal: (println (list 1 2 "abc" "\"") "def") 499 | err: \(1 2 abc "\) def 500 | out: nil 501 | 502 | 503 | - say: Testing keywords 504 | mal: (= :abc :abc) 505 | out: 'true' 506 | 507 | - mal: (= :abc :def) 508 | out: 'false' 509 | 510 | - mal: (= :abc ":abc") 511 | out: 'false' 512 | 513 | - mal: (= (list :abc) (list :abc)) 514 | out: 'true' 515 | 516 | 517 | - say: Testing vector truthiness 518 | mal: (if [] 7 8) 519 | out: 7 520 | 521 | 522 | - say: Testing vector printing 523 | mal: (pr-str [1 2 "abc" "\""] "def") 524 | out: '"[1 2 \"abc\" \"\\\"\"] \"def\""' 525 | 526 | - mal: (pr-str []) 527 | out: '"[]"' 528 | 529 | - mal: (str [1 2 "abc" "\""] "def") 530 | out: '"[1 2 abc \"]def"' 531 | 532 | - mal: (str []) 533 | out: '"[]"' 534 | 535 | 536 | - say: Testing vector functions 537 | mal: (count [1 2 3]) 538 | out: 3 539 | 540 | - mal: (empty? [1 2 3]) 541 | out: 'false' 542 | 543 | - mal: (empty? []) 544 | out: 'true' 545 | 546 | - mal: (list? [4 5 6]) 547 | out: 'false' 548 | 549 | 550 | - say: Testing vector equality 551 | mal: (= [] (list)) 552 | out: 'true' 553 | 554 | - mal: (= [7 8] [7 8]) 555 | out: 'true' 556 | 557 | - mal: (= [:abc] [:abc]) 558 | out: 'true' 559 | 560 | - mal: (= (list 1 2) [1 2]) 561 | out: 'true' 562 | 563 | - mal: (= (list 1) []) 564 | out: 'false' 565 | 566 | - mal: (= [] [1]) 567 | out: 'false' 568 | 569 | - mal: (= 0 []) 570 | out: 'false' 571 | 572 | - mal: (= [] 0) 573 | out: 'false' 574 | 575 | - mal: (= [] "") 576 | out: 'false' 577 | 578 | - mal: (= "" []) 579 | out: 'false' 580 | 581 | 582 | - say: Testing vector parameter lists 583 | mal: ( (fn* [] 4) ) 584 | out: 4 585 | 586 | - mal: ( (fn* [f x] (f x)) (fn* [a] (+ 1 a)) 7) 587 | out: 8 588 | 589 | 590 | - say: Nested vector/list equality 591 | mal: (= [(list)] (list [])) 592 | out: 'true' 593 | 594 | - mal: (= [1 2 (list 3 4 [5 6])] (list 1 2 [3 4 (list 5 6)])) 595 | out: 'true' 596 | -------------------------------------------------------------------------------- /perl/lib/Lingy/nREPL.pm: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | package Lingy::nREPL; 3 | 4 | use Lingy; 5 | use Lingy::Common; 6 | use IO::Socket::INET; 7 | use IO::Select; 8 | use Bencode; 9 | use YAML::PP; 10 | use Data::UUID; 11 | use IO::All; 12 | use Cwd; 13 | 14 | use XXX; 15 | 16 | use constant default_log_file => '.nrepl-log'; 17 | use constant port_file => $ENV{LINGY_NREPL_PORT_FILE} // '.nrepl-port'; 18 | 19 | sub new { 20 | my ($class, %args) = @_; 21 | 22 | srand; 23 | my $port = int(rand(10000)) + 40000; 24 | 25 | my $socket = IO::Socket::INET->new( 26 | LocalPort => $port, 27 | Proto => 'tcp', 28 | Listen => SOMAXCONN, 29 | Reuse => 1, 30 | ) or die "Can't create socket: $IO::Socket::errstr"; 31 | 32 | $socket->autoflush; 33 | 34 | my $log; 35 | if (my $log_file = $ENV{LINGY_NREPL_LOG}) { 36 | $log_file = default_log_file if $log_file eq '1'; 37 | $log = io($log_file); 38 | $log->absolute unless $log->is_stdio; 39 | } 40 | 41 | my $self = bless { 42 | port => $port, 43 | socket => $socket, 44 | runtime => Lingy->new, 45 | clients => {}, 46 | sessions => {}, 47 | yaml => YAML::PP->new(header => 0), 48 | log => $log, 49 | }, $class; 50 | 51 | return $self; 52 | } 53 | 54 | #------------------------------------------------------------------------------ 55 | # nREPL server op codes handlers: 56 | #------------------------------------------------------------------------------ 57 | sub op_eval { 58 | my ($self) = @_; 59 | 60 | if (my $file = $self->{request}{file}) { 61 | RT->env->set('*file*', STRING->new($file)); 62 | } 63 | 64 | eval { 65 | local *STDOUT; 66 | tie *STDOUT, 'StreamedOutput', 67 | sub { $self->send_response(@_) }, 68 | 'out'; 69 | 70 | local *STDERR; 71 | tie *STDERR, 'StreamedOutput', 72 | sub { $self->send_response(@_) }, 73 | 'err'; 74 | 75 | my $code = $self->{request}->{code}; 76 | if (my @results = $self->{runtime}->reps($code)) { 77 | $self->send_response({ 78 | value => $results[-1], 79 | ns => RT->current_ns_name 80 | }); 81 | } 82 | }; 83 | $self->send_response({err => $@}) if $@; 84 | 85 | $self->send_response({status => 'done'}); 86 | } 87 | 88 | sub op_clone { 89 | my ($self) = @_; 90 | 91 | my $session_to_clone = exists $self->{request}{session} 92 | ? $self->{request}{session} 93 | : 'default'; 94 | 95 | my $session_id = Data::UUID->new->create_str(); 96 | 97 | my %cloned_session = %{ $self->{sessions}->{$session_to_clone} }; 98 | $self->{sessions}->{$session_id} = \%cloned_session; 99 | 100 | $self->send_response({ 101 | 'new-session' => $session_id, 102 | status => 'done', 103 | }); 104 | } 105 | 106 | sub op_describe { 107 | my ($self) = @_; 108 | 109 | my %ops = map {($_ => +{})} 110 | qw(eval clone describe close); 111 | 112 | $self->send_response({ 113 | ops => { %ops }, 114 | status => 'done', 115 | }); 116 | } 117 | 118 | sub op_close { 119 | my ($self) = @_; 120 | 121 | 122 | my $session_to_close = $self->{request}{session} or 123 | return $self->send_response({ 124 | status => 'error', 125 | error => "No session specified to close", 126 | }); 127 | 128 | $self->{sessions}{$session_to_close} or 129 | return $self->send_response({ 130 | status => 'error', 131 | error => "No such session: '$session_to_close'", 132 | }); 133 | 134 | delete $self->{sessions}{$session_to_close}; 135 | 136 | $self->send_response({status => 'done'}); 137 | } 138 | 139 | #------------------------------------------------------------------------------ 140 | # Starting and stopping server: 141 | #------------------------------------------------------------------------------ 142 | sub start { 143 | my ($self) = @_; 144 | 145 | $self->{sessions}{default} = {}; 146 | 147 | my $port = $self->{port}; 148 | 149 | io(port_file)->print($port); 150 | 151 | print "nREPL server started on port $port " . 152 | "on host 127.0.0.1 - nrepl://127.0.0.1:$port\n"; 153 | 154 | if (my $log = $self->{log}) { 155 | print "Log file: $log\n" 156 | unless $log->is_stdio; 157 | } 158 | 159 | $self->log({ 160 | '===' => 'START', 161 | 'url' => "nrepl://127.0.0.1:$port", 162 | }); 163 | 164 | $self->{select} = IO::Select->new($self->{socket}); 165 | 166 | $SIG{INT} = sub { 167 | $self->log({ 168 | '===' => 'INTERUPT', 169 | }); 170 | $self->stop; 171 | exit 0; 172 | }; 173 | 174 | return $self; 175 | } 176 | 177 | sub run { 178 | my ($self) = @_; 179 | 180 | my $select = $self->{select}; 181 | my $client = 0; 182 | 183 | while (1) { 184 | foreach my $socket ($select->can_read(0.01)) { 185 | delete @{$self}{qw( conn request )}; 186 | 187 | if ($socket == $self->{socket}) { 188 | my $connection = $self->{socket}->accept; 189 | $self->{clients}->{$connection} = ++$client; 190 | $select->add($connection); 191 | $self->log({ 192 | '===' => 'CONNECT', 193 | client => $client, 194 | }); 195 | next; 196 | } 197 | 198 | my ($request, $buffer, $length) = 199 | $self->next_request($socket, $client) 200 | or next; 201 | 202 | my $op = $request->{op}; 203 | my $client_id = $self->{clients}->{$socket}; 204 | 205 | $self->log({ 206 | '-->' => ":op $op, :client $client_id", 207 | buffer => "$length: $buffer", 208 | request => $request, 209 | }); 210 | 211 | my $handler = "op_$op"; 212 | if ($self->can($handler)) { 213 | @{$self}{qw( conn request )} = ( 214 | $socket, 215 | $request, 216 | ); 217 | $self->$handler; 218 | 219 | } else { 220 | $self->log({ 221 | '???' => $op, 222 | client => $client_id, 223 | error => "Unsupported op: '$op'", 224 | }); 225 | } 226 | } 227 | } 228 | } 229 | 230 | sub stop { 231 | my ($self) = @_; 232 | 233 | return unless defined $self->{select}; 234 | 235 | if (-e port_file) { 236 | unlink port_file 237 | or warn "Could not unlink '${\ port_file}' file: $!"; 238 | } 239 | 240 | $self->log({ 241 | '===' => 'STOP', 242 | 'url' => "nrepl://127.0.0.1:$self->{port}", 243 | }); 244 | 245 | foreach my $client ($self->{select}->handles) { 246 | if ($client != $self->{socket}) { 247 | $self->{select}->remove($client); 248 | shutdown($client, 2) 249 | or warn "Couldn't properly shut down a client connection: $!"; 250 | close $client 251 | or warn "Couldn't close a client connection: $!"; 252 | } 253 | } 254 | 255 | $self->{select}->remove($self->{socket}); 256 | 257 | if ($self->{socket}) { 258 | close $self->{socket} 259 | or warn "Couldn't close the server socket: $!"; 260 | $self->{socket} = undef; 261 | } 262 | 263 | $self->{select} = undef; 264 | } 265 | 266 | sub next_request { 267 | my ($self, $socket, $client) = @_; 268 | my $buffer; 269 | my $length = sysread($socket, $buffer, 65535) 270 | or return $self->close_socket($socket, $client); 271 | my $request; 272 | eval { 273 | $request = Bencode::bdecode($buffer, 1); 274 | }; 275 | die "Error decoding request buffer:\n$buffer\n$@" if $@; 276 | return ($request, $buffer, $length); 277 | } 278 | 279 | sub close_socket { 280 | my ($self, $socket, $client) = @_; 281 | # Connection closed by client 282 | my $client_id = $self->{clients}->{$socket}; 283 | delete $self->{clients}->{$socket}; 284 | $self->{select}->remove($socket); 285 | close($socket); 286 | $self->log({ 287 | '===' => 'CLOSED', 288 | client => $client, 289 | }); 290 | return; 291 | } 292 | 293 | sub DESTROY { 294 | my ($self) = @_; 295 | $self->stop; 296 | } 297 | 298 | #------------------------------------------------------------------------------ 299 | # nREPL server response methods: 300 | #------------------------------------------------------------------------------ 301 | 302 | sub send_response { 303 | my ($self, $data) = @_; 304 | my ($conn, $request) = 305 | @{$self}{qw(conn request)}; 306 | 307 | my $response = { 308 | id => $request->{id}, 309 | $request->{session} ? (session => $request->{session}) : (), 310 | %$data, 311 | }; 312 | 313 | print $conn Bencode::bencode($response); 314 | 315 | $self->log({ 316 | '<--' => ":op $request->{op}, :client $self->{clients}{$conn}", 317 | response => $response, 318 | }); 319 | 320 | return; 321 | } 322 | 323 | #------------------------------------------------------------------------------ 324 | # Logging 325 | #------------------------------------------------------------------------------ 326 | 327 | sub log { 328 | my ( $self, $data ) = @_; 329 | my $log = $self->{log} or return; 330 | my $yaml = $self->{yaml}->dump_string($data); 331 | $log->print( $yaml . "\n" ); 332 | $log->autoflush unless $log->is_stdio; 333 | } 334 | 335 | #------------------------------------------------------------------------------ 336 | # Tied class to capture stdio during Lingy evals 337 | #------------------------------------------------------------------------------ 338 | { 339 | package StreamedOutput; 340 | 341 | sub TIEHANDLE { 342 | my ($class, $send_response, $output_type) = @_; 343 | bless { 344 | send_response => $send_response, 345 | output_type => $output_type, 346 | }, $class; 347 | } 348 | 349 | sub PRINT { 350 | my ( $self, @args ) = @_; 351 | my $output_type = $self->{output_type} // 'out'; 352 | $self->{send_response}->({$output_type => join('', @args)}); 353 | } 354 | 355 | sub PRINTF { 356 | my ( $self, $format, @args ) = @_; 357 | $self->PRINT(sprintf $format, @args); 358 | } 359 | } 360 | 361 | #------------------------------------------------------------------------------ 362 | # Hot patch Bencode to encode numbers as strings 363 | #------------------------------------------------------------------------------ 364 | { 365 | package Bencode; 366 | no warnings 'redefine'; 367 | our ( $DEBUG, $do_lenient_decode, $max_depth, $undef_encoding ); 368 | sub _bencode { 369 | map 370 | +( ( not defined ) ? ( $undef_encoding or croak 'unhandled data type' ) 371 | #: ( not ref ) ? ( m/\A (?: 0 | -? [1-9] \d* ) \z/x ? 'i' . $_ . 'e' : length . ':' . $_ ) 372 | : ( not ref ) ? length . ':' . $_ 373 | : ( 'SCALAR' eq ref ) ? ( length $$_ ) . ':' . $$_ # escape hatch -- use this to avoid num/str heuristics 374 | : ( 'ARRAY' eq ref ) ? 'l' . ( join '', _bencode @$_ ) . 'e' 375 | : ( 'HASH' eq ref ) ? 'd' . do { my @k = sort keys %$_; join '', map +( length $k[0] ) . ':' . ( shift @k ) . $_, _bencode @$_{ @k } } . 'e' 376 | : croak 'unhandled data type' 377 | ), @_ 378 | } 379 | } 380 | 381 | 1; 382 | --------------------------------------------------------------------------------