Compare commits
4 Commits
5ce364d78d
...
4e7ddffbc6
| Author | SHA1 | Date | |
|---|---|---|---|
| 4e7ddffbc6 | |||
| 78a4fb402d | |||
| c1851fe242 | |||
| fbcb129437 |
@@ -284,6 +284,8 @@ lowerVal
|
||||
|
||||
lowerVal (ValLit (LitInt n)) k = k . lowerInt $ n
|
||||
|
||||
-- lowerVal (ValLit (LitQuote (SexpSymbol s))) k = _aaa
|
||||
|
||||
lowerVal (ValLit (LitString s)) k = do
|
||||
rawString <- gensym
|
||||
r <- gensym
|
||||
|
||||
@@ -2,11 +2,21 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
module Gyehoek.Scheme.Syntax where
|
||||
module Gyehoek.Scheme.Syntax
|
||||
( Name
|
||||
, Prim(..)
|
||||
, Lit(..)
|
||||
, Define(..)
|
||||
, Exp(..)
|
||||
, Sexp(..)
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.List (List)
|
||||
import Language.SexpGrammar as Sexp hiding (List)
|
||||
import Language.SexpGrammar
|
||||
( SexpIso(..), list, el, (>>>), rest, sym, symbol )
|
||||
import Language.SexpGrammar qualified as Sexp
|
||||
import Language.SexpGrammar.Generic
|
||||
import GHC.Generics
|
||||
import Prelude hiding ((.), id)
|
||||
@@ -39,6 +49,7 @@ data Lit
|
||||
| LitNil
|
||||
| LitBool Bool
|
||||
| LitString Text
|
||||
| LitQuote Sexp
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Define
|
||||
@@ -53,9 +64,15 @@ data Exp
|
||||
| ExpDefine Define
|
||||
| ExpIf Exp Exp Exp
|
||||
| ExpLit Lit
|
||||
| ExpApply Exp (List Exp)
|
||||
| ExpLambda (List Name) Exp
|
||||
| ExpVar Name
|
||||
| ExpApply Exp (List Exp)
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Sexp
|
||||
= SexpCons Sexp Sexp
|
||||
| SexpSymbol Text
|
||||
| SexpLit Lit
|
||||
deriving (Show, Generic)
|
||||
|
||||
|
||||
@@ -85,6 +102,14 @@ instance SexpIso Lit where
|
||||
$ With (. sym "nil")
|
||||
$ With (. sexpIso)
|
||||
$ With (. sexpIso)
|
||||
$ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
|
||||
$ End
|
||||
|
||||
instance SexpIso Sexp where
|
||||
sexpIso = match
|
||||
$ With (\cons -> cons . Gyehoek.Sexp.todo)
|
||||
$ With (\s -> s . symbol)
|
||||
$ With (\lit -> lit . sexpIso)
|
||||
$ End
|
||||
|
||||
instance SexpIso Define where
|
||||
@@ -105,9 +130,9 @@ instance SexpIso Exp where
|
||||
$ With (. sexpIso)
|
||||
$ With (. if_)
|
||||
$ With (. sexpIso)
|
||||
$ With (\app -> app . list (el sexpIso >>> rest sexpIso))
|
||||
$ With (. lam)
|
||||
$ With (. symbol)
|
||||
$ With (\app -> app . list (el sexpIso >>> rest sexpIso))
|
||||
$ End
|
||||
where
|
||||
if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
|
||||
|
||||
@@ -10,6 +10,8 @@ module Gyehoek.Sexp
|
||||
, encode
|
||||
, decode
|
||||
, parseSexps
|
||||
, prefixSugar
|
||||
, todo
|
||||
)
|
||||
where
|
||||
|
||||
@@ -33,6 +35,7 @@ import GHC.IO.Unsafe (unsafePerformIO)
|
||||
import qualified Data.Text.IO as TIO
|
||||
import Control.Monad (join)
|
||||
import qualified Language.Sexp.Located as SexpLoc
|
||||
import Data.Void (absurd)
|
||||
|
||||
|
||||
sexp :: SexpIso a => Iso' a Text
|
||||
@@ -80,6 +83,24 @@ dotlist x = list $ rest $ coproduct
|
||||
[ x >>> _
|
||||
]
|
||||
|
||||
-- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
|
||||
prefixSugar
|
||||
:: Text -> Prefix
|
||||
-> Grammar Position (Sexp :- t') a
|
||||
-> Grammar Position (Sexp :- t') a
|
||||
prefixSugar name prefix e = coproduct
|
||||
-- 'something
|
||||
[ Sexp.prefixed prefix e
|
||||
-- (quote something)
|
||||
, list $ el (sym name) >>> el e
|
||||
]
|
||||
|
||||
todo :: Grammar p (Sexp :- t) t'
|
||||
todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
|
||||
where
|
||||
f _ = Left $ unexpected "todo"
|
||||
g _ = Left $ unexpected "todo"
|
||||
|
||||
lambda
|
||||
:: (forall t. Grammar Position (Sexp :- t) (a :- t))
|
||||
-> Grammar Position (Sexp :- List a :- t1) t2
|
||||
|
||||
@@ -120,5 +120,5 @@ driver = runGenSym . traverseOf_ (#sourceFiles . folded) \f -> do
|
||||
anfs <- toANF f exps
|
||||
qbe <- toQBE f anfs
|
||||
callQBE f
|
||||
callGCC f ["../runtime/gyehoek.c"]
|
||||
callGCC f ["../runtime/target/debug/libgyehoek.a"]
|
||||
pure ()
|
||||
|
||||
BIN
play/a.out
BIN
play/a.out
Binary file not shown.
48
play/hash.c
Normal file
48
play/hash.c
Normal file
@@ -0,0 +1,48 @@
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include "../runtime/gyehoek.h"
|
||||
#include "../runtime/weak-set.h"
|
||||
|
||||
static int
|
||||
symbol_lookup_predicate_fn (SCM sym1, void *closure) {
|
||||
const SCM sym2 = *((SCM*)closure);
|
||||
const int symp1 = SCM_SYMBOLP (sym1);
|
||||
const int symp2 = SCM_SYMBOLP (sym2);
|
||||
// both symbols?
|
||||
if (SCM_SYMBOLP (sym1) && SCM_SYMBOLP (sym2)) {
|
||||
const SCM str1 = SCM_CELL_OBJECT (sym1, 2);
|
||||
const SCM str2 = SCM_CELL_OBJECT (sym2, 2);
|
||||
const size_t len1 = scm_c_string_length (str1);
|
||||
const size_t len2 = scm_c_string_length (str2);
|
||||
// same length?
|
||||
if (len1 == len2) {
|
||||
// same name?
|
||||
const char * const s1 = scm_c_string_chars (str1);
|
||||
const char * const s2 = scm_c_string_chars (str2);
|
||||
return strncmp (s1, s2, len1);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
SCM test (SCM set, const char *sym_name, SCM value) {
|
||||
SCM str = scm_from_cstring (sym_name);
|
||||
SCM sym = scm_make_symbol (str, scm_c_hash (str));
|
||||
SCM r = scm_c_weak_set_insert (set, scm_c_hash (str), value,
|
||||
symbol_lookup_predicate_fn,
|
||||
&sym);
|
||||
printf ("%ld\n", weak_set_count (set));
|
||||
return r;
|
||||
}
|
||||
|
||||
int main () {
|
||||
/* const char s[] = "wormy"; */
|
||||
/* const SCM str = scm_from_utf8_string (s, sizeof(s)); */
|
||||
/* const unsigned long hash = scm_c_hash (str); */
|
||||
/* printf ("%ld\n", hash); */
|
||||
|
||||
SCM set = scm_c_make_weak_set (31);
|
||||
test (set, "my-symbol", SCM_PACK (SCM_MAKE_SMALL_INT (123)));
|
||||
test (set, "my-symbol", SCM_PACK (SCM_MAKE_SMALL_INT (123)));
|
||||
test (set, "my-symbol2", SCM_PACK (SCM_MAKE_SMALL_INT (456)));
|
||||
}
|
||||
1
runtime/.envrc
Normal file
1
runtime/.envrc
Normal file
@@ -0,0 +1 @@
|
||||
use flake
|
||||
1
runtime/.gitignore
vendored
Normal file
1
runtime/.gitignore
vendored
Normal file
@@ -0,0 +1 @@
|
||||
target
|
||||
56
runtime/Cargo.lock
generated
Normal file
56
runtime/Cargo.lock
generated
Normal file
@@ -0,0 +1,56 @@
|
||||
# This file is automatically @generated by Cargo.
|
||||
# It is not intended for manual editing.
|
||||
version = 4
|
||||
|
||||
[[package]]
|
||||
name = "bdwgc-alloc"
|
||||
version = "0.6.13"
|
||||
source = "git+https://git.deertopia.net/msyds/bdwgc-rust.git#ccc273a168f3ddfee0a2ae170f561f19da8c274a"
|
||||
dependencies = [
|
||||
"cmake",
|
||||
"libc",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "cc"
|
||||
version = "1.2.62"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "a1dce859f0832a7d088c4f1119888ab94ef4b5d6795d1ce05afb7fe159d79f98"
|
||||
dependencies = [
|
||||
"find-msvc-tools",
|
||||
"shlex",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "cmake"
|
||||
version = "0.1.58"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "c0f78a02292a74a88ac736019ab962ece0bc380e3f977bf72e376c5d78ff0678"
|
||||
dependencies = [
|
||||
"cc",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "find-msvc-tools"
|
||||
version = "0.1.9"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "5baebc0774151f905a1a2cc41989300b1e6fbb29aff0ceffa1064fdd3088d582"
|
||||
|
||||
[[package]]
|
||||
name = "gyehoek"
|
||||
version = "0.1.0"
|
||||
dependencies = [
|
||||
"bdwgc-alloc",
|
||||
]
|
||||
|
||||
[[package]]
|
||||
name = "libc"
|
||||
version = "0.2.186"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "68ab91017fe16c622486840e4c83c9a37afeff978bd239b5293d61ece587de66"
|
||||
|
||||
[[package]]
|
||||
name = "shlex"
|
||||
version = "1.3.0"
|
||||
source = "registry+https://github.com/rust-lang/crates.io-index"
|
||||
checksum = "0fda2ff0d084019ba4d7c6f371c95d8fd75ce3524c3cb8fb653a3023f6323e64"
|
||||
17
runtime/Cargo.toml
Normal file
17
runtime/Cargo.toml
Normal file
@@ -0,0 +1,17 @@
|
||||
[package]
|
||||
name = "gyehoek"
|
||||
version = "0.1.0"
|
||||
edition = "2024"
|
||||
|
||||
[lib]
|
||||
name = "gyehoek"
|
||||
# crate-type = ["cdylib"]
|
||||
crate-type = ["staticlib"]
|
||||
|
||||
[dependencies]
|
||||
bdwgc-alloc = { version = "0.6.13"
|
||||
, default-features = false
|
||||
, features = ["cmake"] }
|
||||
|
||||
[patch.crates-io]
|
||||
bdwgc-alloc = { git = 'https://git.deertopia.net/msyds/bdwgc-rust.git' }
|
||||
@@ -1,8 +0,0 @@
|
||||
all: gyehoek.o
|
||||
|
||||
gyehoek.o: gyehoek.c
|
||||
$(CC) $(CFLAGS) -c gyehoek.c -o gyehoek.o
|
||||
|
||||
.PHONY: install
|
||||
install:
|
||||
install -Dm644 -t $(out)/lib gyehoek.o
|
||||
@@ -1,10 +0,0 @@
|
||||
{ stdenv
|
||||
, callPackage
|
||||
, bdwgc ? callPackage ../bdwgc.nix {}
|
||||
}:
|
||||
|
||||
stdenv.mkDerivation {
|
||||
pname = "gyehoek";
|
||||
version = "1.0.0";
|
||||
src = ./.;
|
||||
}
|
||||
|
||||
87
runtime/flake.lock
generated
Normal file
87
runtime/flake.lock
generated
Normal file
@@ -0,0 +1,87 @@
|
||||
{
|
||||
"nodes": {
|
||||
"fenix": {
|
||||
"inputs": {
|
||||
"nixpkgs": [
|
||||
"nixpkgs"
|
||||
],
|
||||
"rust-analyzer-src": "rust-analyzer-src"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1779185128,
|
||||
"narHash": "sha256-Kl2bkmwZJD3n2KWDxuIlturZ7emqRK+anpD1LmDwpmY=",
|
||||
"owner": "nix-community",
|
||||
"repo": "fenix",
|
||||
"rev": "b7bd9323fe26a3b4f4bddbb2c2a1dacabced2f88",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "nix-community",
|
||||
"repo": "fenix",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1778869304,
|
||||
"narHash": "sha256-30sZNZoA1cqF5JNO9fVX+wgiQYjB7HJqqJ4ztCDeBZE=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "d233902339c02a9c334e7e593de68855ad26c4cb",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixos-unstable",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"root": {
|
||||
"inputs": {
|
||||
"fenix": "fenix",
|
||||
"nixpkgs": "nixpkgs",
|
||||
"sydpkgs": "sydpkgs"
|
||||
}
|
||||
},
|
||||
"rust-analyzer-src": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1779074864,
|
||||
"narHash": "sha256-0M3WqsWmtXmv9Ev/vnFfCHosWvISDwiuuhQ104UO3CI=",
|
||||
"owner": "rust-lang",
|
||||
"repo": "rust-analyzer",
|
||||
"rev": "cdfe408d4b436e806ff525cb3e67588a6a009ed1",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "rust-lang",
|
||||
"ref": "nightly",
|
||||
"repo": "rust-analyzer",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"sydpkgs": {
|
||||
"inputs": {
|
||||
"nixpkgs": [
|
||||
"nixpkgs"
|
||||
]
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1778962331,
|
||||
"narHash": "sha256-qMokSV7hsWYiDCkkBGyG0aD4Ds3JLzJzJ0Cp9f/spJU=",
|
||||
"ref": "refs/heads/main",
|
||||
"rev": "59d3a471cd960f9d1f6c645a4fe578a670848e9d",
|
||||
"revCount": 41,
|
||||
"type": "git",
|
||||
"url": "https://git.deertopia.net/msyds/sydpkgs"
|
||||
},
|
||||
"original": {
|
||||
"type": "git",
|
||||
"url": "https://git.deertopia.net/msyds/sydpkgs"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
"version": 7
|
||||
}
|
||||
70
runtime/flake.nix
Normal file
70
runtime/flake.nix
Normal file
@@ -0,0 +1,70 @@
|
||||
{
|
||||
inputs = {
|
||||
nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable";
|
||||
fenix = {
|
||||
url = "github:nix-community/fenix";
|
||||
inputs.nixpkgs.follows = "nixpkgs";
|
||||
};
|
||||
sydpkgs = {
|
||||
url = "git+https://git.deertopia.net/msyds/sydpkgs";
|
||||
inputs.nixpkgs.follows = "nixpkgs";
|
||||
};
|
||||
};
|
||||
|
||||
outputs = { self, nixpkgs, fenix, sydpkgs, ... }:
|
||||
let
|
||||
supportedSystems = [
|
||||
"aarch64-darwin" "aarch64-linux"
|
||||
"x86_64-darwin" "x86_64-linux"
|
||||
];
|
||||
|
||||
each-system = f: nixpkgs.lib.genAttrs supportedSystems (system: f rec {
|
||||
pkgs = import nixpkgs {
|
||||
inherit system overlays;
|
||||
};
|
||||
inherit (pkgs) lib;
|
||||
inherit system;
|
||||
});
|
||||
|
||||
overlays = [
|
||||
(final: prev: {
|
||||
inherit (sydpkgs.packages.${final.stdenv.hostPlatform.system})
|
||||
bdwgc;
|
||||
})
|
||||
fenix.overlays.default
|
||||
];
|
||||
|
||||
in {
|
||||
_pkgs = each-system ({ pkgs, ... }: pkgs);
|
||||
|
||||
packages = each-system ({ pkgs, ... }: {
|
||||
default = pkgs.callPackage ./. {};
|
||||
});
|
||||
|
||||
devShells = each-system ({ pkgs, lib, ... }: {
|
||||
default = pkgs.mkShell {
|
||||
RUSTFLAGS = "-L " + lib.makeLibraryPath [
|
||||
pkgs.bdwgc
|
||||
];
|
||||
packages = [
|
||||
pkgs.pkg-config
|
||||
pkgs.bdwgc
|
||||
(pkgs.fenix.complete.withComponents [
|
||||
"cargo" "clippy" "rust-src" "rustc" "rustfmt"
|
||||
])
|
||||
pkgs.rust-analyzer-nightly
|
||||
pkgs.cmake
|
||||
];
|
||||
};
|
||||
});
|
||||
};
|
||||
|
||||
nixConfig = {
|
||||
extra-substituters = [
|
||||
"https://fenix.cachix.org"
|
||||
];
|
||||
extra-trusted-public-keys = [
|
||||
"fenix.cachix.org-1:ecJhr+RdYEdcVgUkjruiYhjbBloIEGov7bos90cZi0Q="
|
||||
];
|
||||
};
|
||||
}
|
||||
@@ -1,75 +0,0 @@
|
||||
#include <stdio.h>
|
||||
#include <gc.h>
|
||||
#include "gyehoek.h"
|
||||
|
||||
|
||||
|
||||
const long scm_tc3_cons = 0;
|
||||
|
||||
const long scm_tc7_obarray = 0x55;
|
||||
const long scm_tc7_symbol = 0x05;
|
||||
const long scm_tc7_string = 0x15;
|
||||
|
||||
|
||||
|
||||
SCM scm_newline () {
|
||||
putc ('\n', stdout);
|
||||
return SCM_PACK(NULL);
|
||||
}
|
||||
|
||||
static void scm_write_string (SCM x) {
|
||||
const size_t len = SCM_CELL_WORD (x, 1);
|
||||
const char *s = (const char *) SCM_UNPACK_POINTER (SCM_CELL_OBJECT (x, 2));
|
||||
/* FIXME: this is a very naïve implementation with no escaping. */
|
||||
printf ("some unrelated unicode lol: %s\n", "왜 하냐??");
|
||||
printf ("\"%.*s\"", (int) len, s);
|
||||
}
|
||||
|
||||
SCM scm_write (SCM x) {
|
||||
if (SCM_IMP (x)) {
|
||||
printf ("%ld", SCM_UNPACK (x) >> 2);
|
||||
} else if (SCM_CONSP (x)) {
|
||||
printf ("(");
|
||||
scm_write (scm_car (x));
|
||||
printf (" . ");
|
||||
scm_write (scm_cdr (x));
|
||||
printf (")");
|
||||
} else if (SCM_STRINGP (x)) {
|
||||
scm_write_string (x);
|
||||
} else {
|
||||
printf ("#<heap object 0x%016lx>", SCM_UNPACK (x));
|
||||
}
|
||||
return SCM_PACK(NULL);
|
||||
}
|
||||
|
||||
SCM scm_car (SCM x) {
|
||||
return SCM_CELL_OBJECT (x, 0);
|
||||
}
|
||||
|
||||
SCM scm_cdr (SCM x) {
|
||||
return SCM_CELL_OBJECT (x, 1);
|
||||
}
|
||||
|
||||
SCM scm_words (scm_t_bits word_0, uint32_t n_words) {
|
||||
scm_t_bits *r = GC_malloc (n_words * sizeof (scm_t_bits));
|
||||
r[0] = word_0;
|
||||
return SCM_PACK (r);
|
||||
}
|
||||
|
||||
SCM scm_from_utf8_string (const char *str, size_t len) {
|
||||
SCM r = scm_words (scm_tc7_string, 3);
|
||||
SCM_SET_CELL_WORD (r, 1, len);
|
||||
SCM_SET_CELL_WORD (r, 2, str);
|
||||
printf ("str: %p\n", str);
|
||||
return r;
|
||||
}
|
||||
|
||||
SCM scm_from_utf8_symbol (const char *s, size_t len) {
|
||||
}
|
||||
|
||||
SCM scm_cons (SCM car, SCM cdr) {
|
||||
scm_t_bits *r = GC_malloc (2 * sizeof (scm_t_bits));
|
||||
r[0] = SCM_UNPACK (car);
|
||||
r[1] = SCM_UNPACK (cdr);
|
||||
return SCM_PACK (r);
|
||||
}
|
||||
@@ -1,102 +0,0 @@
|
||||
#ifndef GYEHOEK_H
|
||||
#define GYEHOEK_H
|
||||
|
||||
#include <stddef.h>
|
||||
#include <stdint.h>
|
||||
|
||||
|
||||
|
||||
typedef uintptr_t scm_t_bits;
|
||||
|
||||
typedef union SCM { struct { scm_t_bits n; } n; } SCM;
|
||||
|
||||
#define SCM_UNPACK(x) ((x).n.n)
|
||||
#define SCM_PACK(x) ((SCM) { { (scm_t_bits) (x) } })
|
||||
#define SCM_IMP(x) (6 & SCM_UNPACK (x))
|
||||
#define SCM_NIMP(x) (!SCM_IMP (x))
|
||||
#define SCM_HEAP_OBJECT_P(x) (SCM_NIMP (x))
|
||||
|
||||
#define SCM_UNPACK_POINTER(x) ((scm_t_bits *) (SCM_UNPACK (x)))
|
||||
#define SCM_PACK_POINTER(x) (SCM_PACK ((scm_t_bits) (x)))
|
||||
|
||||
#define SCM_FALSE 0b00100
|
||||
#define SCM_TRUE 0b01100
|
||||
#define SCM_EOL 0b10100
|
||||
|
||||
#if (-1 >> 2 == -1) && (-4 >> 2 == -1) && (-5 >> 2 == -2) && (-8 >> 2 == -2)
|
||||
# define SCM_SRS(x, y) ((x) >> (y))
|
||||
#else
|
||||
# define SCM_SRS(x, y) \
|
||||
((x) < 0 \
|
||||
? -1 - (scm_t_signed_bits) (~(scm_t_bits)(x) >> (y)) \
|
||||
: ((x) >> (y)))
|
||||
#endif
|
||||
|
||||
#define SCM_MAKE_SMALL_INT(x) (SCM_SRS ((SCM_PACK (x)), 2) + 2)
|
||||
#define SCM_GET_SMALL_INT(x) (SCM_UNPACK (x) >> 2)
|
||||
|
||||
/* Checking if a SCM variable holds a pair (for historical reasons, in
|
||||
Guile also known as a cons-cell): This is done by first checking that
|
||||
the SCM variable holds a heap object, and second, by checking that
|
||||
tc1==0 holds for the SCM_CELL_TYPE of the SCM variable. */
|
||||
#define SCM_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
|
||||
|
||||
|
||||
|
||||
#define scm_tc2_int 2
|
||||
|
||||
|
||||
|
||||
#define SCM_ITAG3(x) (7 & SCM_UNPACK (x))
|
||||
#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x))
|
||||
|
||||
/* #define scm_tc3_cons 0 */
|
||||
extern const long scm_tc3_cons;
|
||||
|
||||
SCM scm_cons (SCM car, SCM cdr);
|
||||
SCM scm_car (SCM x);
|
||||
SCM scm_cdr (SCM x);
|
||||
|
||||
|
||||
|
||||
#define SCM_UNPACK_POINTER(x) ((scm_t_bits *) (SCM_UNPACK (x)))
|
||||
#define SCM_PACK_POINTER(x) (SCM_PACK ((scm_t_bits) (x)))
|
||||
|
||||
#define SCM_CELL_OBJECT(x, n) (((SCM *)SCM_UNPACK_POINTER (x)) [n])
|
||||
#define SCM_CELL_WORD(x, n) (SCM_UNPACK (SCM_CELL_OBJECT ((x), (n))))
|
||||
|
||||
#define SCM_SET_CELL_OBJECT(x, n, v) \
|
||||
((((SCM *)SCM_UNPACK_POINTER (x)) [n]) = (v))
|
||||
#define SCM_SET_CELL_WORD(x, n, v) \
|
||||
(SCM_SET_CELL_OBJECT ((x), (n), SCM_PACK (v)))
|
||||
|
||||
#define SCM_CELL_TYPE(x) SCM_CELL_WORD (x, 0)
|
||||
#define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x))
|
||||
#define SCM_HAS_HEAP_TYPE(x, type, tag) \
|
||||
(SCM_NIMP (x) && type (x) == (tag))
|
||||
#define SCM_HAS_TYP7(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag))
|
||||
|
||||
extern const long scm_tc7_obarray;
|
||||
extern const long scm_tc7_symbol;
|
||||
extern const long scm_tc7_string;
|
||||
|
||||
|
||||
|
||||
#define SCM_STRINGP(x) (SCM_TYP7 (x) == scm_tc7_string)
|
||||
|
||||
|
||||
|
||||
SCM scm_words (scm_t_bits word_0, uint32_t n_words);
|
||||
|
||||
/* Construct a Scheme string. */
|
||||
SCM scm_from_utf8_string (const char *str, size_t len);
|
||||
|
||||
/* Intern a symbol with a UTF-8 string name. */
|
||||
SCM scm_from_utf8_symbol (const char *s, size_t len);
|
||||
|
||||
|
||||
|
||||
SCM scm_write (SCM);
|
||||
|
||||
|
||||
#endif /* GYEHOEK_H */
|
||||
@@ -1,24 +0,0 @@
|
||||
#include "gyehoek.h"
|
||||
#include "obarray.h"
|
||||
|
||||
typedef struct {
|
||||
unsigned long hash;
|
||||
scm_t_bits key;
|
||||
} scm_t_weak_entry;
|
||||
|
||||
struct weak_entry_data {
|
||||
scm_t_weak_entry *in;
|
||||
scm_t_weak_entry *out;
|
||||
};
|
||||
|
||||
typedef struct {
|
||||
scm_t_weak_entry *entries; /* the data */
|
||||
scm_i_pthread_mutex_t lock; /* the lock */
|
||||
unsigned long size; /* total number of slots. */
|
||||
unsigned long n_items; /* number of items in set */
|
||||
unsigned long lower; /* when to shrink */
|
||||
unsigned long upper; /* when to grow */
|
||||
int size_index; /* index into hashset_size */
|
||||
int min_size_index; /* minimum size_index */
|
||||
} scm_t_weak_set;
|
||||
|
||||
@@ -1,8 +0,0 @@
|
||||
#ifndef OBARRAY_H
|
||||
#define OBARRAY_H
|
||||
|
||||
#define SCM_OBARRAY_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_set))
|
||||
|
||||
SCM scm_obarray_insert ()
|
||||
|
||||
#endif /* OBARRAY_H */
|
||||
109
runtime/src/lib.rs
Normal file
109
runtime/src/lib.rs
Normal file
@@ -0,0 +1,109 @@
|
||||
use std::{io::{stdout, Write}};
|
||||
|
||||
const scm_tc3_cons: u64 = 0;
|
||||
const scm_tc2_int: u64 = 2;
|
||||
|
||||
|
||||
type scm_bits = u64;
|
||||
|
||||
#[repr(C)]
|
||||
#[derive(Clone, Copy)]
|
||||
struct SCM {
|
||||
n : scm_bits
|
||||
}
|
||||
|
||||
fn scm_pack (bits : scm_bits) -> SCM {
|
||||
SCM {n: bits}
|
||||
}
|
||||
|
||||
fn scm_unpack (x : SCM) -> scm_bits {
|
||||
x.n
|
||||
}
|
||||
|
||||
fn scm_unpack_pointer (x : SCM) -> *mut scm_bits {
|
||||
x.n as *mut scm_bits
|
||||
}
|
||||
|
||||
fn scm_pack_pointer (x : *const scm_bits) -> SCM {
|
||||
SCM {n: x as scm_bits}
|
||||
}
|
||||
|
||||
|
||||
|
||||
fn scm_cell_object (x: SCM, n: usize) -> SCM {
|
||||
let p = scm_unpack_pointer (x) as *mut SCM;
|
||||
unsafe {
|
||||
*(p.wrapping_add (n))
|
||||
}
|
||||
}
|
||||
|
||||
fn scm_cell_word (x: SCM, n: usize) -> scm_bits {
|
||||
scm_unpack (scm_cell_object (x, n))
|
||||
}
|
||||
|
||||
fn is_immediate (x: SCM) -> bool {
|
||||
6 & scm_unpack (x) != 0
|
||||
}
|
||||
|
||||
fn scm_cell_type (x: SCM) -> scm_bits {
|
||||
scm_cell_word (x, 0)
|
||||
}
|
||||
|
||||
fn is_cons (x: SCM) -> bool {
|
||||
! is_immediate (x) && (1 & scm_cell_type (x)) == 0
|
||||
}
|
||||
|
||||
fn is_small_int (x: SCM) -> bool {
|
||||
3 & scm_unpack (x) == scm_tc2_int
|
||||
}
|
||||
|
||||
fn get_small_int (x: SCM) -> scm_bits {
|
||||
scm_unpack (x) >> 2
|
||||
}
|
||||
|
||||
fn scm_car (x: SCM) -> SCM {
|
||||
scm_cell_object (x, 0)
|
||||
}
|
||||
|
||||
fn scm_cdr (x: SCM) -> SCM {
|
||||
scm_cell_object (x, 1)
|
||||
}
|
||||
|
||||
#[unsafe(no_mangle)]
|
||||
pub extern "C" fn scm_write (x: SCM) -> SCM {
|
||||
if is_small_int (x) {
|
||||
print! ("{:?}", get_small_int (x));
|
||||
} else if is_cons (x) {
|
||||
print! ("(");
|
||||
scm_write (scm_car (x));
|
||||
print! (" . ");
|
||||
scm_write (scm_cdr (x));
|
||||
print! (")");
|
||||
} else {
|
||||
let ty = if is_immediate (x) { "immediate" } else { "heap object" };
|
||||
print! ("#<{ty} {:#016x}>", scm_unpack (x));
|
||||
}
|
||||
stdout ().flush ();
|
||||
return scm_pack (0);
|
||||
}
|
||||
|
||||
#[unsafe(no_mangle)]
|
||||
pub extern "C" fn scm_from_utf8_string (s: scm_bits, len: scm_bits) -> scm_bits {
|
||||
println! ("scm_from_utf8_string");
|
||||
return 0;
|
||||
}
|
||||
|
||||
pub fn add (left: u64, right: u64) -> u64 {
|
||||
left + right
|
||||
}
|
||||
|
||||
#[cfg(test)]
|
||||
mod tests {
|
||||
use super::*;
|
||||
|
||||
#[test]
|
||||
fn it_works () {
|
||||
let result = add (2, 2);
|
||||
assert_eq! (result, 4);
|
||||
}
|
||||
}
|
||||
Reference in New Issue
Block a user