diff --git a/.gitignore b/.gitignore index 9162cffcc..11e9fa6b8 100644 --- a/.gitignore +++ b/.gitignore @@ -1,39 +1,12 @@ *.dSYM -a.out -.DS_Store +*/.DS_Store -/gl-constants/gl_constants.o +.stack-work/ -/out/*.c -/out/*.so -/out/*.h -/out/*.dll -/out/*.exp -/out/*.lib -/out/*.pdb -/out/*.ilk -/out/*.obj -/out/exe - -/src/*.o - -/bin/carp-repl -/bin/Release/ -/bin/Debug/ - -/build/ -/examples/exe -/src/TAGS +/CarpHask-exe.prof -sourcetree.license - -.idea/ -temp/ - -/TAGS -/bin/project.carp -instrumentations/ -/CMakeCache.txt -CMakeFiles/ -/cmake_install.cmake -/Makefile +/out/*.so +/out/.DS_Store +/out/a.out +/out/main.c +/.DS_Store diff --git a/CMakeLists.txt b/CMakeLists.txt deleted file mode 100644 index 8440a91f0..000000000 --- a/CMakeLists.txt +++ /dev/null @@ -1,62 +0,0 @@ -cmake_minimum_required(VERSION 2.8) - -project(carp-repl) - -set(VERSION_MAJOR "0") -set(VERSION_MINOR "0") -set(VERSION_PATCH "1") -set(VERSION "${VERSION_MAJOR}.${VERSION_MINOR}.${VERSION_PATCH}") - -# use c99 -set(CMAKE_C_FLAGS "--std=c99 ${CMAKE_C_FLAGS}") - -if(${CMAKE_SYSTEM_NAME} STREQUAL "Linux") - set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -D_GNU_SOURCE") - - # linux uses pkg config - Include(FindPkgConfig) - PKG_SEARCH_MODULE(LIBFFI REQUIRED libffi) -else() - # other systems use manually set paths - # set name must match the one set by pkg config - set(LIBFFI_INCLUDE_DIRS - "${PROJECT_SOURCE_DIR}/../libffi/x86_64-apple-darwin15.3.0/include" - CACHE - PATH - "libffi include directory") - - # set name must match the one set by pkg config - set(LIBFFI_LIBRARIES - "${PROJECT_SOURCE_DIR}/../libffi/x86_64-apple-darwin15.3.0/.libs" - CACHE - PATH - "libffi library directory") -endif() - -set(SOURCE_DIR src) -include(globfiles.cmake) - -include_directories( - ${LIBFFI_INCLUDE_DIRS}) - -link_directories( - ${LIBFFI_LIBRARIES}) - -add_executable(${PROJECT_NAME} ${${PROJECT_NAME}_h} ${${PROJECT_NAME}_c}) - -target_link_libraries(${PROJECT_NAME} - ffi - m - c - pthread - dl) - -set_target_properties(${PROJECT_NAME} - PROPERTIES - RUNTIME_OUTPUT_DIRECTORY "${PROJECT_SOURCE_DIR}/bin") - -add_custom_target( - format - COMMAND find . -iname '*.[ch]' | xargs clang-format -style=file -i -) - diff --git a/CarpHask.cabal b/CarpHask.cabal new file mode 100644 index 000000000..03602ff63 --- /dev/null +++ b/CarpHask.cabal @@ -0,0 +1,64 @@ +name: CarpHask +version: 0.2.0.0 +-- synopsis: +-- description: +homepage: https://github.com/eriksvedang/Carp +license: Apache-2.0 +license-file: LICENSE +author: Erik Svedäng +maintainer: erik.svedang@gmail.com +copyright: Erik Svedäng +category: General +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Obj, + Parsing, + Infer, + Emit, + ColorText, + Constraints, + Deftype, + Commands, + Template, + Types, + Util, + Eval + + build-depends: base >= 4.7 && < 5 + , parsec == 3.1.* + , mtl + , containers + , process + , directory + , split + + default-language: Haskell2010 + +executable CarpHask-exe + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , CarpHask + , containers + , process + default-language: Haskell2010 + +test-suite CarpHask-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , CarpHask + , HUnit + , containers + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/eriksvedang/Carp diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 000000000..50b3c04fd --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,90 @@ +module Main where + +import Control.Monad +import qualified System.Environment as SystemEnvironment +import System.IO (hFlush, stdout) +import qualified Data.Map as Map +import ColorText +import Obj +import Types +import Commands +import Template +import Parsing + +defaultProject :: Project +defaultProject = Project { projectTitle = "Untitled" + , projectIncludes = [SystemInclude "prelude.h"] + , projectCFlags = [] + , projectLibFlags = [] + , projectFiles = [] + , projectEchoC = False + , projectCarpDir = "./" + , projectOutDir = "./out/" + } + +repl :: Context -> String -> IO () +repl context readSoFar = + do putStrWithColor Yellow (if null readSoFar then "鲮 " else " ") -- 鲤 / 鲮 + hFlush stdout + input <- fmap (\s -> readSoFar ++ s ++ "\n") getLine + case balance input of + 0 -> do let input' = if input == "\n" then contextLastInput context else input + context' <- executeString context input' + repl (context' { contextLastInput = input' }) "" + _ -> repl context input + +arrayModule :: Env +arrayModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = Just "Array", envImports = [], envMode = ExternalEnv } + where bindings = Map.fromList [ templateNth + , templateReplicate + , templateRepeat + , templateMap + , templateRaw + , templateAset + , templateAsetBang + , templateCount + , templatePushBack + , templatePopBack + , templateDeleteArray + , templateCopyArray + ] + +startingGlobalEnv :: Env +startingGlobalEnv = Env { envBindings = bs, envParent = Nothing, envModuleName = Nothing, envImports = [], envMode = ExternalEnv } + where bs = Map.fromList [ register "and" (FuncTy [BoolTy, BoolTy] BoolTy) + , register "or" (FuncTy [BoolTy, BoolTy] BoolTy) + , register "not" (FuncTy [BoolTy] BoolTy) + , templateNoop + , ("Array", Binder (XObj (Mod arrayModule) Nothing Nothing)) + , register "NULL" (VarTy "a") + ] + +startingTypeEnv :: Env +startingTypeEnv = Env { envBindings = Map.empty, envParent = Nothing, envModuleName = Nothing, envImports = [], envMode = ExternalEnv } + +preludeModules :: String -> [String] +preludeModules carpDir = map (\s -> carpDir ++ "/core/" ++ s ++ ".carp") [ "Int" + , "Double" + , "Float" + , "Array" + , "String" + , "Char" + , "IO" + , "System" + , "Macros" + ] + +main :: IO () +main = do putStrLn "Welcome to Carp 0.2.0" + putStrLn "This is free software with ABSOLUTELY NO WARRANTY." + putStrLn "Evaluate (help) for more information." + args <- SystemEnvironment.getArgs + sysEnv <- SystemEnvironment.getEnvironment + let projectWithFiles = defaultProject { projectFiles = args } + projectWithCarpDir = case lookup "CARP_DIR" sysEnv of + Just carpDir -> projectWithFiles { projectCarpDir = carpDir } + Nothing -> projectWithFiles + context <- foldM executeCommand (Context startingGlobalEnv startingTypeEnv [] projectWithCarpDir "") + (map Load (preludeModules (projectCarpDir projectWithCarpDir))) + context' <- foldM executeCommand context (map Load args) + repl context' "" diff --git a/bin/carp b/bin/carp deleted file mode 100755 index cc2464b9d..000000000 --- a/bin/carp +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash - -# Get the dir of this script (which is in the bin folder) -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" - -WRAPPER=rlwrap -#WRAPPER=lldb -#WRAPPER=valgrind - -CARP_DIR=$DIR/../ $WRAPPER $DIR/carp-repl $@ diff --git a/bin/carp-inferior b/bin/carp-inferior deleted file mode 100755 index 4779867a5..000000000 --- a/bin/carp-inferior +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/bash - -# inferior-lisp-mode in Emacs can't handle lrwrap so this script doesn't use that - -# Get the dir of this script (which is in the bin folder) -DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" - -CARP_DIR=$DIR/../ $DIR/carp-repl diff --git a/bin/carp.bat b/bin/carp.bat deleted file mode 100644 index 8ef9128ae..000000000 --- a/bin/carp.bat +++ /dev/null @@ -1,15 +0,0 @@ -@ECHO OFF - -REM Get the dir of this script (which is in the bin folder) -SET DIR=%~dp0 - -SET WRAPPER= -REM WRAPPER=rlwrap -REM WRAPPER=lldb -REM WRAPPER=valgrind - -SET CARP_EXE=Debug\carp-repl - -SET CARP_DIR=%DIR%..\ - -%WRAPPER% "%DIR%%CARP_EXE%" diff --git a/core/Array.carp b/core/Array.carp new file mode 100644 index 000000000..092fc4ace --- /dev/null +++ b/core/Array.carp @@ -0,0 +1,12 @@ +(defmodule Array + (register str (Fn [(Ref (Array t))] String)) + (register range (Fn [Int Int] (Array Int))) + (register sum (Fn [(Ref (Array Int))] Int)) + ) + +;; Other Array functions available: +;; raw : (Fn [(Array t)] (Ptr t)) +;; nth : (Fn [(Array t) Int] t) +;; aset! : (Fn [(Array t) Int t] ()) +;; count : (Fn [(Array t)] Int) +;; replicate : (Fn [Int t] (Array t)) diff --git a/core/Char.carp b/core/Char.carp new file mode 100644 index 000000000..d40343d44 --- /dev/null +++ b/core/Char.carp @@ -0,0 +1,2 @@ +(defmodule Char + (register str (Fn [Char] String))) diff --git a/core/Double.carp b/core/Double.carp new file mode 100644 index 000000000..5e1a3f365 --- /dev/null +++ b/core/Double.carp @@ -0,0 +1,10 @@ +(defmodule Double + (register + (Fn [Double Double] Double)) + (register - (Fn [Double Double] Double)) + (register * (Fn [Double Double] Double)) + (register / (Fn [Double Double] Double)) + (register toInt (Fn [Double] Int)) + (register fromInt (Fn [Int] Double)) + (register sin (Fn [Double] Double)) + (register cos (Fn [Double] Double)) + ) diff --git a/core/Float.carp b/core/Float.carp new file mode 100644 index 000000000..93abc7c5b --- /dev/null +++ b/core/Float.carp @@ -0,0 +1,6 @@ +(defmodule Float + (register + (Fn [Float Float] Float)) + (register - (Fn [Float Float] Float)) + (register * (Fn [Float Float] Float)) + (register / (Fn [Float Float] Float)) + (register toInt (Fn [Float] Int))) diff --git a/core/IO.carp b/core/IO.carp new file mode 100644 index 000000000..a8a5f52a7 --- /dev/null +++ b/core/IO.carp @@ -0,0 +1,5 @@ +(defmodule IO + (register println (Fn [(Ref String)] ())) + (register print (Fn [(Ref String)] ())) + (register get-line (Fn [] String)) + ) diff --git a/core/Int.carp b/core/Int.carp new file mode 100644 index 000000000..349ade2c1 --- /dev/null +++ b/core/Int.carp @@ -0,0 +1,18 @@ +(defmodule Int + (register + (Fn [Int Int] Int)) + (register - (Fn [Int Int] Int)) + (register * (Fn [Int Int] Int)) + (register / (Fn [Int Int] Int)) + (register < (Fn [Int Int] Bool)) + (register > (Fn [Int Int] Bool)) + (register = (Fn [Int Int] Bool)) + (register mod (Fn [Int Int] Int)) + (register seed (Fn [Int] ())) + (register random (Fn [] Int)) + (register random-between (Fn [Int Int] Int)) + (register str (Fn [Int] String)) + (register from-string (Fn [String] Int)) + (register mask (Fn [Int Int] Bool)) + (register inc (Fn [Int] Int)) + (register dec (Fn [Int] Int))) + diff --git a/core/Macros.carp b/core/Macros.carp new file mode 100644 index 000000000..03e8bf679 --- /dev/null +++ b/core/Macros.carp @@ -0,0 +1,32 @@ +(defdynamic cond-internal [xs] + (if (= (count xs) 0) + (list) + (if (= (count xs) 2) + (list) + (if (= (count xs) 1) + (car xs) + (list + (quote if) + (car xs) + (car (cdr xs)) + (cond-internal (cdr (cdr xs)))))))) + +(defmacro cond [:rest xs] + (cond-internal xs)) + +(defmacro for [settings body] ;; settings = variable, from, to, + (list + (quote let) + (array (car settings) (car (cdr settings))) + (list + (quote while) + (list (quote Int.<) (car settings) (car (cdr (cdr settings)))) + (list (quote do) + body + (list + (quote set!) (car settings) + (list (quote Int.+) + (car settings) + (if (= 4 (count settings)) ;; optional arg for step + (car (cdr (cdr (cdr settings)))) + 1))))))) diff --git a/core/SDLHelper.h b/core/SDLHelper.h new file mode 100644 index 000000000..27d88949b --- /dev/null +++ b/core/SDLHelper.h @@ -0,0 +1,64 @@ +#include + +typedef struct { + SDL_Window *window; + SDL_Renderer *renderer; +} App; + +App app_MINUS_init(const char *title, int width, int height) { + SDL_Init(SDL_INIT_EVERYTHING); + SDL_Window *window; + SDL_Renderer *renderer; + SDL_CreateWindowAndRenderer(width, height, 0, &window, &renderer); + SDL_SetWindowTitle(window, title); + App app; + app.window = window; + app.renderer = renderer; + return app; +} + +SDL_Window *app_MINUS_window(App app) { + return app.window; +} + +SDL_Renderer *app_MINUS_renderer(App app) { + return app.renderer; +} + +void app_MINUS_stop(App *app) { + SDL_DestroyWindow(app->window); + SDL_Quit(); +} + +SDL_Event SDL_Event_init() { + SDL_Event e; + return e; +} + +int event_MINUS_type(SDL_Event *e) { + return e->type; +} + +SDL_Keycode event_MINUS_keycode(SDL_Event *e) { + return e->key.keysym.sym; +} + +int Keycode__EQ_(SDL_Keycode a, SDL_Keycode b) { + return a == b; +} + +SDL_Rect make_MINUS_rect(int x, int y, int w, int h) { + SDL_Rect r; + r.x = x; + r.y = y; + r.w = w; + r.h = h; + return r; +} + +SDL_Point make_MINUS_point(int x, int y) { + SDL_Point p; + p.x = x; + p.y = y; + return p; +} diff --git a/core/String.carp b/core/String.carp new file mode 100644 index 000000000..0ddc271ea --- /dev/null +++ b/core/String.carp @@ -0,0 +1,8 @@ +(defmodule String + (register = (Fn [(Ref String) (Ref String)] Bool)) + (register append (Fn [String String] String)) + (register delete (Fn [String] ())) + (register copy (Fn [(Ref String)] String)) + (register count (Fn [(Ref String)] Int)) + (register duplicate (Fn [(Ref String)] String)) + ) diff --git a/core/System.carp b/core/System.carp new file mode 100644 index 000000000..9ac4b3dbb --- /dev/null +++ b/core/System.carp @@ -0,0 +1,5 @@ +(defmodule System + (register exit (Fn [Int] ())) + (register free (Fn [t] ())) + (register time (Fn [] Int)) + ) diff --git a/core/prelude.h b/core/prelude.h new file mode 100644 index 000000000..db086efc7 --- /dev/null +++ b/core/prelude.h @@ -0,0 +1,243 @@ +#ifndef PRELUDE_H +#define PRELUDE_H + +#include +#include +#include +#include +#include +#include +#include + +typedef char* string; + +bool not(bool b) { + return !b; +} + +#define Int__PLUS_(x, y) ((x) + (y)) +#define Int__MINUS_(x, y) ((x) - (y)) +#define Int__MUL_(x, y) ((x) * (y)) +#define Int__DIV_(x, y) ((x) / (y)) +#define Int__EQ_(x, y) ((x) == (y)) +#define Int__LT_(x, y) ((x) < (y)) +#define Int__GT_(x, y) ((x) > (y)) + +int Int_inc(int x) { return x + 1; } +int Int_dec(int x) { return x - 1; } + +#define Double__PLUS_(x, y) ((x) + (y)) +#define Double__MINUS_(x, y) ((x) - (y)) +#define Double__MUL_(x, y) ((x) * (y)) +#define Double__DIV_(x, y) ((x) / (y)) + +#define Float__PLUS_(x, y) ((x) + (y)) +#define Float__MINUS_(x, y) ((x) - (y)) +#define Float__MUL_(x, y) ((x) * (y)) +#define Float__DIV_(x, y) ((x) / (y)) + +#define and(x, y) ((x) && (y)) +#define or(x, y) ((x) || (y)) + +void IO_println(string *s) { puts(*s); } +void IO_print(string *s) { printf("%s", *s); } + +string IO_get_MINUS_line() { + size_t size = 1024; + char *buffer = malloc(size); + getline(&buffer, &size, stdin); + return buffer; +} + +string str(int x) { + char *buffer = malloc(64); + snprintf(buffer, 64, "%d", x); + return buffer; +} + +int Int_from_MINUS_string(string s) { + return atoi(s); +} + +int Int_mod(int x, int divider) { + return x % divider; +} + +void Int_seed(int seed) { + srand(seed); +} + +int Int_random() { + return rand(); +} + +int Int_random_MINUS_between(int lower, int upper) { + int diff = upper - lower; + return lower + (rand() % diff); +} + +string Int_str(int x) { + return str(x); +} + +bool Int_mask(int a, int b) { + return a & b; +} + +void String_delete(string s) { + free(s); +} + +string String_copy(string *s) { + return strdup(*s); +} + +bool String__EQ_(string *a, string *b) { + return strcmp(*a, *b) == 0; +} + +string String_append(string a, string b) { + int la = strlen(a); + int lb = strlen(b); + int total = la + lb + 1; + string buffer = malloc(total); + snprintf(buffer, total, "%s%s", a, b); + free(a); + free(b); + return buffer; +} + +int String_count(string *s) { + return strlen(*s); +} + +// Replace with 'copy' later: +string String_duplicate(string *s) { + return strdup(*s); +} + +string Char_str(char c) { + char *buffer = malloc(2); + snprintf(buffer, 2, "%c", c); + return buffer; +} + +int exmod__bleh(int x) { + return x * 1000; +} + +// Double.toInt : Double -> Int +int Double_toInt(double x) { + return (int)x; +} + +double Double_fromInt(int x) { + return (double)x; +} + +double Double_sin(double x) { + return sin(x); +} + +double Double_cos(double x) { + return cos(x); +} + +int Float_toInt(double x) { + return (int)x; +} + +// Array +typedef struct { + int len; + void *data; +} Array; + +Array Array_range(int start, int end) { + Array a; + int len = end - start; + a.len = len; + a.data = malloc(sizeof(int) * len); + for(int i = 0; i < len; ++i) { + ((int*)a.data)[i] = start + i; + } + return a; +} + +string Array_str__int(Array *aRef) { + Array a = *aRef; + string buffer = malloc(1024); + string b = buffer; + sprintf(b, "["); b += 1; + for(int i = 0; i < a.len; ++i) { + string temp = malloc(32); + snprintf(temp, 32, "%d", ((int*)a.data)[i]); + sprintf(b, "%s", temp); + b += strlen(temp); + if(i < a.len - 1) { + sprintf(b, " "); b += 1; + } + } + sprintf(b, "]"); b += 1; + *b = '\0'; + return buffer; +} + +string Array_str__string(Array *aRef) { + Array a = *aRef; + string buffer = malloc(1024); + string b = buffer; + sprintf(b, "["); b += 1; + for(int i = 0; i < a.len; ++i) { + char *temp = ((string*)a.data)[i]; + sprintf(b, "%s", temp); + b += strlen(temp); + if(i < a.len - 1) { + sprintf(b, " "); b += 1; + } + } + sprintf(b, "]"); b += 1; + *b = '\0'; + return buffer; +} + +string Array_str__bool(Array a) { + string buffer = malloc(1024); + string b = buffer; + sprintf(b, "["); b += 1; + for(int i = 0; i < a.len; ++i) { + string temp = malloc(32); + snprintf(temp, 32, "%s", (((int*)a.data)[i] ? "true" : "false")); + sprintf(b, "%s", temp); + b += strlen(temp); + if(i < a.len - 1) { + sprintf(b, " "); b += 1; + } + } + sprintf(b, "]"); b += 1; + *b = '\0'; + return buffer; +} + +int Array_sum(Array *aRef) { + Array a = *aRef; + int sum = 0; + for(int i = 0; i < a.len; ++i) { + sum += ((int*)a.data)[i]; + } + return sum; +} + +void System_exit(int code) { + exit(code); +} + +void System_free__string_MUL_(void *p) { + free(p); +} + +int System_time() { + return time(0); +} + +#endif diff --git a/core/sdl.carp b/core/sdl.carp new file mode 100644 index 000000000..9321bf6ff --- /dev/null +++ b/core/sdl.carp @@ -0,0 +1,112 @@ +(system-include "math.h") +(system-include "SDL.h") +(local-include "../core/SDLHelper.h") + +;; Compiler flags +(add-cflag "-I/usr/local/include/SDL2") +(add-cflag "-D_THREAD_SAFE") +(add-lib "-L/usr/local/lib") +(add-lib "-lSDL2") + +;; Setup and quit +(register SDL_Init (Fn [Int] ())) +(register SDL_Delay (Fn [Int] ())) +(register SDL_INIT_EVERYTHING Int) +(register SDL_Quit (Fn [] ())) + +;; SDL_EventType +(register SDL_QUIT Int) +(register SDL_KEYDOWN Int) +(register SDL_UP Int) +(register SDL_MOUSEMOTION Int) +(register SDL_MOUSEBUTTONDOWN Int) +(register SDL_MOUSEBUTTONUP Int) +(register SDL_MOUSEWHEEL Int) + +;; Structures +(register-type SDL_Rect) +(register-type SDL_Point) + +(register make-rect (Fn [Int Int Int Int] SDL_Rect)) ;; x y w h +(register make-point (Fn [Int Int] SDL_Point)) + +;; Rendering +(register SDL_RenderPresent (Fn [(Ptr SDL_Renderer)] ())) +(register SDL_RenderClear (Fn [(Ptr SDL_Renderer)] ())) +(register SDL_RenderCopy (Fn [(Ptr SDL_Renderer) (Ptr SDL_Texture) (Ptr SDL_Rect) (Ptr SDL_Rect)] ())) ;; src-rect & dest-rect +(register SDL_RenderCopyEx (Fn [(Ptr SDL_Renderer) (Ptr SDL_Texture) (Ptr SDL_Rect) (Ptr SDL_Rect) + Double (Ptr SDL_Point) SDL_RendererFlip] ())) ;; src-rect, dest-rect, angle, center, flip +(register SDL_SetRenderDrawColor (Fn [(Ptr SDL_Renderer) Int Int Int Int] ())) ;; rgba +(register SDL_RenderFillRect (Fn [(Ptr SDL_Renderer) (Ptr SDL_Rect)] ())) +(register SDL_RenderFillRects (Fn [(Ptr SDL_Renderer) (Ptr SDL_Rect) Int] ())) ;; rects, count +(register SDL_RenderDrawLine (Fn [(Ptr SDL_Renderer) Int Int Int Int] ())) ;; x1 y1 x2 y2 +(register SDL_RenderDrawLines (Fn [(Ptr SDL_Renderer) (Ptr SDL_Point) Int] ())) ;; lines, count +(register SDL_DestroyTexture (Fn [(Ptr SDL_Texture)] ())) +(register SDL_SetRenderDrawBlendMode (Fn [(Ptr SDL_Renderer) SDL_BlendMode] ())) +(register SDL_BlitSurface (Fn [(Ptr SDL_Surface) (Ptr SDL_Rect) (Ptr SDL_Surface) (Ptr SDL_Rect)] ())) ;; src, srcrect, dst, dstrect +(register SDL_QueryTexture (Fn [(Ptr SDL_Texture) (Ptr Int) (Ptr Int) (Ptr Int) (Ptr Int)] ())) ;; ? ? w h + +;; Blend modes +(register-type SDL_BlendMode) +(register SDL_BLENDMODE_NONE SDL_BlendMode) +(register SDL_BLENDMODE_BLEND SDL_BlendMode) +(register SDL_BLENDMODE_ADD SDL_BlendMode) +(register SDL_BLENDMODE_MOD SDL_BlendMode) + +;; SDL_RendererFlip +(register-type SDL_RendererFlip) +(register SDL_FLIP_NONE SDL_RendererFlip) +(register SDL_FLIP_HORIZONTAL SDL_RendererFlip) +(register SDL_FLIP_VERTICAL SDL_RendererFlip) + +;; Events +(register SDL_PollEvent (Fn [(Ptr SDL_Event)] Bool)) +(register SDL_Event_init (Fn [] SDL_Event)) +(register event-type (Fn [(Ref SDL_Event)] Int)) +(register event-keycode (Fn [(Ref SDL_Event)] SDL_Keycode)) + +;; Keys +(register-type SDL_Keycode) +(register SDLK_RETURN SDL_Keycode) +(register SDLK_SPACE SDL_Keycode) +(register SDLK_ESCAPE SDL_Keycode) +(register SDLK_LEFT SDL_Keycode) +(register SDLK_RIGHT SDL_Keycode) +(register SDLK_UP SDL_Keycode) +(register SDLK_DOWN SDL_Keycode) + +(defmodule Keycode + (register = (Fn [SDL_Keycode SDL_Keycode] Bool))) + +;; Mouse +(register SDL_GetMouseState (Fn [(Ptr Int) (Ptr Int)] Int)) +(register SDL_BUTTON (Fn [Int] Int)) +(register SDL_BUTTON_LEFT Int) +(register SDL_BUTTON_RIGHT Int) + +(deftype MouseState [x Int + y Int + left Bool + right Bool]) + +(defn get-mouse-state [] + (let [x 0 + y 0 + state (SDL_GetMouseState (address x) (address y)) + l (Int.mask state (SDL_BUTTON SDL_BUTTON_LEFT)) + r (Int.mask state (SDL_BUTTON SDL_BUTTON_RIGHT))] + (MouseState.init x y l r))) + +;; Time +(register SDL_GetTicks (Fn [] Int)) + +;; App helper +(register-type App) +(register app-init (Fn [String Int Int] App)) +(register app-window (Fn [App] (Ptr SDL_Window))) +(register app-renderer (Fn [App] (Ptr SDL_Renderer))) +(register app-stop (Fn [(Ref App)] ())) + +(defn quit [app] + (do (app-stop app) + (System.exit 0))) diff --git a/core/sdl_image.carp b/core/sdl_image.carp new file mode 100644 index 000000000..15421a480 --- /dev/null +++ b/core/sdl_image.carp @@ -0,0 +1,5 @@ +(system-include "SDL2/SDL_image.h") +(add-lib "-lSDL2_image") + +(register IMG_LoadTexture (Fn [(Ptr SDL_Renderer) String] (Ptr SDL_Texture))) +(register IMG_Load (Fn [String] (Ptr SDL_Surface))) diff --git a/docs/Contributing.md b/docs/Contributing.md deleted file mode 100644 index bace2aeab..000000000 --- a/docs/Contributing.md +++ /dev/null @@ -1,25 +0,0 @@ -Contributing -============ - -Thank you for considering contributing to Carp. - -This document currently focusses on developer contributions but -we welcome all kinds of contributions. - - -Community ---------- -The best place to start is to join the Carp Gitter channel over at -[https://gitter.im/carp-lang/Carp](https://gitter.im/carp-lang/Carp) - - -License -------- -Carp is currently released under the terms of the the ASL 2.0 license. - - -Code ----- -For tips on how to navigate the codebase please see [DeveloperTips.md](DeveloperTips.md) -in this same directory. - diff --git a/docs/DeveloperTips.md b/docs/DeveloperTips.md deleted file mode 100644 index 4d5634558..000000000 --- a/docs/DeveloperTips.md +++ /dev/null @@ -1,67 +0,0 @@ -Developer Tips -============== - -Code structure --------------- - -At the top-level Carp has two obvious folders for C code: -`src/` and `shared/`. - -`src/` is used for the implementation of the compiler and interpreter, -whereas `shared/` is used for implementation of the runtime -(which is exposed to both interpreted and compiled programs). - -The third code directory is `lisp/` which contains all the Carp code -written in carp itself - being a lisp a lot of Carp's actual implementation -happens within this directory. - -C functions defined within `shared/` must also be bound by a file within `lisp/`, -more information on this will be provided in this document later. - - -Code formatting ---------------- - -C code is automatically formatted using `clang-format`, -if you have `clang-format` installed you can invoke the formatter via running: - - # from the top level directory - $ cmake . - $ make format - -It is recommend that you format your code before making a pull request, -although semi-regular formats are run to catch any code that wasn't -pre-formatted. - - -A quick outline of the C style: - - - 2 space indent - - Never use tabs - - No column width limit - - -A very short example showing some of the features of this style - - int main(int argc, char **argv) { - int a = 14; - int *b = &a; - - switch(a) { - case 14: - puts("a was 14") - break; - - default: - puts("I have no idea what happened") - break; - } - - if(*b > 5) { - puts("*b is bigger than 5") - } - else { - puts("*b is not bigger than 5") - } - } - diff --git a/docs/Install.md b/docs/Install.md deleted file mode 100644 index dce7daee7..000000000 --- a/docs/Install.md +++ /dev/null @@ -1,54 +0,0 @@ -Sorry about the mess in this document, it will be cleaned up and re-organized when there is a good and easy way to build the whole project. - -# Installation - -Clone this repo, then use cmake to generate the project files that you desire. Either run it in the root of the Carp project, or from a sub directory that you create called 'build' or similar. Then build the project and make sure the resulting executable is put into the 'bin' directory (cmake should arrange that automatically). An example of how to do all of this for Xcode is in the file 'xcode.sh' in the root of the project. - -```cmake .``` - -Make sure you run the compiler (i.e. ```make``` if you generated a Makefile). Now there should be a ```Carp/bin/carp-repl``` executable. - -Add the 'bin' directory to your path to enable calling the ```carp``` command. To do this, add the following to your .bashrc / .zshrc / whatever: - -```export PATH=$PATH:~/Carp/bin/``` - -Carp is developed on OSX 10.10 but Linux works too. More platforms are coming soon, Windows is being worked on. There are a few dependencies that have to be installed: - * pkg-config - * libffi - * glfw3 - * rlwrap - -Tip: Build libffi with ```./configure --enable-static --disable-shared``` to avoid generating a dylib that might interfere with other installations of it (like one installed with brew). - -You will have to tell cmake the location of 'libffi' before it can build correctly. Try using their GUI application if you have trouble, it's pretty self explanatory (first press 'Configure', then set up the paths to 'libffi', and then press 'Generate'). - -To make cmake find libffi you might need to add it to the `PKG_CONFIG_PATH`: -``` -export PKG_CONFIG_PATH=../libffi// -``` - -And to be able to run 'make' you might need to add libffi to your `C_INCLUDE_PATH`: - -``` -export C_INCLUDE_PATH=../libffi//include -``` - -or for some people: - -``` -cmake . -DLIBFFI_INCLUDE_DIRS=/opt/local/lib/libffi-3.2.1/include -DLIBFFI_LIBRARIES=/opt/local/lib/ -``` - -Replace with the name of the architecture you built libffi for. - -Note: 'rlwrap' is not strictly needed but makes the REPL experience much nicer, modify the '/bin/carp' script if you don't want to use it. - -## Mac OS X -If 'libffi' is installed with Brew, you can find the libraries at "/usr/local/Cellar/libffi/3.0.13/lib/" and the include files at "/usr/local/opt/libffi/lib/libffi-3.0.13/include". - -With macports 'libffi' is at "/opt/local/lib/libffi-3.2.1/include" and "/opt/local/lib". - -## Linux -On Linux Clang must be installed (GCC support will be added later). - -## Windows diff --git a/docs/LanguageGuide.md b/docs/LanguageGuide.md deleted file mode 100644 index 8d1416b8e..000000000 --- a/docs/LanguageGuide.md +++ /dev/null @@ -1,175 +0,0 @@ -## The Language - -Carp borrows its looks from Clojure but the runtime semantics are much closer to those of ML or Rust. Here's a sample program: - -```clojure -(defn say-hi (text) - (while true - (if (< (strlen text) 10) - (println "Too short!") - (println text)))) -``` - -This compiles to the following C program: -```C -void say_hi(string text) { - bool while_expr_1 = 1; - while(while_expr_1) { - int strlen_result_2 = strlen(text); - bool if_expr_3 = strlen_result_2 < 10; - if(if_expr_3) { - println("Too short!"); - } else { - println(text); - } - while_expr_1 = 1; - } -} -``` - -If-statements are kind of tricky in regards to memory management: -```clojure -(defn say-what (text) - (let [manage-me (string-copy text)] - (if (< (strlen text) 10) - (string-copy "Too short") - manage-me))) -``` - -The 'manage-me' variable is the return value in the second branch, but should get freed if "Too short" is returned. -The output is a somewhat noisy (working on it!) C program: -```C -string say_what(string text) { - string _let_result_0; - { - string _result_0 = string_copy(text); - string manage_me = _result_0; - int _result_1 = strlen(text); - string _if_result_0; - if(_result_1 < 10) { - string _result_2 = string_copy("Too short"); - free(manage_me); - _if_result_0 = _result_2; - } else { - _if_result_0 = manage_me; - } - _let_result_0 = _if_result_0; - } - string _final_result_0 = _let_result_0; - return _final_result_0; -} -``` - -The most important thing in Carp is to work with arrays of data. Here's an example of how that looks: - -```clojure -(defn weird-sum (nums) - (reduce + 0 (map inc (filter even? nums)))) -``` - -All the array modification functions like 'map', 'filter', etc. use C-style mutation of the array and return the same data structure back afterwards, no allocation or deallocation needed. The lifetime analyzer ("borrow checker" in Rust parlance) makes sure that the same data structure isn't used in several places. - -To know whether a function takes over the responsibility of freeing some memory (through its args) or generates some new memory that the caller has to handle (through the return value), just look at the type of the (compiled) function. The type signature can be found with ```(signature ...)```. If the value is a simple type like :string, :Vector3, or similar, it means that the memory ownership gets handed over. If it's a ref signature, meaning that it's a list starting with :ref (i.e. '(:ref :string)'), the memory is just temporarily lended out and someone else will make sure it gets deleted. When interoping with existing C code it's probably useful to send your data structures to C as refs, keeping the memory management inside the Carp section of the program. - -### Data Literals -```clojure -100 ; int -3.14f ; float -10.0 ; double -true ; bool -"hello" ; string -\e ; char -[1 2 3] ; array -``` - -### Dynamic-only Data Literals -Right now the following data types are only available for manipulation in non-compiled code. - -```clojure -(1 2 3) ; list -foo ; symbol -:blergh ; keyword -{:a 10 :b 20} ; dictionary -``` - -### Special Forms -```clojure -(def variable-name value) -(defn function-name (arg1 arg2 ...) (function-body ...)) -(let [var1 expr1, var2 expr2, ...] body) -(do expr1 expr2 ...) -(if expression true-branch false-branch) -(while expression body) -(ref x) ;; Turns an owned value into an unowned one -(reset! variable value) -``` - -### Reader macros -```clojure -&x ; same as (ref x) -@x ; same as (copy x) -``` - -### Dynamic-only Special Forms -``` -(quote x) -(match x pattern-1 expr-1, pattern-2 expr-2, ...) -``` - -### Structs -```clojure -(defstruct Vector2 [x :float, y :float]) - -(def my-pos (Vector2 102.2f 210.3f)) - -;; A 'lens' is automatically generated for each member: -(get-x my-pos) ;; => 102.2f -(set-x my-pos 3.0f) ;; => (Vector2 10.2f 3.0f) -(update-x my-pos inc) ;; => (Vector2 10.2f 4.0f) -``` - -Structs can also contain members of one or more generic types: - -```clojure -(defstruct Pair - [a "t" - b "t"]) - -(defstruct Tuple - [a "a" - b "b"]) -``` - -### Algebraic Data Types (not implemented) -```clojure -(defdata Color - RGB [r :float, g :float, b :float] - Grayscale [amount :float]) - -(def color (Grayscale 50.0f)) -``` - -Omit the name tag to create a data constructor with the same name as the type: -```clojure -(defdata Vector3 [x :double, y :double, z :double]) - -(def position (Vector3 4.0 5.0 -2.0)) -(def x-position (.x position) -``` - -### C interop -```clojure -(def blah (load-dylib "./libs/blah.so")) -(register blah "foo" (:int :int) :string) ;; will register the function 'foo' in the dynamic library 'blah' that takes two ints and returns a string -``` - -### Type annotations -There should never be a need for explicit type annotations in Carp. Still, they can be useful to show intent and make sure that the compiler does thing you were planning for it to do. Type annotations are added using meta data ('ann' stands for 'annotation') on the function form, like this: - -```clojure -^ann '(:fn ((:ref :Ship)) :void) - -(defn draw-ship [ship] - (let [pos (get-shipPos ship)] - (draw-rect (get-x pos) (get-y pos) 10f 10f))) -``` diff --git a/docs/Libraries.md b/docs/Libraries.md deleted file mode 100644 index d86695551..000000000 --- a/docs/Libraries.md +++ /dev/null @@ -1,17 +0,0 @@ -# Core Libraries -See [lisp/core.carp](../lisp/core.carp), proper docs are coming soon! - -# The C standard library (wrapped) -See [lisp/builtins.carp](../lisp/builtins.carp) - -# OpenGL -See [lisp/gl.carp](../lisp/gl.carp) - -# The '*' macros -Since the functions in Carp can't accept a variable number of args there are a bunch of helper macros that allows you to circumvent this limitation. Here are some examples: - -```clojure -(str* "This string " "and this string, here's a number " 123 ", etc...") -(println* "X = " x ", Y = " y) -(and* true false false true false) -``` diff --git a/docs/Manual.md b/docs/Manual.md deleted file mode 100644 index 41c56346b..000000000 --- a/docs/Manual.md +++ /dev/null @@ -1,36 +0,0 @@ -## The Compiler -The Carp language is very tightly integrated with its compiler which itself is written in a dynamic version of Carp (implemented in C). To work on a Carp program you run ```carp``` (first making sure it's in your $PATH, see installation instructions below) which starts the REPL. Everything you want to do to your program can be controlled from here. - -For example, to compile a function named 'fib' you enter the following: -```clojure -λ> (bake fib) -``` - -This results in the compiler analyzing the code form for 'fib' and compiling it to (hopefully very fast) binary code, immediately loading this back into the REPL so that it can be called from there. The resulting C-code, AST and type signature are bound to the three variables 'c', 'ast' and 's', respectively. Inspecting their contents will teach you more about the innards of the Carp language, for sure! - -From the REPL you can also inspect your the state of variables, extend the compiler, script the build process of your project, or statically analyze its code. All these operations should be really quick to execute and easy to remember so you can focus on developing your program. - -To start the Carp compiler in development mode (which will run its test suite), invoke it like this instead: - -```CARP_DEV=1 carp``` - -### Compiler Variables -* ```carp-dir``` The root folder of the Carp compiler, should be the same folder as the one where the README.md file resides. -* ```out-dir``` A string with the name of the folder where build artifacts should be put. Standard value is the 'out' folder in the carp directory. -* ```exe-out-dir``` Where the exe:s produced by (bake-exe ...) should be placed. Standard value is "./" (working directory) -* ```echo-signature-after-bake``` If this is true the type signature of freshly baked functions will be printed in the REPL. -* ```prompt``` The prompt displayed in the repl -* ```profile-infer-time``` Set to true if you want to know the time it takes to infer the types for each function -* ```profile-external-compiler-time``` Set to true if you want to know the time it takes to run the external C compiler -* ```log-unloading-of-dylibs``` Should the compiler log when it unloads dynamic libraries? -* ```log-deps-when-baking-ast``` Should the compiler log the libraries it links to? - -### Special Files -If a file called ```user.carp``` is placed in the folder ```~/.carp/```, that file will get loaded after the compiler has started. This file is meant for user specific settings that you want in all your projects, like little helper functions and other customizations. - -If a file called ```project.carp``` is placed in the folder where you invoke the ```carp``` command this file will get loaded after the compiler has started (and after 'user.carp' has loaded). This files is intended for setting up the build process of this particular project, for example by loading the correct source files, configuring the compiler variables, etc. - -### Recovering from errors -If an error occurs at the REPL, Carp will intercept the error signal and try to recover. Sometimes this does not work (because of memory corruption or similar) and your only option is to restart the process. Quite often it works though, so make sure to try it before resorting to a hard reset. - -When working with glfw windows a crash will not close the window, and creating a new one will not work either. To be able to continue, call ```(glfwTerminate)``` first. This will clear everything related to the window and allow you to start anew. A similar process is probably worth working out for other kind or resources that gets lost when a crash happens. Also make sure you fix the problematic code or state that caused the error or you will just crash again immediately. diff --git a/docs/Research.md b/docs/Research.md deleted file mode 100644 index 2fb7628f1..000000000 --- a/docs/Research.md +++ /dev/null @@ -1,83 +0,0 @@ -https://news.ycombinator.com/item?id=12039268 - -# C PROGRAMMING, LLVM, AND DEBUGGING - -- http://clang.llvm.org/docs/AddressSanitizer.html -- https://www.iar.com/support/resources/articles/advanced-preprocessor-tips-and-tricks/ -- http://jvns.ca/blog/2016/03/01/a-few-notes-on-the-stack/ -- https://www.recurse.com/blog/7-understanding-c-by-learning-assembly -- http://msm.runhello.com/p/1003 -- http://stackoverflow.com/questions/2505385/classes-and-static-variables-in-shared-libraries -- http://www.gameaipro.com/GameAIPro/GameAIPro_Chapter15_Runtime_Compiled_C++_for_Rapid_AI_Development.pdf -- https://fsharpforfunandprofit.com/posts/fsharp-decompiled/ -- http://kristerw.blogspot.se/2016/05/type-based-aliasing-in-c.html - -# OWNERSHIP & BORROWING - -- http://blog.piston.rs/2016/01/23/dynamo/ -- http://evincarofautumn.blogspot.se/2016/01/thoughts-on-using-fractional-types-to.html -- http://andrewbrinker.github.io/blog/2016/03/27/string-types-in-rust/ -- http://www.pipeline.com/~hbaker1/LinearLisp.html -- http://smallcultfollowing.com/babysteps/blog/2016/04/27/non-lexical-lifetimes-introduction/ -- https://doc.rust-lang.org/book/deref-coercions.html -- http://ticki.github.io/blog/lambda_crabs_1/ -- https://gankro.github.io/blah/linear-rust/ - -# MODULES & FUNCTORS - -- http://homepages.inf.ed.ac.uk/mfourman/teaching/mlCourse/notes/sml-modules.html -- https://www.cse.unsw.edu.au/~chak/papers/modules-classes.pdf - -# TYPES - -- https://lambdacube3d.wordpress.com/2016/03/03/tuples-as-heterogeneous-lists/ -- https://jeltsch.wordpress.com/2016/02/22/generic-programming-in-haskell/ -- http://okmij.org/ftp/ML/generalization.html -- http://www.cs.cornell.edu/courses/cs312/2005sp/lectures/rec22.asp -- http://www.cs.cornell.edu/courses/cs3110/2011sp/lectures/lec26-type-inference/type-inference.htm -- http://www.scheme.com/tspl4/examples.html#./examples:h10 - -# CSP - -- http://reaktor.com/blog/why-csp-matters-ii-how-do-i-know-sync-works/ - -# GC - -- http://prl.ccs.neu.edu/blog/2016/05/24/measuring-gc-latencies-in-haskell-ocaml-racket/ - -# OTHER LANGUAGES - -- https://wingolog.org/archives/2016/02/08/a-lambda-is-not-necessarily-a-closure -- http://alex-charlton.com/posts/Prototype_to_polish_Making_games_in_CHICKEN_Scheme_with_Hypergiant/ -- http://beautifulracket.com/first-lang.html -- http://stackoverflow.com/questions/4899113/fixed-point-combinator-for-mutually-recursive-functions/5272086#5272086 -- http://klisp.org -- http://gliese1337.blogspot.se/2012/04/schrodingers-equation-of-software.html -- https://github.com/kiselgra/c-mera -- https://github.com/wolfgangj/bone-lisp/ -- https://github.com/akkartik/mu -- https://github.com/haskell-lisp/liskell -- https://github.com/PistonDevelopers/dyon/pull/318 - -# LANGUAGE DESIGN - -- http://www.complang.tuwien.ac.at/kps2015/proceedings/KPS_2015_submission_29.pdf -- http://www.lihaoyi.com/post/WhatsinaBuildTool.html -- http://prog21.dadgum.com/136.html -- https://existentialtype.wordpress.com/2011/03/19/dynamic-languages-are-static-languages/ - -# GRAPHS - -- https://en.wikipedia.org/wiki/Strongly_connected_component -- https://en.wikipedia.org/wiki/Transitive_closure#In_graph_theory - -# GRAPHICS - -- https://medium.com/@evanwallace/easy-scalable-text-rendering-on-the-gpu-c3f4d782c5ac#.ajyuy8weu -- https://pomax.github.io/bezierinfo/ - -# TO TRY - -- let fun ident(x) => x -- in ident(ident)(2) end - diff --git a/docs/Todo.md b/docs/Todo.md deleted file mode 100644 index 747167617..000000000 --- a/docs/Todo.md +++ /dev/null @@ -1,103 +0,0 @@ -# The Big 'ref' debacle - alternatives: - 1. Allow ref:ed value types to be coerced into non-ref:ed types (best solution, if it works) - 2. A deref function that can remove the ref from primitive types - 3. A 'map-primitive' that can map a function that takes non-refs as argument - since it's annying to not be able to use functions like 'itos' directly with 'map-copy' - (it requires a fn of type &a -> b) - -# Compiler Big Features - - Live Reloading (requires threads and bytecode interpreter) - - Special handling of POD structs (stack allocated, referenced by pointer) - - Compile match statements (could it be a macro?) - - Compile modules (when they exist in the dynamic runtime...) - - Compile dictionaries (requires hashing function for all types that can be keys) - - Lambdas - - get / set special forms? Would enable shorter names, and sharing names for members between different structs - -# Bytecode - - Make bytecode 'match' use labels and gotos instead of recursive calls to eval - -# Compiler Small Features - - Shorter names for concrete versions of generic functions (don't duplicate types like this: 'atan2_Int_Int') - - All types should have capital first letter? - - Be able to save concretized struct types for type checking etc - -# Compiler Correctness - - Variables/functions named the same thing as a struct can override the dylib generated for the struct group - - Must unload all concretized structs when the parent struct is redefined - - Compiler doesn't catch when a let-binding refers to a variable that's defined later (in the same let binding) - - Avoid problems with name shadowing when freeing a local variable (is this possible? disallow shadowing instead?) - - Complete type constraints for binops, check for "numeric" types (use a union type of some sort?). Or turn binops into normal funcs? - -# Compiler efficiency / beauty - - Avoid creating unique typevars for multiple calls with the same types to a generic function? - - Use 'sicp unifier' instead of the current mess - - Use 'generic-name' when concretizing generic primops - - Rewrite a bunch of functions in the compiler passes using pipe operator and update-in - - Speed up some passes by mutating a single variable instead of copying immutable versions around - - Use the new key-is-true function instead of has-key? in lots of places - - Calls back to the compiler from runtime should be minimized and only require a single call, not two or three like it often is now - -# Dynamic Runtime Big Features - - Desugar [...] to (array ...) in reader - - Macro splicing - - Modules - - A Set-type with reader syntax #{} - - Instantiate generic functions like '=' for primitive types when calling them - - Line numbers for dictionary literals - -# Modules - - Name - - List of imported modules (with the name used for importation) - - List of opened modules - - Environment (with all the bindings) - -# Dynamic Runtime Small Features - - Delete content of global var when resetting from repl - - Be able to mark symbols/modules as "frozen" (with meta data) so that they can't be overriden by user - - Better error handling and input validation for primops, clean up the C error/assertion macros - - ONLY allow [] in parameter list for function definitions - - Use size_t where approperiate - - Make the reader warn when the text to read is too big (repl.c) - - Resetting a global variable pointing to an array can be fooled by using wrong kind of array (anything goes at the moment) - -# Dynamic Runtime Optimization - -# Bugs - - Don't allow sending compiled functions of wrong type to ffi functions (check their types with 'signature') - - assert-eq shows wrong result when the assertion fails? (in ffi situations, the wrong type is produced and compared to something else) - -# Sanity checks - - Ensure correctness of GC (run at every step) - - Don't leak values returned from calling ffi functions via non-compiled code - -# Lisp Core Libs - - 'import' function that searches paths for carp files - - shuffle (for lists) - - Conversions between a list of pairs and dictionaries - - 'for' macro with multiple bindings (i, j, etc...) - -# Maybes - - Compile keywords? - - Add void constraints for (do ...) statements ? - - Add proper no-op :node for () ? - - Polymorphic math operators? - - Matching/destructuring in let statements and function arguments too? - - Reading of dotted pairs? - - Not possible to write an 'eat-void' function: (register-builtin "eat_void" '(:void) :void), need a proper unit type for that - - :when clauses in match? - - Use a more generalized method for generating 'str' function when inspecting ptr:s at the REPL (some kind of "hook" system) - - Ownership tracking to enable returning refs from functions (it's forbidden at the moment) - - Reorder arguments to "set"/"update"-lens to make them less problematic for borrow checking (the main structure is given away to the first argument) ? - - Use modules to solve problem of using same name for members in different structs? - - Create a carp_bool type with defined size - -# Niceties - - Built in tutorial for the language - - Built in manual - -# Gotchas - - Unloading of function/dylib doesn't work after another function has linked to it during its compilation. - - Variable shadowing doesn't work properly when referencing itself - - Size of bool is undefined - - Must mark global variables on windows as __declspec(dllimport) when using them and __declspec(dllexport) when providing for others diff --git a/emacs/inf-carp-mode.el b/emacs/inf-carp-mode.el index 7c69e8550..a2751c5d7 100644 --- a/emacs/inf-carp-mode.el +++ b/emacs/inf-carp-mode.el @@ -94,7 +94,7 @@ The following commands are available: \\{inf-carp-minor-mode-map}" :lighter "" :keymap inf-carp-minor-mode-map) -(defcustom inf-carp-program "carp-inferior" +(defcustom inf-carp-program "CarpHask-exe" "Program name for invoking an inferior Carp in Inferior Carp mode." :type 'string :group 'inf-carp) @@ -107,7 +107,7 @@ to load that file." :type 'string :group 'inf-carp) -(defcustom inf-carp-prompt "^[^λ> \n]+λ> *" +(defcustom inf-carp-prompt "^[^鲮 \n] *" ;; "^[^λ> \n]+λ> *" "Regexp to recognize prompts in the Inferior Carp mode." :type 'regexp :group 'inf-carp) diff --git a/examples/array.carp b/examples/array.carp new file mode 100644 index 000000000..f7a2323a3 --- /dev/null +++ b/examples/array.carp @@ -0,0 +1,26 @@ +(import IO) +(import Array) + +(defn nested [] + [[1 2 3] + [4 5 6] + [7 8 9]]) + +(defn excl [x] (String.append x "!")) + +(defn main [] + (let [a (Array.range 1 10) + ;;b (Array.replicate 5 (ref "hej")) + ] + (do + (println (ref (Int.str (nth (ref a) 5)))) + (println (ref (str (ref (range 10 20))))) + (println (ref (str (ref (map excl (replicate 5 "Hi")))))) + ;; (println (ref (str (ref ["hej" "san" "!"])))) + ;; (println (ref (str (nth (ref (nested)) 0)))) + ;; (println (ref (str (nth (ref (nested)) 1)))) + ;; (println (ref (str (nth (ref (nested)) 2)))) + ))) + +;; (build) +;; (run) diff --git a/examples/basics.carp b/examples/basics.carp new file mode 100644 index 000000000..e742e4c71 --- /dev/null +++ b/examples/basics.carp @@ -0,0 +1,125 @@ +(import Int) +(import Double) +(import Float) +(import Array) +(import IO) + +(defn fib [n] + (if (< n 2) + 1 + (+ (fib (dec (dec n))) + (fib (dec n))))) + +(defmodule Things + (defn inside [s] + (let [msg (String.append s "!")] + (println (ref msg)))) + (defn call [] + (inside "Hello"))) + +(defn use-doubles [] + (println (ref (str (Double.toInt (Double.+ 2.0 3.0)))))) + +(deftype Person + [name String + age Int]) + +(defn use-person [] + (let [me (Person.init "Erik" 30)] + (println (Person.name (ref me))))) + +(defn heap-allocations [] + (let [friend (Person.new "Oscar" 30)] + ())) + +(defn refer-up [] + (let [a 10 + b (+ a 5) + c (* a b)] + c)) + +(deftype Thing + [val Int]) + +(defn set-stuff-in-array [] + (let [xs (range 0 10)] + (do + (aset! (ref xs) 4 666) + (println (ref (str (ref xs))))))) + +(defn more-array [] + (let [xs [1 2 3 4] + xs2 (pop-back xs)] + (do + (println (ref (str (ref (push-back xs2 500)))))))) + +(defn using-the-form-to-specialize [x y] + (+ x (the Double y))) + +(defn flip [] + (random-between 0 2)) + +(defn macrooo [] + (let [msg "Print!"] + (cond + (< 10 1) (println (ref "Don't print!")) + (> 10 1) (println (ref msg)) + (println (ref "Don't print!"))))) + +(defn macrooo2 [] + (for [x 1 3] + (for [y 10 100 20] + (println (ref (str (* x y))))))) + +(deftype A [s String]) +(import A) + +(deftype Peep [x Int + y String + z A]) +(import Peep) + +(defn calling-delete [] + (let [plupp (Peep.init 10 "PLUPP" (A.init "w00t")) + poop [(Peep.init 10 "hej" (A.init "aha"))] + strings ["a" "b" "c"]] + (do + (delete plupp) + (delete poop) + (delete strings)))) + +(defn updating [] + (let [p1 (Peep.init 9999 "jaha" (A.init "mmm")) + p2 (Peep.update-x p1 inc)] + (println (ref (str (Peep.x (ref p2))))))) + +(defn character [] + (println (ref (Char.str \#)))) + +(defn negative-numbers [] + (let [x -10.0 y -20.0f z -30] + (* (*(toInt x) (toInt y)) z))) + +(defn main [] + (do (Things.call) + (use-doubles) + (println (ref (str (fib 10)))) + (use-person) + (heap-allocations) + (println (ref (str (refer-up)))) + (println (ref (str (ref [10 20 30 40 50])))) + ;;(println (ref (str (ref (map Thing.val [(Thing.init 100) (Thing.init 200)]))))) + (println (ref (str (Int.mod 30 7)))) + (set-stuff-in-array) + (more-array) + (macrooo) + (macrooo2) + (seed (System.time)) + (println (ref (str (ref (repeat 10 flip))))) + (calling-delete) + (updating) + (character) + (println (ref (str (negative-numbers)))))) + +(build) +(run) diff --git a/examples/battle.carp b/examples/battle.carp deleted file mode 100644 index e71cd9275..000000000 --- a/examples/battle.carp +++ /dev/null @@ -1,29 +0,0 @@ - -(defstruct Enemy - [name :string - hp :int]) - -(defn make-some-enemies [] - [(Enemy @"Voldemort" 200) - (Enemy @"Sauron" 500) - (Enemy @"Satan" 666)]) - -(def player-damage 50) - -(defn attack-enemy [enemy] - (let [current-hp (Enemy-get-hp &enemy)] - (Enemy-set-hp enemy (- current-hp player-damage)))) - -(defn battle [enemies] - (map attack-enemy enemies)) - -(defn try-it-out [] - (let [enemies (make-some-enemies)] - (do (println "Before the battle: ") - (println* &enemies) - (println "...") - (let [new-enemies (battle enemies)] - (do - (println "After the battle:") - (println* &new-enemies)))))) - diff --git a/examples/compile.carp b/examples/compile.carp deleted file mode 100644 index a42e6c881..000000000 --- a/examples/compile.carp +++ /dev/null @@ -1,26 +0,0 @@ -;; This is a step-by-step walkthrough of what the compiler does -;; when it compiles a function. Evaluate one form at a time! - -(defn circle-area [r] - (* pi (* r r))) - -(map circle-area [10.0 20.0 30.0 40.0 50.0]) - -(def code-as-data (code circle-area)) - -(type circle-area) -(type (code circle-area)) - -(def ast (lambda-to-ast code-as-data)) - -(def constraints (generate-constraints ast)) - -(def solution (solve-constraints constraints)) - -(def annotated-ast (annotate-ast ast)) - -(def builder (builder-visit-ast (new-builder) annotated-ast "circle-area")) - -(def c (builder-merge-to-c (:funcs builder))) - -;; (bake circle-area) diff --git a/examples/functor.carp b/examples/functor.carp new file mode 100644 index 000000000..84603f548 --- /dev/null +++ b/examples/functor.carp @@ -0,0 +1,30 @@ +(import IO) +(import Int) +(import Array) + +(defmodule ArrayExtension + (defn fmap [f a] (Array.map f a)) + ) + +(deftype Box [x Int]) + +(defmodule Box + (defn fmap [f box] (Box.set-x box (f (Box.x box))))) + +(import Box) +(import ArrayExtension) + +;;(defn higherOrder [x] (fmap inc x)) + +(defn main [] + (do + (println (str (Box.x (fmap inc (Box.init 100))))) + (println (str (Box.x (Box.fmap inc (Box.init 100))))) + (println (str (ArrayExtension.fmap inc [10 20 30 40 50]))) + (println (str (fmap inc [10 20 30 40 50]))) + (println (Array.str (fmap inc [10 20 30 40 50]))) + (println (Array.str (ArrayExtension.fmap inc [10 20 30 40 50]))) + )) + +(build) +(run) diff --git a/examples/game.carp b/examples/game.carp index b5c84a8fb..49ed252f3 100644 --- a/examples/game.carp +++ b/examples/game.carp @@ -1,47 +1,87 @@ -(import gl) +(import IO) +(import System) +(import Int) +(import Double) +(import Array) -(defn draw-ship [ship] - (let [pos (Ship-get-pos ship)] - (draw-rect (Vec2-get-x pos) - (Vec2-get-y pos) - 10f - 10f))) +(load "core/sdl.carp") +(load "core/sdl_image.carp") +(import Keycode) -(defstruct Ship [pos :Vec2]) +(def max 400) -(defn generate-ships [] - [(Ship (Vec2 100f 300f)) - (Ship (Vec2 150f 100f)) - (Ship (Vec2 200f 150f)) - (Ship (Vec2 250f 050f)) - (Ship (Vec2 300f 100f))]) +(defn r [] + (the Int (random-between 0 max))) -(defn t [] - (dtof (glfwGetTime))) +(defn random-lines [] + (let [p1 (make-point (r) (r)) + p2 (make-point (r) (r)) + p3 (make-point (r) (r))] + [p1 p2 p3 p1])) -(defn draw [state] - (do - ;;(draw-line 300f 200f (+ 300f (* 100.0f (sinf (t)))) (+ 200f (* 100.0f (cosf (t))))) - (draw-circle 200f 200f 100f) - (let [ships state] - (domap draw-ship ships)))) +(deftype Images + [img1 (Ptr SDL_Texture) + img2 (Ptr SDL_Texture)]) -(defn speed [] 1.0f) +(defn dimensions [texture] + (let [w 0 + h 0] + (do + (SDL_QueryTexture texture NULL NULL (address w) (address h)) + (make-rect 0 0 w h)))) -(defn move-vec2 [v] - (let [x (Vec2-get-y &v)] - (Vec2-set-y v (+ (speed) x)))) +(defn draw [rend images] + (let [rect (make-rect 32 32 (- 512 64) (- 512 64))] + (do + (SDL_SetRenderDrawBlendMode rend SDL_BLENDMODE_ADD) + (SDL_SetRenderDrawColor rend 0 0 0 255) + (SDL_RenderClear rend) + (SDL_SetRenderDrawColor rend 200 250 255 255) + (SDL_RenderFillRect rend (address rect)) + (SDL_SetRenderDrawColor rend 100 50 255 155) + (let [rects [(make-rect 48 48 16 16) + (make-rect 48 80 16 16) + (make-rect 48 112 16 16) + (make-rect 48 144 16 16)]] + (SDL_RenderFillRects rend (raw rects) (count (ref rects)))) + (SDL_SetRenderDrawColor rend 255 50 100 255) + (for [x 0 512 16] + (do + (SDL_RenderDrawLine rend x 0 512 512) + (SDL_RenderDrawLine rend 512 (+ 256 (/ x 2)) 0 512))) + (SDL_SetRenderDrawColor rend 0 0 0 255) + (let [lines (random-lines)] + (SDL_RenderDrawLines rend (raw lines) (count (ref lines)))) + (let [img (Images.img1 (the (Ref Images) images))] + (SDL_RenderCopyEx rend + img + (address (dimensions img)) + (address (make-rect 100 100 300 300)) + (* 0.1 (fromInt (SDL_GetTicks))) + (address (make-point 150 150)) + SDL_FLIP_NONE)) + (SDL_RenderPresent rend) + ))) -(defn move [ship] - (Ship-update-pos ship move-vec2)) - -(defn update [state] - (map move state)) - -(defn setup [] - (do (glOrtho 0.0 640.0 480.0 0.0 1.0 -1.0) - (generate-ships))) - -(defn game [] - (glfw-app "The Attack of the Space Worms" setup update draw default-on-keys)) +(defn handle-events [app rend] + (let [event (SDL_Event_init)] + (while (SDL_PollEvent (address event)) + (let [et (event-type (ref event))] + (cond (= et SDL_QUIT) (quit (ref app)) + (= et SDL_KEYDOWN) (let [key (event-keycode (ref event))] + (cond + (= key SDLK_ESCAPE) (quit (ref app)) + (println (ref"Unrecognized key.")))) + (println (ref "Some other event happened..."))))))) +(defn main [] + (let [app (app-init "~ CARP ~" 512 512) + rend (app-renderer app) + img1 (IMG_LoadTexture rend "./img/square.png") + img2 (IMG_LoadTexture rend "./img/carp_logo_969_no_texture.png") + images (Images.init img1 img2)] + (while true + (do + (handle-events app rend) + (draw rend (ref images)) + (SDL_Delay 30))))) diff --git a/examples/guessing.carp b/examples/guessing.carp new file mode 100644 index 000000000..78abc5b40 --- /dev/null +++ b/examples/guessing.carp @@ -0,0 +1,25 @@ +;; The number guessing game + +(import IO) +(import Int) +(import String) + +(defn main [] + (do (println (ref "~ The number guessing game ~")) + (print (ref "Please enter a number between 1 - 99: ")) + (let [play true + answer (random-between 1 100)] + (while play + (let [guess (get-line) + num (from-string guess)] + (if (= (ref guess) (ref "q\n")) + (do + (println (ref "Good bye...")) + (set! play false)) + (do + (if (< num answer) + (println (ref "Too low.")) + (if (> num answer) + (println (ref "Too high.")) + (println (ref "Correct!")))) + (print (ref "Please guess again: "))))))))) diff --git a/examples/life.carp b/examples/life.carp new file mode 100644 index 000000000..2a01a8405 --- /dev/null +++ b/examples/life.carp @@ -0,0 +1,120 @@ +(import IO) +(import System) +(import Int) +(import Double) +(import Array) + +(load "core/sdl.carp") +(load "core/sdl_image.carp") +(import Keycode) +(import MouseState) + +(def width 60) +(def height 60) + +(defn handle-key [app event play] + (let [key (event-keycode event)] + (cond + (= key SDLK_ESCAPE) (do (quit app) false) + (= key SDLK_SPACE) (not play) + (do (println (ref "Unrecognized key.")) + play)))) + +(defn handle-mouse [world] + (let [mouse (ref (get-mouse-state)) + index (+ (/ (x mouse) 10) (* (/ (y mouse) 10) width))] + (aset! world index (not (nth world index))))) + +(defn handle-events [app rend world play] + (let [event (SDL_Event_init) + new-play play] + (do + (while (SDL_PollEvent (address event)) + (let [et (event-type (ref event))] + (cond (= et SDL_QUIT) (quit app) + (= et SDL_KEYDOWN) (set! new-play (handle-key app (ref event) play)) + (= et SDL_MOUSEBUTTONDOWN) (handle-mouse world) + ()))) + new-play))) + +(defn cell-index [x y] + (+ x (* y width))) + +(defn draw [rend world play] + (do + (if play + (SDL_SetRenderDrawColor rend 0 0 0 255) + (SDL_SetRenderDrawColor rend 0 100 50 255)) + (SDL_RenderClear rend) + (for [y 0 height] + (for [x 0 width] + (let [square (make-rect (* x 10) (* y 10) 9 9)] + (do + (if (nth world (cell-index x y)) + (SDL_SetRenderDrawColor rend 255 255 255 255) + (SDL_SetRenderDrawColor rend 50 50 50 255)) + (SDL_RenderFillRect rend (address square)) + )))) + (SDL_RenderPresent rend))) + +(defn cell-value [world x y] + (cond + (< x 0) 0 + (< (dec width) x) 0 + (< y 0) 0 + (< (dec height) y) 0 + (if (nth world (cell-index x y)) + 1 + 0))) + +(defn neighbours [world x y] + (let [a (cell-value world (dec x) (dec y)) + b (cell-value world x (dec y)) + c (cell-value world (inc x) (dec y)) + d (cell-value world (dec x) y) + e 0 + f (cell-value world (inc x) y) + g (cell-value world (dec x) (inc y)) + h (cell-value world x (inc y)) + i (cell-value world (inc x) (inc y))] + (sum (ref [a b c + d e f + g h i])))) + +(defn tick [world newWorld] + (for [i 0 (count world)] + (let [x (mod i height) + y (/ i width) + total (neighbours world x y) + newState (cond + (< total 2) false + (= total 3) true + (> total 3) false + (nth world i))] + (aset! newWorld i newState)))) + +(defn flip [] + (= 0 (random-between 0 20))) + +(defn main [] + (do + (seed (time)) + (let [app (app-init "~ Game of Life ~" 800 600) + rend (app-renderer app) + world (repeat (* height width) flip) + play false] + (while true + (do + (let [new-play (handle-events (ref app) rend (ref world) play)] + (do + (set! play new-play) + (if new-play + (let [newWorld (replicate (* height width) false)] + (do + (tick (ref world) (ref newWorld)) + (set! world newWorld) + (SDL_Delay 50))) + ()))) + (draw rend (ref world) play) + (SDL_Delay 30)))))) + diff --git a/examples/macros.carp b/examples/macros.carp deleted file mode 100644 index 8684e703d..000000000 --- a/examples/macros.carp +++ /dev/null @@ -1,9 +0,0 @@ - -(def a 10) - -(defmacro m0 (blah) - (list '+ 1 blah)) - -(defmacro m1 (blah) - `(+ 1 ~blah)) - diff --git a/examples/memory.carp b/examples/memory.carp new file mode 100644 index 000000000..8d29ae37a --- /dev/null +++ b/examples/memory.carp @@ -0,0 +1,57 @@ +(import IO) +(import Int) +(import Float) +(import Double) +(import Array) +(import System) +(import String) +(import Char) + +(deftype A []) + +(defn a [] + (let [aha (A.init) + hah (A.init)] + hah)) + +(defn e [] + "hej") + +(defn f [] + (let [s "hej"] + (noop (address s)))) + +(defn g [] + (let [s "hej"] + s)) + +(defn h [] + (let [s "hej"] + (println (ref s)))) + +(defn i [s] + (do (println (ref s)) + "hej")) + +(defn j [s] + (do (noop (address s)) + "hej")) + +(defn k [] + (let [s "hej"] + (do (println (ref "?")) + 123))) + +(defn l [] + (do (noop (address "hej")) + (println (ref "blub")) + "ccccc")) + +(defn m [] + (let [x (ref "yes")] + (do (println x) + (println x)))) + +;; (defn main [] +;; (let [xs ["hej" "svej"]] +;; (println "yeah"))) diff --git a/examples/mini.carp b/examples/mini.carp deleted file mode 100644 index cf3c284c0..000000000 --- a/examples/mini.carp +++ /dev/null @@ -1,5 +0,0 @@ -(println "eeeny...") -(println "mini") -(println "miney!") -(defn f [] (error "bleh")) -(f) diff --git a/examples/mouse.carp b/examples/mouse.carp deleted file mode 100644 index 8db75b3ed..000000000 --- a/examples/mouse.carp +++ /dev/null @@ -1,22 +0,0 @@ -(import gl) - -(defn init [window] - (do - (glfwSetCursorPosCallback window on-cursor) - 0)) - -(defn on-cursor (x y) - (println (ref (str x)))) - -;;(str "x: " x ", y: " y) - -(defn draw [state] - (do - (glColor3f 1f 1f 0f) - (draw-circle 0f 0f 0.9f))) - -(defn mouse [] - (glfw-app "Mouse" init id draw default-on-keys)) - -(bake mouse) -;;(mouse) diff --git a/examples/polymorphic.carp b/examples/polymorphic.carp new file mode 100644 index 000000000..08129639a --- /dev/null +++ b/examples/polymorphic.carp @@ -0,0 +1,21 @@ +(import IO) +(import Int) + +(defmodule A + (defn id [x] x) + (defn hard [a b c] + (if a b c))) + +(defn id [x] x) + +(defmodule B + (defn id2 [x] (id x))) + +(defn main [] + (do + (println (ref (B.id2 "hej"))) + (println (ref (str (A.hard true 10 20)))) + (println (ref (str (A.hard false 10 20)))))) + +(build) +(run) diff --git a/examples/presentation.carp b/examples/presentation.carp deleted file mode 100644 index 22586d9d9..000000000 --- a/examples/presentation.carp +++ /dev/null @@ -1,220 +0,0 @@ - -(def topics '(me motivation inspiration features future)) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -(def me {:name "Erik Svedäng" - :job "Game Designer" - :age (* pi (sqrt 89.0)) - :web "http://www.eriksvedang.com" - :twitter "@e_svedang" - :work ["Blueberry Garden" - "Kometen" - "Shot Shot Shoot" - "Tri Tri Triobelisk" - "Clairvoyance" - "Else Heart.Break()"]}) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -(def motivation - {:a "Lisp är AWESOME ...men funkar dåligt för spel (GC, dynamiskt)" - :b "C/C++ har bristfälliga abstraktioner och inget stöd live-utveckling (repl)"}) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -(def inspiration - {1 :Rust - 2 :ML - 3 :Clojure - 4 :Emacs}) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -(defn features [] - (do - (println "1. Ingen Garbage Collector") - (println "2. Automatiskt (statiskt) uträknade typer") - (println "3. Bra stöd för live-kodning") - (println "4. Kompilerar till läsbar C"))) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -(system "open https://github.com/eriksvedang/Carp") diff --git a/examples/project.carp b/examples/project.carp deleted file mode 100644 index 68bcd517d..000000000 --- a/examples/project.carp +++ /dev/null @@ -1,108 +0,0 @@ -;;(reset! echo-signature-after-bake true) -;;(reset! log-unloading-of-dylibs true) -;;(reset! profile-infer-time true) -;;(reset! profile-external-compiler-time true) -;;(reset! log-deps-when-baking-ast true) -;;(reset! log-redefining-struct true) - -;; (def fib (fn [x] -;; (if (< x 2) -;; 1 -;; (+ (fib (- x 2)) -;; (fib (- x 1)))))) - -;; (def d1 {:a {} -;; :b {:a 1 -;; :b 2 -;; :c 3} -;; :c {:a {:x 100} -;; :b {:x 200} -;; :c {:x 300}}}) - -;; (def d2 {:a {} -;; :b {:a 1 -;; :b 2 -;; :c 3} -;; :c {:a {:x 100} -;; :b {:x 66666} -;; :c {:x 300}}}) - -;; (def d3 {:a {} -;; :b {:a 1 -;; :b 2 -;; :c 3} -;; :c {:a {:x 100} -;; :b {:x 200} -;; :c {:x 300}}}) - -;; (defn compare [] -;; (do -;; (assert (not (= d1 d2))) -;; (assert (= d1 d3)))) - -;;(time (for (i 0 50000) (compare))) ;; takes 4700 ms - -;; (println (str "meta d1: " (meta d1))) -;; (println (str "meta d2: " (meta d2))) -;; (println (str "meta d3: " (meta d3))) - -;;(meta {:a 10 :b {:x 10 :y 20}}) - -;; 410767028 -;; 410767028 - -;; {:a {:x 100} -;; :b {:x 666} -;; :c {:x 300}} - - -(def small-dict {:x 100}) -(def medium-dict {:x 100 - :a 0 - :b 0 - :c 0 - :d 0 - :e 0 - :f 0 - :g 0 - :h 0 - :i 0 - :j 0 - :k 0 - :l 0 - :m 0 - :n 0 - :o 0 - :p 0 - :q 0 - :r 0 - :s 0 - :t 0}) -(def large-dict {:aa 0 :ab 0 :ac 0 :ad 0 :ae 0 :af 0 :ag 0 :ah 0 :ai 0 :aj 0 :ak 0 :al 0 :am 0 - :an 0 :ao 0 :ap 0 :aq 0 :ar 0 :as 0 :at 0 :au 0 :av 0 :aw 0 :ax 0 :ay 0 :az 0 - :x 100 - :ca 0 :cc 0 :cd 0 :ce 0 :cf 0 :cg 0 :ch 0 :ci 0 :cj 0 :ck 0 :cl 0 :cm 0 :cn 0 - :co 0 :cp 0 :cq 0 :cr 0 :cs 0 :ct 0 :cu 0 :cv 0 :cw 0 :cx 0 :cy 0 :cz 0 :cq 0 - :da 0 :db 0 :dc 0 :dd 0 :de 0 :df 0 :dg 0 :dh 0 :di 0 :dj 0 :dk 0 :dl 0 :dm 0 - :dn 0 :do 0 :dp 0 :dq 0 :dr 0 :ds 0 :dt 0 :du 0 :dv 0 :dw 0 :dx 0 :dy 0 :dz 0 - }) - -(defn try-lookup [n d] - (for (i 0 n) - (assert-eq 100 (:x d)))) - -;; (if (not (= 100 (:x d))) -;; (error "fail") -;; nil) - -;; (time (try-lookup 10000 small-dict)) -;; (time (try-lookup 10000 medium-dict)) -;; (time (try-lookup 10000 large-dict)) - -;; (time (try-lookup 10000 small-dict)) -;; (time (try-lookup 10000 medium-dict)) -;; (time (try-lookup 10000 large-dict)) - -;; (load-lisp "../lisp/test_printing.carp") -;; (load-lisp (str carp-dir "lisp/test_stack_trace.carp")) -;; (load-lisp (str carp-dir "lisp/test_line_numbers.carp")) diff --git a/examples/robber.carp b/examples/robber.carp deleted file mode 100644 index f85e06df3..000000000 --- a/examples/robber.carp +++ /dev/null @@ -1,17 +0,0 @@ -(defn expand-char [c] - (cond - (= @c \a) (str c) - (= @c \o) (str c) - (= @c \u) (str c) - (= @c \e) (str c) - (= @c \i) (str c) - (= @c \y) (str c) - true (str* c "o" c) - )) - -(defn robber [text] - (string-join "" &(map-copy expand-char &(chars text)))) - -(defn robber-main [] - (while true - (robber "erik"))) diff --git a/examples/selection.carp b/examples/selection.carp new file mode 100644 index 000000000..27bbacf84 --- /dev/null +++ b/examples/selection.carp @@ -0,0 +1,54 @@ +;; Type selection (choose the right function based on the types at the call site) +(import IO) +(import Int) + +;; USER DEFINED FUNCTIONS +(defn f [] true) +(defmodule A (defn f [] 123)) +(defmodule B (defn f [] "hello")) + +(import A) +(import B) + +(defn main [] + (do + (if (f) (println (ref "yes")) (println (ref "no"))) + (println (ref (str (f)))) + (println (ref (f))))) + +(build) +(run) + +;; => yes +;; 123 +;; hello + + + +;; PLUS FUNCTION +(import Double) +(import Float) + +(defn shouldBeInt [x] (+ x 10)) +(defn shouldBeDouble [x] (+ x 10.0)) +(defn shouldBeFloat [x] (+ x 10.0f)) + +(defn shouldBeFloatInLet [x] (let [a (+ x 10.0f)] + a)) + + +;; RECORD FIELDS +(deftype Person [name String]) +(deftype Building [name String]) + +(import Person) +(import Building) + +(defn main [] + (let [thing (Building.init "Eiffel Tower") + another (Person.init "Alice")] + (do (println (name (ref thing))) + (println (name (ref another)))))) + +(build) +(run) diff --git a/examples/spin.carp b/examples/spin.carp deleted file mode 100644 index 808bcef58..000000000 --- a/examples/spin.carp +++ /dev/null @@ -1,24 +0,0 @@ -(import gl) - -(defn init [] - 0f) - -(defn tick [state] - (+ state 0.15f)) - -(defn draw [state] - (let [t @state - steps 100 - step (/ 1f (itof steps))] - (for (i 0 steps) - (let [r (* step (itof i)) - r2 (+ r step)] - (draw-line (* r (cosf (* t r))) - (* r (sinf (* t r))) - (* r2 (cosf (* t r2))) - (* r2 (sinf (* t r2)))))))) - -(defn spin [] - (glfw-app "Spin" init tick draw default-on-keys)) - -(spin) diff --git a/examples/temp.carp b/examples/temp.carp new file mode 100644 index 000000000..c05e8006e --- /dev/null +++ b/examples/temp.carp @@ -0,0 +1,29 @@ +(import IO) +(import Int) +(import Float) +(import Double) +(import Array) +(import System) +(import String) +(import Char) + +;; (deftype QQQ [xxx Int +;; sss String]) + +;; (import QQQ) + +;; (defn f [] +;; (let [stuff (ref [["yeah"] ["a" "b" "c"]]) +;; x @stuff] +;; (do +;; (println (ref (str (nth &x 1))))))) + +;; (defn main [] +;; (f)) + +(defn f [] + (let [stuff ["fsdf" "fsdfsdf"]] + (println (ref (nth &stuff 0))))) + +(defn main [] + (f)) diff --git a/examples/type_failures.carp b/examples/type_failures.carp deleted file mode 100644 index 34a51ec7f..000000000 --- a/examples/type_failures.carp +++ /dev/null @@ -1,45 +0,0 @@ - -;; Examples of type checking failures, to demo the error reporting in various cases. - - -;; Sending an in int to a string-ref argument -(defn fail-1 [] - (strlen 10)) - -;; Return value doesn't match argument type -(defn fail-2 [] - (sinf (strlen "hej"))) - -;; Two type errors in the same function -(defn fail-3 [x] - (string-append "hej" (strlen 3))) - -;; Calling function with too many args -(defn fail-4 [] - (inc 1 2 3)) - -;; Calling function with too few args -(defn fail-5 [] - (println)) - -;; Using non-bool in if statement -(defn fail-6 [] - (if "yeah" 10 20)) - -;; Mismatched types of true/false branch in if -(defn fail-7 [] - (if true 300 4.523)) - -;; Wrong type of let statement -(defn fail-8 [] - (strlen (let [x 10] - x))) - -;; Wrong type of while expression -(defn fail-9 [] - (while 1 (println "CARP"))) - -;; Wrong type in reset! -(defn fail-10 [] - (let [x 3.2] - (reset! x 100))) diff --git a/examples/typograf.carp b/examples/typograf.carp deleted file mode 100644 index 24872aaaa..000000000 --- a/examples/typograf.carp +++ /dev/null @@ -1,109 +0,0 @@ -;; A dynamic font -(import gl) - -(def gstate 65) - -(defn mid-x [] 256f) -(defn mid-y [] 256f) - -(defn em [] 100f) -(defn en [] 70f) - -(defn point-for-id [i] - (copy - (nth - (ref [(Vec2 (mid-x) (mid-y)) - (Vec2 (mid-x) (- (mid-y) (em))) - (Vec2 (+ (mid-x) (em)) (- (mid-y) (en))) - (Vec2 (+ (mid-x) (em)) (mid-y)) - (Vec2 (+ (mid-x) (em)) (+ (mid-y) (en))) - (Vec2 (mid-x) (+ (mid-y) (em))) - (Vec2 (- (mid-x) (em)) (+ (mid-y) (en))) - (Vec2 (- (mid-x) (em)) (mid-y)) - (Vec2 (- (mid-x) (em)) (- (mid-y) (en)))]) - @i))) - -;; 1 -;; / \ -;; 8 2 -;; | | -;; 7 0 3 -;; | | -;; 6 4 -;; \ / -;; 5 - -(defstruct TypografGlyph - [point-ids (:Array :int)]) - -(defn int->glyph [x] - (let [glyphs [(TypografGlyph [8 1 2 3 7 6 5 4 3]) ;; a - (TypografGlyph [8 7 6 5 4 3 7]) ;; b - (TypografGlyph [1 8 7 6 5]) ;; c - (TypografGlyph [2 3 7 6 5 4 3]) ;; d - (TypografGlyph [7 3 2 1 8 6 5 4]) ;; e - (TypografGlyph [2 1 0 7 0 3 0 5]) ;; f - (TypografGlyph [2 1 8 7 6 5 4 3 0]) ;; g - (TypografGlyph [8 7 6 7 3 2 4]) ;; h - (TypografGlyph [1 5]) ;; i - (TypografGlyph [1 5 6]) ;; j - (TypografGlyph [6 8 7 2 7 4]) ;; k - (TypografGlyph [1 5 4]) ;; l - (TypografGlyph [6 8 0 2 4]) ;; m - (TypografGlyph [6 8 4 2]) ;; n - (TypografGlyph [1 2 3 4 5 6 7 8 1]) ;; o - (TypografGlyph [5 1 2 0]) ;; p - (TypografGlyph [1 3 6 4 5 8 7 2 1]) ;; q - (TypografGlyph [6 8 1 2 0 7 0 4]) ;; r - (TypografGlyph [2 1 8 0 4 5 6]) ;; s - (TypografGlyph [5 0 7 3]) ;; t - (TypografGlyph [8 7 6 5 4 3 2]) ;; u - (TypografGlyph [8 5 2]) ;; v - (TypografGlyph [8 6 0 4 2]) ;; w - (TypografGlyph [8 4 0 2 6]) ;; x - (TypografGlyph [8 0 2 0 5]) ;; y - (TypografGlyph [8 2 6 4]) ;; z - ] - i (- x 65)] - (if (< i (count &glyphs)) - (copy (nth &glyphs i)) - (TypografGlyph [])))) - -(defn draw-glyph [glyph] - (let [ids (TypografGlyph-get-point-ids glyph) - points (map-copy point-for-id ids)] - (draw-lines &points))) - -(defn draw [whatever] - (let [glyph (int->glyph gstate)] - (do - (glColor3f 0.3f 0.2f 0.2f) - (draw-line 0f 256f 512f 256f) - (draw-circle 256f 256f 225f) - (glColor3f 1f 1f 1f) - (draw-glyph &glyph)))) - -^ann glfw-key-callback-type -(defn on-keys [window key scancode action mods] - (if (= key-esc key) - (glfwSetWindowShouldClose window true) - (reset! gstate key))) - -(defn setup [] - (do - ;;(reset! gstate 65) - (glOrtho 0.0 512.0 512.0 0.0 1.0 -1.0) 0)) - -(defn update [x] - x) - -;; (if (< gstate (+ 65 25)) -;; (reset! gstate (inc gstate)) -;; (reset! gstate 65)) - -(defn typograf [] - (glfw-app "Typograf" setup update draw on-keys)) - -;;(bake-exe typograf) -;;(bake typograf) -;;(typograf) diff --git a/examples/vec2.carp b/examples/vec2.carp new file mode 100644 index 000000000..9f5a647b8 --- /dev/null +++ b/examples/vec2.carp @@ -0,0 +1,29 @@ +(import IO) +(import String) +(import Int) + +(deftype Vec2 + [x Int + y Int]) + +(defmodule Vec2 + (defn str [v] + (append + (append "x: " (Int.str (Vec2.x v))) + (append ", y: " (Int.str (Vec2.y v))))) + (defn basic [] (Vec2.init 10 20))) + +(defmodule Advanced + (deftype Mat4 [x Int])) + +(defn main [] + (let [v (ref (Vec2.basic))] + (do + (println (ref (Vec2.str v))) + (println (ref (str (Advanced.Mat4.x + (ref (Advanced.Mat4.set-x + (Advanced.Mat4.init 100) + 200))))))))) + +(build) +(run) diff --git a/globfiles.cmake b/globfiles.cmake deleted file mode 100644 index f9b50bd26..000000000 --- a/globfiles.cmake +++ /dev/null @@ -1,48 +0,0 @@ - -file(GLOB ${PROJECT_NAME}_mac_c "${SOURCE_DIR}/*_MacOSX.c") -file(GLOB ${PROJECT_NAME}_mac_cpp "${SOURCE_DIR}/*_MacOSX.cpp") -file(GLOB ${PROJECT_NAME}_mac_m "${SOURCE_DIR}/*_MacOSX.m") -file(GLOB ${PROJECT_NAME}_mac_mm "${SOURCE_DIR}/*_MacOSX.mm") -file(GLOB ${PROJECT_NAME}_mac_h "${SOURCE_DIR}/*_MacOSX.h") -list(APPEND ${PROJECT_NAME}_mac_c ${${PROJECT_NAME}_mac_cpp} ${${PROJECT_NAME}_mac_m} ${${PROJECT_NAME}_mac_mm}) - -file(GLOB ${PROJECT_NAME}_win_c "${SOURCE_DIR}/*_MSWIN.c") -file(GLOB ${PROJECT_NAME}_win_cpp "${SOURCE_DIR}/*_MSWIN.cpp") -file(GLOB ${PROJECT_NAME}_win_h "${SOURCE_DIR}/*_MSWIN.h") -list(APPEND ${PROJECT_NAME}_win_c ${${PROJECT_NAME}_win_cpp}) - -file(GLOB ${PROJECT_NAME}_linux_c "${SOURCE_DIR}/*_Linux.c") -file(GLOB ${PROJECT_NAME}_linux_cpp "${SOURCE_DIR}/*_Linux.cpp") -file(GLOB ${PROJECT_NAME}_linux_h "${SOURCE_DIR}/*_Linux.h") -list(APPEND ${PROJECT_NAME}_mac_c ${${PROJECT_NAME}_linux_cpp}) - -file(GLOB ${PROJECT_NAME}_c "${SOURCE_DIR}/*.c") -file(GLOB ${PROJECT_NAME}_cpp "${SOURCE_DIR}/*.cpp") -file(GLOB ${PROJECT_NAME}_h "${SOURCE_DIR}/*.h") -list(APPEND ${PROJECT_NAME}_c ${${PROJECT_NAME}_cpp}) - -if(${PROJECT_NAME}_mac_c OR ${PROJECT_NAME}_win_c OR ${PROJECT_NAME}_linux_c) - list(REMOVE_ITEM ${PROJECT_NAME}_c ${${PROJECT_NAME}_mac_c} ${${PROJECT_NAME}_win_c} ${${PROJECT_NAME}_linux_c}) - - if(WIN32) - list(APPEND ${PROJECT_NAME}_c ${${PROJECT_NAME}_win_c}) - elseif(APPLE) - list(APPEND ${PROJECT_NAME}_c ${${PROJECT_NAME}_mac_c}) - else() - list(APPEND ${PROJECT_NAME}_c ${${PROJECT_NAME}_linux_c}) - endif() - -endif() - -if(${PROJECT_NAME}_mac_h OR ${PROJECT_NAME}_win_h OR ${PROJECT_NAME}_linux_h) - list(REMOVE_ITEM ${PROJECT_NAME}_h ${${PROJECT_NAME}_mac_h} ${${PROJECT_NAME}_win_h} ${${PROJECT_NAME}_linux_h}) - - if(WIN32) - list(APPEND ${PROJECT_NAME}_h ${${PROJECT_NAME}_win_h}) - elseif(APPLE) - list(APPEND ${PROJECT_NAME}_h ${${PROJECT_NAME}_mac_h}) - else() - list(APPEND ${PROJECT_NAME}_h ${${PROJECT_NAME}_linux_h}) - endif() - -endif() diff --git a/lisp/annotate.carp b/lisp/annotate.carp deleted file mode 100644 index 240e32a3b..000000000 --- a/lisp/annotate.carp +++ /dev/null @@ -1,50 +0,0 @@ -;; Annotating is the process of taking a very simple AST and adding more information to it. - -(defn func-to-annotated-ast (func-name func-code func-signature-if-generic func-type-annotation) - (let [ast (lambda-to-ast func-code) - ast-with-name (assoc ast :name func-name) - ast-with-type-annotation (assoc ast-with-name :annotation func-type-annotation) - ast-fully-annotated (annotate-ast-internal ast-with-type-annotation true func-signature-if-generic) - _ (check-for-ref-return ast-fully-annotated)] - ast-fully-annotated)) - -(defn check-for-ref-return (ast) - (let [t (:type ast)] - (when (ref? (nth t 2)) (error (str "Return type of function '" (:name ast) "' is a reference: " (pretty-signature t)))))) - -(defn annotate-ast (ast) - (annotate-ast-internal ast false nil)) - -(def profile-infer-time false) -(def total-infer-time 0.0f) - -(defn annotate-ast-internal (ast bake-deps func-signature-if-generic) - (let [ast-func-deps (find-func-deps ast bake-deps) - ;;_ (println (str "ast-func-deps: " ast-func-deps)) - start-time (now) - ast-typed (infer-types ast-func-deps func-signature-if-generic) - _ (when profile-infer-time (print-infer-time start-time (get-maybe ast :name))) - ast-named (generate-names (copy {}) ast-typed) - ast-lifetimes (calculate-lifetimes ast-named) - ast-generics (visit-generic-funcs ast-lifetimes) - ;;_ (println (str "ast:\n" ast-generics)) - ] - ast-generics)) - -(defn print-infer-time [start-time func-name] - (let [t (/ (itof (- (now) start-time)) 1000f)] - (do - (println (str (get-console-color console-color-yellow) - "infer-types for " func-name " took " - t " seconds" - (get-normal-console-color))) - (reset! total-infer-time (+ total-infer-time t))))) - -;; WARNING: These helper functions don't know the name of the functions -;; so they will mess upp self-recursive functions since they will think that -;; they are refering to other functions and bake those: - -(defn ann (lambda) (annotate-ast (lambda-to-ast (code lambda)))) -(defn sign (lambda) (:type (ann lambda))) -(defn con (lambda) (generate-constraints (lambda-to-ast (code lambda)))) - diff --git a/lisp/array.carp b/lisp/array.carp deleted file mode 100644 index c72132bd8..000000000 --- a/lisp/array.carp +++ /dev/null @@ -1,23 +0,0 @@ - -;; The generic, built in array. - -;; Basic idea is to: - -;; 1. Give primops signatures -;; 2. Create primops for the generic functions like 'array-new', 'array-delete', 'array-set' & 'array-get' -;; 3. When baking calls to these functions, don't generate code like normal, instead go to a special code generating function -;; 4. This function pastes in a blob of C that can use the type signature of the call to figure out special cases - -;; Example -;; array-get has the type ((:array "a") :int) -> "a" -;; Another function calls it like this: -;; (array-get [1 2 3] 0) -;; The type of the call becomes ((:array :int) :int) -;; When calling the special codegen function it gets access to all the types in the call -;; It sticks them into a predefined block of C: -;; TYPE_A array-get--TYPE_A(Array--TYPE_A array, int index) { -;; return array[index]; -;; } - - - diff --git a/lisp/ast.carp b/lisp/ast.carp deleted file mode 100644 index 40259fc2d..000000000 --- a/lisp/ast.carp +++ /dev/null @@ -1,245 +0,0 @@ -;; Anatomy of AST nodes -;; { :node = The kind of node this is. Can be :function / :arg / :literal / :app (function application) / :binop -;; :type = The type that has been calculated for this node. -;; :name = Used by AST nodes where this makes sense. The name of a variable or function, etc. -;; } - -;; Anatomy of a type -;; Before the type is known it is set to a typevar which is a string of the form "t0", "t1", etc -;; Types can be just a keyword like :int / :string -;; Complex types are lists, like the :fn type (:fn (:int :int) :string) which corresponds to (Int, Int) -> String - -(def typevar-counter 0) - -(defn gen-typevar [] - (let [typevar (str "t" typevar-counter)] - (do (swap! typevar-counter inc) - typevar))) - -(defn arg-list-to-ast [args] - (map (fn (arg) - {:node :arg - :name arg - :type (gen-typevar)}) - args)) - -(defn binop? [form] - (match form - (x ... _) (contains? '(+ - * / < and) x) - _ false)) - -(defn gen-fn-type [arg-count] - (list :fn (repeatedly gen-typevar arg-count) (gen-typevar))) - -(defn array-to-ast [a] - {:node :array - :type (list :Array (gen-typevar)) - :line (meta-get a :line) - :original-form (prn a) - :values (map form-to-ast (array-to-list a))}) - -(defn list-to-ast [l] - (if (binop? l) - (match l - (op left right) {:node :binop - :type (cond - (= op 'and) :bool - :else (gen-typevar)) - :op op - :left (form-to-ast left) - :right (form-to-ast right)}) - (match l - (x ... xs) (if (def? x) - (let [evaled (eval x)] - (if (and* (symbol? x) (macro? evaled)) - (expand-macro l) - (app-to-ast x xs l))) - (app-to-ast x xs l)) - - nil {:node :literal :type :any :value ""}))) - -(defn app-to-ast [x xs original-form] - (do ;;(println (str "app-to-ast: " x ", " xs)) - {:node :app - :type (gen-typevar) - :line (meta-get x :line) - :original-form original-form - :head (assoc (form-to-ast x) :type (gen-fn-type (count xs))) - :tail (map2 (fn [form n] (assoc form :arg-index n)) (map form-to-ast xs) (range 0 (count xs)))})) - -(defn expand-macro [form] - (do ;;(println (str "expand:\n" form)) - (let [macro (code (eval (first form))) - mlam (eval (list 'fn (nth macro 1) (nth macro 2))) ;; convert macro to lambda... this is a strange way to do it - ;;_ (println (str "macro-lambda: " mlam ", type: " (type mlam))) - args (rest form) - ;;_ (println (str "args: " args)) - called-macro (apply mlam args) - ;;called-macro-forms (eval called-macro) - expanded-ast (form-to-ast called-macro) - ;;_ (println (str "expanded-ast: " expanded-ast)) - ] - ;;(println (str "called-macro:\n" called-macro ", type: " (type called-macro))) - expanded-ast))) - -(defn if-to-ast [expr if-true if-false] - {:node :if - :type (gen-typevar) - :expr (form-to-ast expr) - :original-form (list 'if expr if-true if-false) - :line (meta-get expr :line) - :if-true (form-to-ast if-true) - :if-false (form-to-ast if-false)}) - -(defn do-to-ast [forms] - {:node :do - :type (gen-typevar) - :forms (map form-to-ast forms)}) - -(defn bindings-to-ast [bindings] - (match bindings - [name value ... rest-bindings] (cons {:node :binding - :type (gen-typevar) - :name name - :value (form-to-ast value)} - (bindings-to-ast rest-bindings)) - _ ())) - -(defn let-to-ast [bindings body] - {:node :let - :type (gen-typevar) - :bindings (bindings-to-ast bindings) - :body (form-to-ast body) - :original-form (list 'let bindings body) - :line (meta-get bindings :line)}) - -(defn while-to-ast [expr body] - {:node :while - :type :void - :expr (form-to-ast expr) - :body (form-to-ast body) - :original-form (list 'while expr body) - :line (meta-get expr :line)}) - -(defn ref-to-ast [expr] - {:node :ref - :type (list :ref (gen-typevar)) - :line (meta-get expr :line) - :original-form expr - :expr (form-to-ast expr)}) - -(defn reset-to-ast [symbol expr] - (if (symbol? symbol) - {:node :reset - :type :void - :symbol (literal-or-lookup-to-ast symbol) - :expr (form-to-ast expr) - :line (meta-get symbol :line) - :original-form (list 'reset! symbol expr)} - (error (str "Non-symbol '" symbol "' found in reset! form.")))) - -(defn literal-or-lookup-to-ast [expr] - (if (symbol? expr) - (let [is-generic-lens-stub (and* (def? expr) (is-generic-lens-stub? (eval (list 'meta expr)))) - node {:node :lookup - :type (gen-typevar) - :generic-lens-stub is-generic-lens-stub - :line (meta-get expr :line) - :original-form expr - :value expr}] ;; change key to :name ..? - (if is-generic-lens-stub - (assoc (assoc node :struct (symbol (eval (list 'meta-get expr :struct)))) - :stub-ending (eval (list 'meta-get expr :stub-ending))) - node)) - {:node :literal - :type (type-of-literal expr) - :line (meta-get expr :line) - :original-form (prn expr) - :value expr})) - -(defn type-of-literal [expr] - (let [t (type expr)] - (cond - (= :string t) '(:ref :string) ; Literal strings are refs - (= :ptr t) (do ;; TODO: is this cond-clause ever used? - (println (str "expr " expr " is a ptr of type: " (meta-get expr :type) " with value " (eval expr))) - (if-let [real-type (meta-get expr :type)] - real-type - (error (str "No type on expr: " expr)))) - :else t))) - -(defn is-generic-lens-stub? [form] - (if (nil? form) - false - (key-is-true? form :generic-lens-stub))) - -(defn is-struct-constructor? [form] - (and* (dict? form) (true? (get-maybe form :struct)))) - -(defn struct-constructor-ast [struct-description] - (let [struct-name (:name struct-description) - struct-type (keyword struct-name) - arg-count (:member-count struct-description) - member-types (:member-types struct-description) - ] - (do - {:node :lookup - :constructor true - :generic (any? generic-type? (array-to-list member-types)) - :typevars (typevars-from-member-types member-types) - :type (list :fn (repeatedly gen-typevar arg-count) (keyword struct-name)) - :member-types member-types - :member-names (:member-names struct-description) - :struct-name struct-name - :value (str "new-" struct-name)}))) - -(defn typevars-from-member-types [types] - ;; Hack to make the order be correct: - (reverse (set (filter generic-type? (array-to-list types))))) - -(defn form-to-ast [form] - (match form - ('if expr a b) (if-to-ast expr a b) - ('if ... _) (error (str "'if' needs exactly two branches. Compiler got:\n" form)) - - ('do ... forms) (do-to-ast forms) - - ('let bindings body) (let-to-ast bindings body) - ('let ... _) (error (str "'let' needs exactly two inner forms, bindings and a body. Compiler got:\n" form)) - - ('while expr body) (while-to-ast expr body) - ('while ... _) (error (str "'while' needs exactly two inner forms, an expression and a body. Compiler got:\n" form)) - - ('ref expr) (ref-to-ast expr) - ('ref ... _) (error (str "'ref' needs exactly one inner form, an expression. Compiler got:\n" form)) - - ('reset! symbol expr) (reset-to-ast symbol expr) - ('reset! ... _) (error (str "'reset' needs exactly two inner form, a symbol and an expression. Compiler got:\n" form)) - - ('include-c-code s) {:node :c-code :code s :type (gen-typevar)} - - 'NULL {:node :null :type (gen-typevar)} - 'true {:node :literal :type :bool :value 1} - 'false {:node :literal :type :bool :value 0} - - x (if (list? x) - (list-to-ast x) - (if (array? x) - (array-to-ast x) - (if (and* (symbol? x) (def? x) (is-struct-constructor? (eval x))) - (struct-constructor-ast (eval x)) - (literal-or-lookup-to-ast x)))))) - -(defn body-to-ast [body] - (form-to-ast body)) - -;; Takes a list representation of a lambda and creates an AST from it -(defn lambda-to-ast [form] - (do (assert-eq :list (type form)) - (match form - ('fn args body) {:node :function - :type (gen-fn-type (count args)) - :annotation nil - :args (arg-list-to-ast (if (array? args) (array-to-list args) args)) - :body (body-to-ast body)} - _ (error (str "Failed to match lambda form: " form))))) diff --git a/lisp/boot.carp b/lisp/boot.carp deleted file mode 100644 index ea6cbb687..000000000 --- a/lisp/boot.carp +++ /dev/null @@ -1,46 +0,0 @@ -(def carp-dir (getenv "CARP_DIR")) - -(if (= carp-dir "") - (do (println (str "Environment variable 'CARP_DIR' is not set, did you run 'carp-repl' directly?\n" - "Please use the carp shell script instead.")) - (exit -1)) - nil) - -(load-lisp (str carp-dir "lisp/core_macros.carp")) - -(defn env-variable-true? [v] - (and* (not (= "" v)) - (not (= "0" v)) - (not (= "false" v)))) - -(def carp-dev (env-variable-true? (getenv "CARP_DEV"))) - -;; ~~~ CORE ~~~ -(load-lisp (str carp-dir "lisp/builtins.carp")) -(load-lisp (str carp-dir "lisp/core.carp")) -(load-lisp (str carp-dir "lisp/signatures.carp")) -(load-lisp (str carp-dir "lisp/tester.carp")) - -(when carp-dev - (load-lisp (str carp-dir "lisp/core_tests.carp"))) - -;; ~~~ COMPILER ~~~ -(load-lisp (str carp-dir "lisp/compiler.carp")) - -;; TODO: reactivate -(when carp-dev - (do - (time (load-lisp (str carp-dir "lisp/compiler_tests.carp"))) - (load-lisp (str carp-dir "lisp/examples.carp")) - (load-lisp (str carp-dir "lisp/glfw_test.carp")) - )) - -;;(load-lisp (str carp-dir "lisp/improved_core.carp")) - -;; ~~~ USER BOOT FILES ~~~ -(let [user-boot-file (str (getenv "HOME") "/.carp/user.carp")] - (when (file-exists? user-boot-file) - (load-lisp user-boot-file))) - -(when (file-exists? "project.carp") - (load-lisp "project.carp")) diff --git a/lisp/bug.carp b/lisp/bug.carp deleted file mode 100644 index 40baa2698..000000000 --- a/lisp/bug.carp +++ /dev/null @@ -1,21 +0,0 @@ -(defstruct Person [age :int]) - -(def peeps [(Person 29) - (Person 30)]) - -(defn grow [person] - (update-age person inc)) - -(defn grow-peeps [] - (map grow peeps)) - -(defn example [] - (println* (ref (grow-peeps)))) - - -;; [(Person @"erik" 29) -;; (Person @"marie" 30)] - -(defn main1 [] - (while true - (example))) diff --git a/lisp/builder.carp b/lisp/builder.carp deleted file mode 100644 index 819f325a1..000000000 --- a/lisp/builder.carp +++ /dev/null @@ -1,342 +0,0 @@ -(def slim-code-generation true) - -;; Creates a C code builder which allows for out-of-order generation of C from the AST -(defn new-builder [] - {:headers () - :functions () - :deps () - :main ()}) - -(defn builder-add [builder category block] - (update-in builder (list category) (fn (blocks) (set (cons-last blocks block))))) - -(defn builder-add-headers [builder files] - (reduce (fn (b file) (builder-add b :headers (str "#include " file))) - builder - files)) - -;; Takes a completed C code builder and returns its string with C code -(defn builder-merge-to-c [builder] - (let [funcs (:functions builder) - headers (:headers builder) - main (:main builder)] - (str (join "\n\n" - (list (join "\n" headers) - (join "\n\n" funcs) - (join "\n\n" main))) - "\n"))) - -(def indent-level 1) - -(defn indent [] - (join "" (replicate " " indent-level))) - -(defn indent-in! [] - (swap! indent-level inc)) - -(defn indent-out! [] - (swap! indent-level dec)) - -(defn free-variables [free-list deps] - (do - ;;(println (str "free-list: " free-list)) - (map (fn [t] (bake-generic-primop-auto "delete" (list :fn (list t) :void))) (map :type free-list)) - (join "" (map (fn (variable) - (let [delete-signature (list :fn (list (:type variable)) :void) - delete-fn-name (generic-name "delete" delete-signature)] - (do - (dict-set! deps :mutable-value (cons delete-fn-name (:mutable-value deps))) - (str (indent) (c-ify-name delete-fn-name) "(" (c-ify-name (:name variable)) ");\n")))) - free-list)))) - -(defn ensure-function-type [t] - (match t - (:fn arg-types return-type) (let [func-type-name (str "Fn_" (join "_" (map type-build-no-star arg-types)) - "_" (type-build-no-star return-type))] - (do (if (has-key? graph func-type-name) - (do ;;(println (str "Ignoring " func-type-name)) - func-type-name) - (do ;;(println (str "Adding function type " func-type-name)) - (graph/add-node! :function-type - func-type-name - (str "typedef " (type-build return-type) - "(*" func-type-name ")(" - (join "," (map type-build arg-types)) - ");" - ;;" // ensure function type " (str t) - ) - "" ;; no body - "" ;; group - nil ;; dylib ptr - () ;; (struct-groups-in-type t) ;; deps - (calculate-dependency-level t) ;; (log (str func-type-name " dep lvl: ") - ) - func-type-name)))) - - _ (error "Can't match t in ensure-function-type: " t))) - -(defn struct-groups-in-type [t] - (if (list? t) - (set (mapcat struct-groups-in-type t)) - (if (struct-type? t) - (list (name t)) - ()))) - -(defn visit-arg-explicit [c arg deps] - (let [result (visit-form c arg true deps)] - (str-append! c (str (indent) (type-build (:type arg)) " " (c-ify-name (:arg-name arg)) " = " (get result :c) ";\n")))) - -(defn visit-args-explicit [c args deps] - (let [] - (do - ;;(println "visit args:" args) - (map (fn (arg) (visit-arg-explicit c arg deps)) args) - (map (fn (arg) {:c (:arg-name arg)}) args)))) - -(defn inlined-literal? [ast] - (and* (= :literal (:node ast)) - (contains? '(:int :float :double :bool (:ref :string)) (:type ast)))) - -(defn inlined-lookup? [ast] - (= :lookup (:node ast))) - -(defn inlined-binop? [ast] - (= :binop (:node ast))) - -;; Print Objs in a way that the C compiler accepts -(defn c-prn [x] - (match (type x) - :char (str "'" x "'") ;; chars are written like this in Carp: \e but like this: 'e' in C. - _ (prn x))) - -;; New version of visit arg that generates slimmer code (no intermediate arg variables) -(defn visit-arg-slim [c arg deps] - (let [arg-name (:arg-name arg) - arg-type (:type arg) - result (visit-form c arg true deps)] - (match (:node arg) - - :lookup (do ;;(println (str "Arg " arg-name " is lookup.")) - {:c (c-ify-name (str (:value arg)))}) - - :literal (do ;;(println (str "Arg " arg-name " is literal.")) - {:c (c-prn (:value arg))}) - - _ (let [result-name (get-maybe arg :result-name)] - (if (nil? result-name) - (do (str-append! c (str (indent) (type-build arg-type) " " (c-ify-name arg-name) " = " (:c result) ";\n")) - {:c (:arg-name arg)}) - {:c result-name})) - - ))) - -(defn visit-args-slim [c args deps] - (let [] - (do - ;(println (str "visit args slim:\n" args)) - (map (fn (arg) (visit-arg-slim c arg deps)) args)))) - -(defn visit-let-bindings (c bindings deps) - (map (fn (b) (let [value-result (visit-form c (:value b) false deps)] - (str-append! c (str (indent) (type-build (:type b)) " " (c-ify-name (str (:name b))) " = " (:c value-result) ";\n")))) - bindings)) - -(defn visit-form [c form toplevel deps] - (do - ;;(println (str "\nvisit-form:\n" form)) - (match (get form :node) - - :binop (let [result-a (visit-form c (get form :left) false deps) - result-b (visit-form c (get form :right) false deps)] - {:c (str (if toplevel "" "(") (:c result-a) " " (:op form) " " (:c result-b) (if toplevel "" ")"))}) - - :literal (let [val (:value form) - result-name (get-maybe form :result-name)] - (if (or (inlined-literal? form) (nil? result-name)) - {:c (c-prn val)} - (do - (str-append! c (str (indent) - (type-build (:type form)) " " - (:result-name form) " = " - (c-prn val) ";\n")) - {:c (:result-name form)}))) - - :lookup (let [val (:value form)] - {:c (c-ify-name (name val))}) - - :ref (let [expr (:expr form) - result (visit-form c expr toplevel deps)] - result) - - :reset (let [expr (:expr form) - symbol (:value (:symbol form)) - result (visit-form c expr toplevel deps) - t (:type expr)] - (do - ;;(str-append! c (str (indent) "printf(\"address of " symbol " = %p\\n\", &" symbol ");\n")) - (when (managed-type? t) - (do - (str-append! c (str (indent) "// free '" symbol "' before assigning to it:\n")) - (str-append! c (str (indent) "if(" (c-ify-name (str symbol)) ") {\n")) - (indent-in!) - (str-append! c (free-variables (list {:name (c-ify-name (str symbol)) :type t}) deps)) - (indent-out!) - (str-append! c (str (indent) "}\n")))) - (str-append! c (str (indent) (c-ify-name (str symbol)) " = " (:c result) ";\n")) - {:c ""})) - - :if (let [n (get form :result-name) - if-expr (visit-form c (get form :expr) true deps)] - (do (if (= :void (:type form)) - () ;; no result variable needed - (str-append! c (str (indent) (type-build (:type form)) " " n ";\n"))) - - (str-append! c (str (indent) "if(")) - (str-append! c (:c if-expr)) - (str-append! c (str ")")) - - ;; true-block begins - (str-append! c " {\n") - (indent-in!) - (let [result-a (visit-form c (:if-true form) true deps)] - (do - (str-append! c (free-variables (get-maybe form :free-left) deps)) - (if (= :void (:type form)) - () ;; no-op - (str-append! c (str (indent) n " = " (get result-a :c) ";\n"))) - (indent-out!) - (str-append! c (str (indent) "} else {\n")))) - - (indent-in!) ;; false-block-begins - (let [result-b (visit-form c (:if-false form) true deps)] - (do - (str-append! c (free-variables (get-maybe form :free-right) deps)) - (if (= :void (:type form)) - () ;; no-op - (str-append! c (str (indent) n " = " (get result-b :c) ";\n"))) - (indent-out!) - (str-append! c (str (indent) "}\n")))) - {:c n})) - - :app (let [head (get form :head) - func-name (get head :value) - c-func-name (c-ify-name (str func-name)) - n (:result-name form) - ;;_ (println (str "c before call to " func-name ":\n" c)) - arg-results ((if slim-code-generation visit-args-slim visit-args-explicit) c (get form :tail) deps) - ;;_ (println (str "c after call to " func-name ":\n" c)) - arg-vars (map :c arg-results) - t (:type form)] - (do - (if (= :void t) - (do (str-append! c (str (indent) c-func-name "(" (join ", " arg-vars) ");\n")) - {:c n}) - ;;{:c (str c-func-name "(" (join ", " arg-vars) ")")} - (do (str-append! c (str (indent) (type-build t) " " n " = " c-func-name "(" (join ", " arg-vars) ");\n")) - {:c n}) - ))) - - :do (let [forms (:forms form) - ;_ (println (str "forms:\n" forms)) - results (map (fn (x) (visit-form c x toplevel deps)) forms)] - {:c (:c (last results))}) - - :let (let [n (:result-name form)] - (do (if (= :void (:type form)) - () ;; nothing - (str-append! c (str (indent) (type-build (:type form)) " " n ";\n"))) - (str-append! c (str (indent) "{\n")) - (indent-in!) - (let [body (:body form) - _ (visit-let-bindings c (:bindings form) deps) - result (visit-form c body false deps)] - (do (str-append! c (free-variables (get-maybe form :free) deps)) - (if (= :void (:type form)) - () - (str-append! c (str (indent) n " = " (:c result) ";\n"))))) - (indent-out!) - (str-append! c (str (indent) "}\n")) - {:c n})) - - :while (let [while-expr (visit-form c (get form :expr) true deps) - while-expr-name (:while-expr-name form)] - (do (str-append! c (str (indent) (type-build (get-in form '(:expr :type))) " " while-expr-name " = " (get while-expr :c) ";\n")) - (str-append! c (str (indent) "while(" while-expr-name ") {\n")) - (indent-in!) - (let [body (:body form)] - (visit-form c body false deps)) - (let [while-expr-again (visit-form c (get form :expr) true deps)] - (do - (str-append! c (free-variables (get-maybe form :free) deps)) - (str-append! c (str (indent) while-expr-name " = " (get while-expr-again :c) ";\n")) - )) - (indent-out!) - (str-append! c (str (indent) "}\n")))) - - :c-code (do - ;;(str-append! c ) - {:c (:code form)}) - - :null {:c "NULL"} - - :array (let [n (:result-name form) - inner-type (nth (:type form) 1) - t (type-build inner-type) - t-no-star (c-ify-name (type-build-no-star inner-type)) - vals (:values form) - arg-results (map (fn (arg) (visit-arg-slim c arg deps)) vals) - arg-vars (map :c arg-results)] - (do (str-append! c (str (indent) "Array* " n " = malloc(sizeof(Array));\n" - (indent) n "->count = " (count vals) ";\n" - (indent) n "->data = malloc(sizeof(" t ") * " (count vals) ");\n" - (indent) t " *casted" n " = " n "->data;\n" - (join "\n" (map2 (fn [arg-name index] - (str (indent) "casted" n "[" index "] = " arg-name ";")) - arg-vars - (range 0 (count arg-vars)))) - "\n")) - {:c n})) - - x (error (str "visit-form failed to match " x))))) - -(defn arg-list-build [args] - (join ", " (map (fn (arg) (str (type-build (get arg :type)) " " (c-ify-name (str (:name arg)))))args))) - -(defn visit-function [builder ast func-name] - (let [t (:type ast) - _ (when (not (list? t)) (error "Can't generate code for function, it's type is not a list.")) - return-type (nth t 2) - args (get ast :args) - body (get ast :body) - c (copy "") ;; mutable string holding the resulting C code for the function - deps (copy {:mutable-value (get-maybe ast :deps)}) ;; HACK: passing around a dict so that the mutation of the cdr (in the binding pair) will work. Add set-cdr! to list instead? - result (visit-form c body true deps) - result-var-name (:result-name ast) - ret-type (get-in ast '(:type 2))] - (do - ;;(println "visit-function: \n" ast) - (let [code (str "API " (type-build return-type) " " (c-ify-name func-name) - "(" (arg-list-build args) ") {\n" - c - (if (= :void ret-type) - "" - (str (indent) (type-build ret-type) " " result-var-name " = " (get result :c) ";\n")) ;; TODO: evaluate if this extra step is needed - (free-variables (get-maybe ast :free) deps) - (if (= :void (:type body)) - "" ;; no return - (str (indent) "return " result-var-name ";\n")) - "}")] - {:builder (builder-add builder :functions code) - :deps (:mutable-value deps)})))) - -(defn get-function-prototype [ast func-name] - (let [t (get ast :type) - return-type (nth t 2) - args (get ast :args)] - (str "API " (type-build return-type) " " (c-ify-name func-name) "(" (arg-list-build args) ");"))) - -(defn builder-visit-ast [builder ast func-name] - (match (get ast :node) - :function (visit-function builder ast func-name) - x (error (str "Can't match :ast '" x "' in builder-visit-ast.")))) - diff --git a/lisp/builtins.carp b/lisp/builtins.carp deleted file mode 100644 index 5cebaa71c..000000000 --- a/lisp/builtins.carp +++ /dev/null @@ -1,55 +0,0 @@ -;; Int math -(register-builtin "srand" '(:int) :void) -(register-builtin "rand" '() :int) -(register-builtin "max" '(:int :int) :int) -(register-builtin "inc" '(:int) :int) -(register-builtin "dec" '(:int) :int) -(register-builtin "mod" '(:int :int) :int) - -;; Double math -(register-builtin "sin" '(:double) :double) -(register-builtin "cos" '(:double) :double) -(register-builtin "sqrt" '(:double) :double) - -;; Float math -(register-builtin "sinf" '(:float) :float) -(register-builtin "cosf" '(:float) :float) -(register-builtin "sqrtf" '(:float) :float) - -;; Conversions -(register-builtin "itof" '(:int) :float) -(register-builtin "dtof" '(:double) :float) -(register-builtin "ftod" '(:float) :double) -(register-builtin "itos" '(:int) :string) - -;; Strings -(register-builtin "strlen" '((:ref :string)) :int) -(register-builtin "string_append" '((:ref :string) (:ref :string)) :string) -(register-builtin "eat_string" '(:string) :void) -(register-builtin "string_copy" '((:ref :string)) :string) -(register-builtin "last_index_of" '(:string :char) :int) -(register-builtin "substring" '(:string :int) :string) -(register-builtin "file_path_component" '(:string) :string) -(register-builtin "chars" '((:ref :string)) '(:Array :char)) -(register-builtin "string_join" '((:ref :string) (:ref (:Array :string))) :string) - -;; IO -(register-builtin "printf" '((:ref :string)) :void) -(register-builtin "print" '((:ref :string)) :void) -(register-builtin "println" '((:ref :string)) :void) -(register-builtin "get_input" '() :string) -(register-builtin "get_normal_console_color" '() :string) -(register-builtin "get_console_color" '(:int) :string) - -;; Files -(register-builtin "file_existsQMARK" '((:ref :string)) :bool) - -;; System -(register-builtin "system" '((:ref :string)) :void) -(register-builtin "sleep" '(:int) :void) -(register-builtin "async" '((:fn () :void)) :void) - -;;Misc -(register-builtin "nullQMARK" '((:ref :any)) :bool) -(register-builtin "not" '(:bool) :bool) - diff --git a/lisp/calculate_lifetimes.carp b/lisp/calculate_lifetimes.carp deleted file mode 100644 index c041fff1e..000000000 --- a/lisp/calculate_lifetimes.carp +++ /dev/null @@ -1,567 +0,0 @@ - -(defn clean-free-list (free-list) - (map (fn (n) {:name (:name n) :type (:type n)}) free-list)) - -(defn ownership-analyze-internal (ast) - (match (:node ast) - :function {:node :function :free (clean-free-list (:free ast)) :body (ownership-analyze-internal (:body ast))} - :let {:node :let :free (clean-free-list (:free ast)) :body (ownership-analyze-internal (:body ast))} - :if {:node :if - :free-left (clean-free-list (:free-left ast)) - :free-right (clean-free-list (:free-right ast)) - :body-left (ownership-analyze-internal (:if-true ast)) - :body-right (ownership-analyze-internal (:if-false ast))} - ;;:app {:node :app :head (ownership-analyze-internal (:head ast)) :tail (map ownership-analyze-internal (:tail ast))} - x nil ;;{:node x} - )) - -;; This function takes an uncompiled function and extracts the information needed for ownership, making it easier to write tests -(defn ownership-analyze (lambda) - (ownership-analyze-internal (annotate-ast (lambda-to-ast (code lambda))))) - - - -(defn convert-param-node (a) - {:name (str (:name a)) - :type (:type a) - :doc "parameter"}) - -(defn primitive-type? (t) - (contains? '(:int :float :double :bool :char) t)) - -(defn void-type? (t) - (= :void t)) - -(defn managed-type? (t) - (match t - (:ref _) false - (:fn _ _) false - _ (not (or (void-type? t) (primitive-type? t))))) - -(defn manage? (descriptor) - (managed-type? (:type descriptor))) - -(defn dont-free-result-variable (ast vars) - (let [result-var-name (get-maybe ast :result-name)] - (do - ;;(println (str "result-var-name: " result-var-name)) - (if (= nil result-var-name) - vars - (remove (fn (v) (= (:name v) result-var-name)) vars))))) - -(defn ref? (v) - (match v - (:ref _) true - _ false)) - -(defn remove-var-with-name (vars name) - (remove (fn (v) (= name (:name v))) vars)) - -;; Used for reducing over the args in a function application -(defn calc-lifetime-for-arg (data parameter-types arg-ast) - (do - ;;(println "CALCARG. data:\n") - ;;(println (str data "\n")) - ;;(println "arg-ast:\n") - ;;(println arg-ast) - (let [ast (:ast data) - vars (:vars data) - pos (:pos data) - env (:env data) - parameter-type (nth parameter-types pos) - is-ref (ref? parameter-type) - - ;;_ (println (str "\n " (:arg-name arg-ast) " vars:\n" vars "\n")) - - new-data (if (and* (= :literal (:node arg-ast)) (not is-ref)) - {:ast arg-ast :vars vars} ;; a literal as an arg to a non-ref parameter doesn't create any new vars to free - (calculate-lifetimes-internal {:ast arg-ast - :env env - :vars vars} - is-ref)) - new-arg-ast (:ast new-data) - new-vars (:vars new-data) - - ;;_ (println (str "\nnew-vars:\n" new-vars "\n")) - - new-vars-eaten-result (let [result-name (get-maybe new-arg-ast :result-name)] - (if (nil? result-name) - new-vars - (remove-var-with-name new-vars result-name))) - - ;;_ (println (str "\nnew-vars-eaten-result:\n" new-vars-eaten-result "\n")) - - ;;_ (println (str "new-arg-ast:\n" new-arg-ast)) - - new-ast (assoc-in ast (list :tail pos) new-arg-ast) - - ;;_ (println (str "pos " pos " AST: " ast " => " new-ast)) - - new-app-data {:ast new-ast - :vars new-vars-eaten-result - :env env - :pos (inc pos)}] - new-app-data))) - -(defn managed-ref-type? (t) - (match t - (:ref inner-t) (managed-type? inner-t) - _ false)) - -(defn calc-lifetime-for-let-binding (data binding-ast) - (do - (let [ast (:ast data) - vars (:vars data) - env (:env data) - pos (:pos data) - t (:type binding-ast) - - extended-vars (if (managed-type? t) - (cons {:name (str (:name binding-ast)) :type t :doc "let binding"} vars) - vars) - - new-env (if (and* (managed-ref-type? t) (= :ref (get-in binding-ast '(:value :node))) (= :lookup (get-in binding-ast '(:value :expr :node)))) - (assoc env (str (:name binding-ast)) (str (get-in binding-ast '(:value :expr :value)))) - env) - ;;_ (println (str "new-env: " new-env)) - - ;;_ (println (str "\nextended-vars: " extended-vars)) - - new-data (calculate-lifetimes-internal {:ast (:value binding-ast) :env env :vars extended-vars} false) - new-binding-ast (assoc binding-ast :value (:ast new-data)) - new-vars (:vars new-data) - - ;;_ (println (str "\nnew-vars:\n" new-vars)) - - new-vars-after-handover (let [result-name (get-maybe (:value binding-ast) :result-name)] - (if (nil? result-name) - new-vars - (remove-var-with-name new-vars result-name))) - - ;;_ (println (str "\nnew-vars-after-handover:\n" new-vars-after-handover)) - - new-ast (assoc-in ast (list :bindings pos) new-binding-ast) - ;;_ (println (str "pos " pos " AST: " ast "\n => \n" new-ast)) - - new-app-data {:ast new-ast - :vars new-vars-after-handover - :env new-env - :pos (inc pos)}] - new-app-data))) - -(defn calc-lifetime-for-do-form (data form-ast) - (do - (let [ast (:ast data) - vars (:vars data) - pos (:pos data) - env (:env data) - eaten (get-maybe data :eaten) - - data-after-visited-form (calculate-lifetimes-internal {:ast form-ast - :vars vars - :env env - :eaten eaten} false) - - vars-after-visited-form (:vars data-after-visited-form) - form-ast-after-visited-form (:ast data-after-visited-form) - - new-ast (assoc-in ast (list :forms pos) form-ast-after-visited-form) - new-eaten (get-maybe data-after-visited-form :eaten) - - new-app-data {:ast new-ast - :vars vars-after-visited-form - :pos (inc pos) - :env env - :eaten new-eaten}] - new-app-data))) - -(defn calc-lifetime-for-array (data form-ast) - (do - (let [ast (:ast data) - vars (:vars data) - pos (:pos data) - env (:env data) - eaten (get-maybe data :eaten) - - data-after-visited-form (calculate-lifetimes-internal {:ast form-ast - :vars vars - :env env - :eaten eaten} false) - - vars-after-visited-form (:vars data-after-visited-form) - vars-after-visited-form-removed-result (if-let [result-name (get-maybe form-ast :result-name)] - (remove-var-with-name vars-after-visited-form result-name) - vars-after-visited-form) - - form-ast-after-visited-form (:ast data-after-visited-form) - - new-ast (assoc-in ast (list :values pos) form-ast-after-visited-form) - new-eaten (get-maybe data-after-visited-form :eaten) - - new-app-data {:ast new-ast - :vars vars-after-visited-form-removed-result - :pos (inc pos) - :env env - :eaten new-eaten}] - new-app-data))) - -(defn calculate-lifetimes-internal (data in-ref) - (do - ;;(println (str "CALC: " (:node (:ast data)))) - (let [ast (:ast data) - env (:env data) - vars (:vars data)] - (match (:node ast) - - :function (let [;;_ (println (str "\nfunction vars-before: " vars)) - - parameter-nodes (:args ast) - new-variables (filter manage? (map convert-param-node parameter-nodes)) - - ;;_ (println (str "\nfunction new-variables: " new-variables)) - - pre-body (:body ast) - ;;_ (println (str "\npre-body:\n" pre-body)) - - data-after (calculate-lifetimes-internal {:ast pre-body :env env :vars new-variables} in-ref) - vars-after (:vars data-after) - - ;;_ (println (str "\nfunction vars-after:\n" vars-after "\n")) - - vars-with-return-value-removed (dont-free-result-variable (:body ast) vars-after) - new-body (:ast data-after) - - ;;_ (println (str "\nnew-body:\n" new-body)) - ;;_ (println (str "\nast before:\n" ast)) - ast-after (assoc ast :body new-body) - ;;_ (println (str "\nast after:\n" ast-after)) - ast-final (assoc ast-after :free vars-with-return-value-removed) - ;;_ (println (str "\nast final:\n" ast-final)) - ] - {:ast ast-final - :env env - :vars '()}) - - :literal (let [vars-after (if (managed-type? (:type ast)) - (cons {:name (:result-name ast) :type (:type ast) :doc "literal"} vars) - vars) - ;;_ (println (str "vars-after literal " (:value ast) ": " vars-after)) - ] - {:ast ast - :env env - :vars vars-after}) - - :ref (let [data-after (calculate-lifetimes-internal {:ast (:expr ast) :env env :vars vars} true)] - {:ast (assoc ast :expr (:ast data-after)) - :env (:env data-after) - :vars (:vars data-after)}) - - :lookup (let [;;_ (println (str "\nin-ref: " in-ref ", lookup: \n" ast "\nvars: \n" vars "\nenv:\n" env)) - sym (:value ast) - var-name (str sym) - t (:type ast) - ref-lookup (get-maybe env var-name) - ;;_ (println (str "ref-lookup: " ref-lookup)) - is-ref-lookup (not (nil? ref-lookup)) - ;;_ (println (str "is-ref-lookup: " is-ref-lookup)) - derefed-var-name (if is-ref-lookup - ref-lookup - var-name) - ;;_ (println (str "derefed-var-name: " derefed-var-name)) - given-away (= 0 (count (filter (fn (v) (= derefed-var-name (:name v))) vars)))] - - (if (and* (or* is-ref-lookup (managed-type? t)) given-away) - (if (:global-lookup ast) - data - (error {:error error-given-away - :show-stacktrace false - :message (str "Error at line " (:line ast) " in function ???" ", " - "the variable '" var-name "' has already been given away to another function.")})) - (let [vars-after (if in-ref - vars - (remove-var-with-name vars var-name)) - ;; _ (when (not (= vars vars-after)) - ;; (do (println (str "\nLookup ate '" (:value ast) "':\n" ast)) - ;; ;;(println (str "Vars before:\n" vars "\nVars after:\n" (:value ast) ": " vars-after)) - ;; )) - final-data {:ast ast - :vars vars-after - :env env - :eaten (list var-name)} - ;;_ (println (str "final-ast:\n" final-ast)) - ] - final-data))) - - :binop (let [left (calculate-lifetimes-internal {:ast (:left ast) :env env :vars vars} in-ref) - vars-after-left (:vars left) - right (calculate-lifetimes-internal {:ast (:right ast) :env env :vars vars-after-left} in-ref) - vars-after-right (:vars right) - ast0 (assoc ast :left (:ast left)) - ast1 (assoc ast0 :right (:ast right))] - {:ast ast1 - :env env - :vars vars-after-right}) - - :app (let [;;_ (println (str "APP VARS BEFORE\n" vars)) - tail (:tail ast) - init-data (assoc data :pos 0) - parameter-types (get-in ast '(:head :type 1)) - data-after (reduce (fn (d a) (calc-lifetime-for-arg d parameter-types a)) init-data tail) - vars-after (:vars data-after) - ret-type (get-in ast '(:head :type 2)) - vars-after-with-ret-val (if (managed-type? ret-type) - (cons {:name (:result-name ast) :type ret-type :doc "app ret val"} vars-after) - vars-after) - ast-after (:ast data-after)] - (do - ;;(println (str "APP VARS AFTER\n" vars-after)) - {:ast ast-after - :env env - :vars vars-after-with-ret-val})) - - :if (let [;;_ (println (str "if-ast:\n" ast)) - ;;_ (println (str "vars before if:\n" vars)) - - data-after-expr (calculate-lifetimes-internal {:ast (:expr ast) :env env :vars vars} in-ref) - - vars-after-expr (:vars data-after-expr) - ;;_ (println (str "\nvars-after-expr:\n" vars-after-expr)) - - data-after-left (calculate-lifetimes-internal {:ast (:if-true ast) :env env :vars vars-after-expr} in-ref) - data-after-right (calculate-lifetimes-internal {:ast (:if-false ast) :env env :vars vars-after-expr} in-ref) - ;;_ (println (str "data-after-left:\n" data-after-left "\ndata-after-right:\n" data-after-right)) - - vars-after-left (let [result-name (get-maybe (:if-true ast) :result-name) - vs (:vars data-after-left)] - (if (nil? result-name) - vs - (remove-var-with-name vs result-name))) - - vars-after-right (let [result-name (get-maybe (:if-false ast) :result-name) - vs (:vars data-after-right)] - (if (nil? result-name) - vs - (remove-var-with-name vs result-name))) - - ;;_ (println (str "\nvars-after-left:\n" vars-after-left "\nvars-after-right:\n" vars-after-right)) - - new-vars-left (remove (fn (v) (contains? vars-after-expr v)) vars-after-left) ;; the NEW vars after visiting this branch - new-vars-right (remove (fn (v) (contains? vars-after-expr v)) vars-after-right) - - ;;_ (println (str "new-vars-left:\n" new-vars-left "\nnew-vars-right:\n" new-vars-right)) - - all-vars (union vars-after-left vars-after-right) - ;;_ (println (str "\nall-vars:\n" all-vars)) - - eaten-in-either-branch (filter (fn (v) (or (not (contains? vars-after-left v)) - (not (contains? vars-after-right v)))) - all-vars) - ;;_ (println (str "\neaten-in-either-branch:\n" eaten-in-either-branch)) - - free-left (intersection eaten-in-either-branch vars-after-left) - free-right (intersection eaten-in-either-branch vars-after-right) - ;;_ (println (str "\nfree-left:\n" free-left "\nfree-right:\n" free-right)) - - all-freed (union free-left free-right) - ;;_ (println (str "\nall-freed:\n" all-freed)) - - vars-after-all (intersection (remove (fn (v) (contains? all-freed v)) vars-after-expr) (union vars-after-left vars-after-right)) - ;;_ (println (str "\nvars-after-all:\n" vars-after-all)) - - if-ret-type (:type ast) - vars-after-all-with-ret-val (if (managed-type? if-ret-type) - (cons {:name (:result-name ast) :type if-ret-type :doc "if ret val"} vars-after-all) - vars-after-all) - - eaten-left (get-maybe data-after-left :eaten) - eaten-right (get-maybe data-after-right :eaten) - ;;_ (println (str "eaten-left:\n" eaten-left "\neaten-right:\n" eaten-right)) - eaten (union eaten-left eaten-right) - ;;_ (println (str "\neaten:\n" eaten)) - - ast-after-expr (assoc ast :expr (:ast data-after-expr)) - ast0 (assoc ast-after-expr :if-true (:ast data-after-left)) - ast1 (assoc ast0 :if-false (:ast data-after-right)) - ast2 (assoc ast1 :free-left free-left) - ast3 (assoc ast2 :free-right free-right) - - ast-after-all ast3 - - ;;_ (println (str "vars-after-all-with-ret-val:\n" vars-after-all-with-ret-val)) - - ] - {:ast ast-after-all - :vars vars-after-all-with-ret-val - :env env - :eaten eaten}) - - :let (let [ - ;;_ (println (str "\nlet vars before " (get-maybe ast :result-name) ":\n" vars)) - - init-data (assoc data :pos 0) - data-after-bindings (reduce calc-lifetime-for-let-binding init-data (:bindings ast)) - ;;_ (println (str "data-after-bindings:\n" data-after-bindings)) - - vars-after-bindings (:vars data-after-bindings) - ast-after-bindings (:ast data-after-bindings) - env-after-bindings (:env data-after-bindings) - - ;;_ (println (str "env-after-bindings:\n" env-after-bindings)) - - not-eaten-by-bindings (filter (fn (v) (contains? vars-after-bindings v)) vars) - eaten-by-bindings (map :name (remove (fn (v) (contains? not-eaten-by-bindings v)) vars)) - ;;_ (println (str "\nLET eaten by bindings in " (get-maybe ast :result-name) ":\n" eaten-by-bindings)) - - ;;_ (println (str "\nlet vars-after-bindings (before body):\n" vars-after-bindings)) - ;; _ (println (str "ast-after-bindings:\n" ast-after-bindings)) - - ;;_ (println (str "\nLET will visit body of " (get-maybe ast :result-name) ", Current vars:\n" vars-after-bindings)) - - data-after-body (calculate-lifetimes-internal {:ast (:body ast-after-bindings) - :env env-after-bindings - :vars vars-after-bindings} - in-ref) - - vars-after-body (:vars data-after-body) - ;;_ (println (str "\nLET back from visiting body of " (get-maybe ast :result-name) ", Current vars:\n" vars-after-body)) - - ast-after-body (assoc ast-after-bindings :body (:ast data-after-body)) - - ;;_ (println (str "\nlet vars-after-body:\n" vars-after-body)) - ;; _ (println (str "ast-after-bindings:\n" ast-after-bindings)) - ;; _ (println (str "ast-after-body:\n" ast-after-body)) - - ;;_ (println (str "\ndata-after-body:\n" data-after-body)) - - eaten (get-maybe data-after-body :eaten) - vars-after-body-minus-eaten (if (nil? eaten) - vars-after-body - (do - ;;(println (str "Will eat:\n" eaten)) - (remove (fn (v) (contains? eaten (:name v))) vars-after-body))) - - ;;_ (println (str "\nlet vars minus eaten " (get-maybe ast :result-name) ", Current vars:\n" vars-after-body-minus-eaten)) - - ;; only remove the variables that were not already there before entering let form: - vars-after-body-and-return-1 (remove (fn (v) (contains? vars v)) vars-after-body-minus-eaten) - ;;_ (println (str "\nlet vars-after-body-and-return-1:\n" vars-after-body-and-return-1)) - - vars-after-body-and-return-2 (let [result-name (get-maybe (:body ast-after-body) :result-name)] - (if (nil? result-name) - vars-after-body-and-return-1 - (remove-var-with-name vars-after-body-and-return-1 result-name))) - ;;_ (println (str "\nlet vars-after-body-and-return-2:\n" vars-after-body-and-return-2)) - - final-ast (assoc ast-after-body :free vars-after-body-and-return-2) - - original-vars-still-alive (intersection vars vars-after-body) - - final-vars (let [ast-type (:type ast)] - (if (managed-type? ast-type) - (cons {:name (:result-name ast) :type ast-type :doc "let ret val"} original-vars-still-alive) - original-vars-still-alive)) - - ;;_ (println (str "\nlet final-vars:\n" final-vars)) - - ;;_ (println (str "\nlet eaten-by-bindings: " eaten-by-bindings)) - ] - {:ast final-ast - :vars final-vars - :env env-after-bindings - :eaten eaten-by-bindings}) - - :reset (let [data-after-expr (calculate-lifetimes-internal {:ast (:expr ast) :env env :vars vars} in-ref) - ;;_ (println (str "data-after-expr:\n" data-after-expr)) - ast-after-expr (assoc ast :expr (:ast data-after-expr)) - env-after-expr (:env data-after-expr) - vars-after-expr (:vars data-after-expr) - - ;;_ (println (str "ast:" ast-after-expr)) - - final-vars (let [result-name (get-maybe (:expr ast-after-expr) :result-name)] - (if (nil? result-name) - vars-after-expr - (remove-var-with-name vars-after-expr result-name))) - ] - {:ast ast-after-expr - :env env-after-expr - :vars final-vars}) - - :while (let [data-after-expr (calculate-lifetimes-internal {:ast (:expr ast) :env env :vars vars} in-ref) - ;;_ (println (str "data-after-expr:\n" data-after-expr)) - - vars-after-expr (:vars data-after-expr) - ast-after-expr (assoc ast :expr (:ast data-after-expr)) - - data-after-body (calculate-lifetimes-internal {:ast (:body ast-after-expr) :env env :vars vars-after-expr} in-ref) - ;;_ (println (str "data-after-body:\n" data-after-body)) - ast-after-body (:ast data-after-body) - vars-after-body (:vars data-after-body) - - ;; Visit the body a second time, to "simulate" the loop: - second-result (calculate-lifetimes-internal {:ast ast-after-body - :env (:env data-after-body) - :vars vars-after-body} - in-ref) - ;;_ (println (str "second-result:\n" second-result)) - - new-ast-after-body (assoc ast-after-expr :body ast-after-body) - vars-after-body-and-return (remove (fn (v) (contains? vars v)) vars-after-body) - - final-ast (assoc new-ast-after-body :free vars-after-body-and-return) - final-vars vars ;; TODO: return value from while-form? - ] - {:ast final-ast - :env env - :vars final-vars}) - - :do (let [init-data (assoc data :pos 0) - data-after-forms (reduce calc-lifetime-for-do-form init-data (:forms ast)) - final-ast (:ast data-after-forms) - final-eaten (get-maybe data-after-forms :eaten) - ;;_ (println (str "do final-eaten: " final-eaten)) - vars-after-forms (:vars data-after-forms) - final-vars (let [result-name (get-maybe (last (:forms final-ast)) :result-name)] - (if (nil? result-name) - vars-after-forms - (remove-var-with-name vars-after-forms result-name))) - ] - {:ast final-ast - :vars final-vars - :env env - :eaten final-eaten}) - - :array (let [;;_ (println (str "vars before:\n" vars)) - ;;_ (println (str "values:\n" (:values ast))) - - init-data (assoc data :pos 0) - data-after-forms (reduce calc-lifetime-for-array init-data (:values ast)) - - ast-after-forms (:ast data-after-forms) - eaten-after-forms (get-maybe data-after-forms :eaten) - vars-after-forms (:vars data-after-forms) - - ;;_ (println (str "vars-after-forms:\n" vars-after-forms)) - ;;_ (println (str "eaten-after-forms: " eaten-after-forms)) - - vars-after-array-expr (cons {:name (:result-name ast) - :type (:type ast) - :doc "array ret val"} - vars-after-forms) - - ;;_ (println (str "final vars:\n" vars-after-array-expr)) - ] - {:ast ast-after-forms - :vars vars-after-array-expr - :env env - :eaten eaten-after-forms - }) - - _ data)))) - -(defn calculate-lifetimes (ast) - (:ast (calculate-lifetimes-internal {:ast ast - :env {} - :vars '()} - false))) - diff --git a/lisp/cc.carp b/lisp/cc.carp deleted file mode 100644 index 76bdc57ab..000000000 --- a/lisp/cc.carp +++ /dev/null @@ -1,100 +0,0 @@ -;; C-compiler things - -(def out-dir (str carp-dir "out/")) -(def exe-out-dir "./") -(def exe-name "exe") - -(def profile-external-compiler-time false) -(def total-external-compile-time 0.0f) - -(def platform-specifics - (if (windows?) - {:dylib-extension ".dll" - :link-extension ".lib" - :include-flag "/I" - :linkdir-flag "/link /NOLOGO /LIBPATH:"} - {:dylib-extension ".so" - :link-extension ".so" - :include-flag "-I" - :linkdir-flag "-L"})) - -(defn link-libs (dependencies) - (join " " (map (fn (f) (str out-dir (c-ify-name (str f)) (:link-extension platform-specifics))) dependencies))) - -(defn include-paths () - (str (:include-flag platform-specifics) "/usr/local/include " (:include-flag platform-specifics) carp-dir "/shared")) - -(defn lib-paths () - (cond - (windows?) "" - (osx?) (str (:linkdir-flag platform-specifics) "/usr/local/lib/ -lglfw3") - (linux?) (str (:linkdir-flag platform-specifics) "/usr/local/lib/ -lglfw -lm -pthread -ldl"))) - -(defn framework-paths () - (if (or (windows?) (linux?)) - "" - "-framework OpenGL -framework Cocoa -framework IOKit")) - -(defn print-external-compiler-time [start-time func-name] - (let [t (/ (itof (- (now) start-time)) 1000f)] - (do - (println (str (get-console-color console-color-yellow) - "External compilation of '" func-name "' took " - t " seconds." - (get-normal-console-color))) - (reset! total-external-compile-time (+ total-external-compile-time t))))) - -(defn run-compiler [c-func-name c-file-name total-dependencies exe] - (let [start-time (now)] - (do - (if (windows?) - (run-cl c-func-name c-file-name total-dependencies exe) - (run-clang c-func-name c-file-name total-dependencies exe)) - (when profile-external-compiler-time - (print-external-compiler-time start-time c-func-name))))) - -(defn run-clang [c-func-name c-file-name total-dependencies exe] - (let [clang-command (str "clang -g -DAPI= " - (if exe - (str "-o " exe-out-dir exe-name " ") - (str "-shared -fPIC -D_GNU_SOURCE -g -o " out-dir c-func-name ".so ")) - c-file-name " " - (include-paths) " " - (lib-paths) " " - (framework-paths) " " - (link-libs total-dependencies))] - (do - (def cmd clang-command) - (system clang-command)))) - -(defn run-cl [c-func-name c-file-name total-dependencies exe] - (let [common-options "/nologo /DWIN32 /Od /Zi /MDd /Fe" - cl-command (str "cl.exe " - (if exe - (str common-options out-dir c-func-name ".exe ") - (str "/DAPI=__declspec(dllexport) /LDd " common-options out-dir c-func-name ".dll ")) - c-file-name " " - (include-paths) " " - (lib-paths) " " - (framework-paths) " " - (link-libs total-dependencies))] - (do - ;;(println cl-command) - (def cmd cl-command) - (system cl-command)))) - -(defn clean-build-artifacts () - (if (windows?) - (do - (system "del declarations.h") - (system "del *.dll") - (system "del *.exp") - (system "del *.lib") - (system "del *.pdb") - (system "del *.ilk") - (system "del *.obj")) - (do - (system "rm declarations.h") - (system "rm *.so") - (system "rm *.c") - (system "rm -r *.dSYM")))) diff --git a/lisp/compiler.carp b/lisp/compiler.carp deleted file mode 100644 index 5fbadd131..000000000 --- a/lisp/compiler.carp +++ /dev/null @@ -1,189 +0,0 @@ -(load-lisp (str carp-dir "lisp/error_codes.carp")) -(load-lisp (str carp-dir "lisp/compiler_helpers.carp")) -(load-lisp (str carp-dir "lisp/ast.carp")) -(load-lisp (str carp-dir "lisp/infer_types.carp")) -(load-lisp (str carp-dir "lisp/generate_names.carp")) -(load-lisp (str carp-dir "lisp/calculate_lifetimes.carp")) -(load-lisp (str carp-dir "lisp/builder.carp")) -(load-lisp (str carp-dir "lisp/func_deps.carp")) -(load-lisp (str carp-dir "lisp/generics.carp")) -(load-lisp (str carp-dir "lisp/structs.carp")) -(load-lisp (str carp-dir "lisp/globals.carp")) -(load-lisp (str carp-dir "lisp/cc.carp")) -(load-lisp (str carp-dir "lisp/annotate.carp")) -(load-lisp (str carp-dir "lisp/graph.carp")) -(load-lisp (str carp-dir "lisp/concretize.carp")) -(load-lisp (str carp-dir "lisp/sicp_solver.carp")) - -(def header-files (list "\"declarations.h\"" "\"shared.h\"")) -(def echo-signature-after-bake false) - -(defmacro bake (func-symbol) - (list 'compiler/bake-function-and-its-dependers (str func-symbol))) - -(defn compiler/bake-function-and-its-dependers [func-name] - (if (foreign? (eval (symbol func-name))) - :already-baked - (let [dependers (graph/dependers func-name)] - (do - ;;(println (str "Compiler is baking '" func-name "' and its users: " (join ", " dependers))) - (graph/unload func-name) - (map graph/unload dependers) ;; ALL the functions must be unloaded before calling try-bake on them in the next step - (map compiler/try-bake dependers) - (compiler/try-bake func-name))))) - -(def log-ignores false) - -^doc "If it's a lambda this will either bake it or mark it as generic. If it's not a lambda it will be ignored." -(defn compiler/try-bake [symbol-name] - (let [evaled (eval (symbol symbol-name))] - (cond - (lambda? evaled) (compiler/bake-code symbol-name (code evaled) (meta-get evaled :ann)) - (foreign? evaled) (do (when log-ignores (println (str "compiler/try-bake will ignore foreign function '" symbol-name "'"))) - :ignored) - (ptr-to-global? evaled) (do (when log-ignores (println (str "compiler/try-bake will ignore ptr-to-global '" symbol-name "'"))) - :ignored) - (primop? evaled) (error (str "Trying to bake primop: " evaled)) - :else (bake-global symbol-name '())))) - -^doc "Compile a generic lambda to a specific, fully typed version by providing a signature with the types needed." -(defn compiler/concretize [original-func-name generic-func-name func-code func-signature] - (let [annotated-ast (func-to-annotated-ast generic-func-name func-code func-signature nil) - extra-deps (list original-func-name)] - (if (generic-function? annotated-ast) - (error (str "Failed to concretize generic function " generic-func-name ":\n" annotated-ast)) - (do - (compiler/bake-ast generic-func-name annotated-ast func-code) - (graph/update-node! generic-func-name :depends-on - (cons original-func-name (get-maybe (get graph generic-func-name) :depends-on))))))) - -^doc "Will convert an s-expression to an ast and then compile it in the same way as 'bake-ast'." -(defn compiler/bake-code [func-name func-code func-type-annotation] - (let [annotated-ast (func-to-annotated-ast func-name func-code nil func-type-annotation)] - (if (generic-function? annotated-ast) - (mark-lambda-as-generic func-name annotated-ast) - (compiler/bake-ast func-name annotated-ast func-code)))) - -(def log-deps-when-baking-ast false) - -(defn remove-non-user-defined-deps [deps] - (let [names (keys graph)] - (filter (fn (dep) (if (string? dep) - (contains? names dep) - (error (str "dep must be string: " dep)))) - deps))) - -^doc "Will look into the 'graph' and find what actual dylib the function is compiled into." -(defn deps-by-group [deps] - (map (fn [dep] - (if-let [node (get-maybe graph dep)] - (:group node) - dep)) - deps)) - -^doc "Will find all the dependencies of the ast and compile it to a dylib using 'compiler/bake-group'." -(defn compiler/bake-ast [func-name ast-annotated original-code] - (let [build-result (builder-visit-ast (new-builder) ast-annotated func-name) - builder-deps (:deps build-result) ;; dependencies on destructors found during the builder phase - c-program-string (builder-merge-to-c (:builder build-result)) - proto (get-function-prototype ast-annotated func-name) - c-func-name (c-ify-name func-name) - c-file-name (str out-dir c-func-name ".c") - all-deps (remove-non-user-defined-deps (set (concat (:func-deps ast-annotated) builder-deps))) - final-deps (deps-by-group all-deps) - func-signature (get ast-annotated :type)] - (do - (when log-deps-when-baking-ast - (do - (println (str "\n- '" func-name "' -")) - (println (str "Func deps from ast: " (join ", " (:func-deps ast-annotated)))) - (println (str "Builder deps: " (join ", " builder-deps))) - ;;(println (str "Extra deps: " (join ", " all-deps))) - (println (str "All deps (after pruning): " (join ", " all-deps))) - (println (str "Final deps (by group): " (join ", " final-deps))) - (println ""))) - (def c c-program-string) - (compiler/bake-group func-name - (list {:name func-name - :proto proto - :src c-program-string - :sig func-signature}) - final-deps) - (meta-set! (eval (symbol func-name)) :code original-code)))) - -^doc "" -(defn compiler/bake-src [func-name proto src func-signature deps] - (compiler/bake-group func-name - (list {:name func-name - :proto proto - :src src - :sig func-signature}) - deps)) - -(defn kind-of-node [code-node] - (match (:sig code-node) - (:fn _ _) :function - t :global)) - -^doc "A 'group' is one unit of compilation, like a .so or .dll file. - The 'code-node':s sent to this function are dictionaries describing - all the functions that go into the same group. - They must contain the keys :name :proto :src :sig" -(defn compiler/bake-group [group-name code-nodes deps] - (let [src (with-declarations-header (join "\n\n" (map (fn [d] (:src d)) code-nodes))) - c-file-name (c-ify-name (str out-dir group-name ".c")) - dylib-full-path (c-ify-name (str out-dir group-name (:dylib-extension platform-specifics)))] - (do - ;;(println (str "Compiling group '" group-name "'.")) - (def src src) - (map (fn [code-node] - (graph/add-node! (kind-of-node code-node) (:name code-node) (:proto code-node) (:src code-node) group-name nil deps 0)) - code-nodes) - (graph/save-prototypes!) - (save c-file-name src) - (run-compiler (c-ify-name group-name) c-file-name deps false) - (def out-lib (load-dylib dylib-full-path)) - (map (fn [code-node] - (let [name (:name code-node) - c-name (c-ify-name name)] - (do - (match (:sig code-node) - (:fn arg-types return-type) (register out-lib c-name arg-types return-type) - t (register-variable out-lib c-name t)) - (graph/update-node! name :dylib-ptr out-lib) - (when echo-signature-after-bake (println (str name " : " (pretty-signature (:sig code-node)))))))) - code-nodes) - :OK))) - -(defn with-declarations-header [s] (str "#include \"declarations.h\"\n\n" s)) - -(defn complete-main-src [starting-function-name] - (str "#include \"declarations.h\"\n\n" - (join "\n\n" (values graph-src)) - "\n\n" - "int main() {\n" - (call-init-closures) "\n" - " " (c-ify-name starting-function-name) "();\n" - "}\n")) - -(defn call-init-closures [] - (join "\n" (map (fn [node] - (str " " (c-ify-name (:name node)) "();")) - (filter is-init-closure? (values graph))))) - -(defn is-init-closure? [node] - (key-is-true? node :is-init-closure)) - -(defn bake-exe-internal [starting-function-name] - (do - (compiler/bake-function-and-its-dependers starting-function-name) - (let [src (complete-main-src starting-function-name) - c-file-name (str out-dir "main.c") - no-dependencies ()] - (do - (def mainc src) - (save c-file-name src) - (run-compiler "-whatever-" c-file-name no-dependencies true))))) - -(defmacro bake-exe [starting-function-symbol] - (list 'bake-exe-internal (str starting-function-symbol))) diff --git a/lisp/compiler_helpers.carp b/lisp/compiler_helpers.carp deleted file mode 100644 index e263cf868..000000000 --- a/lisp/compiler_helpers.carp +++ /dev/null @@ -1,74 +0,0 @@ -(defn pretty-signature [t] - (match t - (:fn args ret) (str "(" (join ", " (map pretty-signature args)) ") -> " (pretty-signature ret)) - (:ref r) (str "&" (pretty-signature r) "") - (:Array a) (str "Array " (pretty-signature a)) - x (if (list? x) - (join " " (map pretty-signature x)) - (if (keyword? t) - (name t) - (if (string? t) - t - (error (str "Can't prettify type signature: " t))))))) - -(defn generic-type? [t] - (match (type t) - :string true - :keyword false - :list (any? true? (map generic-type? t)) - x (error (str "Invalid type in 'generic-type?': " (prn x))))) - -(defn generic-function? [ast] - (match (:type ast) - (:fn arg-types ret-type) (or (any? generic-type? arg-types) (generic-type? ret-type)) - x (error (str "Can't match " x " in generic-function?")))) - -(defn c-ify-name [lisp-name] - (let [x0 (str-replace lisp-name "-" "_") - x1 (str-replace x0 "?" "QMARK") - x2 (str-replace x1 "!" "BANG") - x3 (str-replace x2 "*" "PTR") - x4 (str-replace x3 "<" "LT") - x5 (str-replace x4 ">" "GT") - x6 (str-replace x5 "=" "EQ")] - x6)) - -(defn type-build [t] - (type-build-internal t true)) - -(defn type-build-no-star [t] - (type-build-internal t false)) - -(defn type-build-internal [t star] - (if (string? t) - ;;(error (str "Can't build type from unresolved typevar '" t "'")) - "typevar" - (match t - :? "unknown" - (:fn _ _) (ensure-function-type t) - (:ref r) (type-build-internal r star) - ;;(:Array a) (str "Array" (if star "*" "")) ;; TODO: case not needed - :float "float" - :double "double" - :int "int" - :char "char" - :bool "bool" - :string "string" - :void "void" - x (if (list? x) - (do - (when (= :Array (first x)) - (ensure-array-type x)) - (str (type-build-internal (first x) false) "LT" (join "_" (map (fn [inner-t] (type-build-internal inner-t false)) (rest x))) "GT" (if star "*" ""))) - (str (c-ify-name (name x)) (if star "*" "")))))) - -(defn ensure-array-type [t] - (graph/add-node! :array-type - (generic-safe-name t) - (str "typedef Array " (c-ify-name (generic-safe-name t)) ";") - "" ;; no body - "" ;; group - nil ;; dylib ptr - () ;; (struct-groups-in-type t) ;; deps - (calculate-dependency-level t) ;; (log (str func-type-name " dep lvl: ") - )) diff --git a/lisp/compiler_tests.carp b/lisp/compiler_tests.carp deleted file mode 100644 index 4d1125990..000000000 --- a/lisp/compiler_tests.carp +++ /dev/null @@ -1,20 +0,0 @@ -;;(println "Running compiler tests now...") - -;; (reset! profile-infer-time true) -;; (reset! profile-external-compiler-time true) - -(load-lisp (str carp-dir "lisp/test_arrays.carp")) -(load-lisp (str carp-dir "lisp/test_structs.carp")) -(load-lisp (str carp-dir "lisp/test_globals.carp")) -(load-lisp (str carp-dir "lisp/test_binops.carp")) -(load-lisp (str carp-dir "lisp/test_constraints.carp")) -(load-lisp (str carp-dir "lisp/test_ownership.carp")) -(load-lisp (str carp-dir "lisp/test_equality.carp")) -(load-lisp (str carp-dir "lisp/test_printing.carp")) -(load-lisp (str carp-dir "lisp/test_baking.carp")) -(load-lisp (str carp-dir "lisp/test_generics.carp")) -(load-lisp (str carp-dir "lisp/test_correctness.carp")) - -;; These tests are for manual inspections: -(load-lisp (str carp-dir "lisp/test_stack_trace.carp")) -(load-lisp (str carp-dir "lisp/test_line_numbers.carp")) diff --git a/lisp/concretize.carp b/lisp/concretize.carp deleted file mode 100644 index 8e3e502e7..000000000 --- a/lisp/concretize.carp +++ /dev/null @@ -1,598 +0,0 @@ -;; The easy version of bake-generic-primop, used to ensure that a certain instance of a generic function exists -;; For example, to ensure that 'nth' (a primop) exists for float arrays, call this function like this: -;; (bake-generic-primop-auto "nth" '(:fn ((:ref (:Array :float)) :int) :float)) -;; This will generate the function nth--RefTo-ArrayOf-float-int-float of type (&Array float, int) -> float -(defn bake-generic-primop-auto [primop-name signature] - (let [func-name (generic-name (symbol primop-name) signature)] - (bake-generic-primop func-name primop-name signature))) - -;; Used by the visit-generic-func algorithm to generate and register baked version of generic primops -(defn bake-generic-primop [func-name primop-name signature] - (let [c-func-name (c-ify-name func-name) - c-file-name (str out-dir c-func-name ".c")] - (if (graph/node-exists? func-name) - (do - ;;(println (str "Ignoring already baked generic primop: " func-name)) - nil) - (let [result (build-generic-primop c-func-name primop-name signature) - c-program-string (:c result) - proto (str (:proto result) ";") - deps (:deps result) - ] - (do - (def c c-program-string) - ;;(println (str "Baking generic primop " func-name)) - ;; (println (str "Prototype for " func-name ":\n" proto)) - ;; (println (str "C-code for " func-name ":\n" c-program-string)) - (compiler/bake-src func-name proto c-program-string signature deps)))))) - -(defn build-generic-primop [c-func-name primop-name signature] - (match primop-name - - "" (match signature - (:fn () ) - (let [proto (str) - c (str)] - {:proto proto :c c :deps ()}) - _ (error "Invalid type for call to ''")) - - "map" (match signature - (:fn ((:fn (a) a) (:Array a)) (:Array a)) (let [proto (str "API " (type-build (list :Array a)) " " c-func-name "(" (type-build (list :fn (list a) a)) " f, Array *array)") - c (str proto - "{ \n" - " int count = array->count;\n" - " " (type-build a) "* casted = array->data;\n" - " for(int i = 0; i < count; i++) {\n" - " casted[i] = f(casted[i]);\n" - " }\n" - " array->data = casted;" - " return array;\n" - "}")] - {:proto proto :c c :deps ()}) - x (error (str "Invalid type for call to 'map': " x))) - - ;; TODO: can this be a normal function now? - "map-copy" (match signature - (:fn ((:fn (a) b) (:ref (:Array a))) (:Array b)) (let [proto (str "API " (type-build (list :Array b)) " " c-func-name "(" (type-build (list :fn (list a) b)) " f, Array *array)") - array-of-size-sig (list :fn (list :int) (list :Array b)) - _ (bake-generic-primop-auto "array-of-size" array-of-size-sig) - array-of-size-call (generic-name "array-of-size" array-of-size-sig) - ;;_ (println array-of-size-call) - c (str proto - "{ \n" - " int count = array->count;\n" - " " (type-build a) "* casted = array->data;\n" - " Array* new_array = " (c-ify-name array-of-size-call) "(count);\n" - " " (type-build b) "* new_casted = new_array->data;\n" - " for(int i = 0; i < count; i++) {\n" - " new_casted[i] = f(casted[i]);\n" - " }\n" - ;;" free(array);\n" - " return new_array;\n" - "}")] - {:proto proto :c c :deps (list array-of-size-call)}) - x (error (str "Invalid type for call to 'map-copy': " x))) - - "str" (do - ;;(println (str "Calling str for signature: " signature)) - (match signature - - (:fn ((:ref :Array)) :string) (error "Can't instantiate 'str' for :Array with no type variable.") - - (:fn ((:ref (:Array t))) :string) (instantiate-str-or-prn-for-array c-func-name t) - - (:fn ((:ref :int)) :string) (build-generic-primop c-func-name "str" '(:fn (:int) :string)) - (:fn (:int) :string) (let [proto (str "API string " c-func-name "(int x)") - c (str proto " { return itos(x); }")] - {:proto proto :c c :deps ()}) - - (:fn ((:ref :char)) :string) (build-generic-primop c-func-name "str" '(:fn (:char) :string)) - (:fn (:char) :string) (let [proto (str "API string " c-func-name "(char x)") - c (str proto " { string s = malloc(2); s[0] = x; s[1] = '\\0'; return s; }")] - {:proto proto :c c :deps ()}) - - (:fn ((:ref :bool)) :string) (build-generic-primop c-func-name "str" '(:fn (:bool) :string)) - (:fn (:bool) :string) (let [proto (str "API string " c-func-name "(bool b)") - c (str proto " { if(b) { return strdup(\"true\"); } else { return strdup(\"false\"); } }")] - {:proto proto :c c :deps ()}) - - (:fn ((:ref :float)) :string) (build-generic-primop c-func-name "str" '(:fn (:float) :string)) - (:fn (:float) :string) (let [proto (str "API string " c-func-name "(float x)") - c (str proto " { " - " char output[50];" - " snprintf(output, 50, \"%ff\", x);" - " return strdup(output);" - "}")] - {:proto proto :c c :deps ()}) - - (:fn ((:ref :double)) :string) (build-generic-primop c-func-name "str" '(:fn (:double) :string)) - (:fn (:double) :string) (let [proto (str "API string " c-func-name "(double x)") - c (str proto " { " - " char output[50];" - " snprintf(output, 50, \"%f\", x);" - " return strdup(output);" - "}")] - {:proto proto :c c :deps ()}) - - (:fn ((:ref :string)) :string) (instantiate-str-for-string c-func-name) - - (:fn ((:ref maybe-struct-type)) :string) (instantiate-str-or-prn-for-struct - c-func-name - (fix-generic-struct-name maybe-struct-type) - (printable-name-from-struct-type maybe-struct-type)) - - x (error {:error error-invalid-arg-type-to-generic - :show-stacktrace false - :message (str "Invalid (non-ref?) type for call to 'str': " x)}))) - - "prn" (do - ;;(println (str "Calling prn for signature: " signature)) - (match signature - - (:fn ((:ref :Array)) :string) (error "Can't instantiate 'prn' for :Array with no type variable.") - - (:fn ((:ref (:Array t))) :string) (instantiate-str-or-prn-for-array c-func-name t) - - (:fn ((:ref :int)) :string) (build-generic-primop c-func-name "str" '(:fn (:int) :string)) - (:fn (:int) :string) (build-generic-primop c-func-name "str" '(:fn (:int) :string)) - - (:fn ((:ref :char)) :string) (build-generic-primop c-func-name "prn" '(:fn (:char) :string)) - (:fn (:char) :string) (let [proto (str "API string " c-func-name "(char x)") - c (str proto " { string s = malloc(3); s[0] = '\\\\'; s[1] = x; s[2] = '\\0'; return s; }")] - {:proto proto :c c :deps ()}) - - (:fn ((:ref :bool)) :string) (build-generic-primop c-func-name "str" '(:fn (:bool) :string)) - (:fn (:bool) :string) (build-generic-primop c-func-name "str" '(:fn (:bool) :string)) - - (:fn ((:ref :float)) :string) (build-generic-primop c-func-name "str" '(:fn (:float) :string)) - (:fn (:float) :string) (build-generic-primop c-func-name "str" '(:fn (:float) :string)) - - (:fn ((:ref :double)) :string) (build-generic-primop c-func-name "str" '(:fn (:double) :string)) - (:fn (:double) :string) (build-generic-primop c-func-name "str" '(:fn (:double) :string)) - - (:fn ((:ref :string)) :string) (instantiate-prn-for-string c-func-name) - - (:fn ((:ref maybe-struct-type)) :string) (instantiate-str-or-prn-for-struct - c-func-name - (fix-generic-struct-name maybe-struct-type) - (printable-name-from-struct-type maybe-struct-type)) - - x (error {:error error-invalid-arg-type-to-generic - :show-stacktrace false - :message (str "Invalid (non-ref?) type for call to 'prn': " x)}))) - - "delete" (do - (match signature - (:fn ((:Array t)) :void) (instantiate-delete-for-array c-func-name t) - (:fn (:string) :void) (instantiate-delete-for-string c-func-name) - (:fn (maybe-struct-type) :void) (instantiate-delete-for-struct c-func-name (fix-generic-struct-name maybe-struct-type)) - x (error (str "Invalid type for call to 'delete': " x)))) - - "error" (match signature - (:fn ((:ref :string)) :int) (instantiate-error c-func-name :int) - (:fn ((:ref :string)) t) (instantiate-error c-func-name t)) - - "copy" (do - (match signature - (:fn ((:ref :float)) :float) (instantiate-copy-for-primitive-type c-func-name :float) ;; These are no-ops - (:fn ((:ref :double)) :double) (instantiate-copy-for-primitive-type c-func-name :double) - (:fn ((:ref :bool)) :bool) (instantiate-copy-for-primitive-type c-func-name :bool) - (:fn ((:ref :int)) :int) (instantiate-copy-for-primitive-type c-func-name :int) - (:fn ((:ref :char)) :char) (instantiate-copy-for-primitive-type c-func-name :char) - (:fn ((:ref (:Array t))) t) (instantiate-copy-for-array c-func-name t) - (:fn ((:ref :string)) :string) (instantiate-copy-for-string c-func-name) - ;;(:fn (:string) :string) (instantiate-copy-for-string c-func-name) - (:fn ((:ref maybe-struct-type)) maybe-struct-type) (instantiate-copy-for-struct c-func-name (fix-generic-struct-name maybe-struct-type)) - x (error (str "Invalid type for call to 'copy': " x)))) - - "nth" (match signature - (:fn ((:ref (:Array t)) :int) (:ref t)) - (let [proto (str "API " (type-build t) " " c-func-name "(Array *a, int index)") - c (str proto - " {\n" - "if(index < 0 || index >= a->count) { printf(\"Array index out of bounds: %d\\n\", index); raise(SIGSEGV); }\n" - "return ((" (type-build t) "*)(a->data))[index];\n" - "}\n")] - {:proto proto :c c :deps ()}) - _ (error "Invalid type for call to 'nth'")) - - "count" (match signature - (:fn ((:ref (:Array t))) :int) - (let [proto (str "API int " c-func-name "(Array *a)") - c (str proto " { return a->count; }")] - {:proto proto :c c :deps ()}) - _ (error "Invalid type for call to 'count'")) - - "array-of-size" (match signature - (:fn (:int) (:Array t)) - (let [proto (str "API " (type-build (list :Array t)) " " c-func-name "(int count)") - c (str proto - "{ Array *a = malloc(sizeof(Array));" - " a->count = count;" - " a->data = calloc(count, sizeof(" (type-build t) "));" - " return a;" - " }")] - {:proto proto :c c :deps ()}) - x (error (str "Invalid type for call to 'array-of-size': " x))) - - "reduce" (match signature - ;;(:fn ((:fn (a b) a) a (:ref (:Array b))) a) - (:fn ((:fn (a b) a) a (:ref (:Array b))) a) - (let [proto (str "API " (type-build a) " " c-func-name "(" (type-build (list :fn (list a b) a)) " f, " (type-build a) " a, " (type-build (list :Array b))" bs)") - c (str proto - " {\n" - " " (type-build b) " *casted = bs->data;\n" - " " (type-build a) " result = a;\n" - " for(int i = 0; i < bs->count; i++) {\n" - " result = f(result, casted[i]);\n" - " }\n" - " return result;\n" - "}\n")] - {:proto proto :c c :deps ()}) - x (error (str "Invalid type for call to 'reduce': " x))) - - "array-set" (match signature - (:fn ((:Array t) :int t) (:Array t)) - (let [proto (str "API " (type-build (list :Array t)) " " c-func-name "(Array *a, int index, " (type-build t) " value)") - c (str proto " { ((" (type-build t) "*)(a->data))[index] = value; return a; }")] - {:proto proto :c c :deps ()}) - _ (error "Invalid type for call to 'array-set'")) - - "=" (match signature - (:fn (:int :int) :bool) (instantiate-eq-for-primitive-type c-func-name :int) - (:fn (:bool :bool) :bool) (instantiate-eq-for-primitive-type c-func-name :bool) - (:fn (:char :char) :bool) (instantiate-eq-for-primitive-type c-func-name :char) - - (:fn ((:ref :int) (:ref :int)) :bool) (instantiate-eq-for-primitive-type c-func-name :int) - (:fn ((:ref :bool) (:ref :bool)) :bool) (instantiate-eq-for-primitive-type c-func-name :bool) - (:fn ((:ref :char) (:ref :char)) :bool) (instantiate-eq-for-primitive-type c-func-name :char) - - ;; float and double can't be compared using '=' - - (:fn ((:ref :string) (:ref :string)) :bool) (instantiate-eq-for-string c-func-name) - (:fn ((:ref (:Array a)) (:ref (:Array a))) :bool) (instantiate-eq-for-array c-func-name a) - (:fn ((:ref maybe-struct-type) (:ref maybe-struct-type)) :bool) (instantiate-eq-for-struct c-func-name maybe-struct-type) - _ (error (str "Invalid signature for call to '=': " (pretty-signature signature)))) - - x (error (str "Can't build generic primop for '" x "'")))) - -(defn instantiate-error [c-func-name t] - (let [proto (str "API " (type-build t) " " c-func-name "(string msg)") - c (str proto " { printf(\"ERROR: %s\\n\", msg); raise(SIGSEGV);" - (match t - :int "return 0;" - :float "return 0.0f;" - :double "return 0.0;" - :bool "return false;" - :char "return '0';" - :string "return \"\";" - :void "" - _ "NULL") - " }")] - {:proto proto :c c :deps ()})) - -(defn instantiate-eq-for-primitive-type [c-func-name t] - (let [proto (str "API bool " c-func-name "(" (type-build t) " a, " (type-build t) " b)") - c (str proto " { return ((a) == (b)); }\n")] - {:proto proto :c c :deps ()})) - -(defn instantiate-eq-for-string [c-func-name] - (let [proto (str "API bool " c-func-name "(string a, string b)") - c (str proto " { return strcmp(a, b) == 0; }\n")] - {:proto proto :c c :deps ()})) - -(defn instantiate-eq-for-array [c-func-name inner-t] - (let [proto (str "API bool " c-func-name "(Array *a, Array *b)") - - inner-arg-type (list :ref inner-t) ;; (if (primitive-type? inner-t) inner-t (list :ref inner-t)) - inner-signature (list :fn (list inner-arg-type inner-arg-type) :bool) - inner-eq-call (c-ify-name (generic-name (symbol "=") inner-signature)) - _ (bake-generic-primop-auto "=" inner-signature) - - c (str proto " " - "{\n" - " if(a->count != b->count) { return false; }\n" - " " (type-build inner-t) " *casted_a = a->data;\n" - " " (type-build inner-t) " *casted_b = b->data;\n" - " for(int i = 0; i < a->count; i++) {\n" - " if(!" inner-eq-call "(casted_a[i], casted_b[i])) { return false; }\n" - " }\n" - " return true;\n" - "}\n")] - {:proto proto :c c :deps (list inner-eq-call)})) - -(defn instantiate-eq-for-struct [c-func-name maybe-struct-type] - (if (keyword? maybe-struct-type) - (let [_ (when (or (= :string maybe-struct-type) - (primitive-type? maybe-struct-type)) - (error (str "Primitive type sent to '=' instantiator for struct types, but it is not a struct type: " maybe-struct-type))) - lookup (eval (symbol (name maybe-struct-type)))] - (if (and* (dict? lookup) (= true (get-maybe lookup :struct))) - (let [t-name (name maybe-struct-type) - proto (str "API bool " c-func-name "(" t-name " *a, " t-name " *b)") - member-names (array-to-list (:member-names lookup)) - member-types (array-to-list (:member-types lookup)) - reffed-member-types (map (fn [mt] (list :ref mt)) member-types) ;;(map (fn [mt] (ref-or-no-ref mt)) member-types) - deps (cons t-name (map (fn [t] (c-ify-name (generic-name "=" (list :fn (list t t) :bool)))) reffed-member-types)) - ;;_ (println (str c-func-name " deps: " deps)) - c (str proto " {\n" - "if(a == b) { return true; }\n" - " " - (join " " (map2 (fn [t n] - (do - ;;(println (str "t: " t)) - (let [inner-signature (list :fn (list t t) :bool) - _ (bake-generic-primop-auto "=" inner-signature) - inner-name (c-ify-name (generic-name "=" inner-signature)) - cn (c-ify-name n)] - (str "if(!" inner-name "(a->" cn ", b->" cn ")) { return false; }\n")))) - reffed-member-types - member-names)) - " return true;\n" - "}\n")] - {:proto proto - :c c - :deps deps}) - (error (str "Invalid (non-struct) type for call to '=': " maybe-struct-type "\n" lookup)))) - (error (str "Invalid type for call to '=': " maybe-struct-type)))) - -(defn instantiate-str-for-string [c-func-name] - (let [proto (str "API string " c-func-name "(string s)") - c (str proto "{ return strdup(s); }\n")] - {:proto proto - :c c - :deps ()})) - -(defn instantiate-prn-for-string [c-func-name] - (let [proto (str "API string " c-func-name "(string s)") - c (str proto " {\n" - ;;" printf(\"calling str on string '%s'\\n\", s);\n" - " int len = strlen(s);\n" - " int new_len = len + 4;\n" - " char *new_s = malloc(sizeof(char) * new_len);\n" - " new_s[0] = '@';\n" - " new_s[1] = '\"';\n" - " memcpy(new_s + 2, s, len); " - " new_s[new_len - 2] = '\"';\n" - " new_s[new_len - 1] = '\\0';\n" - " return new_s;\n" - "}\n")] - {:proto proto :c c :deps ()})) - -(defn ref-or-no-ref [t] - (if (primitive-type? t) - t - (list :ref t))) - -(defn instantiate-str-or-prn-for-struct [c-func-name maybe-struct-type printable-name] - (if (keyword? maybe-struct-type) - (let [_ (when (or (= :string maybe-struct-type) - (primitive-type? maybe-struct-type)) - (error (str "Primitive type sent to 'str' instantiator for struct types, but it is not a struct type: " maybe-struct-type))) - lookup (eval (symbol (name maybe-struct-type)))] - (if (and* (dict? lookup) (= true (get-maybe lookup :struct))) - (let [t-name (name maybe-struct-type) - proto (str "API string " c-func-name "(" (c-ify-name t-name) " *x)") - member-names (array-to-list (:member-names lookup)) - member-types (array-to-list (:member-types lookup)) - reffed-member-types (map (fn [mt] (ref-or-no-ref mt)) member-types) - ;;_ (println (str "reffed-member-types: " reffed-member-types)) - deps (cons t-name (map (fn [t] (c-ify-name (generic-name "prn" (list :fn (list t) :string)))) reffed-member-types)) - ;;_ (println (str "deps: " deps)) - c (str proto " {\n" - " char buffer[1024];\n" - " int pos = 0;\n" - " buffer[pos++] = '(';\n" - " snprintf(buffer + pos, 1000, \"%s\", \"" printable-name "\");" - " pos += " (strlen printable-name) ";" - " buffer[pos++] = ' ';\n" - " char *s;" - (join " " (map2 (fn [t n] - (do - ;;(println (str "t: " t)) - (bake-generic-primop-auto "prn" (list :fn (list t) :string)) - (str " - s = " (c-ify-name (generic-name "prn" (list :fn (list t) :string))) "(x->" (c-ify-name n) "); - snprintf(buffer + pos, 1000, \"%s\", s); - pos += strlen(s); - buffer[pos++] = ' ';"))) - reffed-member-types - member-names)) - " \n" - " pos--;\n" - " buffer[pos++] = ')';\n" - " buffer[pos++] = '\\0';\n" - " return strdup(buffer);\n" - ;;"return \"" t-name "\"; " - "}\n")] - {:proto proto - :c c - :deps deps}) - (error (str "Invalid (non-struct) type for call to 'str': " maybe-struct-type "\n" lookup)))) - (error (str "Invalid type for call to 'str': " maybe-struct-type)))) - -(defn instantiate-str-or-prn-for-array [c-func-name t] - (let [proto (str "API string " c-func-name "(Array *a)") - ;; Call str without ref for primitive types, otherwise use ref - inner-arg-type (if (primitive-type? t) t (list :ref t)) - inner-signature (list :fn (list inner-arg-type) :string) - inner-prn-call (c-ify-name (generic-name (symbol "prn") inner-signature)) - _ (bake-generic-primop-auto "prn" inner-signature) - ;;_ (println (str "inner-prn-call: " inner-prn-call)) - c (str proto - "{\n" - " char buffer[1024];\n" - " int pos = 0;\n" - " int count = a->count;\n" - " buffer[pos++] = '[';\n" - " " (type-build t) " *casted_data = a->data;\n" - " for(int i = 0; i < count; i++) {\n" - ;;" printf(\"%d \", casted_data[i]);\n" - " char *inner_str = " inner-prn-call "(casted_data[i]);\n" - " snprintf(buffer + pos, 1024 - pos - 1,\"%s\", inner_str);\n" - " pos += strlen(inner_str);\n" - " if(i < count - 1) {\n" - ;;" buffer[pos++] = ',';\n" - " buffer[pos++] = ' ';\n" - " }\n" - " free(inner_str);\n" - " }\n" - " buffer[pos++] = ']';\n" - " buffer[pos++] = '\\0';\n" - " return strdup(buffer);\n" - "}")] - {:proto proto :c c :deps (list inner-prn-call)})) - -(defn instantiate-copy-for-string [c-func-name] - (let [;;_ (println (str "instantiate " c-func-name)) - proto (str "API string " c-func-name "(string s)") - c (str proto " { return strdup(s); }")] - {:proto proto :c c :deps ()})) - -(defn instantiate-copy-for-primitive-type [c-func-name t] - (let [proto (str "API " (type-build t) " " c-func-name "(" (type-build t)" x)") - c (str proto " { return x; }")] - {:proto proto :c c :deps ()})) - -(defn instantiate-copy-for-struct [c-func-name maybe-struct-type] - (do - ;;(println (str "instantiate-copy-for-struct: " c-func-name " of type " maybe-struct-type)) - (if (keyword? maybe-struct-type) - (let [_ (when (or (= :string maybe-struct-type) - (primitive-type? maybe-struct-type)) - (error (str "Primitive type sent to 'copy' instantiator for struct types, but it is not a struct type: " maybe-struct-type))) - lookup (eval (symbol (name maybe-struct-type)))] - (if (and* (dict? lookup) (= true (get-maybe lookup :struct))) - (let [t-name (name maybe-struct-type) - proto (str (c-ify-name t-name) " *" c-func-name "(" (c-ify-name t-name) " *x)") - ;;_ (println (str "proto for struct copying function: " proto)) - member-names (array-to-list (:member-names lookup)) - member-types (array-to-list (:member-types lookup)) - c (str proto " { \n" - " " (type-build maybe-struct-type) " x_copy = calloc(1, sizeof(" (c-ify-name t-name) "));\n" - (join " " (map2 (fn [t n] - (if (primitive-type? t) - (str " x_copy->" (c-ify-name n) " = x->" (c-ify-name n) ";\n") - (let [inner-copy-sig (list :fn (list (list :ref t)) t) - copy-function-c-name (c-ify-name (generic-name "copy" inner-copy-sig))] - (do - (bake-generic-primop-auto "copy" inner-copy-sig) - (str "x_copy->" (c-ify-name n) " = " copy-function-c-name "(x->" (c-ify-name n) ");\n"))))) - member-types - member-names)) - " return x_copy;\n" - "}\n")] - {:proto proto - :c c - :deps (cons t-name - (map (fn [t] (c-ify-name (generic-name "copy" (list :fn (list (list :ref t)) t)))) - (remove primitive-type? member-types)))}) - (error (str "Invalid (non-struct) type for call to 'copy': " maybe-struct-type "\n" lookup)))) - (error (str "Invalid type for call to 'copy': " maybe-struct-type))))) - -(defn instantiate-copy-for-array [c-func-name array-type] - (let [proto (str "API Array *" c-func-name "(Array *a)") - ;; Call str without ref for primitive types, otherwise use ref - t (second array-type) - inner-arg-type (if (primitive-type? t) t (list :ref t)) - inner-signature (list :fn (list (list :ref t)) t) - inner-copy-call (if (primitive-type? t) - "" - (c-ify-name (generic-name "copy" inner-signature))) - ;;_ (println (str "inner-copy-call: " inner-copy-call)) - _ (when (not (primitive-type? t)) - (bake-generic-primop-auto "copy" inner-signature)) - c (str proto - "{ \n" - " Array *a_copy = malloc(sizeof(Array));\n" - " a_copy->count = a->count;\n" - " a_copy->data = calloc(a->count, sizeof(" (type-build inner-arg-type) "));\n" - " int count = a_copy->count;\n" - " " (type-build t) " *casted_data = a->data;\n" - " " (type-build t) " *casted_data_copy = a_copy->data;\n" - " for(int i = 0; i < count; ++i) {\n" - (if (primitive-type? t) - " casted_data_copy[i] = casted_data[i];\n" - (str " casted_data_copy[i] = " inner-copy-call "(casted_data[i]);\n")) - " }\n" - " return a_copy; \n" - "}\n")] - {:proto proto - :c c - :deps (if (primitive-type? t) - '() - (list inner-copy-call))})) - -(defn instantiate-delete-for-string [c-func-name] - (let [proto (str "API void " c-func-name "(string s)") - c (str proto " { free(s); }")] - {:proto proto :c c :deps ()})) - -(defn instantiate-delete-for-struct [c-func-name maybe-struct-type] - (if (keyword? maybe-struct-type) - (let [_ (when (or* (= :void maybe-struct-type) - (= :string maybe-struct-type) - (primitive-type? maybe-struct-type)) - (error (str "Primitive type sent to 'delete' instantiator for struct types, but it is not a struct type: " maybe-struct-type))) - lookup (eval (symbol (name maybe-struct-type)))] - (if (and* (dict? lookup) (= true (get-maybe lookup :struct))) - (let [t-name (name maybe-struct-type) - proto (str "API void " c-func-name "(" (c-ify-name t-name) " *x)") - ;;_ (println (str "proto for struct delete function: " proto)) - member-names (array-to-list (:member-names lookup)) - member-types (array-to-list (:member-types lookup)) - c (str proto " {\n" - (join "" (map2 (fn [t n] - (if (managed-type? t) - (let [inner-delete-sig (list :fn (list t) :void) - delete-function-c-name (str "delete__" (c-ify-name (generic-safe-name t)) "_void")] - (do - (bake-generic-primop-auto "delete" inner-delete-sig) - (str " " delete-function-c-name "(x->" (c-ify-name n) ");\n"))) - (str " /* no need to delete " t " member '" n "' */\n"))) - member-types - member-names)) - " free(x);\n" - "}\n")] - {:proto proto - :c c - :deps (cons t-name (map (fn [t] (str "delete__" (c-ify-name (generic-safe-name t)) "_void")) (filter managed-type? member-types)))}) - (error (str "Invalid (non-struct) type for call to 'str': " maybe-struct-type "\n" lookup)))) - (error (str "Invalid type for call to 'str': " maybe-struct-type)))) - -(defn instantiate-delete-for-array [c-func-name t] - (let [proto (str "API void " c-func-name "(Array *a)") - inner-signature (list :fn (list t) :void) - inner-delete-call (c-ify-name (generic-name "delete" inner-signature)) - ;;_ (println (str "inner-delete-call: " inner-delete-call)) - _ (when (not (primitive-type? t)) - (bake-generic-primop-auto "delete" inner-signature)) - c (str proto - "{ \n" - (if (primitive-type? t) - "/* no inner pointers to delete */\n" - (str - " int count = a->count;\n" - " " (type-build t) " *casted_data = a->data;\n" - " for(int i = 0; i < count; ++i) {\n" - (str " " inner-delete-call "(casted_data[i]);\n") - " }\n" - )) - " free(a->data);\n" - " free(a); \n" - "}\n")] - {:proto proto - :c c - :deps (if (primitive-type? t) - '() - (list inner-delete-call))})) - -(defn fix-generic-struct-name [t] - (if (list? t) - (keyword (generic-safe-name t)) - t)) - -(defn printable-name-from-struct-type [t] - (match t - (base-t ... rest-t) (name base-t) - x (name x))) diff --git a/lisp/core.carp b/lisp/core.carp deleted file mode 100644 index 98fc0ff67..000000000 --- a/lisp/core.carp +++ /dev/null @@ -1,414 +0,0 @@ - -(defmacro assert (x) - (list 'assert-eq true x)) - -(defn assert-approx-eq (target x) - (do - (assert-eq true (< x (+ target 0.1f))) - (assert-eq true (< (- target 0.1f) x)))) - -(defn id (x) x) - -^doc "Returns true if the key exists on the dictionary AND it is set to true." -(defn key-is-true? [dict key] - (if (nil? dict) - false - (let [x (get-maybe dict key)] - (if (nil? x) - false - x)))) - -(defn get-in (dict keys) - (if (= () keys) - dict - (get-in (get dict (first keys)) (rest keys)))) - -(defn dict-set-in! (dict keys value) - (if (= 1 (count keys)) - (dict-set! dict (first keys) value) - (dict-set-in! (get dict (first keys)) (rest keys) value))) - -(defn update-in! (dict key-path f) - (dict-set-in! dict key-path (f (get-in dict key-path)))) - -(defn update-in (dict key-path f) - (let [new (copy dict)] - (do (update-in! new key-path f) - new))) - -(defn assoc (dict key val) - (let [new (copy dict)] - (do - (dict-set! new key val) - new))) - -(defn assoc-in (dict keys val) - (let [new (copy dict)] - (do - (dict-set-in! new keys val) - new))) - -(defn replicate (thing times) - (if (< times 1) - '() - (cons thing (replicate thing (- times 1))))) - -(defn repeatedly (f times) - (if (< times 1) - '() - (cons (f) (repeatedly f (- times 1))))) - -^doc "Replace all occurrences of `something` in a list with `replacement`" -(defn replace [the-list something replacement] - (match the-list - () () - (x ... xs) (if (= x something) - (cons replacement (replace xs something replacement)) - (cons x (replace xs something replacement))))) - -(def total-time 0) - -(defmacro time (form) - (list 'let (array 't1 (list 'now)) - (list 'let (array - 'result form - 't (list '- (list 'now) 't1)) - (list 'do - (list 'println (list 'str "Evaluating form " (str form) " took " 't "ms.")) - (list 'reset! 'total-time (list '+ 'total-time 't)) - 'result)))) - -(defmacro swap! (sym f) - (list 'reset! sym (list f sym))) - -(defn > [x y] - (and (not (= x y)) - (not (< x y)))) - -^doc "Returns true if item is within items" -(defn contains? (items item) - (match items - () false - (x ... xs) (if (= x item) - true - (contains? xs item)))) - -^doc "Returns true if the array xs contains the item x" -(defn array-contains? [xs x] - (let [result false] - (do (for (i 0 (count xs)) - (when (= (nth xs i) x) - (reset! result true))) - result))) - -(defn string-contains? [str char] - (array-contains? (chars str) char)) - -^doc "Returns true if (pred item) returns true for any item within xs" -(defn any? (pred xs) - ;; short circuit if any (pred item) is true - (let [cont true - res false] - (do - (while cont - (match xs - () (do - (reset! cont false)) - (x) (do - (reset! cont false) - (reset! res (pred x))) - (x ... rest) (if (pred x) - (do - (reset! cont false) - (reset! res true)) - (reset! xs rest)))) - res))) - -(defn true? (x) (if x true false)) -(defn false? (x) (if x false true)) - -(defn log (message value) - (do - (println (str message value)) - value)) - -(defn nil? (x) (= nil x)) -(defn not-nil? (x) (not (= nil x))) - -(defn int? (x) (= :int (type x))) -(defn float? (x) (= :float (type x))) -(defn double? (x) (= :double (type x))) -(defn string? (x) (= :string (type x))) -(defn symbol? (x) (= :symbol (type x))) -(defn keyword? (x) (= :keyword (type x))) -(defn env? (x) (= :env (type x))) -(def dict? env?) -(defn list? (x) (= :list (type x))) -(defn array? (x) (= :array (type x))) -(defn macro? (x) (= :macro (type x))) -(defn lambda? (x) (= :lambda (type x))) -(defn foreign? (x) (= :foreign (type x))) -(defn primop? (x) (= :primop (type x))) -(defn ptr? [x] (= :ptr (type x))) -(defn ptr-to-global? [x] (= :ptr-to-global (type x))) - -(defn function? (x) (or* (lambda? x) - (foreign? x) - (primop? x))) - -(defn range (start stop) - (if (< start stop) - (cons start (range (inc start) stop)) - '())) - -(defn range-f (start stop step) - (if (< start stop) - (cons start (range-f (+ start step) stop step)) - '())) - -^doc "Returns reversed list" -(defn reverse (l) - (match l - () () - (x) (list x) - (x ... xs) (cons-last (reverse xs) x))) - -^doc "Returns true if dictionary `dict` contains key `key`" -(defn has-key? (dict key) - (not (= () (get-maybe dict key)))) - -(defn even? (x) (= 0 (mod x 2))) -(defn odd? (x) (= 1 (mod x 2))) - -^doc "Returns last item in list" -(defn last (xs) - (match xs - () (error "Can't call last on empty list.") - (x) x - _ (last (rest xs)))) - -(defn mapcat (f xs) - (apply concat (map f xs))) - -(def load load-lisp) ;; alias to allow inferior-lisp-mode to load file - -(defn true? (x) (= true x)) -(defn false? (x) (= false x)) - -^doc "Returns true if `(pred item)` returns true for all items within xs" -(defn all? [pred xs] - ;; short circuit if any (pred item) is false - (let [cont true - res true] - (do - (while cont - (match xs - () (do - (reset! cont false)) - (x) (do - (reset! cont false) - (reset! res (pred x))) - (x ... rest) (if (not (pred x)) - (do - (reset! cont false) - (reset! res false)) - (do - (reset! xs rest) - (reset! res true))))) - res))) - -(defn remove (pred xs) - (filter (fn (x) (not (pred x))) xs)) - -(defn cons-unique (x xs) - (if (contains? xs x) - xs - (cons x xs))) - -(defn set-internal (xs ys) - (match xs - () ys - (x ... xs) (set-internal xs (cons-unique x ys)) - (x) (cons-unique x ys))) - -(defn set (xs) - (set-internal xs '())) - -(defn union (xs ys) - (let [both (concat xs ys)] - (set both))) - -(defn intersection (xs ys) - (match xs - () () - (x ... xs) (if (contains? ys x) - (cons x (intersection xs ys)) - (intersection xs ys)))) - -(defn sort-by [f xs] - (match xs - () () - (y ... ys) (concat (sort-by f (filter (fn [x] (f x y)) ys)) - (list y) - (sort-by f (filter (fn [x] (not (f x y))) ys))))) - -(defn sort [xs] - (sort-by < xs)) - -(defmacro for [b body] - (match b - (sym start limit) (list 'let (array sym start) - (list 'while (list '< sym limit) - (list 'do - body - (list 'reset! sym (list '+ sym 1))))) - _ (error "Failed to match bindings in for loop."))) - -(defn domap [f xs] - (for (i 0 (count xs)) - (f (nth xs i)))) - -(defmacro str-ref [x] - (list 'ref (list 'str x))) - -(defn second [xs] - (nth xs 1)) - -(defn third [xs] - (nth xs 1)) - -(defn doc [x] - (meta-get x :doc)) - -(defn thread-first-internal [start-value forms] - (match forms - () start-value - ((f ... args) ... xs) (concat (list f (thread-first-internal start-value xs)) args) - (x ... xs) (list x (thread-first-internal start-value xs)))) - -(defmacro -> [start-value ... forms] - (thread-first-internal start-value (reverse forms))) - -(defn thread-last-internal [start-value forms] - (match forms - () start-value - ((f ... args) ... xs) (concat (list f) args (list (thread-last-internal start-value xs))) - (x ... xs) (list x (thread-last-internal start-value xs)))) - -(defmacro ->> [start-value ... forms] - (thread-last-internal start-value (reverse forms))) - -(defmacro if-let [binding a b] - (match binding - [var-name expr] (list 'let (array var-name expr) - (list 'if (list 'nil? var-name) - b - a)) - x (error (str "Incorrect binding in if-let:" x)))) - -(defmacro when-let [binding a] - (match binding - [var-name expr] (list 'let (array var-name expr) - (list 'if (list 'nil? var-name) - nil - a)) - x (error (str "Incorrect binding in when-let:" x)))) - -(defn cond-internal [forms] - (match forms - () (list 'error "No condition was true in 'cond' macro.") - (expr body ... xs) (list 'if expr body (cond-internal xs)))) - -(defmacro cond [... forms] - (cond-internal forms)) - -(defn template [text substitutions] - (reduce (fn [t pair] (str-replace t (first pair) (str (second pair)))) - text - (map2 list (keys substitutions) (values substitutions)))) - -(defn shell-quote [arg] - (str - "'" ;; surround with quotes - (str-replace - (str-replace arg "\\" "\\\\") ;; replace backslashes - "'" "\\'") ;; replace single quotes - "'")) - -(defn ls () (system "ls")) -(defn pwd () (system "pwd")) -(defn user () (getenv "USER")) -(defn mkdir (dir-name) (system (str "mkdir " (shell-quote dir-name)))) -(defn touch (file-name) (system (str "touch " (shell-quote file-name)))) - -(register-builtin "platform" '() :int) - -(def platform-osx 0) -(def platform-windows 1) -(def platform-linux 2) -(def platform-unknown 100) - -(defn windows? [] - (= (platform) platform-windows)) - -(defn osx? [] - (= (platform) platform-osx)) - -(defn linux? [] - (= (platform) platform-linux)) - -(defmacro import (module-symbol) - (list 'import-internal (str module-symbol))) -;;`(import-internal (name ~module-symbol)) - -(defn import-internal [module-name] - (load-lisp (str carp-dir "lisp/" module-name ".carp"))) - -(def console-color-black 0) -(def console-color-red 1) -(def console-color-green 2) -(def console-color-yellow 3) -(def console-color-blue 4) -(def console-color-magenta 5) -(def console-color-cyan 6) -(def console-color-white 7) - -(def pi 3.14159265) -(def two-pi (* pi 2.0)) - -(defmacro eb [form] - (list 'eval-bytecode (list 'bytecode form))) - -(defn maximum [xs] - (match (count xs) - 0 (error "Can't find maximum value in empy list") - 1 (nth xs 0) - _ (reduce max (nth xs 0) xs))) - -(defn empty? [xs] - (= 0 (count xs))) - -(defn split-every-second [xs] - (match xs - () (list () ()) - (_) (error "split-every-second needs an even number of arguments") - (a b ... misc) (let [inside (split-every-second misc)] - (list (cons a (first inside)) - (cons b (second inside)))))) - -^doc "A shorter name for 'meta-get-all'" -(defn meta [x] - (meta-get-all x)) - -(defn str-internal [strings] - (let [s @""] - (do (for (i 0 (count strings)) - (reset! s (string-append &s (nth strings i)))) - s))) - -(defmacro str* [... strings] - (list 'str-internal (list 'ref (apply array (map (fn [s] (list 'str s)) strings))))) - -(defmacro println* [... forms] - (list 'println (list 'ref (list 'str-internal (list 'ref (apply array (map (fn [s] (list 'str s)) forms))))))) - diff --git a/lisp/core_macros.carp b/lisp/core_macros.carp deleted file mode 100644 index a7331b438..000000000 --- a/lisp/core_macros.carp +++ /dev/null @@ -1,141 +0,0 @@ -(def defmacro (macro (name args body) - (list 'do - (list 'def name (list 'macro args body)) - (list 'meta-set! name :name (str name))))) - -;; (if BYTECODE_EVAL -;; (do -;; (def write-match-case -;; (fn [pattern binder] -;; )) -;; (def match-internal -;; (fn [value exprs] -;; (if (= 0 (count exprs)) -;; '() -;; (if (= 1 (count exprs)) -;; (error (str "Uneven number of expressions in match: " value " " exprs)) -;; (write-match-case (nth exprs 0) (nth exprs 1)) -;; )))) -;; (defmacro match [value ... exprs] -;; (match-internal value exprs))) -;; nil) - -;; TODO: remove this hack when old interpreter is gone -(defmacro lets [a b c] - (list 'let (array a b) c)) - -(def let-internal - (fn [bindings body] - (match (count bindings) - 0 body - 1 (error "Uneven nr of forms in bindings.") - _ (list 'lets (nth bindings 0) (nth bindings 1) (let-internal (rest (rest bindings)) body))))) - -(defmacro let [bindings body] - (let-internal (array-to-list bindings) body)) - - -(defmacro when (expr a) (list 'if expr a nil)) -(defmacro if-not (expr a b) (list 'if (list 'not expr) a b)) -(defmacro comment (form) nil) - -(defmacro assert-eq (a b) - (list 'if-not (list '= a b) - (list 'error (list 'str "assert-eq fail:\n" (str a) " \n=>\n" a "\n\n - VS - \n\n" (str b) " \n=>\n" b)) - nil)) - -(defmacro assert-error (error-code form) - (list 'let (array 'result (list 'catch-error form)) - (list 'if (list 'nil? 'result) - (list 'error (list 'str "No error!\n" (str form) "\n=>\n" 'result)) - (list 'if-not (list '= error-code (list :error 'result)) - (list 'error (list 'str "assert-error failed, expected error code " error-code " but got " (list :error 'result))) - :OK)))) - -(defmacro defn (name args body) - (list 'do - (list 'def name (list 'fn args body)) - (list 'meta-set! name :line (meta-get name :line)) - (list 'meta-set! name :name (str name)) - (list 'meta-set! name :user-defined true))) - - -(defn letrec-internal [bindings body binders values] - (match (count bindings) - 0 (cons-last (cons 'do (map2 (fn [b v] (list 'reset! b v)) binders values)) body) - 1 (error "Uneven nr of forms in bindings.") - _ (list 'lets (nth bindings 0) :undefined (letrec-internal - (rest (rest bindings)) - body - (cons-last binders (nth bindings 0)) - (cons-last values (nth bindings 1)) - )))) - -(defmacro letrec [bindings body] - (letrec-internal (array-to-list bindings) body () ())) - -;;(def let letrec) - - -(defn quasiquote-internal [form] - (do - (error "QUASIQUOTE IS TEMPORARILY UNAVAILABLE") - (match form - ('dequote x) x - - ;; (x ... xs) (match x - ;; ('dequote-splicing inner-x) (concat (quasiquote-internal (eval inner-x)) (quasiquote-internal xs)) - ;; _ (cons (quasiquote-internal x) (quasiquote-internal xs))) - - x (if (list? x) - (cons 'list (map quasiquote-internal x)) - (list 'quote x)) - ))) - -(defmacro quasiquote (form) - (quasiquote-internal form)) - -;; (defn quasiquote-internal [form] -;; (do -;; (println (str "form: " form)) -;; (if (list? form) -;; (match form -;; ('dequote x) x -;; _ (map quasiquote-internal form)) -;; form))) - -;; (defn replace-dequotes [form] -;; (match form -;; () () -;; ('dequote x) x -;; (x ... xs) (cons (replace-dequotes x) (replace-dequotes xs)) -;; x x)) - -;; (defmacro quasiquote (form) -;; (list 'quote (map replace-dequotes form))) - - - -;; AND -(defmacro and [a b] (list 'if a b false)) - -(defn and-internal [forms] - (match forms - (a) a - (a b) (list 'and a b) - (a ... xs) (list 'and a (and-internal xs)))) - -(defmacro and* [... forms] - (and-internal forms)) - -;; OR -(defmacro or [a b] - (list 'if a true b)) - -(defn or-internal [forms] - (match forms - (a b) (list 'or a b) - (a ... xs) (list 'or a (or-internal xs)))) - -(defmacro or* [... forms] - (or-internal forms)) diff --git a/lisp/core_tests.carp b/lisp/core_tests.carp deleted file mode 100644 index 7ee210154..000000000 --- a/lisp/core_tests.carp +++ /dev/null @@ -1,413 +0,0 @@ -(tester/set-suite! "core") - -(deftest test-pipe-first - (assert-eq (list 7 8 9 10 11 12) - (-> 10 - (- 3) - (range 13)))) - -(deftest test-pipe-last - (assert-eq 20 - (->> [3 4 5 6] - (reduce (fn [a b] (+ a b)) 0) - (- 38)))) - -(deftest test-sort - (let [nums '(4 5 6 2 3 7 1)] - (do - (assert-eq '(1 2 3 4 5 6 7) (sort nums)) - (assert-eq '(7 6 5 4 3 2 1) (sort-by > nums))))) - -(deftest test-doubles - (let [x 3.0d - y 5.0d] - (assert (< 14.0d (* x y) 16.0d)))) - -;; TODO: Reactivate this test when transition to bytecode is complete! -;; (deftest test-bind-to-function-in-let -;; (assert-eq (catch-error (defn misbind [] -;; (let [(fn [] nil) 123] -;; :fail))) -;; "Must bind to symbol in 'let' form: (lets (fn [] nil) 123 :fail)" -;; ;;"Trying to bind to non-symbol in let form: (fn [] nil)" -;; )) - -(deftest test-template - (assert-eq "cAr123" (template "carp" {"a" "A" "p" 123}))) - -(deftest test-for-macro - (let [sum 0] - (do (for (i 0 5) - (reset! sum (+ sum i))) - (assert-eq 10 sum)))) - -(deftest test-catch-error - (do - (assert-eq nil (catch-error ((fn () "no error")))) - (assert-eq (catch-error ((fn () (error "error!")))) "error!"))) - -(deftest test-dict-eq - (do - (let [d1 {:x 10 :y 20} - d2 {:x 10} - d3 {:y 20 :x 10}] - (do - (assert-eq d1 d3) - (assert-eq false (= d1 d2)) - (assert-eq false (= d1 {})) - (assert-eq d3 (assoc d2 :y 20)) - (assert-eq false (= d1 (assoc d3 :z 30))))))) - -(deftest test-set - (do - (let [s1 (set '())] - (do - (assert-eq 0 (count s1)))) - - (let [s1 (set '(1 2 3 2 3 2 1 3 3 2))] - (do - (assert-eq 3 (count s1)) - (assert-eq true (contains? s1 1)) - (assert-eq true (contains? s1 2)) - (assert-eq true (contains? s1 3)))))) - -(deftest test-intersection - (do - (let [s1 '(1 2 3 4 5) - s2 '() - s3 '(5) - s4 '(10 20) - s5 '(6 2 7 3)] - (do - (assert-eq 0 (count (intersection s1 s2))) - - (assert-eq 1 (count (intersection s1 s3))) - (assert-eq true (contains? (intersection s1 s3) 5)) - - (assert-eq 0 (count (intersection s1 s4))) - - (assert-eq 2 (count (intersection s1 s5))) - (assert-eq true (contains? (intersection s1 s5) 2)) - (assert-eq true (contains? (intersection s1 s5) 3)) )))) - - -(deftest test-union - (do - (let [u1 (union '() '(5 5 5))] - (do - (assert-eq 1 (count u1)) - (assert-eq true (contains? u1 5)))) - - (let [u1 (union '(5 5 5) '())] - (do - (assert-eq 1 (count u1)) - (assert-eq true (contains? u1 5)))) - - (let [u1 (union '(1 3) '(2 2 3 2 3 3))] - (do - (assert-eq 3 (count u1)) - (assert-eq true (contains? u1 1)) - (assert-eq true (contains? u1 2)) - (assert-eq true (contains? u1 3)))))) - -(deftest test-negative-numbers - (do - (assert-eq (- 10) -10) - (assert-eq 123 (- 0 -123)))) - -(deftest test-str-replace - (do - (assert-eq "Erik" (str-replace "erik" "e" "E")))) - -(deftest test-all-predicate - (do - (assert-eq true (all? even? (list 2 4 6 8))) - (assert-eq false (all? even? (list 2 4 6 9))) - (assert-eq true (all? even? ())))) - -(deftest test-while-loop - (let [x 0 - s ""] - (do - (while (< x 10) - (do - (str-append! s (str x)) - (swap! x inc))) - (assert-eq "0123456789" s)))) - -(deftest test-mapcat - (assert-eq '(1 2 3 1 2 3 4 1 2 3 4 5) (mapcat (fn (x) (range 1 (inc x))) '(3 4 5)))) - -(deftest test-floats - (do - (let [x 3.5f - y 2.0f] - (do - (assert-eq false (< x y)) - (assert-eq true (< y x)) - (assert-approx-eq 5.5f (+ x y)) - (assert-approx-eq 7.0f (* x y)) - (assert-approx-eq 1.5f (- x y)) - (assert-approx-eq 1.75f (/ x y)) - )))) - -(deftest test-shadowing - (let [x 100 - shadow-fn (fn (x) - (do - (reset! x 42) - (assert-eq x 42)))] - (do - (shadow-fn 0) - (assert-eq 100 x)))) - -(deftest test-keyword-in-list-in-match - (assert-eq (match true - true '(:a :b (:c) :d)) - (list :a :b (list :c) :d))) - -(deftest test-varable-capture - (let [x 3 - capture (fn () - (fn (y) (* x y))) - captured (capture)] - (assert-eq (captured 4) 12))) - -(deftest test-cons-last - (assert-eq '(100 200 300 400 500) (cons-last '(100 200 300 400) 500))) - -(deftest test-match-2 - (assert-eq (match '(hej du) - ('blargh _) :error - ('hej _) :correct - _ :also-error) - :correct)) - -(deftest test-match-with-nil - (assert-eq (match '(1 2 3) - () :b - '(1 2 7) :c - '(1 2 3) :d - _ :e) - :d)) - -(deftest test-assoc - (let [m {:a 10}] - (do - (assert-eq 100 (get (assoc m :a 100) :a)) - (assert-eq 200 (get (assoc m :b 200) :b)) - (assert-eq 10 (get m :a))))) - -(deftest test-has-key - (do - (assert-eq true (has-key? {:a 10 :b 20} :a)) - (assert-eq true (has-key? {:a 10 :b 20} :b)) - (assert-eq false (has-key? {:a 10 :b 20} :c)))) - -(deftest test-keyword-lookup - (assert-eq 20 (:b {:a 10 :b 20 :c 30}))) - -(deftest test-range - (do - (assert-eq '(3 4 5 6) (range 3 7)) - (assert-eq () (range 20 10)))) - -(deftest test-assoc-in - (let [m2 {:a {:b 20}}] - (do - (assert-eq 200 (get-in (assoc-in m2 '(:a :b) 200) '(:a :b))) ; change local copy - (assert-eq 20 (get-in m2 '(:a :b)))))) ; unchanged) - -(deftest test-swap - (let [x 10] - (do - (swap! x inc) - (assert-eq 11 x)))) - -(deftest test-str-append - (let [greeting "hej"] - (do - (str-append! greeting "!") - (str-append! greeting "!") - (str-append! greeting "!") - (assert-eq "hej!!!" greeting)))) - -(deftest test-str-join - (do - (assert-eq "" (join "," '())) - (assert-eq "10" (join "," '(10))) - (assert-eq "10,20,30" (join "," '(10 20 30))))) - -(deftest test-apply-str - (assert-eq "erikisaksvedang" (apply str (list "erik" "isak" "svedang")))) - -(deftest test-contains - (do - (assert-eq true (contains? (list 10 20 30) 20)) - (assert-eq true (contains? '(30) 30)) - (assert-eq false (contains? (list 10 20 30) 50)) - (assert-eq false (contains? () 100)))) - -(deftest test-fib - (letrec [fib (fn (n) - (match n - 0 0 - 1 1 - 2 1 - x (+ (fib (- x 2)) (fib (- x 1)))))] - (assert-eq '(1 1 2 3 5 8 13 21 34) (map fib '(1 2 3 4 5 6 7 8 9))))) - -(deftest test-dictionary-mutation - (let [stuff {:a 100 :b 200 :c 300 123 102030 :d () :e (+ 2 3)} - gruff (list "hej" :boo 'nice) - tree {:a 10 :b {:a 20 :b 30} :c {:a 40 :b 50}}] - (do - (dict-set-in! tree '(:b :a) "hejsan") - (assert-eq (get-in tree '(:b :a)) "hejsan") - - (update-in! tree '(:c :a) (fn (x) (* x 1000))) - (assert-eq (get-in tree '(:c :a)) 40000) - - (let [tree-2 (update-in tree '(:c :a) (fn (x) (- x 1)))] - (do - (assert-eq (get-in tree '(:c :a)) 40000) - (assert-eq (get-in tree-2 '(:c :a)) 39999)))))) - -(deftest test-dictionary-copy - (let [a {:xxx 100} - b (copy a) - c a] - (do - (dict-set-in! a '(:xxx) 200) - (assert-eq 200 (get a :xxx)) - (assert-eq 100 (get b :xxx)) ; unchanged, because of copy - (assert-eq 200 (get c :xxx)) ; changed, just an alias - ))) - -(deftest test-dictionary-evaluation - ;; Evaluation of dictionaries should not modify the literal - (let [self-destruct ( fn (x) - {:x x} - (assert-eq (str (fn (x) {:x x})) (str self-destruct)) - (self-destruct 10))] - (assert-eq (str (fn (x) {:x x})) (str self-destruct)))) - -(deftest test-map - (assert-eq (map (fn (x) (* x x)) '(1 2 3 4 5)) - (list 1 4 9 16 25))) - -(deftest test-filter - (assert-eq (filter even? '(1 2 3 4 5 6)) - (list 2 4 6))) - -(deftest test-reduce - (assert-eq (reduce + 0 '(1 2 3 4 5)) - 15)) - -(deftest test-match - (do - (assert-eq 123 (match 123 x x)) - (assert-eq (match 20 - 10 :a - 20 :b - 30 :c) - :b) - (assert-eq (match 42 - a (+ a 10)) - 52) - (assert-eq (match '(1 2 3) - (a b c) (+ a b (* c c))) - 12) - (let [me (list "erik" 29) - me-2 (match me (name age) {:name name :age age})] - (assert-eq (get me-2 :age) 29)))) - -;; TODO: Create a not* macro for checking many at the same time?! -(deftest test-not - (do - (assert-eq true (not false)) - (assert-eq true (not (not true))) - ;; (assert-eq true (not false false false)) - ;; (assert-eq false (not false false true false)) - (assert-eq false (not true)) - (assert-eq false (not (not false))) - )) - -(deftest test-misc - (do - (assert-eq 10 (id 10)))) - -(deftest test-concat - (do - (assert-eq (concat '(1 2) '(3 4)) '(1 2 3 4)) - (assert-eq (concat '(1 ) '(2 3 4)) '(1 2 3 4)) - (assert-eq (concat '() '(1 2 3 4)) '(1 2 3 4)) - (assert-eq (concat '(1 2 3) '(4)) '(1 2 3 4)) - (assert-eq (concat '(1 2 3 4) '()) '(1 2 3 4)) - (assert-eq (concat '(1 2) '(3) '(4)) '(1 2 3 4)) - (assert-eq (concat '(1 2) () '(3) () '(4)) '(1 2 3 4)) - (assert-eq (concat '() '(1) () '(2) () '(3) () '(4) ()) '(1 2 3 4)) - (assert-eq (concat '() '()) '()) - (assert-eq (concat '() '() '()) '()))) - -(deftest test-reset - (let [temp "" - abc (fn (x) - (do - (reset! temp (str temp "Ole, ")) - (reset! temp (str temp "dole, ")) - (reset! temp (str temp "doff!")) - x))] - (do - (assert-eq "hej" (abc "hej")) - (assert-eq "Ole, dole, doff!" temp)))) - -;; THIS TEST DOESN'T WORK WITH BYTECODE, maybe re-enable when pretty printing of lambdas can be turned off dynamically -;; (deftest test-self-destruct-2 -;; ;; Doesn't work when pretty printing of lambda bodies is turned off -;; (do -;; (defn self-destruct-2 (x) -;; (list 1 2 x 4 5)) -;; (assert-eq "(fn (x) (list 1 2 x 4 5))" (str self-destruct-2)) -;; (self-destruct-2 10) -;; (assert-eq "(fn (x) (list 1 2 x 4 5))" (str self-destruct-2)) -;; ;;(reset! print-lambda-body before) -;; )) - -(deftest test-dict-set-in-array - (do - (let [xs '(1 2 3)] - (do (dict-set-in! xs '(1) "hejsan") - (assert-eq '(1 "hejsan" 3) xs))))) - -(deftest test-match-array - (assert-eq (match [3 4 5] - (x y z) :fail - [a b c] (* a (+ b c)) - _ :also-fail) - 27)) - -(deftest test-string-handling - (do - (assert (string-contains? "abc" \a)) - (assert (not (string-contains? "abc" \d))))) - -(deftest test-any? - (do - (defn is-a (x) (= \a x)) - (assert (any? is-a (cons \a (cons \b (cons \c nil))))) - (assert (not (any? is-a (cons \d (cons \b (cons \c nil)))))))) - -(deftest test-all? - (do - (defn is-a (x) (= \a x)) - (assert (all? is-a (list \a \a \a))) - (assert (not (all? is-a (list \a \a \a \b)))))) - -;; Can't test this inside a function: -(defn define-at-toplevel () - (def top-var :mountain-high)) -(define-at-toplevel) -(assert-eq :mountain-high top-var) - -(tester/run-suite "core") diff --git a/lisp/error_codes.carp b/lisp/error_codes.carp deleted file mode 100644 index d1b668254..000000000 --- a/lisp/error_codes.carp +++ /dev/null @@ -1,10 +0,0 @@ - -(def error-given-away 1) -(def error-test-failed 2) -(def error-binding-to-non-symbol 3) -(def error-failed-typechecking 4) -(def error-return-ref 5) -(def error-ref-in-array 6) -(def error-invalid-arg-type-to-generic 7) -(def error-struct-with-ref-members 8) - diff --git a/lisp/examples.carp b/lisp/examples.carp deleted file mode 100644 index bf71b308e..000000000 --- a/lisp/examples.carp +++ /dev/null @@ -1,75 +0,0 @@ - -(defn max (a b) - (if (< a b) b a)) - -(defn blah (x s) - (* x (strlen s))) - -(defn fiz (x) - (* 3.3 x)) - -(defn tiny () - (max (+ 2 3) (* 7 2))) - -(defn three (x) - (if (= x 3) - (println "Three!!!") - (println "Not three..."))) - -(defn say () - (do (println "A") - (println "B") - (println "C"))) - -(defn eternal () - (while true - (println "eternal"))) - -(defn slimmer (x s) - (+ x (* (strlen s) (- x 1)))) - -(defn say-hi (text) - (while true - (if (< (strlen text) 10) - (println "Too short!") - (println text)))) - -(defn a-while () - (while true - (println "what!"))) - -(defn say-what (text) - (let [manage-me (string-copy text)] - (if (< (strlen text) 10) - (string-copy "Too short") - manage-me))) - -(defn crash () - (error "bam!")) - -(defn crash-soon () - (crash)) - -(defn soon () - (crash-soon)) - - - -(defn repl () - (while true - (do (print "repl> ") - (let [in (get-input)] - (println (str (eval (read in)))))))) - -(def s ".") - -(defn loop () - (do - (async repl) - (while true - (do - (println s) - (sleep 1))))) - - -;; (call (fn () (println "CARP!!!"))) diff --git a/lisp/func_deps.carp b/lisp/func_deps.carp deleted file mode 100644 index c341f17cc..000000000 --- a/lisp/func_deps.carp +++ /dev/null @@ -1,110 +0,0 @@ -;; vars-in-scope is a list of symbols -;; deps is a list of strings refering to the functions that has to be baked for this function to work - -(defn global? [vars-in-scope symbol] - (not (contains? vars-in-scope symbol))) - -(defn find-func-deps [ast bake-deps] - (letrec [deps (copy '()) - - _ (when (not (dict? ast)) (error (str "ast is not a dict: " ast))) - _ (when (not (= :function (get-maybe ast :node))) (error (str "ast is not a function ast node: " ast))) - - func-name (let [n (get-maybe ast :name)] (if (nil? n) "" n)) - - find-deps-in-list (fn [asts vars-in-scope] - (reduce (fn [result a] (cons-last result (find-func-deps-internal a vars-in-scope))) '() asts)) - - find-deps-in-bindings (fn [bindings vars-in-scope] - (reduce (fn [result binding] (cons-last result (update-in binding '(:value) (fn [bv] (find-func-deps-internal bv vars-in-scope))))) '() bindings)) - - find-func-deps-internal (fn [ast vars-in-scope] - (do ;;(println (str "visit: " (:node ast))) - (match (:node ast) - - :lookup (let [symbol (:value ast) - symbol-name (str symbol) - is-global-lookup (global? vars-in-scope symbol) - ;;_ (println (str "Comparing " func-name " with " symbol-name)) - self-recursive (= func-name symbol-name) - is-constructor (= true (get-maybe ast :constructor)) - ] - (if self-recursive - (assoc ast :self-recursive true) - (do - (when is-global-lookup - (let [evaled (eval symbol) - is-primop (primop? evaled) - is-lambda (lambda? evaled) - is-function (function? evaled) - is-generic-lens-stub (key-is-true? (meta evaled) :generic-lens-stub)] - (do - (when (and (not is-function) (not is-constructor)) - (do - ;;(println (str symbol " is not a function/constructor, make it a global variable.")) - (bake-global (name symbol) deps) - (reset! deps (cons symbol-name deps)))) - (when is-constructor - (do - ;;(println (str "Found constructor '" symbol-name "'")) - (reset! deps (cons symbol-name deps)))) - (when (and* is-lambda bake-deps (not is-generic-lens-stub)) ;; Bake, then add to deps - (do - ;;(println (str symbol " is a dependency of " func-name ", code: " (code evaled))) - (compiler/bake-code symbol-name (code evaled) (meta-get evaled :ann)) - (reset! deps (cons symbol-name deps)))) - (when (foreign? evaled) - (reset! deps (cons symbol-name deps))) - ))) - (assoc ast :global-lookup is-global-lookup)))) - - :reset (let [ast0 (update-in ast '(:expr) (fn [a] (find-func-deps-internal a vars-in-scope))) - ast1 (update-in ast0 '(:symbol) (fn [a] (find-func-deps-internal a vars-in-scope)))] - ast1) - - :app (let [ast0 (update-in ast '(:head) (fn [a] (find-func-deps-internal a vars-in-scope))) - ast1 (update-in ast0 '(:tail) (fn [a] (find-deps-in-list a vars-in-scope)))] - ast1) - - :function (let [args (:args ast) - new-vars (union (map :name args) vars-in-scope)] - (update-in ast '(:body) (fn [a] (find-func-deps-internal a new-vars)))) - - :if (let [ast0 (update-in ast '(:expr) (fn [a] (find-func-deps-internal a vars-in-scope))) - ast1 (update-in ast0 '(:if-true) (fn [a] (find-func-deps-internal a vars-in-scope))) - ast2 (update-in ast1 '(:if-false) (fn [a] (find-func-deps-internal a vars-in-scope)))] - ast2) - - :while (let [ast0 (update-in ast '(:expr) (fn [a] (find-func-deps-internal a vars-in-scope))) - ast1 (update-in ast0 '(:body) (fn [a] (find-func-deps-internal a vars-in-scope)))] - ast1) - - :binop (let [ast0 (update-in ast '(:left) (fn [a] (find-func-deps-internal a vars-in-scope))) - ast1 (update-in ast0 '(:right) (fn [a] (find-func-deps-internal a vars-in-scope)))] - ast1) - - :literal ast - - :do (let [new-ast (update-in ast '(:forms) (fn [a] (find-deps-in-list a vars-in-scope)))] - new-ast) - - :let (let [bindings (:bindings ast) - new-vars (union (map :name bindings) vars-in-scope) - ast0 (assoc ast :bindings (find-deps-in-bindings bindings new-vars))] - (update-in ast0 '(:body) (fn [a] (find-func-deps-internal a new-vars)))) - - :ref (let [ast0 (update-in ast '(:expr) (fn [a] (find-func-deps-internal a vars-in-scope)))] - ast0) - - :null ast - - :array (let [ast0 (update-in ast '(:values) (fn [a] (find-deps-in-list a vars-in-scope)))] - ast0) - - x (error (str "find-func-deps can't handle node: " x)) - - ))) - - new-ast (find-func-deps-internal ast '())] - (assoc new-ast :func-deps deps))) - diff --git a/lisp/generate_names.carp b/lisp/generate_names.carp deleted file mode 100644 index 486900ca1..000000000 --- a/lisp/generate_names.carp +++ /dev/null @@ -1,88 +0,0 @@ -;; These names are used for temp variables when emitting the C-code. - -(defn gen-var-name [var-name-counters base-name] - (let [maybe-counter (get-maybe var-name-counters base-name)] - (do (when (nil? maybe-counter) - (dict-set! var-name-counters base-name 0)) - (let [counter (get var-name-counters base-name)] - (do (dict-set! var-name-counters base-name (inc counter)) - (str "_" base-name "_" counter)))))) - -(defn generate-names [var-name-counters ast] - (do - ;;(println (str "\ngenerate-names:\n" (:node ast))) - (match (:node ast) - - :function (let [ast1 (assoc ast :body (generate-names var-name-counters (:body ast))) - ast2 (assoc ast1 :result-name (gen-var-name var-name-counters "final_result"))] - ast2) - - :if (let [if-result-name (gen-var-name var-name-counters "if_result") - ast1 (assoc ast :result-name if-result-name) - ast2 (assoc ast1 :expr (generate-names var-name-counters (:expr ast))) - ast3 (assoc ast2 :if-true (generate-names var-name-counters (:if-true ast))) - ast4 (assoc ast3 :if-false (generate-names var-name-counters (:if-false ast)))] - ast4) - - :while (let [while-expr-name (gen-var-name var-name-counters "expr") - ast1 (assoc ast :while-expr-name while-expr-name) - ast2 (assoc ast1 :body (generate-names var-name-counters (:body ast))) - ast3 (assoc ast2 :expr (generate-names var-name-counters (:expr ast)))] - ast3) - - :let (let [let-result-name (gen-var-name var-name-counters "let_result") - ast1 (assoc ast :bindings (map (fn [x] (generate-names var-name-counters x)) (:bindings ast))) - ast2 (assoc ast1 :body (generate-names var-name-counters (:body ast))) - ast3 (assoc ast2 :result-name let-result-name)] - ast3) - - :binding (let [named-value (generate-names var-name-counters (:value ast))] - (assoc ast :value named-value)) - - :app (let [head (:head ast) - func-name (:value head) - c-func-name (c-ify-name (str func-name)) - app-result-name (gen-var-name var-name-counters (str "result")) - - args (:tail ast) - arg-names (repeatedly (fn [] (gen-var-name var-name-counters "arg")) (count args)) - - ast1 (assoc ast :head (generate-names var-name-counters (:head ast))) - ast2 (assoc ast1 :tail (map (fn [node] (generate-names var-name-counters node)) (:tail ast1))) - ast3 (assoc ast2 :result-name app-result-name) - - ast4 (assoc ast3 :tail (map2 (fn [arg arg-name] (assoc arg :arg-name arg-name)) (:tail ast3) arg-names)) - ] - ast4) - - :binop (let [ast1 (assoc ast :left (generate-names var-name-counters (:left ast))) - ast2 (assoc ast1 :right (generate-names var-name-counters (:right ast)))] - ast2) - - :do (let [named-forms (map (fn [x] (generate-names var-name-counters x)) (:forms ast)) - ast1 (assoc ast :forms named-forms)] - ast1) - - :literal (assoc ast :result-name (gen-var-name var-name-counters "lit")) - - :ref (let [named-expr (generate-names var-name-counters (:expr ast)) - ast1 (assoc ast :expr named-expr)] - ast1) - - :reset (let [named-expr (generate-names var-name-counters (:expr ast))] - (assoc ast :expr named-expr)) - - :lookup ast - - :null ast - - :array (let [ast1 (update-in ast '(:values) (fn [vals] (map (fn [node] (generate-names var-name-counters node)) vals))) - ast2 (assoc ast1 :result-name (gen-var-name var-name-counters "array")) - vals (:values ast1) - arg-names (repeatedly (fn [] (gen-var-name var-name-counters "arg")) (count vals)) - ast3 (assoc ast2 :values (map2 (fn [arg arg-name] (assoc arg :arg-name arg-name)) vals arg-names))] - ast3) - - _ (error (str "Can't generate name for node " ast)) - - ))) diff --git a/lisp/generics.carp b/lisp/generics.carp deleted file mode 100644 index 88cd18f12..000000000 --- a/lisp/generics.carp +++ /dev/null @@ -1,175 +0,0 @@ - -(defn generic-safe-name [t] - (match t - () "" - (x ... xs) (str (generic-safe-name x) "<" (join "-" (map generic-safe-name xs)) ">") - x (if (keyword? x) - (name t) - (error (str "generic-safe-name can't handle type signature: " t))))) - -(defn generic-suffix [signature] - (str (join "-" (map generic-safe-name (nth signature 1))) - "-" - (generic-safe-name (nth signature 2)))) - -(defn generic-name [base-name signature] - (do - ;;(println (str "Will find generic name for " base-name " with signature " signature)) - (str base-name "--" (generic-suffix signature)))) - -;; Used for let polymorphism to make the generic type of a function unique (i.e. change all the "T":s to a fresh typevar) -;; (:fn ("T" "S") "T") becomes (:f ("t319" "t302") "t319) -(defn uniquify-typevars [t] - (uniquify-typevars-internal t (copy {}))) - -(defn uniquify-typevars-internal [t substs] - (if (string? t) - (let [existing-tvar (get-maybe substs t)] - (if (nil? existing-tvar) - (let [new-tvar (gen-typevar)] - (do - (dict-set! substs t new-tvar) - new-tvar)) - existing-tvar)) - (if (keyword? t) - t - (if (list? t) - (map (fn [x] (uniquify-typevars-internal x substs)) t) - (error (str "Can't handle t " t " of type " (type t))))))) - -(defn mark-lambda-as-generic [func-name annotated-ast] - (let [func-def (eval (symbol func-name))] - (do - (meta-set! func-def :generic true) - (meta-set! func-def :signature (:type annotated-ast)) - (def ast annotated-ast) - (def s (pretty-signature (:type annotated-ast))) - (if echo-signature-after-bake - (println (str func-name " : " s)) - nil)))) - -(defn visit-generic-funcs [ast] - (letrec [deps (copy (:func-deps ast)) - - visit-lookup (fn [ast] - (let [t (:type ast)] - (do - ;;(println (str (:value ast) " : " t)) - ;;(println (str "ast:\n" ast)) - (if (and* (nil? (get-maybe ast :self-recursive)) (:global-lookup ast)) - (let [lookup-sym (:value ast) - ;;_ (println (str "Will eval " ast)) - global-lookup (eval lookup-sym) - ;;_ (println (str "global-lookup:\n" global-lookup)) - - lookup-t (type global-lookup) - ;;_ (println (str "lookup-t: " lookup-t)) - is-generic (meta-get lookup-t :generic) - is-generic-lens-stub (key-is-true? ast :generic-lens-stub) - ] - - (if (and* (lambda? global-lookup) is-generic) - (if (generic-type? t) - (do - ;;(println (str "Lambda with missing type information, can't compile concrete version: " lookup-sym " of type " t)) - ast) - (if is-generic-lens-stub - (let [struct-t (get-in (:type ast) '(1 0)) - struct-description (eval (:struct ast)) - member-types (:member-types struct-description) - struct-name (:name struct-description) - concrete-struct-name (generic-safe-name struct-t) - stub-ending (:stub-ending ast) - concrete-stub-name (str concrete-struct-name stub-ending) - ] - (do - ;; (println (str "Concretizing " (:value ast) - ;; " struct-t: " struct-t - ;; " struct-name: " struct-name - ;; " concrete-struct-name: " concrete-struct-name - ;; " struct description:\n" struct-description)) - ;;(println (str "t: " t)) - (concretize-struct-simple struct-t) - (reset! deps (cons concrete-stub-name deps)) - (assoc-in ast '(:value) (symbol concrete-stub-name)))) - (let [n (generic-name lookup-sym t)] - (do - ;;(println (str "generic lookup of '" lookup-sym "', t: " t ", lookup-t: " lookup-t ", n: " generic-name)) - (compiler/concretize (str lookup-sym) n (code global-lookup) t) - (reset! deps (cons n deps)) - (let [ast0 (assoc-in ast '(:value) (symbol n))] ;; make it call another function... - ast0))))) - (if (and (primop? global-lookup) is-generic) - (if (generic-type? t) - (do ;;(println (str "Primop with missing type information, can't compile concrete version: " t)) - ast) - (let [n (generic-name lookup-sym t)] - (do - ;;(println (str "Found a generic primop to bake: " lookup-sym)) - ;; (println (str "Final name will be " n)) - (bake-generic-primop n - (str lookup-sym) - t) - (reset! deps (cons n deps)) - (assoc-in ast '(:value) (symbol n))))) - - (if (and (key-is-true? ast :constructor) (key-is-true? ast :generic)) - (let [struct-name (:struct-name ast) - concrete-struct-type (nth t 2) - concrete-struct-name (generic-safe-name concrete-struct-type) - ;;_ (println (str "concrete-struct-name: " concrete-struct-name ", t: " t)) - constructor-name (str "new-" concrete-struct-name) - concrete-types (nth t 1)] - (do - (concretize-struct struct-name concrete-struct-name concrete-types) - (reset! deps (cons constructor-name deps)) - (assoc-in ast '(:value) (symbol constructor-name)))) - ast) - ))) - ast)))) - - visit-generic-funcs-internal (fn [ast] - (match (:node ast) - :function (update-in ast '(:body) visit-generic-funcs-internal) - - :app (let [head (:head ast) - ast0 (update-in ast '(:tail) (fn (a) (map visit-generic-funcs-internal (:tail ast))))] - (update-in ast0 '(:head) visit-generic-funcs-internal)) - - :lookup (visit-lookup ast) - - :if (let [ast0 (update-in ast '(:expr) visit-generic-funcs-internal) - ast1 (update-in ast0 '(:if-true) visit-generic-funcs-internal) - ast2 (update-in ast1 '(:if-false) visit-generic-funcs-internal)] - ast2) - - :binop (let [ast0 (update-in ast '(:left) visit-generic-funcs-internal) - ast1 (update-in ast0 '(:right) visit-generic-funcs-internal)] - ast1) - - :reset (let [ast0 (update-in ast '(:expr) visit-generic-funcs-internal)] - ast0) - - :literal ast - - :ref (update-in ast '(:expr) visit-generic-funcs-internal) - - :let (let [ast0 (update-in ast '(:bindings) - (fn [forms] (map visit-generic-funcs-internal forms)))] - (update-in ast0 '(:body) visit-generic-funcs-internal)) - - :binding (update-in ast '(:value) visit-generic-funcs-internal) - - :while (let [ast0 (update-in ast '(:expr) visit-generic-funcs-internal) - ast1 (update-in ast0 '(:body) visit-generic-funcs-internal)] - ast1) - - :null ast - - :array (update-in ast '(:values) (fn [vals] (map visit-generic-funcs-internal vals))) - - :do (update-in ast '(:forms) (fn [forms] (map visit-generic-funcs-internal forms))) - - x (error (str "visit-generic can't handle node type " x))))] - (assoc (visit-generic-funcs-internal ast) :func-deps deps))) - diff --git a/lisp/gl.carp b/lisp/gl.carp deleted file mode 100644 index d89dcd1c6..000000000 --- a/lisp/gl.carp +++ /dev/null @@ -1,151 +0,0 @@ -(def glfw nil) -(def gl nil) - -;; use libgl for gl functions under linux -;; use glfw on other platforms - -(if (linux?) - (do - (def glfw (load-dylib "libglfw.so.3")) - (def gl (load-dylib "libGL.so.1"))) "") - -(if (osx?) - (do - (def glfw (load-dylib "libglfw3.dylib")) - (def gl glfw)) "") - -(reset! extra-header-deps (cons "" extra-header-deps)) - -;; (register-struct GLFWmonitor) -;; (register-struct GLFWwindow) - -(register glfw "glfwInit" '() :bool) -(register glfw "glfwCreateWindow" '(:int :int (:ref :string) (:ref :GLFWmonitor) (:ref :GLFWwindow)) '(:ref :GLFWwindow)) -(register glfw "glfwMakeContextCurrent" '((:ref :GLFWwindow)) :void) -(register glfw "glfwTerminate" '() :void) -(register glfw "glfwPollEvents" '() :void) -(register glfw "glfwWindowShouldClose" '((:ref :GLFWwindow)) :bool) -(register glfw "glfwSwapBuffers" '((:ref :GLFWwindow)) :void) -(register glfw "glfwSetWindowShouldClose" '((:ref :GLFWwindow) :bool) :void) -(register glfw "glfwGetTime" '() :double) -(register glfw "glfwDestroyWindow" '((:ref :GLFWwindow)) :void) - -(def glfw-key-callback-type '(:fn ((:ref :GLFWwindow) :int :int :int :int) :void)) -(register glfw "glfwSetKeyCallback" (list '(:ref :GLFWwindow) glfw-key-callback-type) :void) - -(def glfw-cursor-callback-type '(:fn ((:ref :GLFWwindow) :double :double) :void)) -(register glfw "glfwSetCursorPosCallback" (list '(:ref :GLFWwindow) glfw-cursor-callback-type) :void) - - -(register gl "glClearColor" '(:float :float :float :float) :void) -(register gl "glClear" '(:int) :void) -(register gl "glColor3f" '(:float :float :float) :void) -(register gl "glBegin" '(:int) :void) -(register gl "glEnd" '() :void) -(register gl "glVertex3f" '(:float, :float, :float) :void) -(register gl "glOrtho" '(:double :double :double :double :double :double) :void) -(register gl "glLoadIdentity" '() :void) - -(def carp-gl-color-buffer-bit 16384) -(def carp-gl-lines 1) -(def carp-gl-line-strip 3) -(def carp-gl-triangles 4) - -(def key-esc 256) -(def key-arrow-up 265) -(def key-arrow-right 262) -(def key-arrow-down 264) -(def key-arrow-left 263) - -(def key-state-up 0) -(def key-state-down 1) -(def key-state-pressed 2) - -;; glfwSetCharCallback(window, character_callback); -;; void character_callback(GLFWwindow* window, unsigned int codepoint) - -;; glfwSetCursorPosCallback(window, cursor_pos_callback); -;; static void cursor_position_callback(GLFWwindow* window, double xpos, double ypos) - -(defn set-clear-color [] - (glClearColor 0.0f 0.95f 0.75f 1.0f)) - -(defn draw-rect [x y w h] - (do (glBegin carp-gl-triangles) - (glVertex3f x y 0.0f) - (glVertex3f (+ x w) y 0.0f) - (glVertex3f (+ x w) (+ y h) 0.0f) - (glVertex3f (+ x w) (+ y h) 0.0f) - (glVertex3f x (+ y h) 0.0f) - (glVertex3f x y 0.0f) - (glEnd))) - -(defn draw-line [x1 y1 x2 y2] - (do (glBegin carp-gl-lines) - (glVertex3f x1 y1 0.0f) - (glVertex3f x2 y2 0.0f) - (glEnd))) - -(defn draw-circle [x y r] - (do (glBegin carp-gl-line-strip) - (for (i 0 65) - (let [v (* (dtof two-pi) (/ (itof i) 64f))] - (glVertex3f (+ x (* r (cosf v))) (+ y (* r (sinf v))) 0.0f))) - (glEnd))) - -(defstruct Vec2 [x :float y :float]) - -(defn draw-vec2 [v] - (glVertex3f (Vec2-get-x v) (Vec2-get-y v) 0.0f)) - -(defn draw-lines (positions) - (do (glBegin carp-gl-line-strip) - (domap draw-vec2 positions) - (glEnd))) - -(defn draw-line-vec2 [p1 p2] - (let [x1 (Vec2-get-x p1) - y1 (Vec2-get-y p1) - x2 (Vec2-get-x p2) - y2 (Vec2-get-y p2)] - (draw-line x1 y1 x2 y2))) - -^ann glfw-key-callback-type -(defn default-on-keys [window key scancode action mods] - (if (= key-esc key) - (glfwSetWindowShouldClose window true) - (do - (print "key: ") - (print &(str key)) - (print ", scancode: ") - (print &(str scancode)) - (print ", action: ") - (print &(str action)) - (print ", mods: ") - (println &(str mods))))) - -(defn default-init [] - 0f) - -(defn glfw-app [title init tick render-callback on-key-callback] - (if (glfwInit) - (let [window (glfwCreateWindow 512 512 title NULL NULL)] - (if (null? window) - (error "No window.") - (do (println "Window OK.") - (glfwMakeContextCurrent window) - (glfwSetKeyCallback window on-key-callback) - ;;(glOrtho 0.0 640.0 480.0 0.0 1.0 -1.0) - (let [state (init)] - (while (not (glfwWindowShouldClose window)) - (do - (glClearColor 0.1f 0.1f 0.1f 1.0f) - (glClear carp-gl-color-buffer-bit) - (glColor3f 1.0f 1.0f 1.0f) - (render-callback &state) - (reset! state (tick (copy &state))) - (glfwSwapBuffers window) - (glfwPollEvents)))) - (println "Time to go.") - (glfwTerminate)))) - (error "Failed to initialize glfw."))) diff --git a/lisp/glfw_test.carp b/lisp/glfw_test.carp deleted file mode 100644 index 389358888..000000000 --- a/lisp/glfw_test.carp +++ /dev/null @@ -1,31 +0,0 @@ -(import gl) - -(defn gl-demo () - (if (glfwInit) - (let [window (glfwCreateWindow 640 480 "Yeah!" NULL NULL)] - (if (null? window) - (error "No window.") - (do (println "Window OK.") - (glfwMakeContextCurrent window) - (while (not (glfwWindowShouldClose window)) - (do - (glClearColor 0.6f 0.85f 0.85f 1.0f) - (glClear carp-gl-color-buffer-bit) - (glColor3f 1.0f 0.9f 0.2f) - (draw-rect -0.5f -0.5f 1.0f 1.0f) - (glfwSwapBuffers window) - (glfwPollEvents))) - (println "Time to go.") - (glfwTerminate)))) - (error "Failed to initialize glfw."))) - -;;(bake draw-rect) - -;(def app-ast (lambda-to-ast (code app))) -;(def app-asta (annotate-ast app-ast)) - -;;(bake* gl-demo '(draw-rect)) -;;(bake-gl-exe) - -(bake gl-demo) - diff --git a/lisp/globals.carp b/lisp/globals.carp deleted file mode 100644 index 7021bfa41..000000000 --- a/lisp/globals.carp +++ /dev/null @@ -1,56 +0,0 @@ - -(defn type-of-value [val] - (let [t (type val)] - (if (or (= :ptr t) (= :ptr-to-global t)) - (meta-get val :type) - (match t - :array (if (= 0 (count val)) - (error (str "Can't figure out type from empty array.")) - (list :Array (type-of-value (nth val 0)))) - _ t)))) - -(defn type-of-global [global-variable-name] - (let [s (symbol global-variable-name) - t (type-of-value (eval s))] - (do - ;;(println (str "type of global " global-variable-name " is " t)) - t))) - -(defn bake-global [variable-name mutable-deps] - (let [t (type-of-global variable-name) - evaled (eval (symbol variable-name)) - ;;_ (println (str "Global '" variable-name "' to bake has type " t " and value " evaled)) - c-variable-name (c-ify-name variable-name) - init-value (if (contains? '(:int :float :double :string :char :bool) t) - (c-prn evaled) - "NULL") - ] - (if (graph/node-exists? variable-name) - (do - ;;(println (str "Ignoring already baked global variable: '" variable-name "'")) - :ignored) - - (let [;;_ (println (str "Adding global named " variable-name " of type " t)) - prototype (str "API extern " (type-build t) " " c-variable-name ";") - c-code (str "API " (type-build t) " " c-variable-name " = " init-value ";") - init-closure-name (str variable-name "-init-closure") - init-value-safe (read (prn evaled)) ;; this removes bugs with ptrs to structs!!! - init-closure-def (list 'defn (symbol init-closure-name) [] (list 'reset! (symbol variable-name) init-value-safe)) - ] - (do - (def c c-code) - (compiler/bake-src variable-name prototype c-code t '()) - ;;(reset! mutable-deps (cons (symbol init-closure-name) mutable-deps)) - - (when (= "NULL" init-value) - (do - (eval (list 'reset! (symbol variable-name) evaled)) ;; OBS! Must set the value of the global after baking it since the bake leaves it set to NULL: - - ;;(println (str "Defining init closure " init-closure-name)) - (eval init-closure-def) - (compiler/bake-function-and-its-dependers init-closure-name) - (graph/update-node! init-closure-name :is-init-closure true) - - )) - - :baked))))) diff --git a/lisp/graph.carp b/lisp/graph.carp deleted file mode 100644 index e250fd526..000000000 --- a/lisp/graph.carp +++ /dev/null @@ -1,134 +0,0 @@ -;; The dependency graph -;; -;; Nodes are functions, groups of mutually recursive functions, modules, structs, etc. -;; Each node can be compiled into its own dynamic library and depends on a set of other nodes. -;; Compiling a node should be very straight forward: -;; -;; (bake-node "foo") -;; -;; The whole graph lives in a data structure called 'graph' which is a big dictionary. - -(def graph {}) -(def graph-src {}) - -^doc "kind - :function / :global (variable) / :struct / :module / function-type - name - a string, also the key in the graph dictionary - proto - what will go into the header file - src - what will go into the C-file - group - a string, the name used for the particular dylib where this node is compiled - dylib-ptr - pointer to the dylib Obj - depends-on - a list of names of nodes that this node depend on - " -(defn graph/add-node! [kind name proto src group dylib-ptr depends-on order] - (do (dict-set! graph-src name src) - (dict-set! graph name {:kind kind - :name name - :proto proto - :group group - :dylib-ptr dylib-ptr - :depends-on (map str depends-on) - :order order}))) - -(defn graph/update-node! [name key value] - (dict-set-in! graph (list name key) value)) - -(defn graph/dependers [name] - (set - (mapcat (fn [node] - (let [deps (:depends-on node)] - (if (contains? deps name) - (concat (list (:name node)) (graph/dependers (:name node))) - ()))) - (values graph)))) - -(defn graph/depending-groups [name] - (mapcat (fn [node] - (let [deps (:depends-on node)] - (if (contains? deps name) - (concat (list node) (graph/depending-groups (:group node))) - ()))) - (values graph))) - -(defn graph/node-exists? [name] - (not-nil? (get-maybe graph name))) - -(def extra-header-deps ()) - -(defn graph/get-kind [kind] - (filter (fn [n] (= (:kind n) kind)) (values graph))) - -(defn compare-order [a b] - (< (:order a) (:order b))) - -(defn graph/save-prototypes! () - (save (str out-dir "declarations.h") - (str - "#include \n" - "\n\n//Extra headers:\n" - (join "\n" (map (fn [header] (str "#include " header)) extra-header-deps)) - "\n\n//Structs & function types:\n" - (join "\n" (map :proto (sort-by compare-order (concat (graph/get-kind :struct) - (graph/get-kind :function-type) - (graph/get-kind :array-type))))) - "\n\n//Globals:\n" - (join "\n" (map :proto (graph/get-kind :global))) - "\n\n//Functions:\n" - (join "\n" (map :proto (graph/get-kind :function))) - "\n"))) - -(def log-unloading-of-dylibs false) - -^doc "Takes the name of a function and unloads it if it is in the list of baked functions. - Also turns foreign functions back into lambdas through 're-lambda-fy'." -(defn graph/unload [name] - (when-let [baked-node (get-maybe graph name)] - (let [dylib (get baked-node :dylib-ptr)] - (do (when log-unloading-of-dylibs - (println (str "Unloading " dylib " for function " name "."))) - (unload-dylib dylib) - (dict-remove! graph name) - (graph/re-lambda-fy name) - )))) - -^doc "Removes all nodes belonging to a group and unloads their dylib. Not recursive, but returns depending groups." -(defn graph/unload-group [group-name] - (let [dylib nil - depending-groups '()] - (do - ;;(println (str "Will unload group '" group-name "'")) - (map (fn [node] - (do - (when (= (:group node) group-name) - (do (dict-remove! graph (:name node)) - (if (nil? dylib) - (reset! dylib (:dylib-ptr node)) - (if (nil? (:dylib-ptr node)) - :ignore - (assert-eq dylib (:dylib-ptr node)))))) - (when (contains? (:depends-on node) group-name) - (reset! depending-groups (cons (:group node) depending-groups))))) - (values graph)) - (do (if (nil? dylib) - :no-dylib-to-unload - (unload-dylib dylib)) - depending-groups)))) - -(defn graph/re-lambda-fy [func-name] - (let [function-symbol (if (symbol? func-name) - func-name - (symbol func-name)) - func (eval function-symbol)] - (if (foreign? func) - (let [func-code (meta-get func :code)] - (do - ;;(println (str "re-lambda-fy:ing baked function '" func-name "' using original code: " func-code)) - (eval (list 'def (symbol func-name) func-code)))) - (do - ;;(println (str "re-lambda-fy will ignore non-baked function: " func-name)) - :ignore)))) - -;; (defn graph/re-lambda-fy-all-functions [] -;; (map re-lambda-fy (graph/get-kind :function))) - -(defn graph/print [] - (println (str (keys graph)))) diff --git a/lisp/improved_core.carp b/lisp/improved_core.carp deleted file mode 100644 index 58695fded..000000000 --- a/lisp/improved_core.carp +++ /dev/null @@ -1,7 +0,0 @@ - -;; The improved Core uses the complete language to make better versions of some of the functions. -;; This is done as a final step after the compiler has bootstrapped itself. - -(defn println* [x] - (println (ref (str (ref x))))) - diff --git a/lisp/infer_types.carp b/lisp/infer_types.carp deleted file mode 100644 index aa7c350f1..000000000 --- a/lisp/infer_types.carp +++ /dev/null @@ -1,602 +0,0 @@ - -^doc "The type env is bindings from variable names to types or variables, i.e. {:x :int, :y \"t10\"}." -(defn type-env-extend [type-env args] - (let [new-env (copy type-env)] - (do (reduce (fn (_ pair) (dict-set! new-env (nth pair 0) (nth pair 1))) - nil - (map2 list (map :name args) (map :type args))) - new-env))) - -(defn get-type-of-symbol [type-env symbol] - (let [lookup (get-maybe type-env symbol)] - (if (nil? lookup) - (let [global-lookup (eval symbol) - t (type-of-global (str symbol))] - (match t - :lambda (if (meta-get global-lookup :generic) - (let [signature (meta-get global-lookup :signature) - uniquified (uniquify-typevars signature)] - (do - ;;(println (str "'" symbol "' is generic with signature " signature ", uniquified: " uniquified)) - uniquified)) - (error (str "Found non-baked symbol '" symbol "'."))) - :macro (error (str "Found non-expanded macro '" symbol "'.")) - :foreign (signature global-lookup) - :primop (let [s (signature global-lookup)] - (if (nil? s) - (error (str "No signature set for primop " symbol " (maybe it isn't allowed to be baked?)")) - (uniquify-typevars s))) - _ t)) - lookup))) - -(defn math-op? [op] - (contains? '(+ - * /) op)) - -(def log-chaining false) - -^doc "Generates a dictionary with location data used when type unification fails." -(defn location [ast-a ast-b] - (do - ;;(println (str "ast-a: " ast-a "\n" "ast-b: " ast-b)) - {:a {:line (if (dict? ast-a) (get-maybe ast-a :line) "???") - :node (:node ast-a) - :original-form (if (dict? ast-a) (get-maybe ast-a :original-form) "???")} - :b {:line (if (dict? ast-b) (get-maybe ast-b :line) "???") - :node (:node ast-b) - :original-form (if (dict? ast-b) (get-maybe ast-b :original-form) "???")}})) - -;; These values determine the order of the constraints when passed to the constraint solver. -;; Lower values mean that they are solved earlier. This affects error messages, not the solvability of the types. -(def prio-func-annotation 1) -(def prio-if-branch 3) -(def prio-func-ret-constr 5) -(def prio-default 10) -(def prio-lookup-constraint 11) -(def prio-func-arg-constr 16) -(def prio-app-arg-constraint 20) -(def prio-binop 30) - -(defn generate-constraints-internal [constraints ast type-env] - (do - ;;(println (str "gen constrs: \n" ast)) - (match (get ast :node) - - :function (let [extended-type-env (type-env-extend type-env (get ast :args)) - extended-type-env-2 (let [fn-name (get-maybe ast :name)] - (if (string? fn-name) - (assoc extended-type-env (symbol fn-name) (:type ast)) - extended-type-env)) - new-constraints (generate-constraints-internal constraints (:body ast) extended-type-env-2) - func-ret-constr {:a (get-in ast '(:type 2)) ;; the return type of the fn type - :b (get-in ast '(:body :type)) - :prio prio-func-ret-constr - :doc (str "func-ret-constr")} - func-arg-constrs (map2 (fn [a b] {:a a - :b b - :prio prio-func-arg-constr - :doc "func-arg"}) - (map :type (:args ast)) - (get-in ast '(:type 1))) - annotation-constr (if (nil? (:annotation ast)) - () - (list {:a (:annotation ast) - :b (:type ast) - :prio prio-func-annotation - :doc (str "func-annotation-constr")}))] - (concat annotation-constr func-arg-constrs (cons func-ret-constr new-constraints))) - - :app (let [ret-constr {:a (get ast :type) - :b (get-in ast '(:head :type 2)) - :prio prio-default - :doc "ret-constr for :app"} - arg-constrs (map2 (fn (a b) (do ;;(println (str "ast: " ast)) - {:a a - :b (:type b) - :prio prio-app-arg-constraint - :location (location (:head ast) - b) - :constraint-kind :app-arg - :arg-index (get-maybe b :arg-index) - :head-name (str (get-maybe (:head ast) :value)) - :doc (str "app-arg " a " vs " (:type b))})) - (get-in ast '(:head :type 1)) - (:tail ast)) - head-constrs (generate-constraints-internal '() (:head ast) type-env) - tail-constrs (reduce (fn [constrs tail-form] (generate-constraints-internal constrs tail-form type-env)) - '() (:tail ast)) - new-constraints (concat tail-constrs head-constrs (cons ret-constr arg-constrs))] - (concat new-constraints constraints)) - - :literal constraints ;; literals don't need constraints - - :ref (letrec [expr (:expr ast) - x0 (generate-constraints-internal constraints expr type-env) - inner-type (match (:type ast) - (:ref t) t - _ (error "Not a ref type")) - expr-constr {:a inner-type - :b (:type expr) - :prio prio-default - :doc "ref-constr"}] - (cons expr-constr x0)) - - :reset (let [expr (:expr ast) - symbol (:value (:symbol ast)) - x0 (generate-constraints-internal constraints expr type-env) - t (get-type-of-symbol type-env symbol) - expr-constr {:a t - :b (:type expr) - :prio prio-default - :doc "reset!-constr" - :constraint-kind :reset-constr - :location (location {:line (:line ast) :original-form symbol :node :reset-symbol} - expr)}] - (cons expr-constr x0)) - - :lookup (if (has-key? ast :constructor) - (let [member-types (array-to-list (:member-types ast)) - t (:type ast) - is-generic (:generic ast) - struct-type (keyword (:struct-name ast)) - constructor-return-constr {:a (if is-generic - (cons struct-type (:typevars ast)) - struct-type) - :b (nth t 2) - :prio prio-default - :doc "constructor-return-value"} - constructor-arg-constrs (map2 (fn [a b] {:a a - :b b - :prio prio-default - :doc "constructor-arg"}) - member-types - (nth t 1))] - (cons constructor-return-constr constructor-arg-constrs)) - (let [val (:value ast) - ;;_ (println (str "\nLookup of " (:value ast) ", type-env:\n" type-env)) - t (get-type-of-symbol type-env val) - ;;_ (println (str "type of lookup '" val "': " t)) - ] - (if (nil? t) - (error (str "Can't create constraint for lookup of '" val "', it's type is nil.")) - (cons {:a (:type ast) - :b t - :prio prio-lookup-constraint - :location (location ast - {:node :lookup-other :line "?" :original-form val}) - :constraint-kind :lookup - :doc (str "lookup " val)} constraints)))) - - :binop (let [x0 (generate-constraints-internal constraints (get ast :left) type-env) - x1 (generate-constraints-internal x0 (get ast :right) type-env) - same-arg-type-constr {:a (get-in ast '(:left :type)) - :b (get-in ast '(:right :type)) - :prio prio-binop - :doc "same-arg-type-constr" - :constraint-kind :same-arg-type-constr - :location (location (:left ast) (:right ast))} - maybe-constr (if (math-op? (:op ast)) - (list {:a (get-in ast '(:left :type)) - :b (:type ast) - :prio prio-binop - :doc "maybe constr"}) - ()) - ] - ;;(concat x1 (list left-arg-constr right-arg-constr ret-constr))) - (concat maybe-constr (cons same-arg-type-constr x1))) - - :if (let [x0 (generate-constraints-internal constraints (get ast :if-true) type-env) - x1 (generate-constraints-internal x0 (get ast :if-false) type-env) - x2 (generate-constraints-internal x1 (get ast :expr) type-env) - left-result-constr {:a (get-in ast '(:if-true :type)) - :b (:type ast) - :constraint-kind :if-branch-constr - :prio prio-if-branch - :doc "if-left-constr" - :location (location (:if-true ast) ast)} - right-result-constr {:a (get-in ast '(:if-false :type)) - :b (:type ast) - :constraint-kind :if-branch-constr - :prio prio-if-branch - :doc "if-right-constr" - :location (location (:if-false ast) ast)} - expr-must-be-bool {:a :bool - :b (get-in ast '(:expr :type)) - :constraint-kind :if-expr-constr - :prio prio-default - :doc "if-expr-constr" - :location (location {:line :invalid :node :bool} (:expr ast))}] - (concat x2 (list - expr-must-be-bool - left-result-constr - right-result-constr))) - - :do (let [x0 (reduce (fn [constrs form] (generate-constraints-internal constrs form type-env)) - constraints (:forms ast)) - n (count (:forms ast)) - _ (when (= 0 n) (error (str "do-form must have at least one statement."))) - ret-constr {:a (:type ast) - :b (get-in ast (list :forms (- n 1) :type)) - :prio prio-default - :doc "do-ret-constr"}] - (cons ret-constr x0)) - - :let (let [bindings (:bindings ast) - extended-type-env (reduce (fn [e b] (assoc e (:name b) (get-in b '(:value :type)))) type-env bindings) - ;;_ (println "Extended type env: " extended-type-env) - let-constr {:a (:type ast) - :b (get-in ast '(:body :type)) - :prio prio-default - :doc "let-constr"} - bindings-constr (mapcat (fn [binding] (let [bind-constr {:a (:type binding) - :b (get-in binding '(:value :type)) - :doc (str "let-bind-constr") - :prio prio-default} - value-constrs (generate-constraints-internal constraints (:value binding) extended-type-env)] - (cons bind-constr value-constrs))) - bindings) - body-constrs (generate-constraints-internal constraints (:body ast) extended-type-env)] - (cons let-constr (concat bindings-constr body-constrs))) - - :while (let [x0 (generate-constraints-internal constraints (get ast :body) type-env) - x1 (generate-constraints-internal x0 (get ast :expr) type-env) - body-result-constr {:a (get-in ast '(:body :type)) - :b (:type ast) - :prio prio-default} - expr-must-be-bool {:a :bool - :b (get-in ast '(:expr :type)) - :prio prio-default - :constraint-kind :while-expr-constr - :location (location {:line :invalid :node :bool} (:expr ast))}] - (concat x1 (list expr-must-be-bool ))) - - :null constraints - - :array (letrec [t (:type ast) - inner-type (nth t 1) - value-constrs (mapcat (fn [val] (letrec [val-constr {:a inner-type - :b (:type val) - :doc (str "array-value-constr") - :prio prio-default} - inner-constrs (generate-constraints-internal constraints val type-env)] - (cons val-constr inner-constrs))) - (:values ast))] - value-constrs) - - _ constraints - ))) - -(defn generate-constraints [ast] - (let [constraints '()] - (generate-constraints-internal constraints ast {}))) - -;; A shorter name: -(def gencon generate-constraints) - -(defn typevar? [x] (string? x)) - -(def log-substs false) - -(defn extend-substitutions [substs lhs value] - (do - (when log-substs - (do - (println (str "\nSubsts:\n" substs)) - (println (str "Try extend " lhs " => " value)))) - (if (= :fail substs) - :fail - (let [value-lookup (lookup-in-substs-fast substs value)] - (if (typevar? lhs) - (let [existing (get-maybe substs lhs)] - (if (= nil existing) - (let [new-substs (assoc substs lhs value-lookup) - ;;_ (println (str "new-substs:\n" new-substs)) - substs-replaced-from-right (replace-subst-from-right-fast new-substs lhs value-lookup) - ;;_ (println (str "substs-replaced-from-right:\n" substs-replaced-from-right)) - ] - (do (when log-substs (println (str "No existing binding, set " lhs " to " value-lookup - ", substs-replaced-from-right:\n" substs-replaced-from-right))) - substs-replaced-from-right)) - (do (when log-substs (println (str "Existing binding: " existing))) - (if (list? existing) - (if (list? value-lookup) - (let [_ (when log-substs (println "The existing binding is a list")) - pairs (map2 (fn [e l] {:e e :l l}) existing value-lookup) - _ (when log-substs (println (str "pairs:\n" pairs))) - new-substs (reduce (fn [s m2] - (if (= (:e m2) lhs) - s ;; Don't try to extend because it will lead to infinite loop!!! - (extend-substitutions s (:e m2) (:l m2)))) - substs - pairs) - _ (when log-substs (println (str "\nBack from list, new substs: " new-substs)))] - new-substs) - (do - substs)) - (if (typevar? existing) - (do (when log-substs (println (str "The existing binding is a typevar, will replace " existing " with " value-lookup " from right"))) - (let [result (replace-subst-from-right-fast substs existing value-lookup)] - (do ;;(println (str "result: " result)) - result))) - (do (when log-substs (println "The existing binding is not a typevar")) - (if (types-exactly-eq? existing value-lookup) - (do (when log-substs (println "Current binding matches new value")) - substs) - (do (when log-substs (println "Current binding do not match new value")) - (if (or (= :any lhs) (typevar? value-lookup)) - substs - :fail - ;;(error (str "Can't unify typevar \n\n" existing "\n\nwith\n\n" value-lookup "\n\nLocation: " (meta-get value :doc))) - ))))))))) - ;; Not a typevar: - (if (list? lhs) - (if (list? value-lookup) - (do - ;;(println (str "Both lhs and value-lookup are lists: " lhs ", " value-lookup)) - (reduce (fn [s m2] (let [s1 (extend-substitutions s (:t m2) (:v m2))] - (extend-substitutions s1 (:v m2) (:t m2)))) - substs (map2 (fn [t v] {:t t :v v}) lhs value-lookup))) - (do - ;;(println (str "value lookup must be a list when lhs is a list: " lhs)) - substs)) - (do (when log-substs (println (str "lhs " lhs " is not a tvar or list, value lookup: " value-lookup))) - (if (or* (= :any lhs) (= :any value-lookup) (= lhs value-lookup) (typevar? value-lookup)) - substs - :fail - ;;(error (str "Can't unify \n" lhs " with \n" value-lookup)) - )))))))) - -(defn solve-list [substs-and-errors a-list b-list constraint flipped] - (match (list a-list b-list) - (() ()) substs-and-errors - ((a ... as) (b ... bs)) (solve (solve substs-and-errors a b constraint false) as bs constraint true) - _ (error "Shouldn't happen"))) - -(defn solve [substs-and-errors a b constraint flipped] - (do - ;;(println (str "\nsolve:\n" substs-and-errors "\na:\n" a "\nb:\n" b)) - (let [substs (:substs substs-and-errors) - type-errors (:type-errors substs-and-errors)] - (let [result (if (and (list? a) (list? b)) - (if (= (count a) (count b)) - (solve-list substs-and-errors a b constraint flipped) - (assoc substs-and-errors :type-errors (cons {:type-error true - :a (if flipped b a) - :b (if flipped a b) - :constraint (assoc constraint :constraint-kind :arg-list-length-mismatch) - :loc (get-maybe constraint :location)} - type-errors))) - (let [new-substs (extend-substitutions substs a b)] - (if (= new-substs :fail) - :fail - (assoc substs-and-errors :substs new-substs))))] - (if (= :fail result) - (let [loc (get-maybe constraint :location)] - (assoc substs-and-errors :type-errors (cons {:type-error true - :a (if flipped b a) - :b (if flipped a b) - :constraint constraint - :loc loc} - type-errors))) - result))))) - -(defn print-type-error [final-substs e] - (let [a (:a e) - b (:b e) - constraint (:constraint e) - loc (:loc e)] - (if (nil? loc) - (println (str "Can't unify typevar " a " WITH " b " (missing info)\n" loc)) - (println (str (describe-constraint constraint loc a b final-substs) - "\n"))))) - -(defn describe-constraint [constraint loc a b substs] - (let [constraint-kind (get-maybe constraint :constraint-kind)] - (if (nil? constraint-kind) - (str "Missing a constraint kind for " constraint) - (match constraint-kind - - :app-arg (str (highlight (str - "Conflicting types for arg " (:arg-index constraint) " to " - (get-func-name-maybe constraint) - ":\n")) - "The expected type of the argument to" - (str-expected-type (:a loc) a substs) - (but) - "the actual type of" - (str-expected-type (:b loc) b substs)) - - :lookup (str (highlight "Conflicting types for lookup:\n") - (str-expected-type (:a loc) a substs) - (but) - (str-expected-type (:b loc) b substs)) - - :while-expr-constr (str (highlight "The expression in a while-statement must be of type bool:\n") - (str-expected-type (:b loc) b substs)) - - :if-expr-constr (str (highlight "The expression in an if-statement must be of type bool:\n") - (str-expected-type (:b loc) b substs)) - - :if-branch-constr (str (highlight "Conflicting types for a true/false-branch and its if statement:\n") - "The type of the branch" - (str-expected-type (:a loc) a substs) - (but) - "The type of the whole if-statement" - (str-expected-type (:b loc) b substs)) - - :reset-constr (str (highlight "Conflicting types for reset! statement:\n") - "The type the variable" - (str-expected-type (:a loc) a substs) - (but) - "The type of the expression" - (str-expected-type (:b loc) b substs)) - - :arg-list-length-mismatch (str (highlight (str "Wrong number of arguments to " - (get-func-name-maybe constraint) - ":\n")) - (str-expected-type (:a loc) a substs) - (but) - (str-expected-type (:b loc) b substs)) - - :same-arg-type-constr (str (highlight "Conflicting types for arguments to binary operator:\n") - (str-expected-type (:a loc) a substs) - (but) - (str-expected-type (:b loc) b substs)) - - x (str "Unhandled kind of constraint:" x))))) - -(defn get-func-name-maybe [constraint] - (if (nil? (get-maybe constraint :head-name)) - "FUNCTION" - (:head-name constraint))) - -(defn highlight [text] - (str (get-console-color console-color-blue) - text - (get-normal-console-color))) - -(defn but [] - (highlight "\n - BUT - \n")) - -(defn str-expected-type [sub-loc t substs] - (str - " '" - (:original-form sub-loc) - "'" - " is " (get-type substs t) - " (line " - (:line sub-loc) - ")" - )) - -(defn solve-constraint-internal [substs-and-errors constraint] - (let [a (:a constraint) - b (:b constraint)] - (solve (solve substs-and-errors a b constraint false) b a constraint true))) ; Solving from both directions! TODO: is this needed? - -;; Returns a substitution map from type variables to actual types -(defn solve-constraints [constraints] - (let [result (reduce solve-constraint-internal {:substs {} :type-errors ()} constraints) - final-substs (:substs result) - type-errors (:type-errors result)] - (if (< 0 (count type-errors)) - (do - (println "") - (map (fn [type-error] (print-type-error final-substs type-error)) - (set type-errors)) ;; turning it to a set because duplicate of errors may occur because we run solver both ways at the moment - ;;(println (str "What we managed to infer:\n" final-substs "\n")) - (error {:error error-failed-typechecking :show-stacktrace false :message "Failed to typecheck."})) - final-substs))) - -(defn compare-constraints [c1 c2] - (< (:prio c1) (:prio c2))) - -(defn sort-constraints [constraints] - (sort-by compare-constraints constraints)) - -(defn make-type-list [substs typevars] - (map (fn [t] (if (string? t) (get-type substs t) - (if (list? t) - (make-type-list substs t) - t))) - typevars)) - -(defn get-type [substs typevar] - (if (list? typevar) - (make-type-list substs typevar) - (let [maybe-type (get-maybe substs typevar)] - (if (= maybe-type ()) - typevar ;; lookup failed, there is no substitution for this type variable (= it's generic) - maybe-type)))) - -(defn assign-types-to-list [asts substs] - (map (fn (x) (assign-types x substs)) asts)) - -(defn assign-types-to-binding [b substs] - (let [x0 (assoc b :type (get-type substs (:type b))) - x1 (assoc x0 :value (assign-types (:value b) substs))] - x1)) - -(defn assign-types [ast substs] - (match (:node ast) - :function (let [a (assoc ast :type (get-type substs (:type ast))) - b (assoc a :body (assign-types (:body ast) substs)) - c (assoc b :args (assign-types-to-list (:args ast) substs))] - c) - - :app (let [head (:head ast) - app-ret-type (get-type substs (:type ast)) - ast0 (assoc ast :type app-ret-type) - ast1 (assoc ast0 :head (assign-types (:head ast0) substs)) - ast2 (assoc ast1 :tail (map (fn [x] (assign-types x substs)) (:tail ast1)))] - ast2) - - :literal ast - - :lookup (assoc ast :type (get-type substs (:type ast))) - - :arg (assoc ast :type (get-type substs (:type ast))) - - :ref (let [x0 (assoc ast :type (get-type substs (:type ast))) - x1 (assoc x0 :expr (assign-types (:expr x0) substs))] - x1) - - :reset (let [x0 (assoc ast :expr (assign-types (:expr ast) substs))] - x0) - - :binop (let [x0 (assoc ast :type (get-type substs (:type ast))) - x1 (assoc x0 :left (assign-types (:left ast) substs)) - x2 (assoc x1 :right (assign-types (:right ast) substs))] - x2) - - :if (let [x0 (assoc ast :type (get-type substs (:type ast))) - x1 (assoc x0 :if-true (assign-types (:if-true ast) substs)) - x2 (assoc x1 :if-false (assign-types (:if-false ast) substs)) - x3 (assoc x2 :expr (assign-types (:expr ast) substs))] - x3) - - :do (let [x0 (assoc ast :forms (map (fn [x] (assign-types x substs)) (:forms ast))) - x1 (assoc x0 :type (get-type substs (:type ast)))] - x1) - - :let (let [x0 (assoc ast :bindings (map (fn [b] (assign-types-to-binding b substs)) (:bindings ast))) - x1 (assoc x0 :body (assign-types (:body x0) substs)) - let-ret-type (get-type substs (:type x1)) - _ (when (ref? let-ret-type) - (error {:error error-return-ref - :message (str "The return type of " (:original-form x1) " on line " (:line x1) " is not owned.\n") - :show-stacktrace false})) - x2 (assoc x1 :type let-ret-type)] - x2) - - :while (let [x0 (assoc ast :type (get-type substs (:type ast))) - x1 (assoc x0 :body (assign-types (:body ast) substs)) - x2 (assoc x1 :expr (assign-types (:expr ast) substs))] - x2) - - :null ast - - :array (letrec [inner-type (nth (:type ast) 1) - looked-up-inner-type (get-type substs inner-type) - _ (when (ref? looked-up-inner-type) - (error {:error error-ref-in-array - :message (str "The type of the elements in the array " (:original-form ast) " on line " (:line ast) " is not owned.\n") - :show-stacktrace false})) - x0 (assoc ast :type (list :Array looked-up-inner-type)) - x1 (assoc x0 :values (map (fn [x] (assign-types x substs)) (:values ast)))] - x1) - - :c-code (assoc ast :type (get-type substs (:type ast))) - - _ (error (str "Can't assign types to ast node " ast)))) - -(defn infer-types [ast func-signature-if-generic] - (let [type-constraints (generate-constraints ast) - func-signature-constraint (if (nil? func-signature-if-generic) '() (list {:a func-signature-if-generic - :b (:type ast) - :prio prio-default - :doc "generic-constr"})) - sorted-constraints (sort-constraints (concat func-signature-constraint type-constraints)) - substs (solve-constraints sorted-constraints) - ;;substs (solver/solve sorted-constraints) - ast-typed (assign-types ast substs)] - ast-typed)) diff --git a/lisp/math.carp b/lisp/math.carp deleted file mode 100644 index 299963843..000000000 --- a/lisp/math.carp +++ /dev/null @@ -1,4 +0,0 @@ - -(defn adv [] - 666) - diff --git a/lisp/misc.carp b/lisp/misc.carp deleted file mode 100644 index 3c9a855fb..000000000 --- a/lisp/misc.carp +++ /dev/null @@ -1,47 +0,0 @@ -(defn f-f () - 123) - -(defn g-g () - (f-f)) - -(defn conso2 (a b c) - (do - ;;(glVertex3f a b c) ;; 8 - ;;(glVertex3f b c a) ;; 40 - ;;(glVertex3f c a b) ;; 168 - ;;(glVertex3f c a b) ;; 680 - ;;(glVertex3f c a b) ;; 2728 - ;;(glVertex3f c a b) ;; 10920 - )) - -(defn conso1 (x) - (do - (cosf x) - (cosf x) ;; 12 - (cosf x) ;; 28 - (cosf x) ;; 60 - ;;(cosf x) ;; 124 - )) - -(defn test-conso () - (do - ;;(def conso-ast (form-to-ast '(cosf x))) - (def conso-ast (form-to-ast '(let [x 10f] (do (cosf x) (cosf x) (cosf x))))) ;; (cosf x) (cosf x)))) - (def conso-con (generate-constraints conso-ast)) - (def conso-asta (annotate-ast conso-ast)) - )) - -;;(test-conso) - - -;; (def v-ast (form-to-ast '(glVertex3f (+ 0.0f 0.8f) (+ 0.0f 0.7f) 0.0f))) -;; (def v-con (gencon v-ast)) -;; (def v-asta (annotate-ast v-ast)) - -;; (defn vg (x) -;; (glVertex3f x (+ 1.0f x) 2.0f)) - -;; (def vg-ast (lambda-to-ast (code vg))) -;; (def vg-con (gencon vg-ast)) -;; (def vg-asta (annotate-ast v-ast)) - diff --git a/lisp/play-example.carp b/lisp/play-example.carp deleted file mode 100644 index 689bd474b..000000000 --- a/lisp/play-example.carp +++ /dev/null @@ -1,20 +0,0 @@ - -(defn println* [x] - (println (ref (str (ref x))))) - - - -(defstruct Player [playerName :string - playerScore :int]) - -(defn x2 [x] - (* x 2)) - -(defn grow [player] - (update-playerScore player x2)) - -(defn play [] - (let [p1 (Player (copy "erik") 100) - p2 (Player (copy "marie") 120)] - (println* (map grow [p1 p2])))) - diff --git a/lisp/profiling.carp b/lisp/profiling.carp deleted file mode 100644 index 3707d4c17..000000000 --- a/lisp/profiling.carp +++ /dev/null @@ -1,114 +0,0 @@ - -;;(sort-by < (list 4 3 5 1 7)) -;; (def nums (range 1 500)) -;; (def sorted (time (sort-by > nums))) -;; (println (str sorted)) - - - - - -(defn test-faster-unification [] - (for (i 0 10) - (do - (defn f [] - (let [x (dd 100) - a [(dd 1) (dd 2) (dd 3) (dd 4) (dd 5)] - b [(dd 3) (dd (inc 5)) (dd (dec 5))] - c (map inc [x]) - d (map dec (map dec (map dec [x x x x x x x x x x x])))] - (copy &[@&a @&b @&c @&d @&a @&b @&c @&d a b c d]))) - (time (bake f))))) - -;;(test-faster-unification) - -;; f : () -> Array Array int -;; Evaluating form (bake f) took 6993ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5979ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5642ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5419ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5613ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5441ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5616ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5660ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5646ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5484ms. - -;; f : () -> Array Array int -;; Evaluating form (bake f) took 7030ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5902ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5640ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5630ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5219ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5575ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5460ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5142ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5131ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 5394ms. - - -;; f : () -> Array Array int -;; Evaluating form (bake f) took 1834ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 1058ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 1107ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 1144ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 1094ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 1046ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 1061ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 1000ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 1032ms. -;; Unloading for function f. -;; f : () -> Array Array int -;; Evaluating form (bake f) took 1022ms. diff --git a/lisp/sicp_solver.carp b/lisp/sicp_solver.carp deleted file mode 100644 index 5798796b8..000000000 --- a/lisp/sicp_solver.carp +++ /dev/null @@ -1,247 +0,0 @@ -;; Most of the code is from SICP - -(defn solver/unify [p1 p2 bindings] - (do - ;;(println (str "p1: " p1 " p2: " p2)) - (cond (= bindings :fail) :fail - (= p1 p2) bindings - (typevar? p1) (solver/extend-if-possible p1 p2 bindings) - (typevar? p2) (solver/extend-if-possible p2 p1 bindings) - (= :any p1) bindings - (= :any p2) bindings - (and (list? p1) (list? p2)) (solver/unify (first p1) (first p2) - (solver/unify (rest p1) (rest p2) bindings)) - :else :fail))) - -(defn solver/extend-if-possible [var val bindings] - (let [binding (get-maybe bindings var)] - (cond - (not-nil? binding) (solver/unify binding val bindings) - - (typevar? val) (if-let [b2 (get-maybe bindings val)] - (solver/unify var b2 bindings) - (assoc bindings var val)) - - :else (assoc bindings var val)))) - -(defn recursive-lookup [bindings x] - (cond - (nil? x) nil - (list? x) (map (fn [x0] (recursive-lookup bindings x0)) x) - (string? x) (let [result (get-maybe bindings x)] - (if (= result x) - result - (recursive-lookup bindings result))) - :else x)) - -(defn solver/solve-constraints-internal [constraints] - (let [step-1 (reduce (fn [bindings-and-errors constraint] - (let [result (solver/unify (:a constraint) (:b constraint) (:bindings bindings-and-errors))] - (if (= :fail result) - (assoc bindings-and-errors :type-errors (cons {:type-error true - :a (:a constraint) - :b (:b constraint) - :constraint constraint - :loc (get-maybe constraint :location)} - (:type-errors bindings-and-errors))) - (assoc bindings-and-errors :bindings result)))) - {:bindings {} :type-errors ()} - constraints)] - (if (< 0 (count (:type-errors step-1))) - step-1 ;; got errors, early return - (let [step-1-bindings (:bindings step-1) - fixed-bindings (reduce (fn [bindings variable] - (let [fixed (recursive-lookup step-1-bindings variable)] - (assoc bindings variable fixed))) - {} - (keys step-1-bindings))] - (assoc step-1 :bindings fixed-bindings))))) - -(defn solver/solve [constraints] - (let [result (solver/solve-constraints-internal constraints) - ;;_ (println (str (str "solver/solve results:\n" result))) - final-bindings (:bindings result) - type-errors (:type-errors result)] - (if (< 0 (count type-errors)) - (do - (println "") - (map (fn [type-error] (print-type-error final-bindings type-error)) - (set type-errors)) ;; turning it to a set because duplicate of errors may occur because we run solver both ways at the moment - ;;(println (str "What we managed to infer:\n" final-bindings "\n")) - (error {:error error-failed-typechecking :show-stacktrace false :message "Failed to typecheck."})) - final-bindings))) - - -;; (solver/solve (list {:a :int :b "b"})) - -;; (solver/solve (list {:a :int :b "b"} -;; {:a "b" :b :int})) - -;; (solver/solve (list {:a :int :b "b"} -;; {:a "a" :b "b" -;; :a :int :b "a"})) - -;; (solver/solve (list {:a "a" :b "b"} -;; {:a :int :b "b"})) - -;; (solver/solve (list {:a '(:int :int) :b '("a" "a")})) - -;; (solver/solve (list {:a '("b" :int) :b '(:float "a")})) - -;; (solver/solve (list {:a '("b" :int) :b '(:float "a")})) - -;; (solver/solve (list {:a '("c" "b" :int ("c" "c") "c") :b '(:int :float "a" "d" "a")})) - -;; (solver/solve (list {:a '((:int "a") ("b" :float) ("e" "e")) :b '(("d" :double) (:string "c") (:x :x))})) - -;; ;; (solver/solve (list {:a "a" :b "b"} -;; ;; {:a :int :b "b"} -;; ;; {:a "a" :b :float})) - -;; (tester/set-suite! "new-constraints") - -;; (deftest test-constraint-solving-1 -;; (let [;;_ (println "\n- Constraint solving 1 -") -;; constraints (list {:a :int :b "t0"}) -;; solution (solver/solve constraints) -;; solution-backwards (solver/solve (reverse constraints))] -;; (do -;; (assert-eq solution {"t0" :int}) -;; (assert-eq solution solution-backwards)))) - -;; (deftest test-constraint-solving-2 -;; (let [;;_ (println "\n- Constraint solving 2 -") -;; constraints (list {:a :int :b "t0"} -;; {:a "t1" :b "t0"}) -;; solution (solver/solve constraints) -;; ;;_ (println "\n- Backwards -") -;; solution-backwards (solver/solve (reverse constraints))] -;; (do -;; (assert-eq solution {"t0" :int "t1" :int}) -;; (assert-eq solution solution-backwards)))) - -;; (deftest test-constraint-solving-3 -;; (let [;;_ (println "\n- Constraint solving 3 -") -;; constraints (list {:a (list :bool :float) :b (list "t0" "t1")}) -;; solution (solver/solve constraints) -;; ;;_ (println "\n- Backwards -") -;; solution-backwards (solver/solve (reverse constraints))] -;; (do -;; (assert-eq solution {"t0" :bool "t1" :float}) -;; (assert-eq solution solution-backwards)))) - -;; (deftest test-constraint-solving-4 -;; (let [;;_ (println "\n- Constraint solving 4 -") -;; constraints (list {:a (list :ref "t0") :b (list :ref :string)}) -;; solution (solver/solve constraints) -;; ;;_ (println "\n- Backwards -") -;; solution-backwards (solver/solve (reverse constraints))] -;; (do -;; (assert-eq solution {"t0" :string}) -;; (assert-eq solution solution-backwards)))) - -;; (deftest test-constraint-solving-5 -;; (let [;;_ (println "\n- Constraint solving 5 -") -;; constraints (list {:a (list :ref "t0") :b "t1"} -;; {:a "t1" :b (list :ref :int)}) -;; solution (solver/solve constraints) -;; ;;_ (println "\n- Backwards -") -;; solution-backwards (solver/solve (reverse constraints))] -;; (do -;; (assert-eq solution {"t0" :int -;; "t1" (list :ref :int)}) -;; (assert-eq solution solution-backwards)))) - -;; (deftest test-constraint-solving-6 -;; (let [;;_ (println "\n- Constraint solving 6 -") -;; constraints (list {:a "t0" :b "t0"} -;; {:a "t0" :b "t1"} -;; {:a "t1" :b :float} -;; {:a "t1" :b "t1"}) -;; solution (solver/solve constraints) -;; ;;_ (println "\n- Backwards -") -;; solution-backwards (solver/solve (reverse constraints))] -;; (do -;; (assert-eq solution {"t0" :float -;; "t1" :float}) -;; (assert-eq solution solution-backwards)))) - -;; (deftest test-constraint-solving-7 -;; (let [;;_ (println "\n- Constraint solving 7 -") -;; constraints (list {:a "t0" :b "t1"} -;; {:a '(:Array "t1") :b '(:Array "t2")} -;; {:a "t2" :b :int}) -;; solution (solver/solve constraints) -;; ;;_ (println "\n- Backwards -") -;; solution-backwards (solver/solve (reverse constraints))] -;; (do -;; (assert-eq solution {"t0" :int -;; "t1" :int -;; "t2" :int}) -;; (assert-eq solution solution-backwards)))) - -;; (deftest test-constraint-solving-8 -;; (let [;;_ (println "\n- Constraint solving 8 -") -;; constraints (list -;; {:a '(:fn (:Array "t3")) :b "t2"} -;; {:a '(:fn (:Array "t1")) :b "t2"} -;; {:a "t3" :b :int} -;; ) -;; solution (solver/solve constraints) -;; ;;_ (println "\n- Backwards -") -;; solution-backwards (solver/solve (reverse constraints))] -;; (do -;; (assert-eq solution { -;; "t1" :int -;; "t2" '(:fn (:Array :int)) -;; "t3" :int}) -;; (assert-eq solution solution-backwards)))) - -;; (deftest test-subst-in-nested-list -;; (assert-eq -;; {"a" '(:foo (:goo :int))} -;; (replace-subst-from-right-fast {"a" '(:foo (:goo "b"))} "b" :int))) - -;; (deftest test-constraint-solving-9 -;; (let [;;_ (println "\n- Constraint solving 8 -") -;; constraints (list -;; {:a "t3" :b :int} -;; {:a '(:fn (:Array "t3")) :b '(:fn "t2")} -;; ) -;; solution (solver/solve constraints) -;; ;;_ (println "\n- Backwards -") -;; solution-backwards (solver/solve (reverse constraints)) -;; ] -;; (do -;; (assert-eq solution { -;; "t2" '(:Array :int) -;; "t3" :int}) -;; (assert-eq solution solution-backwards) -;; ))) - -;; (deftest test-constraint-solving-10 -;; (let [;;_ (println "\n- Constraint solving 10 -") -;; constraints (list - -;; {:a "x", -;; :b '(:BLURG :FLORP)} - -;; {:a '("y" "c"), -;; :b '(("a" "b") "a")} - -;; {:a "x" -;; :b "y"} - -;; ) -;; solution (solver/solve constraints) -;; ;;_ (println "\n- Backwards -") -;; solution-backwards (solver/solve (reverse constraints))] -;; (do -;; (assert-eq solution {"a" :BLURG -;; "b" :FLORP -;; "c" :BLURG -;; "x" '(:BLURG :FLORP) -;; "y" '(:BLURG :FLORP)}) -;; (assert-eq solution solution-backwards)))) - -;; ;;(tester/run-suite "new-constraints") diff --git a/lisp/signatures.carp b/lisp/signatures.carp deleted file mode 100644 index 211e1bbee..000000000 --- a/lisp/signatures.carp +++ /dev/null @@ -1,36 +0,0 @@ -;; Set type signatures for primops -;; These signatures are used when compiling to C to ensure correct instantiation of primops in the generics-module - -;; (defmacro set-signature! (sym sig) -;; `(meta-set! ~sym :signature '~sig)) - -(defmacro set-signature! (sym sig) - (list meta-set! sym :signature (list quote sig))) - -(set-signature! array-of-size (:fn (:int) (:Array "T") )) - -(set-signature! array-set (:fn ((:Array "T") :int "T") (:Array "T") )) -(set-signature! nth (:fn ((:ref (:Array "T")) :int) (:ref "T") )) -(set-signature! count (:fn ((:ref (:Array "T"))) :int )) - -(set-signature! map (:fn ((:fn ("a") "a") (:Array "a")) (:Array "a"))) -(set-signature! map-copy (:fn ((:fn ((:ref "a")) "b") (:ref (:Array "a"))) (:Array "b") )) - -(set-signature! reduce (:fn ((:fn ("a" (:ref "b")) "a") "a" (:ref (:Array "b"))) "a")) -(set-signature! filter (:fn ((:fn ("a") :bool) (:Array "a")) (:Array "a"))) ;; lambda should take ref?! - -(set-signature! copy (:fn ((:ref "T")) "T" )) -(set-signature! delete (:fn ("T") :void )) -(set-signature! str (:fn ("a") :string )) -(set-signature! prn (:fn ("a") :string )) - -(set-signature! = (:fn ("a", "a") :bool )) - -(set-signature! error (:fn ((:ref :string)) "T" )) - -;; str-replace -;; concat (arrays) -;; map2 -;; reduce -;; sort-by - diff --git a/lisp/string_array.carp b/lisp/string_array.carp deleted file mode 100644 index 212168e0f..000000000 --- a/lisp/string_array.carp +++ /dev/null @@ -1,207 +0,0 @@ - -;; typedef string* string_array; - -;; EXPORT string_array string_array_new(int size) { -;; string_array a = calloc(size + 1, sizeof(string)); -;; for(int i = 0; i < size; i++) { -;; a[i] = strdup(""); -;; } -;; return a; -;; } - -;; EXPORT int string_array_count(string_array array) { -;; int i = 0; -;; string_array p = array; -;; while(*p) { -;; i++; -;; p++; -;; } -;; return i; -;; } - -;; EXPORT string string_array_get(string_array array, int pos) { -;; return strdup(array[pos]); -;; } - -;; EXPORT string_array string_array_set(string_array array, int pos, string new_value) { -;; array[pos] = strdup(new_value); -;; return array; -;; } - -;; typedef string (*string_to_string_fn)(string); - -;; EXPORT string_array string_array_map(string_to_string_fn f, string_array array) { -;; string_array p = array; -;; while(*p) { -;; string old_string = *p; -;; string new_string = f(old_string); -;; *p = new_string; -;; p++; -;; } -;; return array; -;; } - - -(register-builtin "string_array_new" '(:int) ':string-array) -(register-builtin "string_array_count" '((:ref :string-array)) :int) -(register-builtin "string_array_get" '((:ref :string-array) :int) :string) -(register-builtin "string_array_set" '(:string-array :int (:ref :string)) :string-array) -(register-builtin "string_array_map" '((:fn (:string) :string) :string-array) :string-array) - -(def s (string-array-new 3)) -(def s1 (string-array-set s 0 "yeah")) -(def s2 (string-array-set s1 1 "oh")) -(def s3 (string-array-set s2 2 "YEAH!")) - -(defn string-array-print (a) - (let [count (string-array-count a) - i 0] - (do (print "[") - (while (< i count) - (do (print "'") - (print (ref (string-array-get a i))) - (print "'") - (when (not (= i (dec count))) - (print " ")) - (reset! i (inc i)) - )) - (println "]")))) -(bake string-array-print) - -(defn sf1 () - (let [a0 (string-array-new 2) - a1 (string-array-set a0 0 "Hello, ")] - (string-append (ref (string-array-get (ref a1) 0)) "YEAH"))) - -(defn test-string-array-1 () - (do - (bake sf1) - (assert-eq "Hello, YEAH" (sf1)))) -(test-string-array-1) - - -(defn sf2 () - (let [a0 (string-array-new 2)] - (let [a1 (string-array-set a0 0 "Hello, ")] - (let [a2 (string-array-set a1 1 "world!")] - (string-append (ref (string-array-get (ref a2) 0)) (ref (string-array-get (ref a2) 1))))))) - -(defn test-string-array-2 () - (do - (bake sf2) - (assert-eq "Hello, world!" (sf2)))) -(test-string-array-2) - - -(defn sf3 () - (let [a0 (string-array-new 2) - a1 (string-array-set a0 0 "Hello, ")] - (do (string-array-new 10) - (let [a2 (string-array-set a1 1 "world!")] - (string-append (ref (string-array-get (ref a2) 0)) - (ref (string-array-get (ref a2) 1))))))) - -(defn test-string-array-3 () - (do - (bake sf3) - (assert-eq "Hello, world!" (sf3)) - )) -(test-string-array-3) - - -(defn sf4 (b) - (let [a (string-array-new 5)] - (if b - a - (let [extra (string-array-new 5)] - extra)))) - -(defn test-string-array-4 () - (do - (bake sf4) - (sf4 true) - (sf4 false) - )) -(test-string-array-4) - - -(defn sf5 (b) - (let [a (string-array-set (string-array-new 5) 0 "bleh")] - (if b - a - (let [extra (string-array-set (string-array-new 5) 0 "yeah")] - extra)))) - -(defn test-string-array-5 () - (do - (bake sf5) - (sf5 true) - (sf5 false) - )) -(test-string-array-5) - - -(defn sf6 (b) - (let [a (string-array-set (string-array-new 6) 0 "bleh")] - (if b - (string-copy "whut") - (let [extra (string-array-set (string-array-new 6) 0 "yeah")] - (string-copy "sup"))))) - -(defn test-string-array-6 () - (do - (bake sf6) - (sf6 true) - (sf6 false) - )) -(test-string-array-6) - - -(defn sf7 () - (let [a0 (string-array-new 2) - a1 (string-array-set a0 0 "a") - a2 (string-array-set a0 1 "b")] ;; Referencing a0 again, even though it was given away above! - a2)) - -(defn test-string-array-7 () - (not (nil? (catch-error (bake sf7))))) -(test-string-array-7) - - -(defn string-array-last (xs) - (let [count (string-array-count xs)] - (string-array-get xs (- count 1)))) - -(defn test-string-array-last () - (do - (bake string-array-last) - (let [s0 (string-array-new 10) - s1 (string-array-set s0 9 "yo")] - (do (assert-eq "yo" (string-array-last s1)))))) -(test-string-array-last) - -(defn fill-array-recursive (a pos value) - (let [count (string-array-count (ref a))] - (if (< pos count) - (fill-array-recursive (string-array-set a pos value) (+ pos 1) value) - a))) - -(defn fill-array (a value) - (let [count (string-array-count (ref a))] - (do (for [i 0 count] - (string-array-set a i value)) - a))) - -(defn string-array-new-init (n init) - (fill-array-recursive (string-array-new n) 0 init)) - -(defn exclaim (s) - (string-append (ref s) "!")) - -(bake exclaim) - -(defn test-smap () - (string-array-print (ref (string-array-map exclaim (string-array-new-init 5 "yo"))))) - -(defn test-smap-2 () - (string-array-print (ref (string-array-new-init 5 "yo")))) diff --git a/lisp/structs.carp b/lisp/structs.carp deleted file mode 100644 index 27922e8e5..000000000 --- a/lisp/structs.carp +++ /dev/null @@ -1,429 +0,0 @@ - -;; Should there be a way to mark existing C-structs? -;; (defmacro register-struct [struct-name] -;; (register-struct-internal (str struct-name))) - -;; (defn register-struct-internal [struct-name] -;; (let [type-definition nil -;; group-name "" -;; dependency-level 0 -;; copy-signature (list :fn (list (list :ref (keyword struct-name))) (keyword struct-name))] -;; (do -;; ;;(graph/add-node! :struct struct-name type-definition "" group-name nil '() dependency-level) -;; (graph/add-node! :struct (generic-name "copy" copy-signature) nil "" group-name nil '() dependency-level)))) - - - -(defmacro defstruct (struct-name struct-members) - (let [names-and-types (split-every-second (array-to-list struct-members))] - (list 'defstruct-internal - (str struct-name) - (keyword (name struct-name)) - (cons 'array (map str (first names-and-types))) - (cons 'array (map (fn [x] (list 'quote x)) (second names-and-types)))))) - -(def log-redefining-struct false) - -(defn defstruct-internal [struct-name struct-type member-names member-types] - (do - ;; (println (str "defstruct-internal: " struct-name - ;; " struct-type: " struct-type - ;; " member-names: " member-names - ;; " member-types: " member-types)) - - (assert-eq (count member-names) (count member-types)) - - (when (not (= 0 (count (filter ref? member-types)))) - (error {:error error-struct-with-ref-members - :message (str "Problem with '" struct-name "', structs can't have reference member(s) of type: " (join ", " (filter ref? member-types))) - :show-stacktrace false})) - - (when (def? (symbol struct-name)) - (when log-redefining-struct (println (str "Note: a struct named '" struct-name "' is already defined, overriding.")))) - - (let [dependers (graph/depending-groups struct-name)] - (do - ;;(println (str "defstruct! Dependers for '" struct-name "': " (map :name dependers))) - (graph/unload-group struct-name) - (map graph/unload-group (set (map :group dependers))) - ;;(println (str "graph nodes: " (keys graph))) - - (if (any? generic-type? (array-to-list member-types)) - (do - (eval (list 'def (symbol struct-name) {:struct true - :generic true - :name struct-name - :member-names member-names - :member-types (if BYTECODE_EVAL member-types (list 'quote member-types)) - :member-count (count member-names) - :significant-type-indexes - (if BYTECODE_EVAL - (apply array (significant-type-indexes (array-to-list member-types))) - (cons 'array (significant-type-indexes (array-to-list member-types)))) - })) - - (define-generic-lens-stubs struct-name member-names member-types) - - :generic-struct) - - (do - (build-struct-group struct-name - struct-type - member-names - member-types - (calculate-dependency-level member-types) - (calculate-dependencies member-types)) - - (eval (list 'def (symbol struct-name) {:struct true - :generic false - :name struct-name - :member-names member-names - :member-types (if BYTECODE_EVAL member-types (list 'quote member-types)) - :size (eval (list (symbol (str "size-" struct-name)))) - :member-offsets (map (fn [member] (eval (list (symbol (str struct-name "-offset-" member))))) - member-names) - :member-count (count member-names) - })) - - ;; Finally we can add back the structs that were removed by 'unload-struct-deps' - (map restore (set (map :group (sort-by compare-order dependers)))) - - (keyword struct-name))))))) - -(defn restore [name] - (do - ;;(println (str "restoring " name)) - (let [x (eval (symbol name))] - (cond - (foreign? x) (graph/re-lambda-fy name) ;; todo: bake again? - (and (dict? x) (key-is-true? x :struct)) (defstruct-internal - name - (keyword name) ;; TODO: is this a bug when a generic struct is recompiled? - (:member-names x) - (:member-types x)) - _ (error (str "Can't restore '" name "'.")))))) - -(defn struct-type? [t] - (if (list? t) - (any? struct-type? t) - (let [x (symbol (name t)) - lookup (if (def? x) (eval x) nil)] - (and (dict? lookup) (key-is-true? lookup :struct))))) - -(defn calculate-dependency-level [member-types] - (if (or (= [] member-types) (nil? member-types)) - 0 - (+ 1 (maximum (map (fn [t] - (if (list? t) - (calculate-dependency-level t) - (if (struct-type? t) - (calculate-dependency-level (:member-types (eval (symbol (name t))))) - -1))) - member-types))))) - -;; Takes a list of types and returns a list of strings with the name of the depencies -(defn calculate-dependencies [member-types] - (remove (fn [n] (= n "Array")) ;; <- this is a temporary hack! - (map type-to-dependency-name (filter struct-type? (array-to-list member-types))))) - -(defn type-to-dependency-name [x] - (cond - (nil? x) (error "Can't convert nil to dependency") - (keyword? x) (name x) - (list? x) (type-to-dependency-name (first x)) - :else (error (str "Can't handle: " x)))) - -(defn build-struct-group [struct-name struct-type member-names member-types dependency-level deps] - (let [c-struct-name (c-ify-name struct-name) - ;;struct-type (keyword struct-name) - member-names (if (array? member-names) (array-to-list member-names) member-names) ;; TODO: This conversion is UGGLY! - c-member-names (map c-ify-name member-names) - member-types (if (array? member-types) (array-to-list member-types) member-types) ;; TODO: This one too!!! - constructor-name (str "new-" struct-name) - c-constructor-name (c-ify-name constructor-name) - c-file-name (str out-dir constructor-name ".c") - constructor-signature (list :fn member-types struct-type) - ;;_ (println (str "member-types: " member-types)) - type-def-c (join " " (map2 (fn [t n] (str (type-build t) " " n ";")) member-types c-member-names)) - type-definition (str "typedef struct { " type-def-c " } " c-struct-name ";") - group-name "" ;; struct-name - ] - (do - (graph/add-node! :struct struct-name type-definition "" group-name nil '() dependency-level) - (let [arg-list-c (join ", " (map2 (fn [t n] (str (type-build t) " " n)) member-types c-member-names)) - proto (str "API " c-struct-name " *" c-constructor-name "(" arg-list-c ");") - substs {"STRUCT-NAME" c-struct-name - "CONSTRUCTOR-NAME" c-constructor-name - "ARG_LIST" arg-list-c - "SETTERS" (join "\n " (map (fn [n] (str "new_struct->" n " = " n ";")) c-member-names))} - c-program-string (template - "API STRUCT-NAME *CONSTRUCTOR-NAME(ARG_LIST) { - STRUCT-NAME *new_struct = malloc(sizeof(STRUCT-NAME)); - SETTERS - return new_struct; -}" - substs) - group (concat - (list {:name constructor-name - :proto proto - :src c-program-string - :sig constructor-signature} - (let [size-signature (list :fn () :int) - size-proto (str "API int size_" c-struct-name "()") - size-c (str size-proto " { return sizeof(" c-struct-name "); } ")] - (lens-function (str "size-" struct-name) size-proto size-c size-signature))) - (apply concat (map2 (fn [mem-name mem-type] - (lens-functions struct-name struct-type mem-name mem-type)) - member-names - member-types)))] - (do - ;;(println (str "group: " group)) - (compiler/bake-group struct-name group deps)))))) - -(defn lens-functions [struct-name struct-type member-name member-type] - (do - ;;(println (str "Generating lens for '" struct-name "'-member '" member-name "' of type " member-type ", struct-type is " struct-type)) - (let [c-struct-name (c-ify-name struct-name) - struct-t (type-build struct-type) - member-t (type-build member-type) - member-t-reffed (if (primitive-type? member-type) - member-type - (list :ref member-type)) - c-member-name (c-ify-name member-name)] - (list - (let [getter-signature (list :fn (list (list :ref struct-type)) member-t-reffed) - getter-proto (str "API " member-t " " c-struct-name "_get_" (c-ify-name member-name) "(" struct-t " x)") - getter-c (str getter-proto "{ return x->" c-member-name "; }")] - (lens-function (str struct-name "-get-" member-name) getter-proto getter-c getter-signature)) - (let [setter-signature (list :fn (list struct-type member-type) struct-type) - setter-proto (str "API " struct-t " " c-struct-name "_set_" (c-ify-name member-name) "(" struct-t " x, " member-t " value)") - setter-c (str setter-proto "{ x->" c-member-name " = value; return x; }")] - (lens-function (str struct-name "-set-" member-name) setter-proto setter-c setter-signature)) - (let [updater-fn-type (list :fn (list member-type) member-type) - updater-fn-t (type-build updater-fn-type) - updater-signature (list :fn (list struct-type updater-fn-type) struct-type) - updater-proto (str "API " struct-t " " c-struct-name "_update_" (c-ify-name member-name) "(" struct-t " x, " updater-fn-t " f)") - updater-c (str updater-proto "{ x->" c-member-name " = f(x->" c-member-name "); return x; }")] - (lens-function (str struct-name "-update-" member-name) updater-proto updater-c updater-signature)) - (let [offset-signature (list :fn () :int) - offset-proto (str "API " "int " c-struct-name "_offset_" (c-ify-name member-name) "()") - offset-c (str offset-proto "{ return offsetof(" (c-ify-name struct-name) ", " c-member-name "); }")] - (lens-function (str struct-name "-offset-" member-name) offset-proto offset-c offset-signature)))))) - -(defn lens-function [func-name proto src func-signature] - (do - (when (graph/node-exists? func-name) - (do - (println (str "WARNING! Overriding lens function: " func-name)) - ;;(graph/unload func-name) - )) - {:name func-name - :proto (str proto ";") - :src src - :sig func-signature})) - -(defn concretize-struct [struct-name concrete-struct-name concrete-types] - (do - ;;(println (str "\nconcretize-struct: " struct-name ", concrete-struct-name: " concrete-struct-name ", concrete-types: " concrete-types)) - (let [struct-description (eval (symbol struct-name)) - ;;_ (println (str "struct-description: " struct-description)) - - member-names (:member-names struct-description) - member-types (:member-types struct-description) - - ;; _ (when (not (= (count concrete-types) (count (set (array-to-list member-types))))) - ;; (error (str "The nr of concrete types must match the number of unique member-types: " - ;; concrete-types " vs " - ;; (set member-types)))) - - mapping (reduce (fn [the-map key-value-pair] - (if (typevar? (first key-value-pair)) - (assoc the-map (first key-value-pair) (second key-value-pair)) - the-map)) - {} - (map2 (fn [k v] (list k v)) (array-to-list member-types) concrete-types)) - ;;_ (println (str "mapping:\n" mapping)) - - significant-type-indexes (:significant-type-indexes struct-description) - ;;_ (println (str "significant-type-indexes: " significant-type-indexes)) - - instantiated-significants (map (fn [i] - (nth concrete-types i)) - significant-type-indexes) - - ;;_ (println (str "instantiated-significants: " instantiated-significants)) - - struct-type (cons (keyword struct-name) (array-to-list instantiated-significants)) - ;;_ (println (str "struct-type: " struct-type)) - - ] - (if (def? (symbol concrete-struct-name)) - (do ;;(println (str "Will not concretize " concrete-struct-name " again.")) - :ignore) - (defstruct-internal - concrete-struct-name - struct-type - member-names - (apply array concrete-types)) - )))) - -;; struct-type is an list of concrete types, -;; beginning with the type of the generic struct -;; i.e. (:Pair :int) -(defn concretize-struct-simple [struct-type] - (do - ;;(println (str "\nconcretize-struct-simple: " struct-type)) - (let [struct-base-type (first struct-type) - known-types (rest struct-type) - struct-description (eval (symbol (name struct-base-type))) - _ (assert-eq (count known-types) (count (:significant-type-indexes struct-description))) - ;; _ (println (str "struct-description:\n" struct-description)) - - member-types (:member-types struct-description) - - substs (reduce (fn [the-map key-value-pair] - (assoc the-map (first key-value-pair) (second key-value-pair))) - {} - (map2 (fn [i t] - (list (nth member-types i) t)) - (array-to-list (:significant-type-indexes struct-description)) - known-types)) - - ;; _ (println (str "substs: " substs)) - - struct-concrete-types (map (fn [t] - (if (typevar? t) - (get substs t) - t)) - (array-to-list member-types)) - - ;; _ (println (str "struct-concrete-types: " struct-concrete-types)) - struct-base-name (name struct-base-type) - struct-concrete-name (generic-safe-name struct-type)] - ;;(println (str "concretize-struct: " struct-base-name " " struct-concrete-name " " struct-concrete-types)) - (concretize-struct struct-base-name struct-concrete-name struct-concrete-types)))) - -;; Returns the indexes of the first occurence of each typevar in a list of types -;; Example 1 - ("a" "a" "b" "b") => [0 2] -;; Example 2 - (:int :int "t" "s" "t") => [2 3] -;; Example 3 - ("x" "y" "z") => [0 1 2] -(defn significant-type-indexes [types] - (map first - (reduce - (fn [indexes pair] - (if (and (typevar? (second pair)) - (not (contains? (map second indexes) (second pair)))) - (cons-last indexes pair) - indexes)) - '() - (map2 (fn [i t] (list i t)) (range 0 (count types)) types)))) - -(defn dynamic-generic-constructor-call [struct-description args] - (let [;;_ (println (str "dynamic-generic-constructor-call:\n" struct-description "\nargs: " args)) - struct-name (:name struct-description) - arg-list (array-to-list args) - concrete-types (map type-of-value arg-list) - member-types (:member-types struct-description) - unique-typevars (typevars-from-member-types member-types) - significants (:significant-type-indexes struct-description) - significant-types (array-to-list (map (fn [i] (nth concrete-types i)) significants)) - struct-type (cons (keyword struct-name) significant-types) - concrete-struct-name (generic-safe-name struct-type)] - (do - (when (not (def? (symbol concrete-struct-name))) - (do - ;; (println (str struct-description)) - ;; (println (str "struct-name: " struct-name - ;; " concrete-struct-name: " concrete-struct-name - ;; " concrete-types: " concrete-types - ;; " significant-types: " significant-types - ;; )) - (concretize-struct struct-name concrete-struct-name concrete-types))) - (let [constructor-call (cons (symbol concrete-struct-name) arg-list) - ;;_ (println (str "constructor-call: " constructor-call)) - struct-instance (eval constructor-call)] - (do (meta-set! struct-instance :type struct-type) - struct-instance))))) - -(defn index-of [xs x] - (let [result nil] - (do - (for (i 0 (count xs)) - (if (= x (nth xs i)) - (reset! result i) - nil)) - (if (nil? result) - (error (str "Can't find " x " in " xs)) - result)))) - -(defn define-generic-lens-stubs [struct-name member-names member-types] - (do - ;;(println (str "Defining generic lens stubs for " struct-name)) ;; " with member types " member-types)) - - (map2 (fn [n t] - (let [get-sym (symbol (str struct-name "-get-" n)) - set-sym (symbol (str struct-name "-set-" n)) - update-sym (symbol (str struct-name "-update-" n)) - generic-vars (reverse (set (array-to-list (filter string? member-types)))) - generic-struct-t (cons (keyword struct-name) generic-vars) - ;;_ (println (str "generic-struct-t: " generic-struct-t)) - t (nth member-types (index-of member-names n)) - get-s (list :fn (list generic-struct-t) t) - set-s (list :fn (list generic-struct-t t) generic-struct-t) - update-s (list :fn (list generic-struct-t (list :fn (list t) t)) generic-struct-t) - ;; _ (println (str "get-s : " (str get-s))) - ;; _ (println (str "set-s : " (str set-s))) - ;; _ (println (str "update-s : " (str update-s))) - ] - (do - ;; GETTER - (eval (list 'defn get-sym (array 'o) (list 'do - (list 'concretize-struct-simple (list :type (list 'meta 'o))) - (list 'eval (list 'list - (list 'symbol (list 'str - (list 'generic-safe-name - (list :type (list 'meta 'o))) - "-get-" - n)) - 'o))))) - (eval (list 'meta-set! get-sym :generic-lens-stub true)) - (eval (list 'meta-set! get-sym :struct struct-name)) - (eval (list 'meta-set! get-sym :generic true)) - (eval (list 'meta-set! get-sym :signature (list 'quote get-s))) - (eval (list 'meta-set! get-sym :stub-ending (str "-get-" n))) - - ;; SETTER - (eval (list 'defn set-sym (array 'o 'v) (list 'do - (list 'concretize-struct-simple (list :type (list 'meta 'o))) - (list 'eval (list 'list - (list 'symbol (list 'str - (list 'generic-safe-name - (list :type (list 'meta 'o))) - "-set-" - n)) - 'o 'v))))) - (eval (list 'meta-set! set-sym :generic-lens-stub true)) - (eval (list 'meta-set! set-sym :struct struct-name)) - (eval (list 'meta-set! set-sym :generic true)) - (eval (list 'meta-set! set-sym :signature (list 'quote set-s))) - (eval (list 'meta-set! set-sym :stub-ending (str "-set-" n))) - - ;; UPDATER - (eval (list 'defn update-sym (array 'o 'f) (list 'do - (list 'concretize-struct-simple (list :type (list 'meta 'o))) - (list 'eval (list 'list - (list 'symbol (list 'str - (list 'generic-safe-name - (list :type (list 'meta 'o))) - "-update-" - n)) - 'o 'f))))) - (eval (list 'meta-set! update-sym :generic-lens-stub true)) - (eval (list 'meta-set! update-sym :struct struct-name)) - (eval (list 'meta-set! update-sym :generic true)) - (eval (list 'meta-set! update-sym :signature (list 'quote update-s))) - (eval (list 'meta-set! update-sym :stub-ending (str "-update-" n))) - ))) - member-names - member-types))) - diff --git a/lisp/test_arrays.carp b/lisp/test_arrays.carp deleted file mode 100644 index b73cbb6ba..000000000 --- a/lisp/test_arrays.carp +++ /dev/null @@ -1,96 +0,0 @@ -(tester/set-suite! "arrays") - -(deftest test-array-literal - (do - (defn array-literal [] - [10 20 30]) - (bake array-literal))) - -(deftest test-get-a-float - (do - (defn get-a-float [xs] - (* 2.0f (copy (nth xs 0)))) - (bake get-a-float))) - -(deftest test-small-array - (do - (defn small-array [] - (let [a (array-of-size 3) - b (array-set a 0 10) - c (array-set b 1 20) - d (array-set c 2 30)] - d)) - (bake small-array))) - -(deftest test-small-array-2 - (do - (defn small-array-2 [] - (array-set - (array-set - (array-set - (array-of-size 3) - 0 10) - 1 20) - 2 30)) - (bake small-array-2))) - -(deftest test-array-literal - (do - (defn array-literal [] - [10 20 30]) - (bake array-literal))) - -(deftest test-array-literal-2 - (do - (defn array-literal-2 [] - [10.1 20.7 30.2]) - (bake array-literal-2))) - -(deftest test-array-of-arrays - (do - (defn array-of-arrays [] - [(array-literal) (array-literal)]) - - (bake array-of-arrays))) - -(deftest test-print-array-of-vector - (do - (defstruct Vector - [vectorX :int - vectorY :int]) - (let [vecs [(Vector 1001 1002) - (Vector 1003 1004) - (Vector 1005 1006)]] - (assert-eq "[(Vector 1001 1002) (Vector 1003 1004) (Vector 1005 1006)]" (str vecs))))) - -(deftest test-nesting - (do - (defn nesting [] - [[(copy "hej")]]) - (bake nesting))) - -(deftest test-copy-an-array-1 - (do - (defn copy-an-array-1 [] - (let [a [100]] - (copy (ref a)))) - (bake copy-an-array-1) - (assert-eq (str [100]) (str (copy-an-array-1))))) - -(deftest test-copy-an-array-2 - (do - (defn copy-an-array-2 [] - (let [a [[1] [2]] - b (copy (ref a))] - b)) - (bake copy-an-array-2) - (assert-eq [[1] [2]] (copy-an-array-2)))) - -(deftest disallow-refs-in-array - (do - (defn refs-in-array-func [] - (let [a ["bleh"]] - a)) - (assert-error error-ref-in-array (bake refs-in-array-func)))) - -(tester/run-suite "arrays") diff --git a/lisp/test_baking.carp b/lisp/test_baking.carp deleted file mode 100644 index 3722ff125..000000000 --- a/lisp/test_baking.carp +++ /dev/null @@ -1,167 +0,0 @@ -(tester/set-suite! "baking") - -(deftest test-fib - (do - (defn fib (n) - (if (< n 2) - 1 - (+ (fib (- n 2)) (fib (- n 1))))) - (bake fib) - (assert-eq (fib 6) 13) - (assert-eq (type fib) :foreign) - :fib-is-ok)) - -(deftest test-hypo - (do (defn hypo [x y] - (sqrtf (+ (* x x) (* y y)))) - (bake hypo) - (assert-approx-eq (hypo 3.0f 4.0f) 5.0f) - (assert-eq (type hypo) :foreign) - :hypo-is-ok)) - -(deftest test-loading - (do - (save (str carp-dir "out/out.c") "int f() { return 100; }") - (system (str "clang -shared -o " carp-dir "out/f.so " carp-dir "out/out.c")) - (def flib (load-dylib (str carp-dir "out/f.so"))) - (register flib "f" () :int) - (assert-eq 100 (f)) - - (save (str carp-dir "out/out.c") "int g() { return 150; }") - (system (str "clang -shared -o " carp-dir "out/g.so " carp-dir "out/out.c")) - (def glib (load-dylib (str carp-dir "out/g.so"))) - (register glib "g" () :int) - (assert-eq 150 (g)) - - (unload-dylib flib) - - (save (str carp-dir "out/out.c") "int f() { return 200; }") - (system (str "clang -shared -o " carp-dir "out/f.so " carp-dir "out/out.c")) - (def flib (load-dylib (str carp-dir "out/f.so"))) - (register flib "f" () :int) - (assert-eq 200 (f)) - )) - -(deftest test-auto-chain-bake-1 - (do - (defn f1 () 100) - (defn f2 () 200) - (defn f3 () (+ (f1) (f2))) - (bake f3) - (assert-eq (f3) 300))) -(test-auto-chain-bake-1) - -(deftest test-auto-chain-bake-2 - (do - (defn f4 () 100) - (defn f5 (x) (+ x 1)) - (defn f6 () (let [z (f5 (f4))] - z)) - (bake f6) - (assert-eq (f6) 101))) -(test-auto-chain-bake-2) - -(deftest test-unloading-depending-functions - (do - (defn f7 [] 100) - (bake f7) - (assert-eq 100 (f7)) - - (defn f8 [] (f7)) - (bake f8) - (assert-eq 100 (f8)) - - (defn f9 [] (f7)) - (bake f9) - (assert-eq 100 (f9)) - - (defn f10 [] (f9)) - (bake f10) - (assert-eq 100 (f10)) - - (defn f7 [] 200) - (bake f7) - - (assert-eq 200 (f7)) - (assert-eq 200 (f8)) - (assert-eq 200 (f9)) - (assert-eq 200 (f10)))) - - -;; LET BINDINGS -(deftest test-recursive-let - (do - (defn recursive-let () - (let [;; The other definition order should get caught by compiler, not clang: - y "whaaaaaaat" - x (string-append "hej" (ref (itos (strlen y)))) - ] - x)) - (bake recursive-let))) - - -;; FUNCTION POINTERS -(deftest test-call-twice - (do (defn call-twice (f) - (do (strlen (ref (f))) (f))) - (defn call-me () - (string-copy "CARP!")) - (bake call-twice) - (bake call-me) - (assert-eq "CARP!" (call-twice call-me)))) - - -;; COMPILE TIME MACROS -(deftest test-macro-1 - (do (defn macro-1 () - (if-not true - 10 - 20)) - (bake macro-1) - (assert-eq (macro-1) 20))) - - -;; PIPE MACROS -(deftest test-baking-of-pipe-last-macro - (do (defn baking-of-pipe-last-macro [] - (->> [10 20 30] - (map inc))) - (bake baking-of-pipe-last-macro) - (assert-eq "[11 21 31]" (str (baking-of-pipe-last-macro))))) - - -(deftest test-baking-of-pipe-first-macro - (do (defn baking-of-pipe-first-macro [] - (-> 10 - (- 2) - (* 2))) - (bake baking-of-pipe-first-macro) - (assert-eq 16 (baking-of-pipe-first-macro)))) - - -;; BAKING OF GROUPS -(deftest test-bake-group - (do - (def example-descriptor-1 {:src "int f() { return 42; }" - :proto "int f();" - :name "f" - :sig '(:fn () :int)}) - - (def example-descriptor-2 {:src "int g() { return f() + f(); }" - :proto "int g();" - :name "g" - :sig '(:fn () :int)}) - (defn h [] (f)) ;; uses f in 'efgroup' - (compiler/bake-group "efgroup" (list example-descriptor-1 example-descriptor-2) ()) - (bake h))) - -(tester/run-suite "baking") - - -;; This does NOT work! -(defn shadow [x] - (let [x (* x 3)] - x)) -;; (def shadowast (lambda-to-ast (code shadow))) -;; (def shadowcon (gencon shadowast)) -;; (def shadowasta (annotate-ast shadowast)) diff --git a/lisp/test_binops.carp b/lisp/test_binops.carp deleted file mode 100644 index 6aa7233b9..000000000 --- a/lisp/test_binops.carp +++ /dev/null @@ -1,55 +0,0 @@ -(tester/set-suite! "binops") - -(deftest test-and-1 - (do - (defn use-and-1 [] - (and true false)) - (bake use-and-1) - (assert-eq false (use-and-1)))) - -(deftest test-and-2 - (do - (defn use-and-2 [] - (and true true)) - (bake use-and-2) - (assert-eq true (use-and-2)))) - -(deftest test-and* - (do - (defn use-and* [] - (and* true true true false true)) - (bake use-and*) - (assert-eq false (use-and*)))) - -(deftest test-or-1 - (do - (defn use-or-1 [] - (or true false)) - (bake use-or-1) - (assert-eq true (use-or-1)))) - -(deftest test-or-2 - (do - (defn use-or-2 [] - (or false false)) - (bake use-or-2) - (assert-eq false (use-or-2)))) - -(deftest test-or* - (do - (defn dont-evaluate-this [] - (do (println "don't evaluate this") - false)) - (defn use-or* [] - (or* false false false true false (dont-evaluate-this))) - (bake use-or*) - (assert-eq true (use-or*)))) - -(deftest test-short-circuit - (do - (defn failsafe [] - (or true (error "fail!!!"))) - (bake failsafe) - (assert-eq true (failsafe)))) - -(tester/run-suite "binops") diff --git a/lisp/test_constraints.carp b/lisp/test_constraints.carp deleted file mode 100644 index e01eb95e1..000000000 --- a/lisp/test_constraints.carp +++ /dev/null @@ -1,153 +0,0 @@ -(tester/set-suite! "constraints") - -(deftest test-replace-from-right - (do - (assert-eq (replace-subst-from-right-fast {:a :b :c :d} :b :e) {:a :e :c :d}) - (assert-eq (replace-subst-from-right-fast {:a :b :c :b} :b :e) {:a :e :c :e}) - (assert-eq (replace-subst-from-right-fast {:a (list :b :b) :c :d} :b :f) {:a (list :f :f) :c :d}))) - -(deftest test-constraint-solving-1 - (let [;;_ (println "\n- Constraint solving 1 -") - constraints (list {:a :int :b "t0"}) - solution (solve-constraints constraints) - solution-backwards (solve-constraints (reverse constraints))] - (do - (assert-eq solution {"t0" :int}) - (assert-eq solution solution-backwards)))) - -(deftest test-constraint-solving-2 - (let [;;_ (println "\n- Constraint solving 2 -") - constraints (list {:a :int :b "t0"} - {:a "t1" :b "t0"}) - solution (solve-constraints constraints) - ;;_ (println "\n- Backwards -") - solution-backwards (solve-constraints (reverse constraints))] - (do - (assert-eq solution {"t0" :int "t1" :int}) - (assert-eq solution solution-backwards)))) - -(deftest test-constraint-solving-3 - (let [;;_ (println "\n- Constraint solving 3 -") - constraints (list {:a (list :bool :float) :b (list "t0" "t1")}) - solution (solve-constraints constraints) - ;;_ (println "\n- Backwards -") - solution-backwards (solve-constraints (reverse constraints))] - (do - (assert-eq solution {"t0" :bool "t1" :float}) - (assert-eq solution solution-backwards)))) - -(deftest test-constraint-solving-4 - (let [;;_ (println "\n- Constraint solving 4 -") - constraints (list {:a (list :ref "t0") :b (list :ref :string)}) - solution (solve-constraints constraints) - ;;_ (println "\n- Backwards -") - solution-backwards (solve-constraints (reverse constraints))] - (do - (assert-eq solution {"t0" :string}) - (assert-eq solution solution-backwards)))) - -(deftest test-constraint-solving-5 - (let [;;_ (println "\n- Constraint solving 5 -") - constraints (list {:a (list :ref "t0") :b "t1"} - {:a "t1" :b (list :ref :int)}) - solution (solve-constraints constraints) - ;;_ (println "\n- Backwards -") - solution-backwards (solve-constraints (reverse constraints))] - (do - (assert-eq solution {"t0" :int - "t1" (list :ref :int)}) - (assert-eq solution solution-backwards)))) - -(deftest test-constraint-solving-6 - (let [;;_ (println "\n- Constraint solving 6 -") - constraints (list {:a "t0" :b "t0"} - {:a "t0" :b "t1"} - {:a "t1" :b :float} - {:a "t1" :b "t1"}) - solution (solve-constraints constraints) - ;;_ (println "\n- Backwards -") - solution-backwards (solve-constraints (reverse constraints))] - (do - (assert-eq solution {"t0" :float - "t1" :float}) - (assert-eq solution solution-backwards)))) - -(deftest test-constraint-solving-7 - (let [;;_ (println "\n- Constraint solving 7 -") - constraints (list {:a "t0" :b "t1"} - {:a '(:Array "t1") :b '(:Array "t2")} - {:a "t2" :b :int}) - solution (solve-constraints constraints) - ;;_ (println "\n- Backwards -") - solution-backwards (solve-constraints (reverse constraints))] - (do - (assert-eq solution {"t0" :int - "t1" :int - "t2" :int}) - (assert-eq solution solution-backwards)))) - -(deftest test-constraint-solving-8 - (let [;;_ (println "\n- Constraint solving 8 -") - constraints (list - {:a '(:fn (:Array "t3")) :b "t2"} - {:a '(:fn (:Array "t1")) :b "t2"} - {:a "t3" :b :int} - ) - solution (solve-constraints constraints) - ;;_ (println "\n- Backwards -") - solution-backwards (solve-constraints (reverse constraints))] - (do - (assert-eq solution { - "t1" :int - "t2" '(:fn (:Array :int)) - "t3" :int}) - (assert-eq solution solution-backwards)))) - -(deftest test-subst-in-nested-list - (assert-eq - {"a" '(:foo (:goo :int))} - (replace-subst-from-right-fast {"a" '(:foo (:goo "b"))} "b" :int))) - -(deftest test-constraint-solving-9 - (let [;;_ (println "\n- Constraint solving 8 -") - constraints (list - {:a "t3" :b :int} - {:a '(:fn (:Array "t3")) :b '(:fn "t2")} - ) - solution (solve-constraints constraints) - ;;_ (println "\n- Backwards -") - solution-backwards (solve-constraints (reverse constraints)) - ] - (do - (assert-eq solution { - "t2" '(:Array :int) - "t3" :int}) - (assert-eq solution solution-backwards) - ))) - -(deftest test-constraint-solving-10 - (let [;;_ (println "\n- Constraint solving 10 -") - constraints (list - - {:a "x", - :b '(:BLURG :FLORP)} - - {:a '("y" "c"), - :b '(("a" "b") "a")} - - {:a "x" - :b "y"} - - ) - solution (solve-constraints constraints) - ;;_ (println "\n- Backwards -") - solution-backwards (solve-constraints (reverse constraints))] - (do - (assert-eq solution {"a" :BLURG - "b" :FLORP - "c" :BLURG - "x" '(:BLURG :FLORP) - "y" '(:BLURG :FLORP)}) - (assert-eq solution solution-backwards)))) - -(tester/run-suite "constraints") diff --git a/lisp/test_correctness.carp b/lisp/test_correctness.carp deleted file mode 100644 index 34c407fe9..000000000 --- a/lisp/test_correctness.carp +++ /dev/null @@ -1,22 +0,0 @@ -(tester/set-suite! "correctness") - -(deftest test-mutate-global-struct - (do (defstruct Blergh [x :int]) - (defn x2 [x] - (* x 2)) - (defn double-blergh [b] - (Blergh-update-x b x2)) - (def x (Blergh 123)) - (assert-eq "(Blergh 246)" (str (double-blergh x))) - (assert-eq "(Blergh 246)" (str (double-blergh x))) - (assert-eq "(Blergh 246)" (str (double-blergh x))))) - -(deftest test-mutate-global-array - (do (def stuff [1 2 3 4 5]) - (defn map-stuff [x] (map inc x)) - (bake map-stuff) - (assert-eq "[2 3 4 5 6]" (str (map-stuff stuff))) - (assert-eq "[2 3 4 5 6]" (str (map-stuff stuff))) - (assert-eq "[2 3 4 5 6]" (str (map-stuff stuff))))) - -(tester/run-suite "correctness") diff --git a/lisp/test_equality.carp b/lisp/test_equality.carp deleted file mode 100644 index 505c9b552..000000000 --- a/lisp/test_equality.carp +++ /dev/null @@ -1,74 +0,0 @@ -(tester/set-suite! "equality") - -(deftest test-eq-int - (do - (defn eq-int [] - (if (= 5 5) - @"yes" - @"no")) - (bake eq-int) - (assert-eq "yes" (eq-int)))) - -(deftest test-eq-bool - (do - (defn eq-bool [] - (if (= true true) - @"yes" - @"no")) - (defn eq-bool-2 [] - (if (= true false) - @"yes" - @"no")) - (bake eq-bool) - (bake eq-bool-2) - (assert-eq "yes" (eq-bool)) - (assert-eq "no" (eq-bool-2)))) - -(deftest test-eq-char - (do - (defn eq-char [] - (if (= \a \a) - @"yes" - @"no")) - (defn eq-char-2 [] - (if (= \a \b) - @"yes" - @"no")) - (bake eq-char) - (bake eq-char-2) - (assert-eq "yes" (eq-char)) - (assert-eq "no" (eq-char-2)))) - -(deftest test-eq-array - (do - (defn eq-array [] - (if (= &[1 2 3] &[1 2 3]) - @"yes" - @"no")) - (defn eq-array-2 [] - (if (= &[1 2 3] &[1 2 4]) - @"yes" - @"no")) - (bake eq-array) - (bake eq-array-2) - (assert-eq "yes" (eq-array)) - (assert-eq "no" (eq-array-2)))) - -(deftest test-eq-struct - (do - (defstruct CompareMe [compare-me-x :int - compare-me-y :int]) - (defn eq-struct [] - (if (= &(CompareMe 2 3) &(CompareMe 2 3)) - @"yes" - @"no")) - (defn eq-struct-2 [] - (if (= &(CompareMe 2 3) &(CompareMe 2 4)) - @"yes" - @"no")) - (bake eq-struct) - (bake eq-struct-2) - (assert-eq "yes" (eq-struct)) - (assert-eq "no" (eq-struct-2)))) - -(tester/run-suite "equality") diff --git a/lisp/test_generics.carp b/lisp/test_generics.carp deleted file mode 100644 index d037f18b4..000000000 --- a/lisp/test_generics.carp +++ /dev/null @@ -1,147 +0,0 @@ -(tester/set-suite! "generics") - -;; (def id-ast (lambda-to-ast (code id))) -;; (def id-con (gencon id-ast)) -;; (def id-asta (annotate-ast id-ast)) - -(deftest test-generic-id - (do (bake id) - (assert-eq true (meta-get id :generic)))) - -(deftest test-generic-call-1 - (do (defn generic-call-1 [] - (if (id true) 10 20)) - (bake generic-call-1) - (assert-eq (signature generic-call-1) (list :fn () :int)))) - -(deftest test-generic-call-2 - (do (defn generic-call-2 [x] - (+ (id 10) (id x))) - (bake generic-call-2) - (assert-eq (signature generic-call-2) (list :fn '(:int) :int)))) - -(deftest test-generic-call-3 - (do (defn generic-call-3 [x] - (do (reset! x (id true)) - x)) - (bake generic-call-3) - (assert-eq (signature generic-call-3) (list :fn '(:bool) :bool)))) - -(deftest test-generic-call-4 - (do (defn generic-call-4 [] - (let [pi (id 3.14f)] - pi))(bake generic-call-4) - (assert-eq (signature generic-call-4) (list :fn '() :float)))) - -(deftest let-polymorphism-1 - (do - (defn polylet-1 [] - (let [a (id 1) - b (id 2.0)] - a)) - - (bake polylet-1))) - -(deftest let-polymorphism-2 - (do - (defstruct A []) - (defstruct B []) - (defn polylet-2 [] - (let [a (copy (ref (A))) - b (copy (ref (B)))] - b)) - (bake polylet-2))) - -(deftest test-generic-function-calling - (do - (defn a-function-as-argument [x y] - (itos (+ x y))) - (defn generic-function-calling-generic-functions [prob-f prob-a prob-b] - (prob-f prob-a prob-b)) - (defn try-it-out [] - (generic-function-calling-generic-functions a-function-as-argument 10 20)) - (bake try-it-out) - (assert-eq "30" (try-it-out)))) - -(deftest test-uniquify - (let [n (uniquify-typevars '("T" :a "S" "T" ("S")))] - (do (assert-eq (nth n 0) (nth n 3)) - (assert-eq (nth n 2) (get-in n '(4 0))) - (assert-eq false (= (nth n 0) (nth n 2))) - (assert-eq :a (nth n 1))))) - -(deftest test-copy-1 - (do - (defn copy-1 [] - (copy "CARP")) - (bake copy-1) - (assert-eq "CARP" (copy-1)))) - -(deftest test-copy-2 - (do - (defstruct CopyMe [copyMeMember :int]) - (defn copy-2 [] - (copy (ref (CopyMe 666)))) - (bake copy-2) - (assert-eq 666 (CopyMe-get-copyMeMember (copy-2))))) - -(deftest test-copy-3 - (do - (defstruct AnotherCopy [aNameToCopy :string anotherNameToCopy :string]) - (defn copy-3 [n1 n2] - (copy (ref (AnotherCopy n1 n2)))) - (bake copy-3) - (assert-eq "(AnotherCopy @\"AHA\" @\"BUHU\")" (str (ref (copy-3 "AHA" "BUHU")))))) - -;; Test that functions depending on generic functions will be recompiled when the original generic function changes -(deftest test-depending-on-generic - (do - (defn idd [x] x) - (defn use-idd [] - (idd 5)) - (defn use-user [] - (use-idd)) - (bake use-user) - (defn idd [x] (* x 3)) - (bake idd) - (assert-eq :foreign (type idd)) - (assert-eq 15 (use-user)))) - -;; Should put tests of realized generic primops into separate file?! -(deftest test-reduce-struct - (do - (defstruct Bleh [bleh-x :int]) - - (defn add-bleh [b1 b2] - (let [x (get-bleh-x &b1)] - (set-bleh-x b1 (+ x (get-bleh-x b2))))) - - ;;(update-bleh-x b1 (fn [x] (+ x (get-bleh-x b2)))) - - ;; (Bleh (+ (get-bleh-x &b1) - ;; (get-bleh-x b2))) - - (defn reduce-over-bleh [] - (let [stuff [(Bleh 10) (Bleh 20) (Bleh 30)] - a (reduce add-bleh (Bleh 0) &stuff) - b (reduce add-bleh (Bleh 100) &stuff) - c (reduce add-bleh (Bleh 2000) &stuff)] - (println* &[a b c]))))) - -(deftest test-reduce-int - (do - (defn add [a b] - (+ a @b)) - (defn r1 [] - (reduce add 0 &[1 2 3 4 5])))) - -(deftest test-instantiate-generic-struct-from-lens - (do (defstruct Bloop [x :bool - t "T" - z :string]) - (let [b (Bloop true 123 @"hello")] - (do - (assert-eq "hello" (Bloop-get-z b)) - (assert-eq 123 (Bloop-get-t b)))))) - -(tester/run-suite "generics") diff --git a/lisp/test_globals.carp b/lisp/test_globals.carp deleted file mode 100644 index 0140d5b59..000000000 --- a/lisp/test_globals.carp +++ /dev/null @@ -1,87 +0,0 @@ -(tester/set-suite! "globals") - -;; char int float double bool string array struct - -(deftest global-int - (do (def the-int 100) - (bake the-int) - (assert-eq "100 ; ptr-to-global" (str the-int)) - (reset! the-int 200) - (gc) - (assert-eq "200 ; ptr-to-global" (str the-int)))) - -(deftest global-float - (do (def the-float 3.14f) - (bake the-float) - (assert-eq "3.140000f ; ptr-to-global" (str the-float)) - (reset! the-float 6.2f) - (gc) - (assert-eq "6.200000f ; ptr-to-global" (str the-float)))) - -(deftest global-double - (do (def the-double 10.0) - (bake the-double) - (assert-eq "10.000000 ; ptr-to-global" (str the-double)) - (reset! the-double 20.0) - (gc) - (assert-eq "20.000000 ; ptr-to-global" (str the-double)))) - -(deftest global-bool - (do (def the-bool true) - (bake the-bool) - (assert-eq "true ; ptr-to-global" (str the-bool)) - (reset! the-bool false) - (gc) - (assert-eq "false ; ptr-to-global" (str the-bool)))) - -(deftest global-string - (do (def the-string @"CrAP") - (bake the-string) - (assert-eq "CrAP ; ptr-to-global" (str the-string)) - (reset! the-string @"CARP!") - (gc) - (assert-eq "CARP! ; ptr-to-global" (str the-string)))) - -(deftest global-char - (do (def the-char \e) - (bake the-char) - (assert-eq "\\e ; ptr-to-global" (str the-char)) - (reset! the-char \f) - (assert-eq "\\f ; ptr-to-global" (str the-char)))) - -(deftest global-array - (do (def the-array [1 2 3]) - (bake the-array) - (assert-eq "[1 2 3] ; ptr-to-global" (str the-array)) - (reset! the-array [4 5 6]) - (assert-eq "[4 5 6] ; ptr-to-global" (str the-array)))) - -(deftest global-struct - (do (defstruct TheStruct [theStructValue :int]) - (def the-struct (TheStruct 500)) - (bake the-struct) - (assert-eq "(TheStruct 500) ; ptr-to-global" (str the-struct)) - (reset! the-struct (TheStruct 600)) - (gc) - (assert-eq "(TheStruct 600) ; ptr-to-global" (str the-struct)))) - -(deftest global-complex - (do (defstruct ComplexStruct [complex (:Array :int)]) - (def the-complex [(ComplexStruct [1 2 3]) (ComplexStruct [4 5 6])]) - (bake the-complex) - (assert-eq "[(ComplexStruct [1 2 3]) (ComplexStruct [4 5 6])] ; ptr-to-global" (str the-complex)) - (reset! the-complex [(ComplexStruct [7 8 9])]) - (gc) - (assert-eq "[(ComplexStruct [7 8 9])] ; ptr-to-global" (str the-complex)))) - -(deftest global-generic-struct - (do (defstruct Blip [x "T" y "T"]) - (def b1 (Blip 123 666)) - (bake b1) - (assert-eq "(Blip 123 666) ; ptr-to-global" (str b1)) - (defstruct Blip [x :bool y "T" z :string]) - (def b2 (Blip true \g @"Yo")) - (bake b2) - (assert-eq "(Blip true \\g @\"Yo\") ; ptr-to-global" (str b2)) )) - -(tester/run-suite "globals") diff --git a/lisp/test_line_numbers.carp b/lisp/test_line_numbers.carp deleted file mode 100644 index b48405b13..000000000 --- a/lisp/test_line_numbers.carp +++ /dev/null @@ -1,43 +0,0 @@ -(def line-1 "hej") - -(def line-3 [1 2 3]) - -(def line-5 '{}) ;; TODO: make dictionary literals work too, they lose their info after the call to 'dictionary' - -(def line-7 '()) - -(def line-9 'whatever) - -(def line-11 :yeah) - -(def line-13 1000) - -(def line-15 3.14) - -(def line-17 '(fn [] "...")) ;; TODO: fix this one too! - -(defn line-19 [] "...") - -;; comment - -(defn line-23 [] "...") - -;; more comments... -;; () [] {} !?@#.-_ <> -;; -; -;;; - -(defn line-31 [] "...") - -(assert-eq 1 (meta-get line-1 :line)) -(assert-eq 3 (meta-get line-3 :line)) -(assert-eq 5 (meta-get line-5 :line)) -(assert-eq 7 (meta-get line-7 :line)) -(assert-eq 9 (meta-get line-9 :line)) -(assert-eq 11 (meta-get line-11 :line)) -(assert-eq 13 (meta-get line-13 :line)) -(assert-eq 15 (meta-get line-15 :line)) -(assert-eq 17 (meta-get line-17 :line)) -(assert-eq 19 (meta-get line-19 :line)) -(assert-eq 31 (meta-get line-31 :line)) diff --git a/lisp/test_ownership.carp b/lisp/test_ownership.carp deleted file mode 100644 index b905905fc..000000000 --- a/lisp/test_ownership.carp +++ /dev/null @@ -1,297 +0,0 @@ -(tester/set-suite! "ownership") - -(deftest test-own-1 - (do - (defn own-1 (s) - (eat-string s)) - (assert-eq '(:fn (:string) :void) - (sign own-1)) - (assert-eq {:node :function, - :free (), - :body ()} - (ownership-analyze own-1)))) - -(deftest test-own-2 - (do - (defn own-2 (s) - (string-copy s)) - (assert-eq '(:fn ((:ref :string)) :string) - (sign own-2)) - (assert-eq {:node :function, - :free '(), - :body ()} - (ownership-analyze own-2)))) - -(deftest test-own-3 - (do - (defn own-3 () - (string-copy (ref (string-copy "CARP")))) - (assert-eq '(:fn () :string) - (sign own-3)) - (assert-eq {:node :function, - :free (list {:name "_result_1" :type :string}), - :body ()} - (ownership-analyze own-3)))) - -(deftest test-own-4 - (do - (defn own-4 () - (let [s (string-copy "CARP1")] - (string-copy "CARP2"))) - (assert-eq '(:fn () :string) - (sign own-4)) - (assert-eq {:node :function, - :free (), - :body {:node :let, - :free (list {:name "s", - :type :string}), - :body ()}} - (ownership-analyze own-4)))) - -(deftest test-own-5 - (do - (defn own-5 () - (let [s1 (string-copy "CARP1") - s2 (string-copy (ref s1))] - 0)) - (assert-eq '(:fn () :int) - (sign own-5)) - (assert-eq {:node :function, - :free (), - :body {:node :let, - :free (list {:name "s2", - :type :string} - {:name "s1", - :type :string}), - :body ()}} - (ownership-analyze own-5)))) - -(deftest test-own-6 - (do - (defn own-6 () - (let [s1 (string-copy "CARP")] - (let [s2 (string-copy (ref s1))] - 0))) - (assert-eq '(:fn () :int) - (sign own-6)) - (assert-eq {:node :function, - :free (), - :body {:node :let, - :free (list {:name "s1", - :type :string}), - :body {:node :let, - :free (list {:name "s2", - :type :string}), - :body ()}}} - (ownership-analyze own-6)))) - -(deftest test-own-7 - (do - (defn own-7 () - (let [s1 (string-copy "CARP")] - (do - (eat-string s1) - (eat-string s1)))) - (assert-error error-given-away (ownership-analyze own-7)))) - -(deftest test-own-8 - (do - (defn own-8 () - (let [s (string-copy "CARP1")] - (if true - s - (string-copy "CARP2")))) - (assert-eq '(:fn () :string) - (sign own-8)) - (assert-eq {:node :function, - :free (), - :body {:node :let - :free () - :body {:node :if, - :free-left (), - :free-right (list {:name "s" - :type :string}) - :body-left () - :body-right ()}}} - (ownership-analyze own-8)))) - -(deftest test-own-9 - (do - (defn own-9 () - (let [s (string-copy "CARP1")] - (if true - s - s))) - (assert-eq '(:fn () :string) - (sign own-9)) - (assert-eq {:node :function, - :free (), - :body {:node :let - :free () - :body {:node :if, - :free-left (), - :free-right () - :body-left () - :body-right ()}}} - (ownership-analyze own-9)))) - -(deftest test-own-10 - (do - (defn own-10 () - (let [s (string-copy "CARP1")] - (if true - 10 - 20))) - (assert-eq '(:fn () :int) - (sign own-10)) - (assert-eq {:node :function, - :free (), - :body {:node :let - :free (list {:name "s" - :type :string}) - :body {:node :if, - :free-left (), - :free-right () - :body-left () - :body-right ()}}} - (ownership-analyze own-10)))) - -(deftest test-own-11 - (do - (defn own-11 () - (let [s1 (string-copy "CARP1") - s2 (string-copy "CARP2")] - (if true - s1 - s2))) - (assert-eq '(:fn () :string) - (sign own-11)) - (assert-eq {:node :function, - :free (), - :body {:node :let - :free () - :body {:node :if, - :free-left (list {:name "s2" - :type :string}), - :free-right (list {:name "s1" - :type :string}) - :body-left () - :body-right ()}}} - (ownership-analyze own-11)))) - -(deftest test-own-12 - (do - (defn own-12 (s1) - (let [] - (if true - (itos (strlen (ref s1))) - s1))) - (assert-eq '(:fn (:string) :string) - (sign own-12)) - (assert-eq {:node :function, - :free (), - :body {:node :let - :free () - :body {:node :if, - :free-left (list {:name "s1" - :type :string}), - :free-right () - :body-left () - :body-right ()}}} - (ownership-analyze own-12)))) - -(deftest test-own-13 - (do - (defn own-13 () - (let [s (string-copy "CARP") - r (ref s)] - (do - (strlen r) - (eat-string s)))) - (assert-eq '(:fn () :void) - (sign own-13)) - (assert-eq {:node :function, - :free (), - :body {:node :let - :free () - :body ()}} - (ownership-analyze own-13)))) - -(deftest test-own-14 - (do - (defn own-14 () - (let [s (string-copy "CARP") - r (ref s)] - (do - (eat-string s) - (strlen r)))) - (assert-error error-given-away (ownership-analyze own-14)))) - -(deftest test-own-15 - (do - (defn own-15 (s1) - (if true - (do (eat-string s1) (string-copy "eaten")) - s1)) - (assert-eq '(:fn (:string) :string) - (sign own-15)) - (assert-eq {:node :function, - :free (), - :body {:node :if, - :free-left (), - :free-right () - :body-left () - :body-right ()}} - (ownership-analyze own-15)))) - -(deftest test-free-things-sent-to-ref - (do - (defn free-the-thing [] - (println (ref (str (ref [1 2 3]))))) - (assert-eq {:node :function, - :free (list {:name "_result_1", - :type :string} - {:name "_array_0", - :type '(:Array :int)}), - :body ()} - (ownership-analyze free-the-thing)))) - -(deftest dont-allow-let-ref - (do - (defn let-returning-ref [] - (copy - (let [x [1 2 3] - r &x] - r))) - (assert-error error-return-ref (bake let-returning-ref)))) - -(deftest ownership-in-while-loop - (do - (defn fool-while [] - (let [x @"yeah"] - (while true - (reset! x (id x))))) - (assert-error error-given-away (bake fool-while)))) - -(deftest reset-in-while-loop-ok - (do (defn while-loop-function [] - (let [s [1 2 3] - x 0] - (while (< x 10) - (do - (reset! s (copy &s)) - (reset! x (inc x)))))) - (bake while-loop-function))) - -(deftest reset-in-while-loop-fail - (do (defn while-loop-function-fail [] - (let [s [1 2 3]] - (while true - (reset! s (id s))))) - (assert-error error-given-away (bake while-loop-function-fail)))) - -;; This one is weird: -(defn own-string-weird (s) - (ref s)) - -(tester/run-suite "ownership") diff --git a/lisp/test_printing.carp b/lisp/test_printing.carp deleted file mode 100644 index 5dd337070..000000000 --- a/lisp/test_printing.carp +++ /dev/null @@ -1,94 +0,0 @@ -(tester/set-suite! "printing") - -(deftest test-str-of-objs - (do - (assert-eq "hej" (str "hej")) - (assert-eq "a" (str \a)) - (assert-eq "123" (str 123)) - (assert-eq "3.140000f" (str 3.14f)) - (assert-eq "10.500000" (str 10.5)) - (assert-eq "true" (str true)) - (assert-eq "false" (str false)))) - -(deftest test-prn-of-objs - (do - (assert-eq "\"hej\"" (prn "hej")) - (assert-eq "\\a" (prn \a)) - (assert-eq "123" (prn 123)) - (assert-eq "3.140000f" (prn 3.14f)) - (assert-eq "10.500000" (prn 10.5)) - (assert-eq "true" (prn true)) - (assert-eq "false" (prn false)))) - -(deftest test-baked-strs - (do (defn str-a-string [] - (str "hej")) - (bake str-a-string) - (assert-eq "hej" (str-a-string)) - - (defn str-a-char [] - (str \y)) - (bake str-a-char) - (assert-eq "y" (str-a-char)))) - -(deftest test-baked-prns - (do (defn prn-a-string [] - (prn "hej")) - (bake prn-a-string) - (assert-eq "@\"hej\"" (prn-a-string)) - - (defn prn-a-char [] - (prn \y)) - (bake prn-a-char) - (assert-eq "\\y" (prn-a-char)))) - -(deftest str-struct-dynamic - (do (defstruct StrMe [str-me-string :string]) - (assert-eq "(StrMe @\"yeah\")" (str (StrMe "yeah"))))) - -(deftest prn-struct-dynamic - (do (defstruct PrnMe [prn-me-string :string]) - (assert-eq "(PrnMe @\"yeah\")" (prn (PrnMe "yeah"))))) - -(deftest str-struct-compiled - (do (defstruct StrMe2 [str-me-2-string :string]) - (defn str-me [] - (str &(StrMe2 @"yeah"))) - (bake str-me) - (assert-eq "(StrMe2 @\"yeah\")" (str-me)))) - -(deftest prn-struct-compiled - (do (defstruct PrnMe2 [prn-me-2-string :string]) - (defn prn-me [] - (prn &(PrnMe2 @"yeah"))) - (assert-eq "(PrnMe2 @\"yeah\")" (prn-me)))) - -(deftest str-array-dynamic - (assert-eq "[1 2 3]" (str [1 2 3]))) - -(deftest prn-array-dynamic - (assert-eq "[1 2 3]" (prn [1 2 3]))) - -(deftest str-array-compiled - (do - (defn str-an-array [] - (str &[@"a" @"b" @"c"])) - (bake str-an-array) - (assert-eq "[@\"a\" @\"b\" @\"c\"]" (str-an-array)))) - -(deftest prn-array-compiled - (do - (defn prn-an-array [] - (prn &[@"a" @"b" @"c"])) - (bake prn-an-array) - (assert-eq "[@\"a\" @\"b\" @\"c\"]" (prn-an-array)))) - -(deftest test-improved-str - (do - (defstruct Woah [woah-name :string]) - (defn use-str [] - (str* "x = " 10 ", name = " "ERIK " &(Woah @"bleh") " ... " &[@"a" @"b" @"c"])) - (bake use-str) - (assert-eq "x = 10, name = ERIK (Woah @\"bleh\") ... [@\"a\" @\"b\" @\"c\"]" (use-str)))) - -(tester/run-suite "printing") diff --git a/lisp/test_stack_trace.carp b/lisp/test_stack_trace.carp deleted file mode 100644 index a4afc1a55..000000000 --- a/lisp/test_stack_trace.carp +++ /dev/null @@ -1,9 +0,0 @@ - -;; TOO BIG TO FAIL - -(defn too-big-to-fail [] - (error {:error error-test-failed - :message "no message"})) - -;; (too-big-to-fail) - diff --git a/lisp/test_structs.carp b/lisp/test_structs.carp deleted file mode 100644 index fb49e8a54..000000000 --- a/lisp/test_structs.carp +++ /dev/null @@ -1,166 +0,0 @@ -(tester/set-suite! "structs") - -;; (defstruct Vec2 [x :float y :float]) - -;; (def v (Vec2 3.0 4.0)) - -;; (def x (get-x v)) -;; (def y (get-y v)) - -;; ;; pretend that the FauxVec2 type in shared.h is the same as Vec2 (they have the same memory layout): -;; (register-builtin "position" '() :Vec2) - -;; (defn print-vec2 [m] -;; (println (str (get-x m) ", " (get-y m)))) - - - - -;; (defstruct Mix [a :int b :float c :int]) - -;; (def m (Mix 10 3.2 20)) - -;; (defn print-mix [m] -;; (println (str "Mix: " (get-a m) ", " (get-b m) ", " (get-c m)))) - -;; (defstruct Mix2 [mix-a :Mix mix-b :Mix]) -;; (def m2 (Mix2 (Mix 1 2.0 3) (Mix 4 5.0 6))) - -;; (defn test-mix2 [] -;; (do -;; (print-mix (get-mix-a m2)) -;; (print-mix (get-mix-b m2)))) - - - - -(defstruct AnotherVector - [xx :int - yy :int]) - -(defn setter-1 [] - (let [v (AnotherVector 100 100)] - (AnotherVector-set-xx v 666))) - -(deftest test-setter-1 - (do (bake setter-1) - (assert-eq 666 (AnotherVector-get-xx (setter-1))))) - - - -(defn updater-1 [] - (let [v (AnotherVector 100 100)] - (AnotherVector-update-yy v inc))) - -(deftest test-updater-1 - (do (bake updater-1) - (assert-eq 101 (AnotherVector-get-yy (updater-1))))) - - - -(deftest test-redefining-struct - (do - (defstruct Prime [prime-x :int]) - (defstruct Prime2 [prime2-member :Prime]) - (defstruct Prime3 [prime3-member :Prime2]) - (defn farao [p] - (Prime-get-prime-x p)) - (bake farao) - (assert-eq "10" (str (farao (Prime 10)))) - - (defstruct Prime [prime-x :int prime-y :int]) - (assert-eq "20" (str (farao (Prime 20 30)))) - (bake farao) - (assert-eq "40" (str (farao (Prime 40 50)))) - (assert-eq "(Prime3 (Prime2 (Prime 1000 2000)))" (str (Prime3 (Prime2 (Prime 1000 2000))))))) - - - -;; GENERIC STRUCTS - -(deftest test-generic-pair-dynamic - (do - (defstruct TestPair - [a "t" - b "t"]) - (let [p1 (TestPair 10 20) - p2 (TestPair true false)] - (do - (assert-eq "(TestPair 10 20)" (str p1)) - (assert-eq 10 (TestPair-get-a p1)) - (assert-eq 20 (TestPair-get-b p1)) - (assert-eq "(TestPair true false)" (str p2)) - (assert-eq true (TestPair-get-a p2)) - (assert-eq false (TestPair-get-b p2)))))) - -(deftest test-generic-pair-compiled-constructor - (do - (defstruct TestPair2 - [a "t" - b "t"]) - (defn fff1 [] - (TestPair2 10 20)) - (defn fff2 [] - (TestPair2 true false)) - (bake fff1) - (bake fff2) - (let [p1 (fff1) - p2 (fff2)] - (do - (assert-eq "(TestPair2 10 20)" (str p1)) - (assert-eq 10 (TestPair2-get-a p1)) - (assert-eq 20 (TestPair2-get-b p1)) - (assert-eq "(TestPair2 true false)" (str p2)) - (assert-eq true (TestPair2-get-a p2)) - (assert-eq false (TestPair2-get-b p2)))))) - -(deftest test-generic-pair-compiled-lenses - (do - (defstruct TestPair - [a "t" - b "t"]) - (defn use-update-lens [x] - (TestPair-update-a (TestPair-update-b x inc) dec)) - (bake use-update-lens) - (assert-eq :foreign (type use-update-lens)) - (assert-eq "(TestPair 9 21)" (str (use-update-lens (TestPair 10 20)))))) - -(deftest test-generic-pair-compiled-everything - (do - (defstruct TestPair - [a "t" - b "t"]) - (defn use-test-pair [x] - (TestPair-get-a (TestPair-set-b x @"no"))) - (defn use-use-test-pair [] - (use-test-pair (TestPair @"yes" @"yeah"))) - (bake use-use-test-pair) - (assert-eq "yes" (use-use-test-pair)))) - -(deftest test-type-with-multiple-typevars - (do - (defstruct TestTuple - [a "t" - b "u" - c "t"]) - (assert-eq "(TestTuple true \\x false)" (str (TestTuple true \x false))))) - -(deftest test-type-with-concrete-types-also - (do - (defstruct TestWeirdTuple - [a "t" - b :bool - c "u"]) - (assert-eq "(TestWeirdTuple \\a true \\c)" (str (TestWeirdTuple \a true \c))))) - -(deftest struct-with-inner-struct - (do - (defstruct InnerStruct - [foo :int]) - (defstruct SomeGenericStruct - [x "t"]) - (assert-eq "(SomeGenericStruct 10)" (str (SomeGenericStruct 10))) - (assert-eq "(SomeGenericStruct [1 2 3])" (str (SomeGenericStruct [1 2 3]))) - (assert-eq "(SomeGenericStruct (InnerStruct 123))" (str (SomeGenericStruct (InnerStruct 123)))))) - -(tester/run-suite "structs") diff --git a/lisp/tester.carp b/lisp/tester.carp deleted file mode 100644 index 9b9dccc1c..000000000 --- a/lisp/tester.carp +++ /dev/null @@ -1,56 +0,0 @@ -(def *active-test-suite* "") - -(defn tester/set-suite! [test-suite-name] - (reset! *active-test-suite* test-suite-name)) - -(def tester/test-suites {}) - -(defn tester/add-test! [test-name] - (let [existing-tests (get-maybe tester/test-suites *active-test-suite*)] - (reset! tester/test-suites (assoc tester/test-suites *active-test-suite* (cons-last existing-tests test-name))))) - -(defn tester/run-suite [test-suite-name] - (let [tests (get tester/test-suites test-suite-name) - failed-count 0 - start-time (now)] - (if (= 0 (count tests)) - (println (str (get-console-color console-color-yellow) - "No tests to run in test suite '" test-suite-name "'." - (get-normal-console-color))) - (do (map (fn [test-name] - (let [test-func (eval (symbol test-name)) - e (catch-error (test-func))] - (if (nil? e) - :success - (do - (println (str (get-console-color console-color-red) - (inc failed-count) "." - " Error in test '" test-name "' \n" - (get-normal-console-color) - e "\n")) - (swap! failed-count inc))))) - tests) - (println (str (if (= 0 failed-count) - (get-console-color console-color-green) - (get-console-color console-color-red)) - "Ran " (count tests) " tests in test suite '" test-suite-name - "', " failed-count " of them failed (took " (/ (- (now) start-time) 1000) " secs)." - (get-normal-console-color))))))) - -(defmacro deftest [name body] - (list 'do - (list 'defn name [] body) - (list 'tester/add-test! (prn name)))) - -;; Example usage: -;; (tester/set-suite! "foo") -;; (deftest t1 (assert-eq 2 2)) -;; (deftest t2 (assert-eq 3 3)) -;; (deftest t3 (assert-eq 12 12)) -;; (tester/run-suite "foo") - -;; (defmacro in-test-suite [test-suite-name forms] -;; (list 'do -;; (list 'reset! *active-test-suite* (prn test-suite-name)) -;; forms -;; (list 'reset! *active-test-suite* (prn "")))) diff --git a/out/.gitignore b/out/.gitignore deleted file mode 100644 index c96a04f00..000000000 --- a/out/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -* -!.gitignore \ No newline at end of file diff --git a/out/keep.txt b/out/keep.txt new file mode 100644 index 000000000..251cf3c3e --- /dev/null +++ b/out/keep.txt @@ -0,0 +1 @@ +Keep this directory. diff --git a/shared/platform.h b/shared/platform.h deleted file mode 100644 index 3f071aeff..000000000 --- a/shared/platform.h +++ /dev/null @@ -1,305 +0,0 @@ -#pragma once - -#include "types.h" - - -#if defined (__APPLE__) || defined(__linux__) - -#include -#include -#include -#include - -// According to http://linux.die.net/man/3/dlopen the symbols RTLD_DEFAULT and RTLD_NEXT -// are defined by only when _GNU_SOURCE was defined before including it. -// On Ubuntu 14.04 this definition fixed the missing symbol though: -#ifndef __USE_GNU -#define __USE_GNU -#endif - -#include -#include - -/* Init/shutdown */ - -void carp_platform_init() { -} - -void carp_platform_shutdown() { -} - -/* --- Threads --- */ - -struct carp_thread { - pthread_t thread; -}; - -typedef struct thread_arg_wrapper { - carp_thread_routine tr; - void* arg; -} thread_arg_wrapper; - -void* thread_proc_wrapper(void* arg) { - thread_arg_wrapper* argw = (thread_arg_wrapper*)arg; - argw->tr(argw->arg); - free(argw); - return 0; -} - -carp_thread_t carp_thread_create(carp_thread_routine thread_routine, void* arg) { - carp_thread_t thread = malloc(sizeof(struct carp_thread)); - assert(thread); - thread_arg_wrapper* argw = malloc(sizeof(thread_arg_wrapper)); - assert(argw); - argw->arg = arg; - argw->tr = thread_routine; - pthread_create(&thread->thread, NULL, thread_proc_wrapper, argw); - return thread; -} - -void carp_thread_destroy(carp_thread_t thread) { - free(thread); -} - -/* --- Timing --- */ - -int carp_millitime() { - struct timeval te; - gettimeofday(&te, NULL); // get current time - long long milliseconds = te.tv_sec * 1000LL + te.tv_usec / 1000; // calculate milliseconds - return milliseconds; -} - -/* --- Libraries --- */ - -struct carp_library { - void* handle; -}; - -carp_library_t carp_load_library(const char* name) { - void* handle = dlopen(name, RTLD_LAZY); - if (handle == NULL) { - return NULL; - } - return (carp_library_t)handle; -} - -int carp_unload_library(carp_library_t lib) { - return dlclose((void*)lib); -} - -void* carp_find_symbol(carp_library_t lib, const char * name) { - if (lib != NULL) { - return dlsym((void*)lib, name); - } - return dlsym(RTLD_DEFAULT, name); -} - -char* carp_get_load_library_error() { - return dlerror(); -} - -CARP_PLATFORM carp_get_platform() { -#ifdef __APPLE__ - return CARP_PLATFORM_OSX; -#elif defined __linux__ - return CARP_PLATFORM_LINUX; -#elif defined WIN32 - return CARP_PLATFORM_WINDOWS; -#endif - return CARP_PLATFORM_UNKNOWN; -} - -#endif // __APPLE__ - -#ifdef WIN32 - -#define WIN32_LEAN_AND_MEAN -#include -#include -#include - -/* Support code for library symbol search */ - -typedef struct module_list { - HMODULE module; - struct module_list* next; -}*module_list_t; - -LARGE_INTEGER carp_perf_freq; -HMODULE carp_main_module = INVALID_HANDLE_VALUE; -HMODULE carp_msvcrt_module = INVALID_HANDLE_VALUE; -module_list_t carp_loaded_modules = NULL; - -module_list_t new_module_list_node() { - module_list_t lst = malloc(sizeof(struct module_list)); - lst->module = INVALID_HANDLE_VALUE; - lst->next = NULL; - return lst; -} - -void add_module_to_list(module_list_t lst, HMODULE module) { - while (lst->module != INVALID_HANDLE_VALUE) { - if (lst->next == NULL) { - lst->next = new_module_list_node(); - } - lst = lst->next; - } - lst->module = module; -} - -void remove_module_from_list(module_list_t lst, HMODULE module) { - while (lst->module != module) { - if (lst->next == NULL) { - return; // not found - } - lst = lst->next; - } - lst->module = INVALID_HANDLE_VALUE; -} - -void free_all_modules_and_destroy_module_list(module_list_t lst) { - while (lst) { - if (lst->module != INVALID_HANDLE_VALUE) { - FreeLibrary(lst->module); - } - module_list_t tmp = lst; - lst = lst->next; - free(tmp); - } -} - -/* Init/shutdown */ - -void carp_platform_init() { - QueryPerformanceFrequency(&carp_perf_freq); - carp_main_module = GetModuleHandle(NULL); - carp_msvcrt_module = LoadLibrary("msvcrt.dll"); - carp_loaded_modules = new_module_list_node(); - add_module_to_list(carp_loaded_modules, carp_msvcrt_module); -} - -void carp_platform_shutdown() { - free_all_modules_and_destroy_module_list(carp_loaded_modules); - carp_main_module = INVALID_HANDLE_VALUE; - carp_msvcrt_module = INVALID_HANDLE_VALUE; - carp_loaded_modules = NULL; -} - -/* --- Threads --- */ - -struct carp_thread { - HANDLE handle; -}; - -typedef struct thread_arg_wrapper { - carp_thread_routine tr; - void* arg; -} thread_arg_wrapper; - -DWORD WINAPI thread_proc_wrapper(LPVOID p) { - thread_arg_wrapper* argw = (thread_arg_wrapper*)p; - argw->tr(argw->arg); - free(argw); - return 0; -} - -carp_thread_t carp_thread_create(carp_thread_routine thread_routine, void* arg) { - carp_thread_t thread = malloc(sizeof(struct carp_thread)); - assert(thread); - thread_arg_wrapper* argw = malloc(sizeof(thread_arg_wrapper)); - assert(argw); - argw->arg = arg; - argw->tr = thread_routine; - thread->handle = CreateThread(NULL, 0, thread_proc_wrapper, argw, 0, 0); - return thread; -} - -void carp_thread_destroy(carp_thread_t thread) { - CloseHandle(thread->handle); - free(thread); -} - -/* --- Timing --- */ - -int carp_millitime() { - LARGE_INTEGER pt; - QueryPerformanceCounter(&pt); - return (int)(((double)pt.QuadPart) / ((double)carp_perf_freq.QuadPart) * 1000); -} - -/* --- Libraries --- */ - -struct carp_library { - HMODULE module; -}; - -carp_library_t carp_load_library(const char* name) { - HMODULE module = LoadLibrary(name); - if (module == NULL) { - return NULL; - } - SetLastError(0); - add_module_to_list(carp_loaded_modules, module); - carp_library_t lib = malloc(sizeof(struct carp_library)); - lib->module = module; - return lib; -} - -int carp_unload_library(carp_library_t lib) { - remove_module_from_list(carp_loaded_modules, lib->module); - BOOL result = FreeLibrary(lib->module); - free(lib); - return !result; -} - -void* carp_find_symbol(carp_library_t lib, const char * name) { - if (lib != NULL) { - assert(lib->module != INVALID_HANDLE_VALUE); - return GetProcAddress(lib->module, name); - } - void* addr = GetProcAddress(carp_main_module, name); - if (addr != NULL) { - return addr; - } - module_list_t lst = carp_loaded_modules; - while (lst) { - if (lst->module != INVALID_HANDLE_VALUE) { - void* addr = GetProcAddress(lst->module, name); - if (addr != NULL) { - return addr; - } - } - lst = lst->next; - } - return NULL; -} - -char error_buf[2048]; - -char* carp_get_load_library_error() { - DWORD error = GetLastError(); - if (error == 0) { - return NULL; - } - assert(sizeof(TCHAR) == 1); // If wide chars are used, we have to convert to utf8 - FormatMessage( - FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, - NULL, - error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), - (LPSTR)&error_buf, - sizeof(error_buf) - 1, - NULL); - return error_buf; -} - -void carp_sleep(int millis) { - Sleep(millis); -} - -CARP_PLATFORM carp_get_platform() { - return CARP_PLATFORM_WINDOWS; -} - -#endif diff --git a/shared/shared.h b/shared/shared.h deleted file mode 100644 index 906607c26..000000000 --- a/shared/shared.h +++ /dev/null @@ -1,192 +0,0 @@ -#pragma once - -#include -#include -#include -#include -#include -#include -#include -#include "types.h" -#include "platform.h" - -// clang-format off -#define and && -// clang-format on - -#ifdef WIN32 -#define EXPORT __declspec(dllexport) -#else -#define EXPORT -#endif - -typedef int unknown; -typedef void* typevar; -typedef void* any; - -typedef char* string; - -EXPORT int intsqrt(int x) { return (int)sqrt(x); } -EXPORT float itof(int x) { return (float)x; } -EXPORT float dtof(double x) { return (float)x; } -EXPORT double ftod(float x) { return (double)x; } - -#ifdef max -#undef max -#endif -EXPORT int max(int x, int y) { - return x > y ? x : y; -} - -EXPORT string itos(int x) { - char *s = malloc(sizeof(char) * 32); - snprintf(s, 32, "%d", x); - return s; -} - -EXPORT bool nullQMARK(void *p) { - return p == NULL; -} - -EXPORT bool not(bool x) { - return !x; -} - -EXPORT void print(string msg) { - printf("%s", msg); -} - -EXPORT void println(string msg) { - assert(msg); - printf("%s\n", msg); -} - -// This function is used for testing of the ownership system -EXPORT void eat_string(char *s) { - free(s); -} - -EXPORT char *string_copy(char *s) { - return strdup(s); -} - -EXPORT char *string_append(char *s1, char *s2) { - char *new_str = malloc(strlen(s1) + strlen(s2) + 1); - new_str[0] = '\0'; - strcat(new_str, s1); - strcat(new_str, s2); - return new_str; -} - -EXPORT bool file_existsQMARK(char *filename) { - FILE *f = fopen(filename, "r"); - bool result = f != NULL; - if(result) { - fclose(f); - } - return result; -} - -EXPORT int inc(int x) { return x + 1; } -EXPORT int dec(int x) { return x - 1; } - -EXPORT void async(void *f) { - //printf("Async starting.\n"); - carp_thread_t th = carp_thread_create(f, "Async"); - carp_thread_destroy(th); - //printf("Async done.\n"); -} - -EXPORT int last_index_of(string s, char c) { - int len = (int)strlen(s); - for(int i = len - 1; i >= 0; i--) { - if(s[i] == c) { - return i; - } - } - return -1; -} - -EXPORT string substring(string s, int index) { - if(index >= strlen(s)) { - printf("Substring out of bounds.\n"); - exit(-1); - } - const char *sub = s + index; - return strdup(sub); -} - -EXPORT string file_path_component(string s) { - int i = last_index_of(s, '/'); - return substring(s, i + 1); -} - -EXPORT string get_input() { - char in[1024]; - fgets(in, 1024, stdin); - return strdup(in); -} - -EXPORT int mod(int x, int y) { - return x % y; -} - -#ifdef WIN32 -EXPORT void sleep(int millis) { - carp_sleep(millis); -} -#endif - -EXPORT CARP_PLATFORM platform() { - return carp_get_platform(); -} - -EXPORT string get_normal_console_color() { - #ifdef WIN32 - return strdup(""); - #else - return strdup("\e[0m"); - #endif -} - -EXPORT string get_console_color(int x) { - #ifdef WIN32 - return strdup(""); - #else - char buffer[16]; - snprintf(buffer, 16, "\e[3%dm", x); - return strdup(buffer); - #endif -} - -EXPORT Array *chars(string s) { - Array *a = malloc(sizeof(Array)); - a->count = strlen(s); - a->data = strdup(s); - return a; -} - -EXPORT string string_join(string separator, Array *array_of_strings) { - string *casted = (string*)array_of_strings->data; - int separator_len = strlen(separator); - int total_length = 0; - int count = array_of_strings->count; - for(int i = 0; i < count; i++) { - total_length += strlen(casted[i]); - total_length += separator_len; - } - total_length -= separator_len; // last separator not included - total_length += 1; // room for '\0' - string result = malloc(total_length); - char *pos = result; - for(int i = 0; i < count; i++) { - sprintf(pos, "%s", casted[i]); - pos += strlen(casted[i]); - if(i < count - 1) { - sprintf(pos, "%s", separator); - } - pos += separator_len; - } - *pos = '\0'; - return result; -} diff --git a/shared/types.h b/shared/types.h deleted file mode 100644 index 0f5c61b4e..000000000 --- a/shared/types.h +++ /dev/null @@ -1,59 +0,0 @@ -#pragma once - -#ifdef bool -#undef bool -#endif - -typedef int bool; -#define true 1 -#define false 0 - -typedef struct carp_thread* carp_thread_t; -typedef void(*carp_thread_routine)(void* arg); - -typedef struct carp_library* carp_library_t; - -/* Init/shutdown */ - -void carp_platform_init(); - -void carp_platform_shutdown(); - -/* --- Threads --- */ - -carp_thread_t carp_thread_create(carp_thread_routine thread_routine, void* arg); - -void carp_thread_destroy(carp_thread_t thread); - -/* --- Timing --- */ - -int carp_millitime(); - -/* --- Libraries --- */ - -carp_library_t carp_load_library(const char* name); - -int carp_unload_library(carp_library_t lib); - -void* carp_find_symbol(carp_library_t lib, const char * name); - -char* carp_get_load_library_error(); - -/* -- misc -- */ - -void carp_sleep(int millis); - -typedef enum CARP_PLATFORM { - CARP_PLATFORM_OSX = 0, - CARP_PLATFORM_WINDOWS = 1, - CARP_PLATFORM_LINUX = 2, - CARP_PLATFORM_UNKNOWN = 100 -} CARP_PLATFORM; - -CARP_PLATFORM carp_get_platform(); - -typedef struct { - int count; - void *data; -} Array; - diff --git a/src/ColorText.hs b/src/ColorText.hs new file mode 100644 index 000000000..43f0421b0 --- /dev/null +++ b/src/ColorText.hs @@ -0,0 +1,18 @@ +module ColorText where + +data TextColor = Blue | Red | Yellow | Green | White + +strWithColor :: TextColor -> String -> String +strWithColor color str = "\x1b[" ++ col ++ "m" ++ str ++ "\x1b[37m" + where col = case color of + Red -> "31" + Green -> "32" + Yellow -> "33" + Blue -> "34" + White -> "37" + +putStrWithColor :: TextColor -> String -> IO () +putStrWithColor color str = putStr (strWithColor color str) + +putStrLnWithColor :: TextColor -> String -> IO () +putStrLnWithColor color str = putStrWithColor color (str ++ "\n") diff --git a/src/Commands.hs b/src/Commands.hs new file mode 100644 index 000000000..ce8f01bd2 --- /dev/null +++ b/src/Commands.hs @@ -0,0 +1,490 @@ +module Commands where + +import System.Exit (exitSuccess) +import System.Process (callCommand) +import System.Directory +import qualified Data.Map as Map +import Data.Maybe (fromJust, mapMaybe, isJust) +import Control.Monad +import Control.Exception +--import Debug.Trace + +import Parsing +import Emit +import Obj +import Types +import Infer +import Deftype +import ColorText +import Template +import Util +import Eval + +data Context = Context { contextGlobalEnv :: Env + , contextTypeEnv :: Env + , contextPath :: [String] + , contextProj :: Project + , contextLastInput :: String + } deriving Show + +data ReplCommand = Define XObj + | AddInclude Includer + | Register String XObj + | RegisterType String + | AddCFlag String + | AddLibraryFlag String + | DefineModule String [XObj] + | DefineType XObj [XObj] + | DefineMacro String XObj XObj + | DefineDynamic String XObj XObj + | Eval XObj + | Expand XObj + | InstantiateTemplate XObj XObj + | Import SymPath + | DoNothing + | ReplMacroError String + | ReplTypeError String + | ReplParseError String + | ReplCodegenError String + | Load FilePath + | Reload + | BuildExe + | RunExe + | Cat + | Print String + | ListBindingsInEnv + | DisplayProject + | Help String + | Quit + | ListOfCommands [ReplCommand] + deriving Show + +consumeExpr :: Context -> XObj -> ReplCommand +consumeExpr (Context globalEnv typeEnv _ _ _) xobj = + case expandAll globalEnv xobj of + Left err -> ReplMacroError (show err) + Right expanded -> + case annotate typeEnv globalEnv (setFullyQualifiedSymbols globalEnv expanded) of + Left err -> ReplTypeError (show err) + Right annXObjs -> ListOfCommands (map (Print . strWithColor Green . toC) annXObjs) + +objToCommand :: Context -> XObj -> ReplCommand +objToCommand ctx xobj = + case obj xobj of + Lst lst -> case lst of + XObj Defn _ _ : _ : _ : _ : [] -> Define xobj + XObj Def _ _ : _ : _ : [] -> Define xobj + XObj (Sym (SymPath _ "module")) _ _ : XObj (Sym (SymPath _ name)) _ _ : innerExpressions -> + DefineModule name innerExpressions + XObj (Sym (SymPath _ "defmodule")) _ _ : XObj (Sym (SymPath _ name)) _ _ : innerExpressions -> + DefineModule name innerExpressions + XObj (Sym (SymPath _ "defmacro")) _ _ : XObj (Sym (SymPath _ name)) _ _ : params@(XObj (Arr _) _ _) : body : [] -> + DefineMacro name params body + XObj (Sym (SymPath _ "defdynamic")) _ _ : XObj (Sym (SymPath _ name)) _ _ : params@(XObj (Arr _) _ _) : body : [] -> + DefineDynamic name params body + XObj (Sym (SymPath _ "deftype")) _ _ : name : rest -> DefineType name rest + XObj (Sym (SymPath _ "eval")) _ _ : form : [] -> Eval form + XObj (Sym (SymPath _ "expand")) _ _ : form : [] -> Expand form + XObj (Sym (SymPath _ "instantiate")) _ _ : name : signature : [] -> InstantiateTemplate name signature + XObj (Sym (SymPath _ "help")) _ _ : XObj (Sym (SymPath _ chapter)) _ _ : [] -> Help chapter + XObj (Sym (SymPath _ "help")) _ _ : [] -> Help "" + XObj (Sym (SymPath _ "quit")) _ _ : [] -> Quit + XObj (Sym (SymPath _ "env")) _ _ : [] -> ListBindingsInEnv + XObj (Sym (SymPath _ "build")) _ _ : [] -> BuildExe + XObj (Sym (SymPath _ "run")) _ _ : [] -> RunExe + XObj (Sym (SymPath _ "cat")) _ _ : [] -> Cat + XObj (Sym (SymPath _ "import")) _ _ : XObj (Sym path) _ _ : [] -> Import path + XObj (Sym (SymPath _ "register")) _ _ : XObj (Sym (SymPath _ name)) _ _ : t : [] -> Register name t + XObj (Sym (SymPath _ "register-type")) _ _ : XObj (Sym (SymPath _ name)) _ _ : [] -> RegisterType name + XObj (Sym (SymPath _ "local-include")) _ _ : XObj (Str file) _ _ : [] -> AddInclude (LocalInclude file) + XObj (Sym (SymPath _ "system-include")) _ _ : XObj (Str file) _ _ : [] -> AddInclude (SystemInclude file) + XObj (Sym (SymPath _ "add-cflag")) _ _ : XObj (Str flag) _ _ : [] -> AddCFlag flag + XObj (Sym (SymPath _ "add-lib")) _ _ : XObj (Str flag) _ _ : [] -> AddLibraryFlag flag + XObj (Sym (SymPath _ "project")) _ _ : [] -> DisplayProject + XObj (Sym (SymPath _ "load")) _ _ : XObj (Str path) _ _ : [] -> Load path + XObj (Sym (SymPath _ "reload")) _ _ : [] -> Reload + _ -> consumeExpr ctx xobj + Sym (SymPath [] (':' : text)) -> ListOfCommands (mapMaybe charToCommand text) + _ -> consumeExpr ctx xobj + +charToCommand :: Char -> Maybe ReplCommand +charToCommand 'x' = Just RunExe +charToCommand 'r' = Just Reload +charToCommand 'b' = Just BuildExe +charToCommand 'c' = Just Cat +charToCommand 'e' = Just ListBindingsInEnv +charToCommand 'h' = Just (Help "") +charToCommand 'p' = Just DisplayProject +charToCommand 'q' = Just Quit +charToCommand _ = Nothing + +define :: Context -> XObj -> IO Context +define ctx@(Context globalEnv _ _ proj _) annXObj = + do --putStrLnWithColor Blue (show (getPath annXObj) ++ " : " ++ showMaybeTy (ty annXObj)) + when (projectEchoC proj) $ + putStrLn (toC annXObj) + return (ctx { contextGlobalEnv = envInsertAt globalEnv (getPath annXObj) annXObj }) + +popModulePath :: Context -> Context +popModulePath ctx = ctx { contextPath = init (contextPath ctx) } + +executeCommand :: Context -> ReplCommand -> IO Context +executeCommand ctx@(Context env typeEnv pathStrings proj lastInput) cmd = + + do when (isJust (envModuleName env)) $ + compilerError ("Global env module name is " ++ fromJust (envModuleName env) ++ " (should be Nothing).") + + case cmd of + + Define xobj -> + let innerEnv = getEnv env pathStrings + in case expandAll env xobj of + Left err -> executeCommand ctx (ReplMacroError (show err)) + Right expanded -> + let xobjFullPath = setFullyQualifiedDefn expanded (SymPath pathStrings (getName xobj)) + xobjFullSymbols = setFullyQualifiedSymbols innerEnv xobjFullPath + in case annotate typeEnv env xobjFullSymbols of + Left err -> executeCommand ctx (ReplTypeError (show err)) + Right annXObjs -> foldM define ctx annXObjs + + DefineModule moduleName innerExpressions -> + case lookupInEnv (SymPath pathStrings moduleName) env of + Just (_, Binder (XObj (Mod _) _ _)) -> + do ctxAfterModuleAdditions <- foldM folder (Context env typeEnv (pathStrings ++ [moduleName]) proj lastInput) innerExpressions + return (popModulePath ctxAfterModuleAdditions) + Just _ -> + do putStrLnWithColor Red ("Can't redefine '" ++ moduleName ++ "' as module.") + return ctx + Nothing -> + do let parentEnv = getEnv env pathStrings + innerEnv = Env (Map.fromList []) (Just parentEnv) (Just moduleName) [] ExternalEnv + newModule = XObj (Mod innerEnv) Nothing (Just ModuleTy) + globalEnvWithModuleAdded = envInsertAt env (SymPath pathStrings moduleName) newModule + ctxAfterModuleDef <- foldM folder (Context globalEnvWithModuleAdded typeEnv (pathStrings ++ [moduleName]) proj lastInput) innerExpressions + return (popModulePath ctxAfterModuleDef) + + DefineType nameXObj rest -> + case nameXObj of + XObj (Sym (SymPath _ typeName)) i _ -> + case moduleForDeftype typeEnv env pathStrings typeName rest i of + Just (typeModuleName, typeModuleXObj, deps) -> + let typeDefinition = + -- NOTE: The type binding is needed to emit the type definition and all the member functions of the type. + XObj (Lst (XObj Typ Nothing Nothing : XObj (Sym (SymPath pathStrings typeName)) Nothing Nothing : rest)) i (Just TypeTy) + ctx' = (ctx { contextGlobalEnv = envInsertAt env (SymPath pathStrings typeModuleName) typeModuleXObj + , contextTypeEnv = extendEnv typeEnv typeName typeDefinition + }) + in do ctx'' <- foldM define ctx' deps + return ctx'' + Nothing -> + do putStrLnWithColor Red ("Invalid type definition: " ++ pretty nameXObj) + return ctx + _ -> + do putStrLnWithColor Red ("Invalid name for type definition: " ++ pretty nameXObj) + return ctx + + InstantiateTemplate nameXObj typeXObj -> + case nameXObj of + XObj (Sym path@(SymPath _ templateName)) _ _ -> + case xobjToTy typeXObj of + Just actualTypeSignature -> + case lookupInEnv path env of + Just (_, Binder (XObj (Lst [XObj (Deftemplate (TemplateCreator templateCreator)) _ _, _]) _ t)) -> + let Just t' = t + nameWithTypeArgSuffix = templateName ++ polymorphicSuffix t' actualTypeSignature + path' = SymPath pathStrings nameWithTypeArgSuffix + template = templateCreator typeEnv env + (instName, instBinder) = instanceBinder path' actualTypeSignature template + in return (ctx { contextGlobalEnv = envAddBinding env instName instBinder }) + Just _ -> do putStrLnWithColor Red ("Can't find a template named '" ++ templateName ++ "'") + return ctx + Nothing -> do putStrLnWithColor Red ("Can't find a template named '" ++ templateName ++ "'") + return ctx + Nothing -> error ("Internal compiler error: No type signature on template '" ++ templateName ++ "'") + _ -> + do putStrLnWithColor Red ("Invalid name for type definition: " ++ pretty nameXObj) + return ctx + + Register name xobj -> + case xobjToTy xobj of + Just t -> let path = SymPath pathStrings name + binding = XObj (Lst [XObj External Nothing Nothing, XObj (Sym path) Nothing Nothing]) (info xobj) (Just t) + env' = envInsertAt env path binding + in return (ctx { contextGlobalEnv = env' }) + Nothing -> do putStrLnWithColor Red ("Can't understand type when registering '" ++ name ++ "'") + return ctx + + RegisterType name -> + let path = SymPath pathStrings name + binding = XObj (Lst [XObj ExternalType Nothing Nothing, XObj (Sym path) Nothing Nothing]) Nothing (Just TypeTy) + typeEnv' = envInsertAt typeEnv path binding + in return (ctx { contextTypeEnv = typeEnv' }) + + DefineMacro name params body -> + let path = SymPath pathStrings name + macro = XObj (Lst [XObj Macro Nothing Nothing, XObj (Sym path) Nothing Nothing, params, body]) + (info body) (Just MacroTy) + in return (ctx { contextGlobalEnv = envInsertAt env path macro }) + + DefineDynamic name params body -> + let path = SymPath pathStrings name + dynamic = XObj (Lst [XObj Dynamic Nothing Nothing, XObj (Sym path) Nothing Nothing, params, body]) + (info body) (Just DynamicTy) + in return (ctx { contextGlobalEnv = envInsertAt env path dynamic }) + + Eval xobj -> + case eval env xobj of + Left e -> + do putStrLnWithColor Red (show e) + return ctx + Right evaled -> + do putStrLnWithColor Yellow (pretty evaled) + return ctx + + Expand xobj -> + case expandAll env xobj of + Left e -> + do putStrLnWithColor Red (show e) + return ctx + Right expanded -> + do putStrLnWithColor Yellow (pretty expanded) + return ctx + + Import path -> + let e = getEnv env pathStrings + imports = envImports e + e' = if path `elem` imports then e else e { envImports = path : imports } + innerEnv = getEnv env pathStrings + in case lookupInEnv path innerEnv of + Just (_, Binder _) -> return ctx { contextGlobalEnv = envReplaceEnvAt env pathStrings e' } + Nothing -> do putStrLnWithColor Red ("Can't import '" ++ show path ++ "'") + return ctx + + BuildExe -> + let src = do decl <- envToDeclarations env typeEnv + typeDecl <- envToDeclarations typeEnv typeEnv + c <- envToC env + return (typeDecl ++ "\n\n" ++ decl ++ "\n\n" ++ c) + in case src of + Left err -> do putStrLnWithColor Red ("[CODEGEN ERROR] " ++ show err) + return ctx + Right okSrc -> do let incl = projectIncludesToC proj + includeCorePath = " -I" ++ projectCarpDir proj ++ "/core/ " + switches = " -g " + flags = projectFlags proj ++ includeCorePath ++ switches + outDir = projectOutDir proj + outMain = outDir ++ "main.c" + outExe = outDir ++ "a.out" + outLib = outDir ++ "lib.so" + createDirectoryIfMissing False outDir + writeFile outMain (incl ++ okSrc) + case Map.lookup "main" (envBindings env) of + Just _ -> do callCommand ("clang " ++ outMain ++ " -o " ++ outExe ++ " " ++ flags) + putStrLn ("Compiled to '" ++ outExe ++ "'") + Nothing -> do callCommand ("clang " ++ outMain ++ " -shared -o " ++ outLib ++ " " ++ flags) + putStrLn ("Compiled to '" ++ outLib ++ "'") + return ctx + + RunExe -> + let outDir = projectOutDir proj + outExe = outDir ++ "a.out" + in do callCommand outExe + return ctx + + Cat -> + let outDir = projectOutDir proj + outMain = outDir ++ "main.c" + in do callCommand ("cat -n " ++ outMain) + return ctx + + Load path -> + do contents <- readFile path + let files = projectFiles proj + files' = if path `elem` files + then files + else path : files + proj' = proj { projectFiles = files' } + executeString (ctx { contextProj = proj' }) contents + + Reload -> + do let paths = projectFiles proj + f :: Context -> FilePath -> IO Context + f context filepath = do contents <- readFile filepath + executeString context contents + foldM f ctx paths + + AddInclude includer -> + let includers = projectIncludes proj + includers' = if includer `elem` includers + then includers + else includer : includers + proj' = proj { projectIncludes = includers' } + in return (ctx { contextProj = proj' }) + + AddCFlag flag -> + let flags = projectCFlags proj + flags' = if flag `elem` flags + then flags + else flag : flags + proj' = proj { projectCFlags = flags' } + in return (ctx { contextProj = proj' }) + + AddLibraryFlag flag -> + let flags = projectLibFlags proj + flags' = if flag `elem` flags + then flags + else flag : flags + proj' = proj { projectLibFlags = flags' } + in return (ctx { contextProj = proj' }) + + ReplParseError e -> + do putStrLnWithColor Red ("[PARSE ERROR] " ++ e) + return ctx + + ReplMacroError e -> + do putStrLnWithColor Red ("[MACRO ERROR] " ++ e) + return ctx + + ReplTypeError e -> + do putStrLnWithColor Red ("[TYPE ERROR] " ++ e) + return ctx + + ReplCodegenError e -> + do putStrLnWithColor Red ("[CODEGEN ERROR] " ++ e) + return ctx + + Print s -> + do putStrLn s + return ctx + + ListBindingsInEnv -> + do putStrLn (prettyEnvironment env) + putStrLn "" + putStrLn "Types:" + putStrLn (prettyEnvironment typeEnv) + putStrLn "" + return ctx + + DisplayProject -> + do print proj + return ctx + + Quit -> exitSuccess + + Help "about" -> do putStrLn "Carp is an ongoing research project by Erik Svedäng, et al." + putStrLn "" + putStrLn "Licensed under the Apache License, Version 2.0 (the \"License\"); \n\ + \you may not use this file except in compliance with the License. \n\ + \You may obtain a copy of the License at \n\ + \http://www.apache.org/licenses/LICENSE-2.0" + putStrLn "" + putStrLn "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY \n\ + \EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \n\ + \IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR \n\ + \PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE \n\ + \LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR \n\ + \CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF \n\ + \SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR \n\ + \BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, \n\ + \WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE \n\ + \OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN\n\ + \IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." + putStrLn "" + return ctx + + Help "language" -> do putStrLn "Special forms:" + putStrLn "(if )" + putStrLn "(while )" + putStrLn "(do ... )" + putStrLn "(let [ ...] )" + --putStrLn "(fn [] )" + putStrLn "(the )" + putStrLn "(ref )" + putStrLn "(address )" + putStrLn "(set! )" + putStrLn "" + putStrLn ("Valid non-alphanumerics: " ++ validCharacters) + putStrLn "" + putStrLn "Number literals:" + putStrLn "1 Int" + putStrLn "1.0 Double" + putStrLn "1.0f Float" + putStrLn "" + putStrLn "Reader macros:" + putStrLn "& (ref )" + putStrLn "@ (copy )" + putStrLn "" + return ctx + + Help "macros" -> do putStrLn "Some useful macros:" + putStrLn "(cond ... )" + putStrLn "(for [ ] )" + putStrLn "" + return ctx + + Help "structs" -> do putStrLn "A type definition will generate the following methods:" + putStrLn "Getters ( (Ref ))" + putStrLn "Setters (set- )" + putStrLn "Updaters (update- )" + putStrLn "init (stack allocation)" + putStrLn "new (heap allocation)" + putStrLn "copy" + putStrLn "delete (used internally, no need to call this explicitly)" + return ctx + + Help "shortcuts" -> do putStrLn "GHC-style shortcuts at the repl:" + putStrLn "(reload) :r" + putStrLn "(build) :b" + putStrLn "(run) :x" + putStrLn "(cat) :c" + putStrLn "(env) :e" + putStrLn "(help) :h" + putStrLn "(project) :p" + putStrLn "(quit) :q" + putStrLn "" + putStrLn "The shortcuts can be combined like this: \":rbx\"" + putStrLn "" + return ctx + + Help _ -> do putStrLn "Compiler commands:" + putStrLn "(load ) - Load a .carp file, evaluate its content, and add it to the project." + putStrLn "(reload) - Reload all the project files." + putStrLn "(build) - Produce an executable or shared library." + putStrLn "(run) - Run the executable produced by 'build' (if available)." + putStrLn "(cat) - Look at the generated C code (make sure you build first)." + putStrLn "(env) - List available bindings in the environment." + putStrLn "(project) - Display information about your project." + putStrLn "(quit) - Terminate this Carp REPL." + putStrLn "(help ) - Available chapters: language, macros, structs, shortcuts, about." + putStrLn "" + putStrLn "To define things:" + putStrLn "(def ) - Define a global variable." + putStrLn "(defn [] ) - Define a function." + putStrLn "(module ...) - Define a module and/or add definitions to an existing one." + putStrLn "(deftype ...) - Define a new type." + putStrLn "(register ) - Make an external variable or function available for usage." + putStrLn "" + putStrLn "C-compiler configuration:" + putStrLn "(system-include ) - Include a system header file." + putStrLn "(local-include ) - Include a local header file." + putStrLn "(add-cflag ) - Add a cflag to the compilation step." + putStrLn "(add-lib ) - Add a library flag to the compilation step." + putStrLn "" + return ctx + + DoNothing -> return ctx + + ListOfCommands commands -> foldM executeCommand ctx commands + +catcher :: Context -> IOException -> IO Context +catcher ctx err = do putStrLnWithColor Red ("[RUNTIME ERROR] " ++ show err) + return ctx + +executeString :: Context -> String -> IO Context +executeString ctx input = catch exec (catcher ctx) + where exec = case parse input of + Left parseError -> executeCommand ctx (ReplParseError (show parseError)) + Right xobjs -> foldM folder ctx xobjs + +folder :: Context -> XObj -> IO Context +folder context xobj = executeCommand context (objToCommand context xobj) diff --git a/src/Constraints.hs b/src/Constraints.hs new file mode 100644 index 000000000..4d7bdcfff --- /dev/null +++ b/src/Constraints.hs @@ -0,0 +1,182 @@ +module Constraints (solve, + Constraint(..), + UnificationFailure(..), + recursiveLookup, + debugSolveOne, -- exported to avoid warning about unused function (should be another way...) + debugResolveFully -- exported to avoid warning about unused function + ) where + +import qualified Data.Map as Map +import Control.Monad +import Debug.Trace + +import Obj +import Types + +data Constraint = Constraint Ty Ty XObj XObj deriving Eq + +data UnificationFailure = UnificationFailure { unificationFailure ::Constraint + , unificationMappings :: TypeMappings + } + | Holes [(String, Ty)] + deriving (Eq, Show) + +instance Show Constraint where + show (Constraint a b _ _) = "" ++ show a ++ " == " ++ show b ++ "" + +-- Finds the symbol with the "lowest name" (first in alphabetical order) +recursiveLookup :: TypeMappings -> String -> Maybe Ty +recursiveLookup mappings name = innerLookup name [] + where innerLookup :: String -> [Ty] -> Maybe Ty + innerLookup k visited = + case Map.lookup k mappings of + Just exists -> case exists of + VarTy v -> if exists `elem` visited + then stop + else innerLookup v (exists : visited) + actualType -> Just actualType + where + stop = Just (minimum (exists : visited)) + Nothing -> Nothing + +-- | This is the entry-point function that takes a list of constraints +-- (for example [t0 == Int, t1 == t0, t1 == t2]) +-- and creates a dictionary of mappings for the type variables +-- (for example t0 => Int, t1 => Int, t2 => Int). +solve :: [Constraint] -> Either UnificationFailure TypeMappings +solve constraints = do naiveMappings <- foldM solveOne Map.empty constraints + fullyResolved <- foldM resolveFully naiveMappings (map fst (Map.toList naiveMappings)) + checkForHoles fullyResolved + +checkForHoles :: TypeMappings -> Either UnificationFailure TypeMappings +checkForHoles mappings = case filter isTypeHole (Map.toList mappings) of + [] -> Right mappings + holes -> Left (Holes holes) + +isTypeHole :: (String, Ty) -> Bool +isTypeHole ('?' : _, _) = True +isTypeHole _ = False + +solveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings +solveOne mappings constraint = solveOneInternal mappings constraint + +debugSolveOne :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings +debugSolveOne mappings constraint = let m' = solveOneInternal mappings constraint + in trace ("" ++ show constraint ++ ", MAPPINGS: " ++ show m') + m' + +solveOneInternal :: TypeMappings -> Constraint -> Either UnificationFailure TypeMappings +solveOneInternal mappings constraint = + case constraint of + -- Two type variables + Constraint aTy@(VarTy aName) bTy@(VarTy bName) _ _ -> + if aTy == bTy + then Right mappings + else do m' <- checkForConflict mappings constraint aName bTy + checkForConflict m' constraint bName aTy + + -- One type variable + Constraint (VarTy aName) bTy _ _ -> checkForConflict mappings constraint aName bTy + Constraint aTy (VarTy bName) _ _ -> checkForConflict mappings constraint bName aTy + + -- Struct types + Constraint (StructTy nameA varsA) (StructTy nameB varsB) _ _ -> + if nameA == nameB + then let (Constraint _ _ i1 i2) = constraint + in foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2)) mappings (zip varsA varsB) + else Left (UnificationFailure constraint mappings) + + -- Func types + Constraint (FuncTy argsA retA) (FuncTy argsB retB) _ _ -> + if length argsA == length argsB + then let (Constraint _ _ i1 i2) = constraint + in foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2)) mappings (zip (retA : argsA) + (retB : argsB)) + else Left (UnificationFailure constraint mappings) + + -- Pointer types + Constraint (PointerTy a) (PointerTy b) _ _ -> + let (Constraint _ _ i1 i2) = constraint + in solveOneInternal mappings (Constraint a b i1 i2) + + -- Ref types + Constraint (RefTy a) (RefTy b) _ _ -> + let (Constraint _ _ i1 i2) = constraint + in solveOneInternal mappings (Constraint a b i1 i2) + + -- Else + Constraint aTy bTy _ _ -> + if aTy == bTy + then Right mappings + else Left (UnificationFailure constraint mappings) + +mkConstraint :: Ty -> Ty -> Constraint +mkConstraint t1 t2 = Constraint t1 t2 dummy dummy + where dummy = XObj External Nothing Nothing + +checkForConflict :: TypeMappings -> Constraint -> String -> Ty -> Either UnificationFailure TypeMappings +checkForConflict mappings constraint name otherTy = + case recursiveLookup mappings name of + Just (VarTy _) -> ok + Just (StructTy structName structTyVars) -> + case otherTy of + StructTy otherStructName otherTyVars | structName == otherStructName -> + foldM solveOneInternal mappings (zipWith mkConstraint structTyVars otherTyVars) + VarTy _ -> Right mappings + _ -> Left (UnificationFailure constraint mappings) + Just (FuncTy argTys retTy) -> + case otherTy of + FuncTy otherArgTys otherRetTy -> do m <- foldM solveOneInternal mappings (zipWith mkConstraint argTys otherArgTys) + solveOneInternal m (mkConstraint retTy otherRetTy) + VarTy _ -> Right mappings + _ -> Left (UnificationFailure constraint mappings) + Just (PointerTy innerTy) -> + case otherTy of + PointerTy otherInnerTy -> solveOneInternal mappings (mkConstraint innerTy otherInnerTy) + VarTy _ -> Right mappings + _ -> Left (UnificationFailure constraint mappings) + Just (RefTy innerTy) -> + case otherTy of + RefTy otherInnerTy -> solveOneInternal mappings (mkConstraint innerTy otherInnerTy) + VarTy _ -> Right mappings + _ -> Left (UnificationFailure constraint mappings) + Just foundNonVar -> case otherTy of + (VarTy v) -> case recursiveLookup mappings v of + Just (VarTy _) -> Right mappings + Just otherNonVar -> if foundNonVar == otherNonVar + then Right mappings + else Left (UnificationFailure constraint mappings) + Nothing -> Right mappings + _ -> if otherTy == foundNonVar + then ok + else Left (UnificationFailure constraint mappings) + -- Not found, no risk for conflict: + Nothing -> ok + where + ok = Right (Map.insert name otherTy mappings) + +debugResolveFully :: TypeMappings -> String -> Either UnificationFailure TypeMappings +debugResolveFully mappings var = trace ("Mappings: " ++ show mappings ++ ", will resolve " ++ show var) (resolveFully mappings var) + +resolveFully :: TypeMappings -> String -> Either UnificationFailure TypeMappings +resolveFully mappings varName = Right (Map.insert varName (fullResolve (VarTy varName)) mappings) + + where fullResolve :: Ty -> Ty + fullResolve x@(VarTy var) = + case recursiveLookup mappings var of + Just (StructTy name varTys) -> StructTy name (map fullLookup varTys) + Just (FuncTy argTys retTy) -> FuncTy (map fullLookup argTys) (fullLookup retTy) + Just found -> found + Nothing -> x -- still not found, must be a generic variable + fullResolve x = x + + fullLookup :: Ty -> Ty + fullLookup vv@(VarTy v) = case recursiveLookup mappings v of + --Just found -> fullLookup found + Just found -> if found == vv + then found + else fullLookup found + Nothing -> vv-- compilerError ("In full lookup: Can't find " ++ v ++ " in mappings: " ++ show mappings) + fullLookup (StructTy name vs) = StructTy name (map fullLookup vs) + fullLookup (FuncTy argTys retTy) = FuncTy (map fullLookup argTys) (fullLookup retTy) + fullLookup x = x diff --git a/src/Deftype.hs b/src/Deftype.hs new file mode 100644 index 000000000..6b93b6076 --- /dev/null +++ b/src/Deftype.hs @@ -0,0 +1,250 @@ +module Deftype (moduleForDeftype) where + +import qualified Data.Map as Map +import Data.Maybe +import Debug.Trace + +import Obj +import Types +import Util +import Template +import Infer + +data AllocationMode = StackAlloc | HeapAlloc + +-- | This function creates a "Type Module" with the same name as the type being defined. +-- A type module provides a namespace for all the functions that area automatically +-- generated by a deftype. +moduleForDeftype :: Env -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Maybe (String, XObj, [XObj]) +moduleForDeftype typeEnv env pathStrings typeName rest i = + let typeModuleName = typeName + emptyTypeModuleEnv = Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv + -- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'. + -- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc. + insidePath = pathStrings ++ [typeModuleName] + in do _ <- validateMembers rest + okInit <- templateForInit insidePath typeName rest + okNew <- templateForNew insidePath typeName rest + (okDelete, deleteDeps) <- templateForDelete typeEnv env insidePath typeName rest + (okCopy, copyDeps) <- templateForCopy typeEnv env insidePath typeName rest + (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath typeName rest + let funcs = okInit : okNew : okDelete : okCopy : okMembers + moduleEnvWithBindings = addListOfBindings emptyTypeModuleEnv funcs + typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy) + deps = deleteDeps ++ membersDeps ++ copyDeps + return (typeModuleName, typeModuleXObj, deps) + +-- | What a mess this function is... +validateMembers :: [XObj] -> Maybe () +validateMembers rest = if all (== True) (map validateOneCase rest) + then Just () + else Nothing + +validateOneCase :: XObj -> Bool +validateOneCase (XObj (Arr arr) _ _) = length arr `mod` 2 == 0 && + all okMemberType (map snd (pairwise arr)) +validateOneCase XObj {} = False + +okMemberType :: XObj -> Bool +okMemberType xobj = case xobjToTy xobj of + Just _ -> True + Nothing -> False + +initArgListTypes :: [XObj] -> [Ty] +initArgListTypes xobjs = map (\(_, x) -> fromJust (xobjToTy x)) (pairwise xobjs) + +templateForInit :: [String] -> String -> [XObj] -> Maybe (String, Binder) +templateForInit insidePath typeName [XObj (Arr membersXObjs) _ _] = + Just $ instanceBinder (SymPath insidePath "init") + (FuncTy (initArgListTypes membersXObjs) (StructTy typeName [])) + (templateInit StackAlloc typeName (memberXObjsToPairs membersXObjs)) +templateForInit _ _ _ = Nothing + +templateForNew :: [String] -> String -> [XObj] -> Maybe (String, Binder) +templateForNew insidePath typeName [XObj (Arr membersXObjs) _ _] = + Just $ instanceBinder (SymPath insidePath "new") + (FuncTy (initArgListTypes membersXObjs) (PointerTy (StructTy typeName []))) + (templateInit HeapAlloc typeName (memberXObjsToPairs membersXObjs)) +templateForNew _ _ _ = Nothing + +templateForDelete :: Env -> Env -> [String] -> String -> [XObj] -> Maybe ((String, Binder), [XObj]) +templateForDelete typeEnv env insidePath typeName [XObj (Arr membersXObjs) _ _] = + Just $ (instanceBinderWithDeps (SymPath insidePath "delete") + (FuncTy [(StructTy typeName [])] UnitTy) + (templateDelete typeEnv env (memberXObjsToPairs membersXObjs))) +templateForDelete _ _ _ _ _ = Nothing + +templateForCopy :: Env -> Env -> [String] -> String -> [XObj] -> Maybe ((String, Binder), [XObj]) +templateForCopy typeEnv env insidePath typeName [XObj (Arr membersXObjs) _ _] = + Just $ (instanceBinderWithDeps (SymPath insidePath "copy") + (FuncTy [(RefTy (StructTy typeName []))] (StructTy typeName [])) + (templateCopy typeEnv env (memberXObjsToPairs membersXObjs))) +templateForCopy _ _ _ _ _ = Nothing + +memberXObjsToPairs :: [XObj] -> [(String, Ty)] +memberXObjsToPairs xobjs = map (\(n, t) -> (getName n, fromJust (xobjToTy t))) (pairwise xobjs) + +templatesForMembers :: Env -> Env -> [String] -> String -> [XObj] -> Maybe ([(String, Binder)], [XObj]) +templatesForMembers typeEnv env insidePath typeName [XObj (Arr membersXobjs) _ _] = + let bindersAndDeps = concatMap (templatesForSingleMember typeEnv env insidePath typeName) (pairwise membersXobjs) + in Just (map fst bindersAndDeps, concatMap snd bindersAndDeps) +templatesForMembers _ _ _ _ _ = error "Can't create member functions for type with more than one case." + +templatesForSingleMember :: Env -> Env -> [String] -> String -> (XObj, XObj) -> [((String, Binder), [XObj])] +templatesForSingleMember typeEnv env insidePath typeName (nameXObj, typeXObj) = + let Just t = xobjToTy typeXObj + p = StructTy typeName [] + memberName = getName nameXObj + fixedMemberTy = if isManaged t then (RefTy t) else t + in [instanceBinderWithDeps (SymPath insidePath memberName) (FuncTy [(RefTy p)] fixedMemberTy) (templateGetter memberName fixedMemberTy) + ,instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) (FuncTy [p, t] p) (templateSetter typeEnv env memberName t) + ,instanceBinderWithDeps (SymPath insidePath ("update-" ++ memberName)) + (FuncTy [p, (FuncTy [t] t)] p) + (templateUpdater memberName)] + +templateInit :: AllocationMode -> String -> [(String, Ty)] -> Template +templateInit allocationMode typeName members = + Template + (FuncTy [] (VarTy "p")) + (const (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg members) ++ ")")) + (const (toTemplate $ unlines [ "$DECL {" + , case allocationMode of + StackAlloc -> " $p instance;" + HeapAlloc -> " $p instance = malloc(sizeof(" ++ typeName ++ "));" + , joinWith "\n" (map (memberAssignment allocationMode) members) + , " return instance;" + , "}"])) + (const []) + +memberArg :: (String, Ty) -> String +memberArg (memberName, memberTy) = tyToC memberTy ++ " " ++ memberName + +memberAssignment :: AllocationMode -> (String, Ty) -> String +memberAssignment allocationMode (memberName, _) = " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";" + where sep = case allocationMode of + StackAlloc -> "." + HeapAlloc -> "->" + +templateGetter :: String -> Ty -> Template +templateGetter member fixedMemberTy = + let maybeAmpersand = case fixedMemberTy of + RefTy _ -> "&" + _ -> "" + in + Template + (FuncTy [RefTy (VarTy "p")] (VarTy "t")) + (const (toTemplate "$t $NAME($(Ref p) p)")) + (const (toTemplate ("$DECL { return " ++ maybeAmpersand ++ "(p->" ++ member ++ "); }\n"))) + (const []) + +templateSetter :: Env -> Env -> String -> Ty -> Template +templateSetter typeEnv env memberName memberTy = + let callToDelete = memberDeletion env (memberName, memberTy) + in + Template + (FuncTy [VarTy "p", VarTy "t"] (VarTy "p")) + (const (toTemplate "$p $NAME($p p, $t newValue)")) + (const (toTemplate (unlines ["$DECL {" + ,callToDelete + ," p." ++ memberName ++ " = newValue;" + ," return p;" + ,"}\n"]))) + (\_ -> (memberDeletionDeps typeEnv env (memberName, memberTy))) + +templateUpdater :: String -> Template +templateUpdater member = + Template + (FuncTy [VarTy "p", (FuncTy [VarTy "t"] (VarTy "t"))] (VarTy "p")) + (const (toTemplate "$p $NAME($p p, $(Fn [t] t) updater)")) + (const (toTemplate (unlines ["$DECL {" + ," p." ++ member ++ " = updater(p." ++ member ++ ");" + ," return p;" + ,"}\n"]))) + (\(FuncTy [_, t] _) -> [defineFunctionTypeAlias t]) + +templateDelete :: Env -> Env -> [(String, Ty)] -> Template +templateDelete typeEnv env members = + Template + (FuncTy [(VarTy "p")] UnitTy) + (const (toTemplate $ "void $NAME($p p)")) + (const (toTemplate $ unlines [ "$DECL {" + , (joinWith "\n" (map (memberDeletion env) members)) + , "}"])) + (\_ -> concatMap (memberDeletionDeps typeEnv env) members) + +-- TODO: Should return an Either since this can fail. +memberDeletion :: Env -> (String, Ty) -> String +memberDeletion env (memberName, t) + | isManaged t = + case filter ((\(Just t') -> (areUnifiable (FuncTy [t] UnitTy) t')) . ty . binderXObj . snd) (multiLookupALL "delete" env) of + [] -> " /* Can't find any delete-function for member '" ++ memberName ++ "' */" + [(_, Binder single)] -> + let Just t' = ty single + (SymPath pathStrings name) = getPath single + suffix = polymorphicSuffix t' (FuncTy [t] UnitTy) + concretizedPath = SymPath pathStrings (name ++ suffix) + in " " ++ pathToC concretizedPath ++ "(p." ++ memberName ++ ");" + _ -> " /* Can't find a single delete-function for member '" ++ memberName ++ "' */" + | otherwise = " /* Ignore non-managed member '" ++ memberName ++ "' */" + +-- TODO: Should return an Either since this can fail. +memberDeletionDeps :: Env -> Env -> (String, Ty) -> [XObj] +memberDeletionDeps typeEnv env (memberName, t) + | isManaged t = + case filter ((\(Just t') -> (areUnifiable (FuncTy [t] UnitTy) t')) . ty . binderXObj . snd) (multiLookupALL "delete" env) of + [] -> (trace $ "No delete function found for member '" ++ memberName ++ "'") [] + [(_, Binder (XObj (Lst ((XObj (Instantiate _) _ _) : _)) _ _))] -> + [] + [(_, Binder single)] -> + case concretizeDefinition False typeEnv env single (FuncTy [t] (UnitTy)) of + Left err -> error (show err) + Right (ok, deps) -> (ok : deps) + _ -> (trace $ "Too many delete functions found for member '" ++ memberName ++ "'") [] + | otherwise = [] + + + + + +--------------------------------------------------------------------- +-- Copy members, replace with "nameOfPolymorphicFunction" in Infer.hs + +templateCopy :: Env -> Env -> [(String, Ty)] -> Template +templateCopy typeEnv env members = + Template + (FuncTy [(RefTy (VarTy "p"))] (VarTy "p")) + (const (toTemplate $ "$p $NAME($p* pRef)")) + (const (toTemplate $ unlines [ "$DECL {" + , " $p copy = *pRef;" + , (joinWith "\n" (map (memberCopy env) members)) + , " return copy;" + , "}"])) + (\_ -> concatMap (memberCopyDeps typeEnv env) members) + +memberCopy :: Env -> (String, Ty) -> String +memberCopy env (memberName, t) + | isManaged t = + case filter ((\(Just t') -> (areUnifiable (FuncTy [(RefTy t)] t) t')) . ty . binderXObj . snd) (multiLookupALL "copy" env) of + [] -> " /* Can't find any copy-function for member '" ++ memberName ++ "' */" + [(_, Binder single)] -> + let Just t' = ty single + (SymPath pathStrings name) = getPath single + suffix = polymorphicSuffix t' (FuncTy [t] UnitTy) + concretizedPath = SymPath pathStrings (name ++ suffix) + in " copy." ++ memberName ++ " = " ++ pathToC concretizedPath ++ "(&(pRef->" ++ memberName ++ "));" + _ -> " /* Can't find a single copy-function for member '" ++ memberName ++ "' */" + | otherwise = " /* Ignore non-managed member '" ++ memberName ++ "' */" + +memberCopyDeps :: Env -> Env -> (String, Ty) -> [XObj] +memberCopyDeps typeEnv env (memberName, t) + | isManaged t = + case filter ((\(Just t') -> (areUnifiable (FuncTy [(RefTy t)] t) t')) . ty . binderXObj . snd) (multiLookupALL "copy" env) of + [] -> (trace $ "No copy function found for member '" ++ memberName ++ "'") [] + [(_, Binder (XObj (Lst ((XObj (Instantiate _) _ _) : _)) _ _))] -> + [] + [(_, Binder single)] -> + case concretizeDefinition False typeEnv env single (FuncTy [t] (UnitTy)) of + Left err -> error (show err) + Right (ok, deps) -> (ok : deps) + _ -> (trace $ "Too many copy functions found for member '" ++ memberName ++ "'") [] + | otherwise = [] diff --git a/src/Emit.hs b/src/Emit.hs new file mode 100644 index 000000000..e29829238 --- /dev/null +++ b/src/Emit.hs @@ -0,0 +1,467 @@ +module Emit (toC, envToC, projectIncludesToC, envToDeclarations) where + +import Data.List (intercalate, sortOn) +import Control.Monad.State +import Control.Monad (when, zipWithM_) +import qualified Data.Map as Map +import Debug.Trace + +import Obj +import Types +import Util +import Template + +addIndent :: Int -> String +addIndent n = replicate n ' ' + +indentAmount :: Int +indentAmount = 4 + +data ToCError = InvalidParameter XObj + | InvalidList XObj + | DontVisitObj Obj + | CannotEmitUnit + | CannotEmitExternal + | CannotEmitModKeyword + | BinderIsMissingType Binder + +instance Show ToCError where + show (InvalidParameter xobj) = "Invalid parameter: " ++ show (obj xobj) + show (InvalidList xobj) = "Invalid list: " ++ show (obj xobj) + show (DontVisitObj o) = "Don't visit " ++ show o ++ " (internal compiler error)." + show CannotEmitUnit = "Can't emit code for empty list: ()" + show CannotEmitExternal = "Can't emit code for external function/variable." + show CannotEmitModKeyword = "Can't emit code for Mod." + show (BinderIsMissingType b) = "Binder is missing type: " ++ show b + +data EmitterState = EmitterState { emitterSrc :: String } + +appendToSrc :: String -> State EmitterState () +appendToSrc moreSrc = modify (\s -> s { emitterSrc = emitterSrc s ++ moreSrc }) + +toC :: XObj -> String +toC root = emitterSrc (execState (visit 0 root) (EmitterState "")) + where visit :: Int -> XObj -> State EmitterState String + visit indent xobj = + case obj xobj of + Lst _ -> visitList indent xobj + Arr _ -> visitArray indent xobj + Num IntTy num -> return (show ((round num) :: Int)) + Num FloatTy num -> return (show num ++ "f") + Num DoubleTy num -> return (show num) + Num _ _ -> error "Can't emit invalid number type." + Bol b -> return (if b then "true" else "false") + Str _ -> visitString indent xobj + Chr c -> return ('\'' : c : '\'' : []) + Sym _ -> visitSymbol xobj + Defn -> error (show (DontVisitObj Defn)) + Def -> error (show (DontVisitObj Def)) + Let -> error (show (DontVisitObj Let)) + If -> error (show (DontVisitObj If)) + While -> error (show (DontVisitObj While)) + Do -> error (show (DontVisitObj Do)) + Typ -> error (show (DontVisitObj Typ)) + Mod _ -> error (show CannotEmitModKeyword) + External -> error (show CannotEmitExternal) + ExternalType -> error (show (DontVisitObj ExternalType)) + e@(Deftemplate _) -> error (show (DontVisitObj e)) + e@(Instantiate _) -> error (show (DontVisitObj e)) + e@(Defalias _) -> error (show (DontVisitObj e)) + e@(MultiSym _ _) -> error (show (DontVisitObj e)) + Address -> error (show (DontVisitObj Address)) + SetBang -> error (show (DontVisitObj SetBang)) + Macro -> error (show (DontVisitObj Macro)) + Dynamic -> error (show (DontVisitObj Dynamic)) + The -> error (show (DontVisitObj The)) + Ref -> error (show (DontVisitObj Ref)) + + visitString indent (XObj (Str str) (Just i) _) = + do let var = freshVar i + appendToSrc (addIndent indent ++ "string " ++ var ++ " = strdup(\"" ++ str ++ "\");\n") + return var + visitString _ _ = error "Not a string." + + visitSymbol :: XObj -> State EmitterState String + visitSymbol xobj@(XObj (Sym path) _ t) = let Just t' = t + in if typeIsGeneric t' + then error ("Can't emit symbol of generic type: " ++ + show path ++ " : " ++ show t' ++ " at " ++ prettyInfoFromXObj xobj) + else return (pathToC path) + visitSymbol _ = error "Not a symbol." + + visitList :: Int -> XObj -> State EmitterState String + visitList indent (XObj (Lst xobjs) (Just i) t) = + case xobjs of + -- Defn + XObj Defn _ _ : XObj (Sym path) _ _ : XObj (Arr argList) _ _ : body : [] -> + do let innerIndent = indent + indentAmount + Just (FuncTy _ retTy) = t + defnDecl = defnToDeclaration path argList retTy + appendToSrc (defnDecl ++ " {\n") + ret <- visit innerIndent body + delete innerIndent i + when (retTy /= UnitTy) $ + appendToSrc (addIndent innerIndent ++ "return " ++ ret ++ ";\n") + appendToSrc "}\n\n" + return "" + + -- Def + XObj Def _ _ : XObj (Sym path) _ _ : expr : [] -> + do ret <- visit 0 expr + let Just t' = t + appendToSrc ("const " ++ tyToC t' ++ " " ++ pathToC path ++ " = " ++ ret ++ ";\n") + return "" + + -- Let + (XObj Let _ _) : (XObj (Arr bindings) _ _) : body : [] -> + let indent' = indent + indentAmount + in do let Just bodyTy = ty body + isNotVoid = bodyTy /= UnitTy + letBodyRet = freshVar i + when isNotVoid $ -- Must be declared outside the scope + appendToSrc (addIndent indent ++ tyToC bodyTy ++ " " ++ letBodyRet ++ ";\n") + appendToSrc (addIndent indent ++ "/* let */ {\n") + let letBindingToC (XObj (Sym (SymPath _ symName)) _ _) expr = + do ret <- visit indent' expr + let Just bindingTy = ty expr + appendToSrc (addIndent indent' ++ tyToC bindingTy ++ " " ++ mangle symName ++ " = " ++ ret ++ ";\n") + letBindingToC _ _ = error "Invalid binding." + _ <- mapM (\(sym, expr) -> letBindingToC sym expr) (pairwise bindings) + ret <- visit indent' body + when isNotVoid $ + appendToSrc (addIndent indent' ++ letBodyRet ++ " = " ++ ret ++ ";\n") + delete indent' i + appendToSrc (addIndent indent ++ "}\n") + return letBodyRet + + -- If + XObj If _ _ : expr : ifTrue : ifFalse : [] -> + let indent' = indent + indentAmount + in do let isNotVoid = ty ifTrue /= Just UnitTy + ifRetVar = freshVar i + when isNotVoid $ + let Just ifT = ty ifTrue + in appendToSrc (addIndent indent ++ tyToC ifT ++ " " ++ ifRetVar ++ ";\n") + exprVar <- visit indent expr + appendToSrc (addIndent indent ++ "if (" ++ exprVar ++ ") {\n") + trueVar <- visit indent' ifTrue + let Just ifTrueInfo = info ifTrue + delete indent' ifTrueInfo + when isNotVoid $ + appendToSrc (addIndent indent' ++ ifRetVar ++ " = " ++ trueVar ++ ";\n") + appendToSrc (addIndent indent ++ "} else {\n") + falseVar <- visit indent' ifFalse + let Just ifFalseInfo = info ifFalse + delete indent' ifFalseInfo + when isNotVoid $ + appendToSrc (addIndent indent' ++ ifRetVar ++ " = " ++ falseVar ++ ";\n") + appendToSrc (addIndent indent ++ "}\n") + return ifRetVar + + -- While + XObj While _ _ : expr : body : [] -> + let indent' = indent + indentAmount + Just exprTy = ty expr + conditionVar = freshVar i + in do exprRetVar <- visitWhileExpression indent + appendToSrc (addIndent indent ++ tyToC exprTy ++ " " ++ conditionVar ++ " = " ++ exprRetVar ++ ";\n") + appendToSrc (addIndent indent ++ "while (" ++ conditionVar ++ ") {\n") + _ <- visit indent' body + exprRetVar' <- visitWhileExpression indent' + delete indent' i + appendToSrc (addIndent indent' ++ conditionVar ++ " = " ++ exprRetVar' ++ ";\n") + appendToSrc (addIndent indent ++ "}\n") + return "" + + where visitWhileExpression :: Int -> State EmitterState String + visitWhileExpression ind = + do s <- get + let (exprRetVar, exprResultState) = runState (visit ind expr) (EmitterState "") + exprSrc = emitterSrc exprResultState + modify (\x -> x { emitterSrc = emitterSrc s ++ exprSrc + }) + return exprRetVar + + -- Do + XObj Do _ _ : expressions -> + do let lastExpr = last expressions + retVar = freshVar i + _ <- mapM (visit indent) (init expressions) + let (Just lastTy) = ty lastExpr + if lastTy == UnitTy + then do _ <- visit indent lastExpr + return "" + else do lastRet <- visit indent lastExpr + appendToSrc (addIndent indent ++ tyToC lastTy ++ " " ++ retVar ++ " = " ++ lastRet ++ ";\n") + return retVar + + -- Address + XObj Address _ _ : value : [] -> + do valueVar <- visit indent value + return ("&" ++ valueVar) + + -- Set! + XObj SetBang _ _ : variable : value : [] -> + do valueVar <- visit indent value + appendToSrc (addIndent indent ++ mangle (getName variable) ++ " = " ++ valueVar ++ ";\n") + return "" + + -- The + XObj The _ _ : _ : value : [] -> + do var <- visit indent value + let Just t' = t + fresh = mangle (freshVar i) + appendToSrc (addIndent indent ++ tyToC t' ++ " " ++ fresh ++ " = " ++ var ++ "; // From the 'the' function.\n") + return fresh + + -- Ref + XObj Ref _ _ : value : [] -> + do var <- visit indent value + let Just t' = t + fresh = mangle (freshVar i) + appendToSrc (addIndent indent ++ tyToC t' ++ " " ++ fresh ++ " = &" ++ var ++ "; // ref\n") + return fresh + + -- Deftype + XObj Typ _ _ : XObj (Sym _) _ _ : _ -> + return "" + + -- Template + (XObj (Deftemplate _) _ _) : (XObj (Sym _) _ _) : [] -> + return "" + + (XObj (Instantiate template) _ _) : (XObj (Sym path) _ _) : [] -> + do let Just t' = t + appendToSrc (templateToC template path t') + return "" + + -- Alias + (XObj (Defalias _) _ _) : _ -> + return "" + + -- External + (XObj External _ _) : _ -> + return "" + + -- Macro + (XObj Macro _ _) : _ -> + return "" + + -- Dynamic + (XObj Dynamic _ _) : _ -> + return "" + + -- Function application + func : args -> + do funcToCall <- visit indent func + argListAsC <- createArgList indent args + let Just (FuncTy _ retTy) = ty func + if retTy == UnitTy + then do appendToSrc (addIndent indent ++ funcToCall ++ "(" ++ argListAsC ++ ");\n") + return "" + else do let varName = freshVar i + appendToSrc (addIndent indent ++ tyToC retTy ++ " " ++ varName ++ " = " ++ funcToCall ++ "(" ++ argListAsC ++ ");\n") + return varName + + -- Empty list + [] -> do appendToSrc (addIndent indent ++ "/* () */\n") + return "" + visitList _ xobj = error ("Must visit list! " ++ show xobj) + + createArgList :: Int -> [XObj] -> State EmitterState String + createArgList indent args = do argStrings <- mapM (visit indent) args + return (intercalate ", " argStrings) + + visitArray :: Int -> XObj -> State EmitterState String + visitArray indent (XObj (Arr xobjs) (Just i) t) = + do let arrayVar = freshVar i + len = length xobjs + Just (StructTy "Array" [innerTy]) = t + appendToSrc (addIndent indent ++ "Array " ++ arrayVar ++ + " = { .len = " ++ show len ++ "," ++ + " .data = malloc(sizeof(" ++ tyToC innerTy ++ ") * " ++ show len ++ ") };\n") + zipWithM_ (visitArrayElement indent arrayVar innerTy) [0..] xobjs + return arrayVar + + visitArray _ _ = error "Must visit array!" + + visitArrayElement :: Int -> String -> Ty -> Int -> XObj -> State EmitterState () + visitArrayElement indent arrayVar innerTy index xobj = + do visited <- visit indent xobj + appendToSrc (addIndent indent ++ "((" ++ tyToC innerTy ++ "*)" ++ arrayVar ++ + ".data)[" ++ show index ++ "] = " ++ visited ++ ";\n") + return () + +delete :: Int -> Info -> State EmitterState () +delete indent i = mapM_ deleterToC (infoDelete i) + where deleterToC :: Deleter -> State EmitterState () + deleterToC FakeDeleter {} = + return () + deleterToC deleter@(ProperDeleter {}) = + appendToSrc $ (addIndent indent) ++ "" ++ pathToC (deleterPath deleter) ++ "(" ++ (deleterVariable deleter) ++ ");\n" + +defnToDeclaration :: SymPath -> [XObj] -> Ty -> String +defnToDeclaration path@(SymPath _ name) argList retTy = + let retTyAsC = tyToC $ if name == "main" + then IntTy + else retTy + paramsAsC = paramListToC argList + in (retTyAsC ++ " " ++ pathToC path ++ "(" ++ paramsAsC ++ ")") + +templateToC :: Template -> SymPath -> Ty -> String +templateToC template path actualTy = + let mappings = unifySignatures (templateSignature template) actualTy + declaration = (templateDeclaration template) actualTy + definition = (templateDefinition template) actualTy + tokens = concatMap (concretizeTypesInToken mappings (pathToC path) declaration) definition + in concatMap show tokens ++ "\n" + +templateToDeclaration :: Template -> SymPath -> Ty -> String +templateToDeclaration template path actualTy = + let mappings = unifySignatures (templateSignature template) actualTy + e = error "Can't refer to declaration in declaration." + declaration = (templateDeclaration template) actualTy + tokens = concatMap (concretizeTypesInToken mappings (pathToC path) e) declaration + in concatMap show tokens ++ ";\n" + +deftypeToDeclaration :: SymPath -> [XObj] -> String +deftypeToDeclaration path rest = + let indent' = indentAmount + (SymPath _ typeName) = path + --p = (PointerTy (StructTy typeName [])) + + typedefCaseToMemberDecl :: XObj -> State EmitterState [()] + typedefCaseToMemberDecl (XObj (Arr members) _ _) = mapM memberToDecl (pairwise members) + typedefCaseToMemberDecl _ = error "Invalid case in typedef." + + memberToDecl :: (XObj, XObj) -> State EmitterState () + memberToDecl (memberName, memberType) = + case xobjToTy memberType of + Just t -> appendToSrc (addIndent indent' ++ tyToC t ++ " " ++ getName memberName ++ ";\n") + Nothing -> error ("Invalid memberType: " ++ show memberType) + + -- Note: the names of types are not namespaced + visit = do appendToSrc "typedef struct {\n" + _ <- mapM typedefCaseToMemberDecl rest + appendToSrc ("} " ++ typeName ++ ";\n") + + in emitterSrc (execState visit (EmitterState "")) + +defaliasToDeclaration :: Ty -> SymPath -> String +defaliasToDeclaration t path = + case t of + (FuncTy argTys retTy) -> "typedef " ++ tyToC retTy ++ "(*" ++ pathToC path ++ ")(" ++ + intercalate ", " (map tyToC argTys) ++ ");\n" + _ -> "typedef " ++ tyToC t ++ " " ++ pathToC path ++ ";\n" + +toDeclaration :: XObj -> String +toDeclaration xobj@(XObj (Lst xobjs) _ t) = + case xobjs of + (XObj Defn _ _) : (XObj (Sym path) _ _) : (XObj (Arr argList) _ _) : _ : [] -> + let (Just (FuncTy _ retTy)) = t + in defnToDeclaration path argList retTy ++ ";\n" + (XObj Def _ _) : (XObj (Sym path) _ _) : _ : [] -> + let Just t' = t + in "const " ++ tyToC t' ++ " " ++ pathToC path ++ ";\n" + (XObj Typ _ _) : (XObj (Sym path) _ _) : rest -> + deftypeToDeclaration path rest + (XObj (Deftemplate _) _ _) : _ -> + "" + (XObj Macro _ _) : _ -> + "" + (XObj Dynamic _ _) : _ -> + "" + (XObj (Instantiate template) _ _) : (XObj (Sym path) _ _) : [] -> + let Just t' = t + in templateToDeclaration template path t' + (XObj (Defalias aliasTy) _ _) : (XObj (Sym path) _ _) : [] -> + defaliasToDeclaration aliasTy path + (XObj External _ _) : _ -> + "" + (XObj ExternalType _ _) : _ -> + "" + _ -> error ("Internal compiler error: Can't emit other kinds of definitions: " ++ show xobj) +toDeclaration _ = error "Missing case." + +paramListToC :: [XObj] -> String +paramListToC xobjs = intercalate ", " (map getParam xobjs) + where getParam :: XObj -> String + getParam (XObj (Sym (SymPath _ name)) _ (Just t)) = tyToC t ++ " " ++ mangle name + getParam invalid = error (show (InvalidParameter invalid)) + +projectIncludesToC :: Project -> String +projectIncludesToC proj = intercalate "\n" (map includerToC (projectIncludes proj)) ++ "\n\n" + where includerToC (SystemInclude file) = "#include <" ++ file ++ ">" + includerToC (LocalInclude file) = "#include \"" ++ file ++ "\"" + +binderToC :: Binder -> Either ToCError String +binderToC binder = let xobj = binderXObj binder + in case xobj of + XObj External _ _ -> Right "" + XObj ExternalType _ _ -> Right "" + XObj (Mod env) _ _ -> envToC env + _ -> case ty xobj of + Just t -> if typeIsGeneric t then Right "" else Right (toC xobj) + Nothing -> Left (BinderIsMissingType binder) + +binderToDeclaration :: Env -> Binder -> Either ToCError String +binderToDeclaration typeEnv binder = + let xobj = binderXObj binder + in case xobj of + XObj (Mod env) _ _ -> envToDeclarations env typeEnv + _ -> case ty xobj of + Just t -> if typeIsGeneric t then Right "" else Right (toDeclaration xobj ++ "") + Nothing -> Left (BinderIsMissingType binder) + +envToC :: Env -> Either ToCError String +envToC env = let binders = map snd (Map.toList (envBindings env)) + in do okCodes <- mapM binderToC binders + return (concat okCodes) + +envToDeclarations :: Env -> Env -> Either ToCError String +envToDeclarations env typeEnv = + let binders = sortDeclarationBinders typeEnv (map snd (Map.toList (envBindings env))) + in do okDecls <- mapM (binderToDeclaration typeEnv) binders + return (concat okDecls) + +-- debugScorePair :: (Int, Binder) -> (Int, Binder) +-- debugScorePair (s,b) = trace ("Scored binder: " ++ show b ++ ", score: " ++ show s) (s,b) + +sortDeclarationBinders :: Env -> [Binder] -> [Binder] +sortDeclarationBinders typeEnv binders = map snd (sortOn fst (map scoreBinder binders)) + where scoreBinder :: Binder -> (Int, Binder) + scoreBinder b@(Binder (XObj (Lst (XObj x _ _ : XObj (Sym (SymPath _ name)) _ _ : _)) _ _)) = + case x of + Typ -> case lookupInEnv (SymPath [] name) typeEnv of + Just (_, Binder typedef) -> (dependencyDepth typeEnv typedef, b) + Nothing -> compilerError ("Can't find " ++ name ++ " in type env.") + _ -> (100, b) + scoreBinder b = (200, b) + +dependencyDepth :: Env -> XObj -> Int +dependencyDepth typeEnv (XObj (Lst (_ : XObj (Sym (SymPath _ selfName)) _ _ : rest)) _ _) = + case concatMap expandCase rest of + [] -> 0 + xs -> maximum xs + where + expandCase :: XObj -> [Int] + expandCase (XObj (Arr arr) _ _) = map (depthOfType . xobjToTy . snd) (pairwise arr) + expandCase _ = compilerError "Malformed case in typedef." + + depthOfType :: Maybe Ty -> Int + depthOfType (Just (StructTy name _)) = depthOfStructType name + depthOfType (Just (FuncTy _ _)) = 0 -- TODO: fix + depthOfType (Just (PointerTy p)) = depthOfType (Just p) + depthOfType (Just (RefTy r)) = depthOfType (Just r) + depthOfType (Just _) = 0 + depthOfType Nothing = -100 -- External / unknown type + + depthOfStructType :: String -> Int + depthOfStructType name = + if name == selfName + then 0 + else case lookupInEnv (SymPath [] name) typeEnv of + Just (_, Binder typedef) -> dependencyDepth typeEnv typedef + 1 + Nothing -> -200 -- refering to unknown type + +dependencyDepth _ xobj = compilerError ("Can't get dependency depth from " ++ show xobj) diff --git a/src/Eval.hs b/src/Eval.hs new file mode 100644 index 000000000..916309106 --- /dev/null +++ b/src/Eval.hs @@ -0,0 +1,235 @@ +module Eval (expandAll, eval, EvalError(..)) where + +import qualified Data.Map as Map +import Data.List (foldl', null) +import Data.List.Split (splitWhen) +import Obj +import Types +import Util +--import Debug.Trace + +newtype EvalError = EvalError String deriving (Eq) + +instance Show EvalError where + show (EvalError msg) = msg + +isRestArgSeparator :: String -> Bool +isRestArgSeparator ":rest" = True +isRestArgSeparator _ = False + +eval :: Env -> XObj -> Either EvalError XObj +eval env xobj = + case obj xobj of -- (trace ("Eval " ++ pretty xobj) xobj) + Lst _ -> evalList xobj + Arr _ -> evalArray xobj + Sym _ -> evalSymbol xobj + _ -> Right xobj + + where + evalList :: XObj -> Either EvalError XObj + evalList (XObj (Lst xobjs) i t) = + case xobjs of + [] -> Right xobj + XObj (Sym (SymPath [] "quote")) _ _ : target : [] -> + return target + XObj (Sym (SymPath [] "list")) _ _ : rest -> + do evaledList <- mapM (eval env) rest + return (XObj (Lst evaledList) i t) + XObj (Sym (SymPath [] "array")) _ _ : rest -> + do evaledArray <- mapM (eval env) rest + return (XObj (Arr evaledArray) i t) + XObj (Sym (SymPath [] "=")) _ _ : a : b : [] -> + do evaledA <- eval env a + evaledB <- eval env b + case (evaledA, evaledB) of + (XObj (Num IntTy aNum) _ _, XObj (Num IntTy bNum) _ _) -> + if ((round aNum) :: Int) == ((round bNum) :: Int) + then Right trueXObj else Right falseXObj + _ -> + --Right falseXObj + Left (EvalError ("Can't compare " ++ pretty evaledA ++ " with " ++ pretty evaledB)) + XObj (Sym (SymPath [] "count")) _ _ : target : [] -> + do evaled <- eval env target + case evaled of + XObj (Lst lst) _ _ -> return (XObj (Num IntTy (fromIntegral (length lst))) Nothing Nothing) + XObj (Arr arr) _ _ -> return (XObj (Num IntTy (fromIntegral (length arr))) Nothing Nothing) + _ -> Left (EvalError ("Applying 'count' to non-list: " ++ pretty evaled)) + XObj (Sym (SymPath [] "car")) _ _ : target : [] -> + do evaled <- eval env target + case evaled of + XObj (Lst (car : _)) _ _ -> return car + XObj (Arr (car : _)) _ _ -> return car + _ -> Left (EvalError ("Applying 'car' to non-list: " ++ pretty evaled)) + XObj (Sym (SymPath [] "cdr")) _ _ : target : [] -> + do evaled <- eval env target + case evaled of + XObj (Lst (_ : cdr)) _ _ -> return (XObj (Lst cdr) Nothing Nothing) + XObj (Arr (_ : cdr)) _ _ -> return (XObj (Arr cdr) Nothing Nothing) + _ -> Left (EvalError "Applying 'cdr' to non-list or empty list") + XObj (Sym (SymPath [] "cons")) _ _ : x : xs : [] -> + do evaledX <- eval env x + evaledXS <- eval env xs + case evaledXS of + XObj (Lst lst) _ _ -> return (XObj (Lst (evaledX : lst)) Nothing Nothing) + _ -> Left (EvalError "Applying 'cons' to non-list or empty list") + XObj If _ _ : condition : ifTrue : ifFalse : [] -> + do evaledCondition <- eval env condition + case obj evaledCondition of + Bol b -> if b then eval env ifTrue else eval env ifFalse + _ -> Left (EvalError ("Non-boolean expression in if-statement: " ++ pretty evaledCondition)) + defnExpr@(XObj Defn _ _) : name : args : body : [] -> + do evaledBody <- eval env body + Right (XObj (Lst [defnExpr, name, args, evaledBody]) i t) + defExpr@(XObj Def _ _) : name : expr : [] -> + do evaledExpr <- expand env expr + Right (XObj (Lst [defExpr, name, evaledExpr]) i t) + theExpr@(XObj The _ _) : typeXObj : value : [] -> + do evaledValue <- expand env value + Right (XObj (Lst [theExpr, typeXObj, evaledValue]) i t) + letExpr@(XObj Let _ _) : (XObj (Arr bindings) bindi bindt) : body : [] -> + if even (length bindings) + then do bind <- mapM (\(n, x) -> do x' <- eval env x + return [n, x']) + (pairwise bindings) + let evaledBindings = concat bind + evaledBody <- eval env body + Right (XObj (Lst [letExpr, XObj (Arr evaledBindings) bindi bindt, evaledBody]) i t) + else Left (EvalError ("Uneven number of forms in let-statement: " ++ pretty xobj)) + doExpr@(XObj Do _ _) : expressions -> + do evaledExpressions <- mapM (eval env) expressions + Right (XObj (Lst (doExpr : evaledExpressions)) i t) + f:args -> do evaledF <- eval env f + case evaledF of + XObj (Lst [XObj Dynamic _ _, _, XObj (Arr params) _ _, body]) _ _ -> + do evaledArgs <- mapM (eval env) args + apply env body params evaledArgs + XObj (Lst [XObj Macro _ _, _, XObj (Arr params) _ _, body]) _ _ -> + apply env body params args + _ -> + Right xobj + --Left (EvalError ("Can't eval non-macro / non-dynamic function: " ++ pretty xobj)) + + evalList _ = error "Can't eval non-list in evalList." + + evalSymbol :: XObj -> Either EvalError XObj + evalSymbol (XObj (Sym path) _ _) = + case lookupInEnv path env of + Just (_, Binder (XObj (Lst (XObj External _ _ : _)) _ _)) -> Right xobj + Just (_, Binder (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> Right xobj + Just (_, Binder (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> Right xobj + Just (_, Binder (XObj (Lst (XObj Defn _ _ : _)) _ _)) -> Right xobj + Just (_, Binder (XObj (Lst (XObj Def _ _ : _)) _ _)) -> Right xobj + Just (_, Binder (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> Right xobj + Just (_, Binder found) -> Right found -- use the found value + Nothing -> Left (EvalError ("Can't find symbol '" ++ show path ++ "'.")) + evalSymbol _ = error "Can't eval non-symbol in evalSymbol." + + evalArray :: XObj -> Either EvalError XObj + evalArray (XObj (Arr xobjs) i t) = + do evaledXObjs <- mapM (eval env) xobjs + return (XObj (Arr evaledXObjs) i t) + evalArray _ = error "Can't eval non-array in evalArray." + +apply :: Env -> XObj -> [XObj] -> [XObj] -> Either EvalError XObj +apply env body params args = + let insideEnv = Env Map.empty (Just env) Nothing [] InternalEnv + allParams = map getName params + [properParams, restParams] = case splitWhen isRestArgSeparator allParams of + [a, b] -> [a, b] + [a] -> [a, []] + _ -> error ("Invalid split of args: " ++ joinWith "," allParams) + n = length properParams + insideEnv' = foldl' (\e (p, x) -> extendEnv e p x) insideEnv (zip properParams (take n args)) + insideEnv'' = if null restParams + then insideEnv' + else extendEnv insideEnv' + (head restParams) + (XObj (Lst (drop n args)) Nothing Nothing) + result = eval insideEnv'' body + in --trace ("Result: " ++ show result) + result + +trueXObj :: XObj +trueXObj = XObj (Bol True) Nothing Nothing + +falseXObj :: XObj +falseXObj = XObj (Bol False) Nothing Nothing + +expandAll :: Env -> XObj -> Either EvalError XObj +expandAll env xobj = + case expand env xobj of + Right expanded -> if expanded == xobj then Right expanded else expandAll env expanded + err -> err + +expand :: Env -> XObj -> Either EvalError XObj +expand env xobj = + case obj xobj of + --case obj (trace ("Expand: " ++ pretty xobj) xobj) of + Lst _ -> expandList xobj + Arr _ -> expandArray xobj + Sym _ -> expandSymbol xobj + _ -> Right xobj + + where + expandList :: XObj -> Either EvalError XObj + expandList (XObj (Lst xobjs) i t) = + case xobjs of + [] -> Right xobj + XObj External _ _ : _ -> Right xobj + XObj (Instantiate _) _ _ : _ -> Right xobj + XObj (Deftemplate _) _ _ : _ -> Right xobj + XObj (Defalias _) _ _ : _ -> Right xobj + defnExpr@(XObj Defn _ _) : name : args : body : [] -> + do expandedBody <- expand env body + Right (XObj (Lst [defnExpr, name, args, expandedBody]) i t) + defExpr@(XObj Def _ _) : name : expr : [] -> + do expandedExpr <- expand env expr + Right (XObj (Lst [defExpr, name, expandedExpr]) i t) + theExpr@(XObj The _ _) : typeXObj : value : [] -> + do expandedValue <- expand env value + Right (XObj (Lst [theExpr, typeXObj, expandedValue]) i t) + letExpr@(XObj Let _ _) : (XObj (Arr bindings) bindi bindt) : body : [] -> + if even (length bindings) + then do bind <- mapM (\(n, x) -> do x' <- expand env x + return [n, x']) + (pairwise bindings) + let expandedBindings = concat bind + expandedBody <- expand env body + Right (XObj (Lst [letExpr, XObj (Arr expandedBindings) bindi bindt, expandedBody]) i t) + else Left (EvalError ("Uneven number of forms in let-statement: " ++ pretty xobj)) + doExpr@(XObj Do _ _) : expressions -> + do expandedExpressions <- mapM (expand env) expressions + Right (XObj (Lst (doExpr : expandedExpressions)) i t) + (XObj (Mod _) _ _) : _ -> + Left (EvalError "Can't eval module") + f:args -> do expandedF <- expand env f + expandedArgs <- mapM (expand env) args + case expandedF of + XObj (Lst [XObj Dynamic _ _, _, XObj (Arr _) _ _, _]) _ _ -> + --trace ("Found dynamic: " ++ pretty xobj) + eval env xobj + XObj (Lst [XObj Macro _ _, _, XObj (Arr _) _ _, _]) _ _ -> + --trace ("Found macro: " ++ pretty xobj) + eval env xobj + _ -> + Right (XObj (Lst (expandedF : expandedArgs)) i t) + expandList _ = error "Can't expand non-list in expandList." + + expandArray :: XObj -> Either EvalError XObj + expandArray (XObj (Arr xobjs) i t) = + do evaledXObjs <- mapM (expand env) xobjs + return (XObj (Arr evaledXObjs) i t) + expandArray _ = error "Can't expand non-array in expandArray." + + expandSymbol :: XObj -> Either a XObj + expandSymbol (XObj (Sym path) _ _) = + case lookupInEnv path env of + Just (_, Binder (XObj (Lst (XObj External _ _ : _)) _ _)) -> Right xobj + Just (_, Binder (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> Right xobj + Just (_, Binder (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> Right xobj + Just (_, Binder (XObj (Lst (XObj Defn _ _ : _)) _ _)) -> Right xobj + Just (_, Binder (XObj (Lst (XObj Def _ _ : _)) _ _)) -> Right xobj + Just (_, Binder (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> Right xobj + Just (_, Binder found) -> Right found -- use the found value + Nothing -> Right xobj -- symbols that are not found are left as-is + expandSymbol _ = error "Can't expand non-symbol in expandSymbol." diff --git a/src/Infer.hs b/src/Infer.hs new file mode 100644 index 000000000..6a3a19d46 --- /dev/null +++ b/src/Infer.hs @@ -0,0 +1,1014 @@ +module Infer (annotate + ,initialTypes + ,genConstraints + ,assignTypes + ,concretizeXObj + ,concretizeDefinition + ,manageMemory + ,insideArrayDeleteDeps + ,insideArrayCopyDeps + ) where + +import Control.Monad.State +import Control.Monad (replicateM) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.List (foldl') +import Data.Maybe (mapMaybe) +import Debug.Trace + +import Obj +import Constraints +import Types +import Util +import Eval + +data TypeError = SymbolMissingType XObj Env + | DefnMissingType XObj + | DefMissingType XObj + | ExpressionMissingType XObj + | SymbolNotDefined SymPath XObj + | InvalidObj Obj XObj + | WrongArgCount XObj + | NotAFunction XObj + | NoStatementsInDo XObj + | TooManyFormsInBody XObj + | LeadingColon XObj + | UnificationFailed Constraint TypeMappings + | CantDisambiguate XObj String Ty [(Ty, SymPath)] + | NoMatchingSignature XObj String Ty [(Ty, SymPath)] + | HolesFound [(String, Ty)] + | FailedToExpand XObj EvalError + | NotAValidType XObj + | CantReturnRefTy XObj + +instance Show TypeError where + show (SymbolMissingType xobj env) = + "Symbol '" ++ getName xobj ++ "' missing type at " ++ prettyInfoFromXObj xobj ++ " in env:\n" ++ prettyEnvironment env + show (DefnMissingType xobj) = + "Function definition '" ++ getName xobj ++ "' missing type at " ++ prettyInfoFromXObj xobj ++ "." + show (DefMissingType xobj) = + "Variable definition '" ++ getName xobj ++ "' missing type at " ++ prettyInfoFromXObj xobj ++ "." + show (ExpressionMissingType xobj)= + "Expression '" ++ pretty xobj ++ "' missing type at " ++ prettyInfoFromXObj xobj ++ "." + show (SymbolNotDefined symPath xobj) = + "Trying to refer to an undefined symbol '" ++ show symPath ++ "' at " ++ prettyInfoFromXObj xobj ++ "." + show (InvalidObj Defn xobj) = + "Invalid function definition at " ++ prettyInfoFromXObj xobj ++ "." + show (InvalidObj If xobj) = + "Invalid if-statement at " ++ prettyInfoFromXObj xobj ++ "." + show (InvalidObj o xobj) = + "Invalid obj '" ++ show o ++ "' at " ++ prettyInfoFromXObj xobj ++ "." + show (WrongArgCount xobj) = + "Wrong argument count in call to '" ++ getName xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ "." + show (NotAFunction xobj) = + "Trying to call non-function '" ++ getName xobj ++ "' at " ++ prettyInfoFromXObj xobj ++ "." + show (NoStatementsInDo xobj) = + "The do-statement has no expressions inside of it at " ++ prettyInfoFromXObj xobj ++ "." + show (TooManyFormsInBody xobj) = + "The statement has too many expressions in body position " ++ prettyInfoFromXObj xobj ++ "." + show (UnificationFailed (Constraint a b aObj bObj) mappings) = + "Can't unify \n\n" ++ --show aObj ++ " WITH " ++ show bObj ++ "\n\n" ++ + " " ++ pretty aObj ++ " : " ++ showMaybeTy (recursiveLookupTy mappings a) ++ " (" ++ prettyInfoFromXObj aObj ++ ")" ++ + "\n\nwith \n\n" ++ + " " ++ pretty bObj ++ " : " ++ showMaybeTy (recursiveLookupTy mappings b) ++ " (" ++ prettyInfoFromXObj bObj ++ ")\n" + show (CantDisambiguate xobj originalName theType options) = + "Can't disambiguate symbol '" ++ originalName ++ "' of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++ + "\nPossibilities:\n " ++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options) + show (NoMatchingSignature xobj originalName theType options) = + "Can't find matching lookup for symbol '" ++ originalName ++ + "' of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++ + "\nNone of the possibilities have the correct signature:\n " ++ joinWith + "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options) + show (LeadingColon xobj) = + "Symbol '" ++ pretty xobj ++ "' starting with colon at " ++ prettyInfoFromXObj xobj ++ "." + show (HolesFound holes) = + "Holes found:\n\n " ++ joinWith "\n " (map (\(name, t) -> name ++ " : " ++ show t) holes) ++ "\n" + show (FailedToExpand xobj (EvalError errorMessage)) = + "Failed to expand at " ++ prettyInfoFromXObj xobj ++ ": " ++ errorMessage + show (NotAValidType xobj) = + "Not a valid type: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj + show (CantReturnRefTy xobj) = + "Functions can't return references: '" ++ getName xobj ++ "' at " ++ prettyInfoFromXObj xobj + +recursiveLookupTy :: TypeMappings -> Ty -> Maybe Ty +recursiveLookupTy mappings t = case t of + (VarTy v) -> recursiveLookup mappings v + _ -> Just t + +-- | Create a fresh type variable (eg. 'VarTy t0', 'VarTy t1', etc...) +genVarTyWithPrefix :: String -> State Integer Ty +genVarTyWithPrefix prefix = + do x <- get + put (x + 1) + return (VarTy (prefix ++ show x)) + +genVarTy :: State Integer Ty +genVarTy = genVarTyWithPrefix "t" + +-- | Create a list of type variables with increasing names +genVarTys :: Int -> State Integer [Ty] +genVarTys n = replicateM n genVarTy + +-- | Gives all type variables new names ("t", counting from current state) while +-- still preserving the same name for type variables with a shared name. +-- Example: (t0, t1, t1) -> t0 +-- becomes: (r2, r3, r3) -> r2 +renameVarTys :: Ty -> State Integer Ty +renameVarTys rootType = do n <- get + let (result, (n', _)) = runState (rename rootType) (n, Map.empty) + put n' + return result + where + rename :: Ty -> State (Integer, Map.Map String Ty) Ty + rename (FuncTy argTys retTy) = do argTys' <- mapM rename argTys + retTy' <- rename retTy + return (FuncTy argTys' retTy') + rename (VarTy v) = do (n, mappings) <- get + case Map.lookup v mappings of + Just found -> return found + Nothing -> do let varTy = VarTy ("r" ++ show n) + newMappings = Map.insert v varTy mappings + put (n + 1, newMappings) + return varTy + rename (StructTy name tyArgs) = do tyArgs' <- mapM rename tyArgs + return (StructTy name tyArgs') + + rename (PointerTy x) = do x' <- rename x + return (PointerTy x') + + rename (RefTy x) = do x' <- rename x + return (RefTy x') + + rename x = return x + +-- | Adds initial types to a s-expression and all its sub-nodes. +-- | Example: (f 10) => <() <10 : Int>) : t0> +initialTypes :: Env -> XObj -> Either TypeError XObj +initialTypes rootEnv root = evalState (visit rootEnv root) 0 + where + visit :: Env -> XObj -> State Integer (Either TypeError XObj) + visit env xobj = case obj xobj of + (Num t _) -> return (Right (xobj { ty = Just t })) + (Bol _) -> return (Right (xobj { ty = Just BoolTy })) + (Str _) -> return (Right (xobj { ty = Just StringTy })) + (Chr _) -> return (Right (xobj { ty = Just CharTy })) + (Lst _) -> visitList env xobj + (Arr _) -> visitArray env xobj + (Sym symPath) -> visitSymbol env xobj symPath + (MultiSym _ paths) -> visitMultiSym env xobj paths + Defn -> return (Left (InvalidObj Defn xobj)) + Def -> return (Left (InvalidObj Def xobj)) + Let -> return (Left (InvalidObj Let xobj)) + If -> return (Left (InvalidObj If xobj)) + While -> return (Left (InvalidObj While xobj)) + Do -> return (Left (InvalidObj Do xobj)) + (Mod _) -> return (Left (InvalidObj If xobj)) + Typ -> return (Left (InvalidObj Typ xobj)) + External -> return (Left (InvalidObj External xobj)) + ExternalType -> return (Left (InvalidObj ExternalType xobj)) + e@(Deftemplate _) -> return (Left (InvalidObj e xobj)) + e@(Instantiate _) -> return (Left (InvalidObj e xobj)) + e@(Defalias _) -> return (Left (InvalidObj e xobj)) + Address -> return (Left (InvalidObj Address xobj)) + SetBang -> return (Left (InvalidObj SetBang xobj)) + Macro -> return (Left (InvalidObj Macro xobj)) + The -> return (Left (InvalidObj The xobj)) + Dynamic -> return (Left (InvalidObj Dynamic xobj)) + Ref -> return (Left (InvalidObj Ref xobj)) + + visitSymbol :: Env -> XObj -> SymPath -> State Integer (Either TypeError XObj) + visitSymbol env xobj symPath = + case symPath of + -- Symbols with leading ? are 'holes'. + SymPath _ name@('?' : _) -> return (Right (xobj { ty = Just (VarTy name) })) + SymPath _ (':' : _) -> return (Left (LeadingColon xobj)) + _ -> + case lookupInEnv symPath env of + Just (foundEnv, binder) -> + case ty (binderXObj binder) of + -- Don't rename internal symbols like parameters etc! + Just theType | envIsExternal foundEnv -> do renamed <- renameVarTys theType + return (Right (xobj { ty = Just renamed })) + | otherwise -> return (Right (xobj { ty = Just theType })) + Nothing -> return (Left (SymbolMissingType xobj foundEnv)) + Nothing -> return (Left (SymbolNotDefined symPath xobj)) + + visitMultiSym :: Env -> XObj -> [SymPath] -> State Integer (Either TypeError XObj) + visitMultiSym _ xobj _ = + do freshTy <- genVarTy + return (Right xobj { ty = Just freshTy }) + + visitArray :: Env -> XObj -> State Integer (Either TypeError XObj) + visitArray env (XObj (Arr xobjs) i _) = + do visited <- mapM (visit env) xobjs + arrayVarTy <- genVarTy + return $ do okVisited <- sequence visited + Right (XObj (Arr okVisited) i (Just (StructTy "Array" [arrayVarTy]))) + + visitArray _ _ = compilerError "The function 'visitArray' only accepts XObj:s with arrays in them." + + visitList :: Env -> XObj -> State Integer (Either TypeError XObj) + visitList env xobj@(XObj (Lst xobjs) i _) = + case xobjs of + -- Defn + defn@(XObj Defn _ _) : nameSymbol@(XObj (Sym (SymPath _ name)) _ _) : (XObj (Arr argList) argsi argst) : body : [] -> + do argTypes <- genVarTys (length argList) + returnType <- genVarTy + funcScopeEnv <- extendEnvWithParamList env argList + let funcTy = Just (FuncTy argTypes returnType) + typedNameSymbol = nameSymbol { ty = funcTy } + -- This environment binding is for self-recursion, allows lookup of the symbol: + envWithSelf = extendEnv funcScopeEnv name typedNameSymbol + visitedBody <- visit envWithSelf body + visitedArgs <- mapM (visit envWithSelf) argList + return $ do okBody <- visitedBody + okArgs <- sequence visitedArgs + return (XObj (Lst [defn, nameSymbol, XObj (Arr okArgs) argsi argst, okBody]) i funcTy) + + XObj Defn _ _ : _ -> return (Left (InvalidObj Defn xobj)) + + -- Def + def@(XObj Def _ _) : nameSymbol : expression : [] -> + do definitionType <- genVarTy + visitedExpr <- visit env expression + return $ do okExpr <- visitedExpr + return (XObj (Lst [def, nameSymbol, okExpr]) i (Just definitionType)) + + (XObj Def _ _) : _ -> return (Left (InvalidObj Def xobj)) + + -- Let binding + letExpr@(XObj Let _ _) : (XObj (Arr bindings) bindi bindt) : body : [] -> + do wholeExprType <- genVarTy + letScopeEnv <- extendEnvWithLetBindings env bindings + case letScopeEnv of + Right okLetScopeEnv -> + do visitedBindings <- mapM (visit okLetScopeEnv) bindings + visitedBody <- visit okLetScopeEnv body + return $ do okBindings <- sequence visitedBindings + okBody <- visitedBody + return (XObj (Lst [letExpr, XObj (Arr okBindings) bindi bindt, okBody]) i (Just wholeExprType)) + Left err -> return (Left err) + + XObj Let _ _ : XObj (Arr _) _ _ : _ -> + return (Left (TooManyFormsInBody xobj)) + XObj Let _ _ : _ -> + return (Left (InvalidObj Let xobj)) + + -- If + ifExpr@(XObj If _ _) : expr : ifTrue : ifFalse : [] -> + do visitedExpr <- visit env expr + visitedTrue <- visit env ifTrue + visitedFalse <- visit env ifFalse + returnType <- genVarTy + return $ do okExpr <- visitedExpr + okTrue <- visitedTrue + okFalse <- visitedFalse + return (XObj (Lst [ifExpr, okExpr, okTrue, okFalse]) i (Just returnType)) + + XObj If _ _ : _ -> return (Left (InvalidObj If xobj)) + + -- While (always return Unit) + whileExpr@(XObj While _ _) : expr : body : [] -> + do visitedExpr <- visit env expr + visitedBody <- visit env body + return $ do okExpr <- visitedExpr + okBody <- visitedBody + return (XObj (Lst [whileExpr, okExpr, okBody]) i (Just UnitTy)) + + XObj While _ _ : _ -> return (Left (InvalidObj While xobj)) + + -- Do + doExpr@(XObj Do _ _) : expressions -> + do t <- genVarTy + visitedExpressions <- fmap sequence (mapM (visit env) expressions) + return $ do okExpressions <- visitedExpressions + return (XObj (Lst (doExpr : okExpressions)) i (Just t)) + + -- Address + addressExpr@(XObj Address _ _) : value : [] -> + do visitedValue <- visit env value + return $ do okValue <- visitedValue + let Just t' = ty okValue + return (XObj (Lst [addressExpr, okValue]) i (Just (PointerTy t'))) + + -- Set! + setExpr@(XObj SetBang _ _) : variable : value : [] -> + do visitedVariable <- visit env variable + visitedValue <- visit env value + return $ do okVariable <- visitedVariable + okValue <- visitedValue + return (XObj (Lst (setExpr : okVariable : okValue : [])) i (Just UnitTy)) + XObj SetBang _ _ : _ -> return (Left (InvalidObj SetBang xobj)) + + -- The + theExpr@(XObj The _ _) : typeXObj : value : [] -> + do visitedValue <- visit env value + return $ do okValue <- visitedValue + case xobjToTy typeXObj of + Just okType -> return (XObj (Lst [theExpr, typeXObj, okValue]) i (Just okType)) + Nothing -> error ("Not a type: " ++ show typeXObj) + (XObj The _ _) : _ -> return (Left (InvalidObj The xobj)) + + -- Ref + refExpr@(XObj Ref _ _) : value : [] -> + do visitedValue <- visit env value + return $ do okValue <- visitedValue + let Just valueTy = ty okValue + return (XObj (Lst (refExpr : okValue : [])) i (Just (RefTy valueTy))) + + -- Function application + func : args -> + do t <- genVarTy + visitedFunc <- visit env func + visitedArgs <- fmap sequence (mapM (visit env) args) + return $ do okFunc <- visitedFunc + okArgs <- visitedArgs + return (XObj (Lst (okFunc : okArgs)) i (Just t)) + + -- Empty list + [] -> return (Right xobj { ty = Just UnitTy }) + + visitList _ _ = compilerError "Must match on list!" + + extendEnvWithLetBindings :: Env -> [XObj] -> State Integer (Either TypeError Env) + extendEnvWithLetBindings env xobjs = + let pairs = pairwise xobjs + emptyInnerEnv = Env { envBindings = Map.fromList [] + , envParent = Just env + , envModuleName = Nothing + , envImports = [] + , envMode = InternalEnv + } + -- Need to fold (rather than map) to make the previous bindings accesible to the later ones, i.e. (let [a 100 b a] ...) + in foldM createBinderForLetPair (Right emptyInnerEnv) pairs + where + createBinderForLetPair :: Either TypeError Env -> (XObj, XObj) -> State Integer (Either TypeError Env) + createBinderForLetPair envOrErr (sym, expr) = + case envOrErr of + Left err -> return (Left err) + Right env' -> + case obj sym of + (Sym (SymPath _ name)) -> do visited <- visit env' expr + return $ do okVisited <- visited + return (envAddBinding env' name (Binder okVisited)) + _ -> error ("Can't create let-binder for non-symbol: " ++ show sym) + + extendEnvWithParamList :: Env -> [XObj] -> State Integer Env + extendEnvWithParamList env xobjs = + do binders <- mapM createBinderForParam xobjs + return Env { envBindings = Map.fromList binders + , envParent = Just env + , envModuleName = Nothing + , envImports = [] + , envMode = InternalEnv + } + where + createBinderForParam :: XObj -> State Integer (String, Binder) + createBinderForParam xobj = + case obj xobj of + (Sym (SymPath _ name)) -> do t <- genVarTy + let xobjWithTy = xobj { ty = Just t } + return (name, Binder xobjWithTy) + _ -> error "Can't create binder for non-symbol parameter." + +genConstraints :: XObj -> Either TypeError [Constraint] +genConstraints root = gen root + where gen xobj = + case obj xobj of + (Lst lst) -> case lst of + -- Defn + (XObj Defn _ _) : _ : (XObj (Arr args) _ _) : body : [] -> + do insideBodyConstraints <- gen body + xobjType <- toEither (ty xobj) (DefnMissingType xobj) + bodyType <- toEither (ty body) (ExpressionMissingType xobj) + let (FuncTy argTys retTy) = xobjType + bodyConstr = Constraint retTy bodyType xobj body + argConstrs = zipWith3 (\a b aObj -> Constraint a b aObj xobj) (map forceTy args) argTys args + return (bodyConstr : argConstrs ++ insideBodyConstraints) + + -- Def + (XObj Def _ _) : _ : expr : [] -> + do insideExprConstraints <- gen expr + xobjType <- toEither (ty xobj) (DefMissingType xobj) + exprType <- toEither (ty expr) (ExpressionMissingType xobj) + let defConstraint = Constraint xobjType exprType xobj expr + return (defConstraint : insideExprConstraints) + + -- Let + XObj Let _ _ : XObj (Arr bindings) _ _ : body : [] -> + do insideBodyConstraints <- gen body + insideBindingsConstraints <- fmap join (mapM gen bindings) + bodyType <- toEither (ty body) (ExpressionMissingType body) + let Just xobjTy = ty xobj + wholeStatementConstraint = Constraint bodyType xobjTy body xobj + bindingsConstraints = zipWith (\(symTy, exprTy) (symObj, exprObj) -> + Constraint symTy exprTy symObj exprObj) + (map (\(a, b) -> (forceTy a, forceTy b)) (pairwise bindings)) + (pairwise bindings) + return (wholeStatementConstraint : insideBodyConstraints ++ + bindingsConstraints ++ insideBindingsConstraints) + + -- If + XObj If _ _ : expr : ifTrue : ifFalse : [] -> + do insideConditionConstraints <- gen expr + insideTrueConstraints <- gen ifTrue + insideFalseConstraints <- gen ifFalse + exprType <- toEither (ty expr) (ExpressionMissingType expr) + trueType <- toEither (ty ifTrue) (ExpressionMissingType ifTrue) + falseType <- toEither (ty ifFalse) (ExpressionMissingType ifFalse) + let expected = XObj (Sym (SymPath [] "condition in if-value")) (info xobj) (ty xobj) + conditionConstraint = Constraint exprType BoolTy expr expected + sameReturnConstraint = Constraint trueType falseType ifTrue ifFalse + Just t = ty xobj + wholeStatementConstraint = Constraint trueType t ifTrue xobj + return (conditionConstraint : sameReturnConstraint : + wholeStatementConstraint : insideConditionConstraints ++ + insideTrueConstraints ++ insideFalseConstraints) + + -- While + XObj While _ _ : expr : body : [] -> + do insideConditionConstraints <- gen expr + insideBodyConstraints <- gen body + exprType <- toEither (ty expr) (ExpressionMissingType expr) + bodyType <- toEither (ty body) (ExpressionMissingType body) + let expectedCond = XObj (Sym (SymPath [] "condition in while-expression")) (info xobj) (ty xobj) + expectedBody = XObj (Sym (SymPath [] "body in while-expression")) (info xobj) (ty xobj) + conditionConstraint = Constraint exprType BoolTy expr expectedCond + wholeStatementConstraint = Constraint bodyType UnitTy body expectedBody + return (conditionConstraint : wholeStatementConstraint : + insideConditionConstraints ++ insideBodyConstraints) + + -- Do + XObj Do _ _ : expressions -> + case expressions of + [] -> Left (NoStatementsInDo xobj) + _ -> let lastExpr = last expressions + in do insideExpressionsConstraints <- fmap join (mapM gen expressions) + xobjType <- toEither (ty xobj) (DefMissingType xobj) + lastExprType <- toEither (ty lastExpr) (ExpressionMissingType xobj) + let retConstraint = Constraint xobjType lastExprType xobj lastExpr + must = XObj (Sym (SymPath [] "statement in do-expression")) (info xobj) (ty xobj) + mkConstr x@(XObj _ _ (Just t)) = Just (Constraint t UnitTy x must) + mkConstr _ = Nothing + expressionsShouldReturnUnit = mapMaybe mkConstr (init expressions) + return (retConstraint : insideExpressionsConstraints ++ expressionsShouldReturnUnit) + + -- Address + XObj Address _ _ : value : [] -> + gen value + + -- Set! + XObj SetBang _ _ : variable : value : [] -> + do insideValueConstraints <- gen value + variableType <- toEither (ty variable) (ExpressionMissingType variable) + valueType <- toEither (ty value) (ExpressionMissingType value) + let sameTypeConstraint = Constraint variableType valueType variable value + return (sameTypeConstraint : insideValueConstraints) + + -- The + XObj The _ _ : _ : value : [] -> + do insideValueConstraints <- gen value + xobjType <- toEither (ty xobj) (DefMissingType xobj) + valueType <- toEither (ty value) (DefMissingType value) + let theTheConstraint = Constraint xobjType valueType xobj value + return (theTheConstraint : insideValueConstraints) + + -- Ref + XObj Ref _ _ : value : [] -> + gen value + + -- Function application + func : args -> + do insideArgsConstraints <- fmap join (mapM gen args) + funcTy <- toEither (ty func) (ExpressionMissingType func) + case funcTy of + (FuncTy argTys retTy) -> + if length args /= length argTys then + Left (WrongArgCount func) + else + let expected = XObj (Sym (SymPath [] ("expected argument to '" ++ getName func ++ "'"))) + (info func) Nothing + argConstraints = zipWith3 (\a t aObj -> Constraint a t aObj expected) + (map forceTy args) + argTys + args + Just xobjTy = ty xobj + retConstraint = Constraint xobjTy retTy xobj func + in return (retConstraint : argConstraints ++ insideArgsConstraints) + funcVarTy@(VarTy _) -> + let fabricatedFunctionType = FuncTy (map forceTy args) (forceTy xobj) + expected = XObj (Sym (SymPath [] ("calling '" ++ getName func ++ "'"))) (info func) Nothing + wholeTypeConstraint = Constraint funcVarTy fabricatedFunctionType func expected + in return (wholeTypeConstraint : insideArgsConstraints) + _ -> Left (NotAFunction func) + + -- Empty list + [] -> Right [] + + (Arr arr) -> + case arr of + [] -> Right [] + x:xs -> do insideExprConstraints <- fmap join (mapM gen arr) + let Just headTy = ty x + Just (StructTy "Array" [t]) = ty xobj + betweenExprConstraints = map (\o -> Constraint headTy (forceTy o) x o) xs + headConstraint = Constraint headTy t x xobj + return (headConstraint : insideExprConstraints ++ betweenExprConstraints) + + _ -> Right [] + +-- | Unsafe way of getting the type from an XObj +forceTy :: XObj -> Ty +forceTy xobj = case ty xobj of + Just t -> t + Nothing -> error ("No type in " ++ show xobj) + +-- | Walk the whole expression tree and replace all occurences of VarTy with their corresponding actual type. +assignTypes :: TypeMappings -> XObj -> XObj +assignTypes mappings root = visit root + where + visit xobj = + case obj xobj of + (Lst _) -> visitList xobj + (Arr _) -> visitArray xobj + _ -> assignType xobj + + visitList (XObj (Lst xobjs) i t) = + let visited = map (assignTypes mappings) xobjs + xobj' = XObj (Lst visited) i t + in assignType xobj' + visitList _ = compilerError "The function 'visitList' only accepts XObjs with lists in them." + + visitArray (XObj (Arr xobjs) i t) = + let visited = map (assignTypes mappings) xobjs + xobj' = XObj (Arr visited) i t + in assignType xobj' + visitArray _ = compilerError "The function 'visitArray' only accepts XObjs with arrays in them." + + assignType :: XObj -> XObj + assignType xobj = case ty xobj of + Just startingType -> xobj { ty = Just (replaceTyVars mappings startingType) } + Nothing -> xobj + +-- | This function performs two things: +-- 1. Finds out which polymorphic functions that needs to be added to the environment for the calls in the function to work. +-- 2. Changes the name of symbols at call sites so they use the polymorphic name +-- Both of these results are returned in a tuple: (, ) +concretizeXObj :: Bool -> Env -> Env -> XObj -> Either TypeError (XObj, [XObj]) +concretizeXObj allowAmbiguity typeEnv rootEnv root = + case runState (visit rootEnv root) [] of + (Left err, _) -> Left err + (Right xobj, deps) -> Right (xobj, deps) + where + visit :: Env -> XObj -> State [XObj] (Either TypeError XObj) + visit env xobj@(XObj (Sym _) _ _) = visitSymbol env xobj + visit env xobj@(XObj (MultiSym _ _) _ _) = visitMultiSym env xobj + visit env (XObj (Lst lst) i t) = do visited <- visitList env lst + return $ do okVisited <- visited + Right (XObj (Lst okVisited) i t) + visit env (XObj (Arr arr) i (Just t)) = do visited <- fmap sequence (mapM (visit env) arr) + modify ((insideArrayDeleteDeps typeEnv env t) ++ ) + modify ((defineArrayTypeAlias t) : ) + return $ do okVisited <- visited + Right (XObj (Arr okVisited) i (Just t)) + visit _ x = return (Right x) + + visitList :: Env -> [XObj] -> State [XObj] (Either TypeError [XObj]) + visitList _ [] = return (Right []) + + visitList env (defn@(XObj Defn _ _) : nameSymbol : args@(XObj (Arr argsArr) _ _) : body : []) = + do mapM_ checkForNeedOfTypedefs argsArr + let functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv + envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName)) _ _) -> + extendEnv e argSymName arg) + functionEnv argsArr + visitedBody <- (visit envWithArgs) body + return $ do okBody <- visitedBody + return [defn, nameSymbol, args, okBody] + visitList env (letExpr@(XObj Let _ _) : (XObj (Arr bindings) bindi bindt) : body : []) = + do visitedBindings <- fmap sequence (mapM (visit env) bindings) + visitedBody <- (visit env) body + return $ do okVisitedBindings <- visitedBindings + okVisitedBody <- visitedBody + return [letExpr, XObj (Arr okVisitedBindings) bindi bindt, okVisitedBody] + visitList env (func : args) = + do f <- visit env func + a <- fmap sequence (mapM (visit env) args) + return $ do okF <- f + okA <- a + return (okF : okA) + + checkForNeedOfTypedefs :: XObj -> State [XObj] (Either TypeError ()) + checkForNeedOfTypedefs (XObj _ _ (Just t)) = + case t of + (FuncTy _ _) | typeIsGeneric t -> return (Right ()) + | otherwise -> do modify (defineFunctionTypeAlias t :) + return (Right ()) + _ -> return (Right ()) + checkForNeedOfTypedefs _ = error "Missing type." + + visitSymbol :: Env -> XObj -> State [XObj] (Either TypeError XObj) + visitSymbol env xobj@(XObj (Sym path) i t) = + case lookupInEnv path env of + Just (foundEnv, binder) + | envIsExternal foundEnv -> + let theXObj = binderXObj binder + Just theType = ty theXObj + Just typeOfVisited = t + in if --(trace $ "CHECKING " ++ getName xobj ++ " : " ++ show theType ++ " with visited type " ++ show t) $ + typeIsGeneric theType && not (typeIsGeneric typeOfVisited) + then case concretizeDefinition allowAmbiguity typeEnv env theXObj typeOfVisited of + Left err -> return (Left err) + Right (concrete, deps) -> + do modify (concrete :) + modify (deps ++) + return (Right (XObj (Sym (getPath concrete)) i t)) + else return (Right xobj) + | otherwise -> return (Right xobj) + Nothing -> return (Right xobj) + visitSymbol _ _ = error "Not a symbol." + + visitMultiSym :: Env -> XObj -> State [XObj] (Either TypeError XObj) + visitMultiSym env xobj@(XObj (MultiSym originalSymbolName paths) i t) = + let Just actualType = t + tys = map (typeFromPath env) paths + tysToPathsDict = zip tys paths + in case filter (matchingSignature actualType) tysToPathsDict of + [] -> return (Left (NoMatchingSignature xobj originalSymbolName actualType tysToPathsDict)) + [(theType, singlePath)] -> let Just t' = t + fake1 = XObj (Sym (SymPath [] "theType")) Nothing Nothing + fake2 = XObj (Sym (SymPath [] "xobjType")) Nothing Nothing + in case solve [Constraint theType t' fake1 fake2] of + Right mappings -> + let replaced = replaceTyVars mappings t' + normalSymbol = XObj (Sym singlePath) i (Just replaced) + in visitSymbol env --- $ (trace ("Disambiguated " ++ pretty xobj ++ + --- " to " ++ show singlePath ++ " : " ++ show replaced)) + normalSymbol + Left failure@(UnificationFailure _ _) -> + return $ Left (UnificationFailed + (unificationFailure failure) + (unificationMappings failure)) + Left (Holes holes) -> + return $ Left (HolesFound holes) + severalPaths -> if allowAmbiguity + then return (Right xobj) + else return (Left (CantDisambiguate xobj originalSymbolName actualType severalPaths)) + where matchingSignature :: Ty -> (Ty, SymPath) -> Bool + matchingSignature tA (tB, _) = areUnifiable tA tB + + visitMultiSym _ _ = error "Not a multi symbol." + +typeFromPath :: Env -> SymPath -> Ty +typeFromPath env p = + case lookupInEnv p env of + Just (e, Binder found) + | envIsExternal e -> forceTy found + | otherwise -> error "Local bindings shouldn't be ambiguous." + Nothing -> error ("Couldn't find " ++ show p ++ " in env " ++ safeEnvModuleName env) + +-- | Given a definition (def, defn, template, external) and +-- a concrete type (a type without any type variables) +-- this function returns a new definition with the concrete +-- types assigned, and a list of dependencies. +concretizeDefinition :: Bool -> Env -> Env -> XObj -> Ty -> Either TypeError (XObj, [XObj]) +concretizeDefinition allowAmbiguity typeEnv globalEnv definition concreteType = + let SymPath pathStrings name = getPath definition + Just polyType = ty definition + suffix = polymorphicSuffix polyType concreteType + newPath = SymPath pathStrings (name ++ suffix) + in + case definition of + XObj (Lst ((XObj Defn _ _) : _)) _ _ -> + let withNewPath = setPath definition newPath + mappings = unifySignatures polyType concreteType + typed = assignTypes mappings withNewPath + in do (concrete, deps) <- concretizeXObj allowAmbiguity typeEnv globalEnv typed + managed <- manageMemory typeEnv globalEnv concrete + return (managed, deps) + XObj (Lst ((XObj (Deftemplate (TemplateCreator templateCreator)) _ _) : _)) _ _ -> + let template = templateCreator typeEnv globalEnv + in Right (instantiateTemplate newPath concreteType template) + XObj (Lst ((XObj External _ _) : _ : [])) _ _ -> + if name == "NULL" + then Right (definition, []) -- A hack to make all versions of NULL have the same name + else let withNewPath = setPath definition newPath + withNewType = withNewPath { ty = Just concreteType } + in Right (withNewType, []) + err -> + compilerError ("Can't concretize " ++ show err ++ ": " ++ pretty definition) + +type MemState = Set.Set Deleter + +manageMemory :: Env -> Env -> XObj -> Either TypeError XObj +manageMemory typeEnv globalEnv root = + let (finalObj, deleteThese) = runState (visit root) (Set.fromList []) + in -- (trace ("Delete these: " ++ joinWithComma (map show (Set.toList deleteThese)))) $ + case finalObj of + Left err -> Left err + Right ok -> let newInfo = fmap (\i -> i { infoDelete = deleteThese }) (info ok) + in Right $ ok { info = newInfo } + + where visit :: XObj -> State MemState (Either TypeError XObj) + visit xobj = + case obj xobj of + Lst _ -> visitList xobj + Arr _ -> visitArray xobj + Str _ -> do manage xobj + return (Right xobj) + _ -> do return (Right xobj) + + visitArray :: XObj -> State MemState (Either TypeError XObj) + visitArray xobj@(XObj (Arr arr) _ _) = + do mapM_ visit arr + mapM_ unmanage arr + _ <- manage xobj + return (Right xobj) + + visitArray _ = error "Must visit array." + + visitList :: XObj -> State MemState (Either TypeError XObj) + visitList xobj@(XObj (Lst lst) i t) = + case lst of + defn@(XObj Defn _ _) : nameSymbol@(XObj (Sym _) _ _) : args@(XObj (Arr argList) _ _) : body : [] -> + do mapM_ manage argList + visitedBody <- visit body + unmanage body + return $ do okBody <- visitedBody + return (XObj (Lst (defn : nameSymbol : args : okBody : [])) i t) + letExpr@(XObj Let _ _) : (XObj (Arr bindings) bindi bindt) : body : [] -> + do preDeleters <- get + visitedBindings <- mapM visitLetBinding (pairwise bindings) + visitedBody <- visit body + unmanage body + postDeleters <- get + let diff = postDeleters Set.\\ preDeleters + newInfo = setDeletersOnInfo i diff + survivors = (postDeleters Set.\\ diff) -- Same as just pre deleters, right?! + put survivors + --trace ("LET Pre: " ++ show preDeleters ++ "\nPost: " ++ show postDeleters ++ "\nDiff: " ++ show diff ++ "\nSurvivors: " ++ show survivors) + manage xobj + return $ do okBody <- visitedBody + okBindings <- fmap (concatMap (\(n,x) -> [n, x])) (sequence visitedBindings) + return (XObj (Lst (letExpr : (XObj (Arr okBindings) bindi bindt) : okBody : [])) newInfo t) + addressExpr@(XObj Address _ _) : value : [] -> + do visitedValue <- visit value + return $ do okValue <- visitedValue + return (XObj (Lst (addressExpr : okValue : [])) i t) + theExpr@(XObj The _ _) : typeXObj : value : [] -> + do visitedValue <- visit value + transferOwnership value xobj + return $ do okValue <- visitedValue + return (XObj (Lst (theExpr : typeXObj : okValue : [])) i t) + refExpr@(XObj Ref _ _) : value : [] -> + do visitedValue <- visit value + --manage xobj + return $ do okValue <- visitedValue + return (XObj (Lst (refExpr : okValue : [])) i t) + doExpr@(XObj Do _ _) : expressions -> + do visitedExpressions <- mapM visit expressions + transferOwnership (last expressions) xobj + return $ do okExpressions <- sequence visitedExpressions + return (XObj (Lst (doExpr : okExpressions)) i t) + whileExpr@(XObj While _ _) : expr : body : [] -> + do preDeleters <- get + visitedExpr <- visit expr + visitedBody <- visit body + manage body + postDeleters <- get + -- Visit an extra time to simulate repeated use + _ <- visit expr + _ <- visit body + let diff = postDeleters Set.\\ preDeleters + put (postDeleters Set.\\ diff) -- Same as just pre deleters, right?! + return $ do okExpr <- visitedExpr + okBody <- visitedBody + let newInfo = setDeletersOnInfo i diff + return (XObj (Lst (whileExpr : okExpr : okBody : [])) newInfo t) + + ifExpr@(XObj If _ _) : expr : ifTrue : ifFalse : [] -> + do visitedExpr <- visit expr + deleters <- get + + let (visitedTrue, stillAliveTrue) = runState (do { v <- visit ifTrue; + transferOwnership ifTrue xobj; + return v + }) + deleters + + (visitedFalse, stillAliveFalse) = runState (do { v <- visit ifFalse; + transferOwnership ifFalse xobj; + return v + }) + deleters + + let removeTrue = stillAliveTrue + removeFalse = stillAliveFalse + deletedInTrue = deleters Set.\\ removeTrue + deletedInFalse = deleters Set.\\ removeFalse + common = Set.intersection deletedInTrue deletedInFalse + delsTrue = deletedInFalse Set.\\ common + delsFalse = deletedInTrue Set.\\ common + stillAlive = deleters Set.\\ (Set.union deletedInTrue deletedInFalse) + + put stillAlive + manage xobj + + return $ do okExpr <- visitedExpr + okTrue <- visitedTrue + okFalse <- visitedFalse + return (XObj (Lst (ifExpr : okExpr : (del okTrue delsTrue) : (del okFalse delsFalse) : [])) i t) + f : args -> + do _ <- visit f + mapM_ visitArg args + manage xobj + return (Right (XObj (Lst (f : args)) i t)) + + [] -> return (Right xobj) + visitList _ = error "Must visit list." + + visitLetBinding :: (XObj, XObj) -> State MemState (Either TypeError (XObj, XObj)) + visitLetBinding (name, expr) = + do visitedExpr <- visit expr + transferOwnership expr name + return $ do okExpr <- visitedExpr + return (name, okExpr) + + visitArg :: XObj -> State MemState (Either TypeError XObj) + visitArg xobj@(XObj _ _ (Just t)) = + if isManaged t + then do visitedXObj <- visit xobj + unmanage xobj + return $ do okXObj <- visitedXObj + return okXObj + else do --(trace ("Ignoring arg " ++ show xobj ++ " because it's not managed.")) + (visit xobj) + visitArg xobj@(XObj _ _ _) = + visit xobj + + createDeleter :: XObj -> Maybe Deleter + createDeleter xobj = + case ty xobj of + Just t -> let var = varOfXObj xobj + in if isManaged t && not (isExternalType typeEnv t) + then case nameOfPolymorphicFunction globalEnv t "delete" of + Just pathOfDeleteFunc -> Just (ProperDeleter pathOfDeleteFunc var) + Nothing -> --trace ("Found no delete function for " ++ var ++ " : " ++ (showMaybeTy (ty xobj))) + Just (FakeDeleter var) + else Nothing + Nothing -> error ("No type, can't manage " ++ show xobj) + + manage :: XObj -> State MemState () + manage xobj = + case createDeleter xobj of + Just deleter -> modify (Set.insert deleter) + Nothing -> return () + + unmanage :: XObj -> State MemState () + unmanage xobj = + case info xobj of + Just i -> let Just t = ty xobj in + if isManaged t && not (isExternalType typeEnv t) + then do deleters <- get + let var = varOfXObj xobj + unmanageThese = Set.filter (\d -> case d of + ProperDeleter { deleterVariable = dv } -> dv == var + FakeDeleter { deleterVariable = dv } -> dv == var + ) + deleters + case Set.toList unmanageThese of + [] -> trace ("Trying to use '" ++ getName xobj ++ "' (" ++ freshVar i ++ ") at " ++ prettyInfoFromXObj xobj ++ + " but it has already been given away.") (return ()) + [one] -> let newDeleters = Set.delete one deleters + in put newDeleters + _ -> error "Too many variables with the same name in set." + else return () + Nothing -> error ("Can't unmanage " ++ show xobj) + + transferOwnership :: XObj -> XObj -> State MemState () + transferOwnership from to = + do unmanage from + manage to + --trace ("Transfered from " ++ getName from ++ " '" ++ varOfXObj from ++ "' to " ++ getName to ++ " '" ++ varOfXObj to ++ "'") $ return () + + varOfXObj :: XObj -> String + varOfXObj xobj = + case xobj of + XObj (Sym (SymPath [] name)) _ _ -> name + _ -> let Just i = info xobj + in freshVar i + +setDeletersOnInfo :: Maybe Info -> Set.Set Deleter -> Maybe Info +setDeletersOnInfo i deleters = fmap (\i' -> i' { infoDelete = deleters }) i + +del :: XObj -> Set.Set Deleter -> XObj +del xobj deleters = xobj { info = (setDeletersOnInfo (info xobj) deleters) } + +isExternalType :: Env -> Ty -> Bool +isExternalType typeEnv (StructTy name _) = + case lookupInEnv (SymPath [] name) typeEnv of + Just (_, Binder (XObj (Lst (XObj ExternalType _ _ : _)) _ _)) -> True + Just _ -> False + Nothing -> False +isExternalType _ _ = + False + +nameOfPolymorphicFunction :: Env -> Ty -> String -> Maybe SymPath +nameOfPolymorphicFunction env t lookupName + | isManaged t = + case filter ((\(Just t') -> areUnifiable (FuncTy [t] UnitTy) t') . ty . binderXObj . snd) (multiLookupALL lookupName env) of + [] -> Nothing + [(_, Binder single)] -> + let Just t' = ty single + (SymPath pathStrings name) = getPath single + suffix = polymorphicSuffix t' (FuncTy [t] UnitTy) + concretizedPath = SymPath pathStrings (name ++ suffix) + in Just concretizedPath + _ -> Nothing + | otherwise = Nothing + +-- depsOfPolymorphicFunction :: Env -> Ty -> String -> [XObj] +-- depsOfPolymorphicFunction env t name +-- | isManaged t = +-- case filter ((\(Just t') -> (areUnifiable (FuncTy [t] UnitTy) t')) . ty . binderXObj . snd) (multiLookupALL name env) of +-- [] -> (trace $ "No dependency found for " ++ show t) [] +-- [(_, Binder (XObj (Lst ((XObj (Instantiate _) _ _) : _)) _ _))] -> +-- [] +-- [(_, Binder single)] -> +-- case concretizeDefinition False env single (FuncTy [t] (UnitTy)) of +-- Left err -> error (show err) +-- Right (ok, deps) -> (ok : deps) +-- _ -> (trace $ "Too many dependencies found for " ++ show t) [] +-- | otherwise = [] + +insideArrayDeleteDeps :: Env -> Env -> Ty -> [XObj] +insideArrayDeleteDeps typeEnv env t + | isManaged t = + case filter ((\(Just t') -> (areUnifiable (FuncTy [t] UnitTy) t')) . ty . binderXObj . snd) (multiLookupALL "delete" env) of + [] -> --(trace $ "No 'delete' function found for " ++ show t) + [] + [(_, Binder (XObj (Lst ((XObj (Instantiate _) _ _) : _)) _ _))] -> + [] + [(_, Binder single)] -> + case concretizeDefinition False typeEnv env single (FuncTy [t] (UnitTy)) of + Left err -> error (show err) + Right (ok, deps) -> (ok : deps) + _ -> (trace $ "Too many 'delete' functions found for " ++ show t) [] + | otherwise = [] + +-- TODO: merge with "insideArrayDeleteDeps" +insideArrayCopyDeps :: Env -> Env -> Ty -> [XObj] +insideArrayCopyDeps typeEnv env t + | isManaged t = + case filter ((\(Just t') -> (areUnifiable (FuncTy [(RefTy t)] t) t')) . ty . binderXObj . snd) (multiLookupALL "copy" env) of + [] -> --(trace $ "No 'copy' function found for " ++ show t) + [] + [(_, Binder (XObj (Lst ((XObj (Instantiate _) _ _) : _)) _ _))] -> + [] + [(_, Binder single)] -> + case concretizeDefinition False typeEnv env single (FuncTy [(RefTy t)] t) of + Left err -> error (show err) + Right (ok, deps) -> (ok : deps) + _ -> (trace $ "Too many 'copy' functions found for " ++ show t) [] + | otherwise = [] + +-- | Convert from the type 'UnificationFailure' to 'TypeError' (enables monadic chaining of Either). +solveConstraintsAndConvertErrorIfNeeded :: [Constraint] -> Either TypeError TypeMappings +solveConstraintsAndConvertErrorIfNeeded constraints = + case solve constraints of + Left failure@(UnificationFailure _ _) -> Left (UnificationFailed (unificationFailure failure) (unificationMappings failure)) + Left (Holes holes) -> Left (HolesFound holes) + Right ok -> Right ok + +check :: XObj -> Either TypeError () +check xobj@(XObj (Lst (XObj Defn _ _ : _)) _ t) = + case t of + Just (FuncTy _ (RefTy _)) -> Left (CantReturnRefTy xobj) + Just _ -> return () + Nothing -> Left (DefnMissingType xobj) +check _ = return () + +annotateOne :: Env -> Env -> XObj -> Bool -> Either TypeError (XObj, [XObj]) +annotateOne typeEnv env xobj allowAmbiguity = do + constraints <- genConstraints xobj + mappings <- solveConstraintsAndConvertErrorIfNeeded constraints + let typed = assignTypes mappings xobj + concretizeXObj allowAmbiguity typeEnv env typed + +-- | Performs all the steps of creating initial types, solving constraints and assigning the types. +-- | Returns a list of all the bindings that need to be added for the new form to work. +-- | The concretization of MultiSym:s (= ambiguous use of symbols, resolved by type usage) +-- | makes it possible to solve more types so let's do it several times. +annotate :: Env -> Env -> XObj -> Either TypeError [XObj] +annotate typeEnv globalEnv xobj = + do initiated <- initialTypes globalEnv xobj + (annotated, dependencies) <- foldM (\(x, deps) allowAmbiguity -> + do (x', deps') <- annotateOne typeEnv globalEnv x allowAmbiguity + return (x', deps ++ deps')) + (initiated, []) + [True, False] + final <- manageMemory typeEnv globalEnv annotated + check final + mapM check dependencies + return (final : dependencies) diff --git a/src/Obj.hs b/src/Obj.hs new file mode 100644 index 000000000..286db60cc --- /dev/null +++ b/src/Obj.hs @@ -0,0 +1,548 @@ +module Obj where + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.List (intercalate, foldl') +import Data.Maybe (mapMaybe) +import Control.Monad.State +import Data.Char +import Types +import Util +--import Debug.Trace + +-- | The canonical Lisp object. +data Obj = Sym SymPath + | MultiSym String [SymPath] + | Num Ty Double + | Str String + | Chr Char + | Bol Bool + | Lst [XObj] + | Arr [XObj] + | Defn + | Def + | Do + | Let + | While + | If + | Mod Env + | Typ + | External + | ExternalType + | Deftemplate TemplateCreator + | Instantiate Template + | Defalias Ty + | Address + | SetBang + | Macro + | Dynamic + | The + | Ref + deriving (Show, Eq) + +newtype TemplateCreator = TemplateCreator { getTemplateCreator :: Env -> Env -> Template } +instance Show TemplateCreator where + show _ = "TemplateCreator" +instance Eq TemplateCreator where + _ == _ = False + +-- | Information about where the Obj originated from. +data Info = Info { infoLine :: Int + , infoColumn :: Int + , infoDelete :: Set.Set Deleter + , infoIdentifier :: Int + } deriving (Show, Eq) + +dummyInfo :: Info +dummyInfo = Info 0 0 (Set.empty) (-1) + +data Deleter = ProperDeleter { deleterPath :: SymPath + , deleterVariable :: String + } + | FakeDeleter { deleterVariable :: String -- used for external types with no delete function + } + deriving (Show, Eq, Ord) + +prettyInfo :: Info -> String +prettyInfo i = "line " ++ show (infoLine i) ++ ", column " ++ show (infoColumn i) + +prettyInfoFromXObj :: XObj -> String +prettyInfoFromXObj xobj = case info xobj of + Just i -> prettyInfo i + Nothing -> "no info" + +-- TODO: change name of this function +freshVar :: Info -> String +freshVar i = "_" ++ show (infoIdentifier i) + +-- | Obj with eXtra information. +data XObj = XObj { obj :: Obj + , info :: Maybe Info + , ty :: Maybe Ty + } deriving (Show, Eq) + +getBinderDescription :: XObj -> String +getBinderDescription (XObj (Lst (XObj Defn _ _ : XObj (Sym _) _ _ : _)) _ _) = "defn" +getBinderDescription (XObj (Lst (XObj Def _ _ : XObj (Sym _) _ _ : _)) _ _) = "def" +getBinderDescription (XObj (Lst (XObj Macro _ _ : XObj (Sym _) _ _ : _)) _ _) = "macro" +getBinderDescription (XObj (Lst (XObj (Deftemplate _) _ _ : XObj (Sym _) _ _ : _)) _ _) = "template" +getBinderDescription (XObj (Lst (XObj (Instantiate _) _ _ : XObj (Sym _) _ _ : _)) _ _) = "instantiate" +getBinderDescription (XObj (Lst (XObj (Defalias _) _ _ : XObj (Sym _) _ _ : _)) _ _) = "alias" +getBinderDescription (XObj (Lst (XObj External _ _ : XObj (Sym _) _ _ : _)) _ _) = "external" +getBinderDescription (XObj (Lst (XObj ExternalType _ _ : XObj (Sym _) _ _ : _)) _ _) = "external-type" +getBinderDescription _ = "?" + +getName :: XObj -> String +getName xobj = show (getPath xobj) + +-- | Extracts the second form (where the name of definitions are stored) from a list of XObj:s. +getPath :: XObj -> SymPath +getPath (XObj (Lst (XObj Defn _ _ : XObj (Sym path) _ _ : _)) _ _) = path +getPath (XObj (Lst (XObj Def _ _ : XObj (Sym path) _ _ : _)) _ _) = path +getPath (XObj (Lst (XObj Macro _ _ : XObj (Sym path) _ _ : _)) _ _) = path +getPath (XObj (Lst (XObj (Deftemplate _) _ _ : XObj (Sym path) _ _ : _)) _ _) = path +getPath (XObj (Lst (XObj (Instantiate _) _ _ : XObj (Sym path) _ _ : _)) _ _) = path +getPath (XObj (Lst (XObj (Defalias _) _ _ : XObj (Sym path) _ _ : _)) _ _) = path +getPath (XObj (Lst (XObj External _ _ : XObj (Sym path) _ _ : _)) _ _) = path +getPath (XObj (Lst (XObj ExternalType _ _ : XObj (Sym path) _ _ : _)) _ _) = path +getPath (XObj (Sym path) _ _) = path +getPath x = SymPath [] (pretty x) + +-- | Changes the second form (where the name of definitions are stored) in a list of XObj:s. +setPath :: XObj -> SymPath -> XObj +setPath (XObj (Lst (defn@(XObj Defn _ _) : XObj (Sym _) si st : rest)) i t) newPath = + XObj (Lst (defn : XObj (Sym newPath) si st : rest)) i t +setPath (XObj (Lst (extr@(XObj External _ _) : XObj (Sym _) si st : [])) i t) newPath = + XObj (Lst (extr : XObj (Sym newPath) si st : [])) i t +setPath x _ = + compilerError ("Can't set path on " ++ show x) + +-- | Convert an XObj to a pretty string representation. +pretty :: XObj -> String +pretty root = visit 0 root + where visit :: Int -> XObj -> String + visit indent xobj = + case obj xobj of + Lst lst -> "(" ++ joinWithSpace (map (visit indent) lst) ++ ")" + Arr arr -> "[" ++ joinWithSpace (map (visit indent) arr) ++ "]" + Num IntTy num -> show (round num :: Int) + Num FloatTy num -> show num ++ "f" + Num DoubleTy num -> show num + Num _ _ -> compilerError "Invalid number type." + Str str -> show str + Chr c -> '\\' : c : "" + Sym path -> show path + MultiSym originalName paths -> originalName ++ "{" ++ joinWithComma (map show paths) ++ "}" + Bol b -> if b then "true" else "false" + Defn -> "defn" + Def -> "def" + If -> "if" + While -> "while" + Do -> "do" + Let -> "let" + Mod _ -> "module" + Typ -> "deftype" + Deftemplate _ -> "deftemplate" + Instantiate _ -> "instantiate" + External -> "external" + ExternalType -> "external-type" + Defalias _ -> "defalias" + Address -> "address" + SetBang -> "set!" + Macro -> "macro" + Dynamic -> "dynamic" + The -> "the" + Ref -> "ref" + +-- | Get the type of an XObj as a string. +typeStr :: XObj -> String +typeStr xobj = case ty xobj of + Nothing -> " : _" + Just t -> " : " ++ show t + +-- | Convert XObj to pretty string representation with type annotations. +prettyTyped :: XObj -> String +prettyTyped = visit 0 + where visit :: Int -> XObj -> String + visit indent xobj = + let suffix = typeStr xobj ++ "\n" + in case obj xobj of + Lst lst -> "(" ++ joinWithSpace (map (visit indent) lst) ++ ")" ++ suffix + Arr arr -> "[" ++ joinWithSpace (map (visit indent) arr) ++ "]" ++ suffix + _ -> pretty xobj ++ suffix + +-- | Wraps and holds an XObj in an environment. +newtype Binder = Binder { binderXObj :: XObj } deriving Eq + +instance Show Binder where + show binder = showBinderIndented 0 (getName (binderXObj binder), binder) + +showBinderIndented :: Int -> (String, Binder) -> String +showBinderIndented indent (name, Binder (XObj (Mod env) _ _)) = + replicate indent ' ' ++ name ++ " : Module = {\n" ++ + prettyEnvironmentIndented (indent + 4) env ++ + "\n" ++ replicate indent ' ' ++ "}" +showBinderIndented indent (name, Binder xobj) = + replicate indent ' ' ++ name ++ -- " (" ++ show (getPath xobj) ++ ")" ++ + " : " ++ showMaybeTy (ty xobj) ++ " " ++ getBinderDescription xobj + +-- | Helper function to create binding pairs for registering external functions. +register :: String -> Ty -> (String, Binder) +register name t = (name, Binder (XObj (Lst [XObj External Nothing Nothing, + XObj (Sym (SymPath [] name)) Nothing Nothing]) + (Just dummyInfo) (Just t))) + +data EnvMode = ExternalEnv | InternalEnv deriving (Show, Eq) + +-- | Environment +data Env = Env { envBindings :: Map.Map String Binder + , envParent :: Maybe Env + , envModuleName :: Maybe String + , envImports :: [SymPath] + , envMode :: EnvMode + } deriving (Show, Eq) + +safeEnvModuleName :: Env -> String +safeEnvModuleName env = + case envModuleName env of + Just name -> name ++ ", with parent " ++ parent + Nothing -> "???, with parent " ++ parent + where parent = + case envParent env of + Just p -> safeEnvModuleName p + Nothing -> "Global" + +-- | Used by the compiler command "(env)" +prettyEnvironment :: Env -> String +prettyEnvironment = prettyEnvironmentIndented 0 + +prettyEnvironmentIndented :: Int -> Env -> String +prettyEnvironmentIndented indent env = + joinWith "\n" $ map (showBinderIndented indent) (Map.toList (envBindings env)) ++ + [replicate indent ' ' ++ "Imports:"] ++ + map (showImportIndented indent) (envImports env) + +showImportIndented :: Int -> SymPath -> String +showImportIndented indent path = replicate indent ' ' ++ show path + +-- | Checks if an environment is "external", meaning it's either the global scope or a module scope. +envIsExternal :: Env -> Bool +envIsExternal env = + case envMode env of + ExternalEnv -> True + InternalEnv -> False + +-- | Find the Binder at a specified path. +lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder) +lookupInEnv (SymPath [] name) env = + case Map.lookup name (envBindings env) of + Just found -> Just (env, found) + Nothing -> case envParent env of + Just parent -> lookupInEnv (SymPath [] name) parent + Nothing -> Nothing +lookupInEnv path@(SymPath (p : ps) name) env = + case Map.lookup p (envBindings env) of + Just (Binder xobj) -> + case xobj of + (XObj (Mod modEnv) _ _) -> lookupInEnv (SymPath ps name) modEnv + _ -> Nothing + Nothing -> + case envParent env of + Just parent -> lookupInEnv path parent + Nothing -> Nothing + +-- | Find all the possible (imported) symbols that could be referred to +multiLookup :: String -> Env -> [(Env, Binder)] +multiLookup = multiLookupInternal False + +multiLookupALL :: String -> Env -> [(Env, Binder)] +multiLookupALL = multiLookupInternal True + +-- | The advanced version of multiLookup that allows for looking into modules that are NOT imported. +multiLookupInternal :: Bool -> String -> Env -> [(Env, Binder)] +multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootEnv + + where getEnvFromBinder :: (a, Binder) -> Env + getEnvFromBinder (_, Binder (XObj (Mod foundEnv) _ _)) = foundEnv + getEnvFromBinder (_, Binder err) = error ("Can't handle imports of non modules yet: " ++ show err) + + lookupInLocalEnv :: String -> Env -> Maybe (Env, Binder) + lookupInLocalEnv n localEnv = case Map.lookup n (envBindings localEnv) of -- No recurse! + Just b -> Just (localEnv, b) + Nothing -> Nothing + + imports :: Env -> [Env] + imports env = if allowLookupInAllModules + then let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings env)) + in envs ++ (concatMap imports envs) + -- Only lookup in imported modules: + else let paths = envImports env + in mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path env)) paths + + binderToEnv :: Binder -> Maybe Env + binderToEnv (Binder (XObj (Mod e) _ _)) = Just e + binderToEnv _ = Nothing + + importsLookup :: Env -> [(Env, Binder)] + importsLookup env = mapMaybe (lookupInLocalEnv name) (imports env) + + recursiveLookup :: Env -> [(Env, Binder)] + recursiveLookup env = + let spine = case Map.lookup name (envBindings env) of + Just found -> [(env, found)] + Nothing -> [] + leafs = importsLookup env + above = case envParent env of + Just parent -> recursiveLookup parent + Nothing -> [] + in spine ++ leafs ++ above + +-- | Add an XObj to a specific environment. TODO: rename to envInsert +extendEnv :: Env -> String -> XObj -> Env +extendEnv env name xobj = envAddBinding env name (Binder xobj) + +-- | Add a Binder to an environment at a specific path location. +envInsertAt :: Env -> SymPath -> XObj -> Env +envInsertAt env (SymPath [] name) xobj = envAddBinding env name (Binder xobj) +envInsertAt env (SymPath (p:ps) name) xobj = + case Map.lookup p (envBindings env) of + Just (Binder (XObj (Mod innerEnv) i t)) -> + let newInnerEnv = Binder (XObj (Mod (envInsertAt innerEnv (SymPath ps name) xobj)) i t) + in env { envBindings = Map.insert p newInnerEnv (envBindings env) } + Just _ -> error ("Can't insert into non-module: " ++ p) + Nothing -> error ("Can't insert into non-existing module: " ++ p) + +envReplaceEnvAt :: Env -> [String] -> Env -> Env +envReplaceEnvAt _ [] replacement = replacement +envReplaceEnvAt env (p:ps) replacement = + case Map.lookup p (envBindings env) of + Just (Binder (XObj (Mod innerEnv) i t)) -> + let newInnerEnv = Binder (XObj (Mod (envReplaceEnvAt innerEnv ps replacement)) i t) + in env { envBindings = Map.insert p newInnerEnv (envBindings env) } + Just _ -> error ("Can't replace non-module: " ++ p) + Nothing -> error ("Can't replace non-existing module: " ++ p) + +-- | Add a Binder to a specific environment. +envAddBinding :: Env -> String -> Binder -> Env +envAddBinding env name binder = env { envBindings = Map.insert name binder (envBindings env) } + +-- | Add a list of bindings to an environment +addListOfBindings :: Env -> [(String, Binder)] -> Env +addListOfBindings env bindingsToAdd = foldl' (\e (n, b) -> envAddBinding e n b) env bindingsToAdd + +-- | Get an inner environment. +getEnv :: Env -> [String] -> Env +getEnv env [] = env +getEnv env (p:ps) = case Map.lookup p (envBindings env) of + Just (Binder (XObj (Mod innerEnv) _ _)) -> getEnv innerEnv ps + Just _ -> error "Can't get non-env." + Nothing -> error "Can't get env." + +-- | Changes the symbol part of a defn (the name) to a new symbol path +-- | Example: (defn foo () 123) => (defn GreatModule.foo () 123) +setFullyQualifiedDefn :: XObj -> SymPath -> XObj +setFullyQualifiedDefn (XObj (Lst (defn : (XObj _ symi symt) : args : body : [])) i t) newPath = + XObj (Lst (defn : (XObj (Sym newPath) symi symt) : args : body : [])) i t +setFullyQualifiedDefn (XObj (Lst (def : (XObj _ symi symt) : expr : [])) i t) newPath = + XObj (Lst (def : (XObj (Sym newPath) symi symt) : expr : [])) i t +setFullyQualifiedDefn xobj _ = error ("Can't set new path on " ++ show xobj) + +-- | Changes all symbols EXCEPT bound vars (defn names, variable names, etc) to their fully qualified paths. +-- | This must run after the 'setFullyQualifiedDefn' function has fixed the paths of all bindings in the environment. +-- | This function does NOT go into function-body scope environments and the like. +setFullyQualifiedSymbols :: Env -> XObj -> XObj +setFullyQualifiedSymbols env (XObj (Lst (defn@(XObj Defn _ _) : + sym@(XObj (Sym (SymPath _ functionName)) _ _) : + args@(XObj (Arr argsArr) _ _) : + body : [])) + i t) = + -- For self-recursion, there must be a binding to the function in the inner env. + -- Note: This inner env is ephemeral since it is not stored in a module or global scope. + let functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv + envWithSelf = extendEnv functionEnv functionName sym + envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName)) _ _) -> extendEnv e argSymName arg) envWithSelf argsArr + in (XObj (Lst [defn, sym, args, setFullyQualifiedSymbols envWithArgs body]) i t) +setFullyQualifiedSymbols env (XObj (Lst (the@(XObj The _ _) : typeXObj : value : [])) i t) = + let value' = setFullyQualifiedSymbols env value + in (XObj (Lst [the, typeXObj, value']) i t) +setFullyQualifiedSymbols env (XObj (Lst (def@(XObj Def _ _) : sym : expr : [])) i t) = + let expr' = setFullyQualifiedSymbols env expr + in (XObj (Lst [def, sym, expr']) i t) +setFullyQualifiedSymbols env (XObj (Lst (letExpr@(XObj Let _ _) : bind@(XObj (Arr bindings) bindi bindt) : body : [])) i t) = + if even (length bindings) + then let innerEnv = Env Map.empty (Just env) (Just "LET") [] InternalEnv + envWithBindings = foldl' (\e (binderSym@(XObj (Sym (SymPath _ binderName)) _ _), _) -> + extendEnv e binderName binderSym) + innerEnv + (pairwise bindings) + newBinders = XObj (Arr (concatMap (\(s, o) -> [s, setFullyQualifiedSymbols envWithBindings o]) + (pairwise bindings))) bindi bindt + newBody = setFullyQualifiedSymbols envWithBindings body + in (XObj (Lst [letExpr, newBinders, newBody]) i t) + else (XObj (Lst [letExpr, bind, body]) i t) -- Leave it untouched for the compiler to find the error. +setFullyQualifiedSymbols env (XObj (Lst xobjs) i t) = + let xobjs' = map (setFullyQualifiedSymbols env) xobjs + in XObj (Lst xobjs') i t +setFullyQualifiedSymbols env xobj@(XObj (Sym (SymPath [] name)) i t) = -- Only do this on unqualified symbols (just 'foo', not 'A.B.foo') + case multiLookup name env of + [] -> xobj + [(_, Binder foundOne)] -> XObj (Sym (getPath foundOne)) i t + multiple -> + case filter (not . envIsExternal . fst) multiple of + -- There is at least one local binding, use the path of that one: + (_, Binder local) : _ -> XObj (Sym (getPath local)) i t + -- There are no local bindings, this is allowed to become a multi lookup symbol: + _ -> --(trace $ "Turned " ++ name ++ " into multisym: " ++ joinWithComma (map (show .getPath . binderXObj . snd) multiple)) + XObj (MultiSym name (map (getPath . binderXObj . snd) multiple)) i t + +setFullyQualifiedSymbols env xobj@(XObj (Sym path) i t) = + case lookupInEnv path env of + Just (_, Binder found) -> XObj (Sym (getPath found)) i t + Nothing -> xobj +setFullyQualifiedSymbols _ xobj = xobj + +-- | Project (represents a lot of useful information for working at the REPL and building executables) +data Project = Project { projectTitle :: String + , projectIncludes :: [Includer] + , projectCFlags :: [FilePath] + , projectLibFlags :: [FilePath] + , projectFiles :: [FilePath] + , projectEchoC :: Bool + , projectCarpDir :: FilePath + , projectOutDir :: FilePath + } + +projectFlags :: Project -> String +projectFlags proj = joinWithSpace (projectCFlags proj ++ projectLibFlags proj) + +instance Show Project where + show (Project title incl cFlags libFlags srcFiles echoC carpDir outDir) = + unlines [ "Title: " ++ title + , "Includes:\n " ++ joinWith "\n " (map show incl) + , "Cflags:\n " ++ joinWith "\n " cFlags + , "Library flags:\n " ++ joinWith "\n " libFlags + , "Carp source files:\n " ++ joinWith "\n " srcFiles + , "Echo C: " ++ if echoC then "true" else "false" + , "Output directory: " ++ outDir + , "CARP_DIR: " ++ carpDir + ] + +-- | Represent the inclusion of a C header file, either like or "string.h" +data Includer = SystemInclude String + | LocalInclude String + deriving Eq + +instance Show Includer where + show (SystemInclude file) = "<" ++ file ++ ">" + show (LocalInclude file) = "\"" ++ file ++ "\"" + +-- | Converts an S-expression to one of the Carp types. +xobjToTy :: XObj -> Maybe Ty +xobjToTy (XObj (Sym (SymPath _ "Int")) _ _) = Just IntTy +xobjToTy (XObj (Sym (SymPath _ "Float")) _ _) = Just FloatTy +xobjToTy (XObj (Sym (SymPath _ "Double")) _ _) = Just DoubleTy +xobjToTy (XObj (Sym (SymPath _ "String")) _ _) = Just StringTy +xobjToTy (XObj (Sym (SymPath _ "Char")) _ _) = Just CharTy +xobjToTy (XObj (Sym (SymPath _ "Bool")) _ _) = Just BoolTy +xobjToTy (XObj (Sym (SymPath _ s@(firstLetter:_))) _ _) | isLower firstLetter = Just (VarTy s) + | otherwise = Just (StructTy s []) +xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr")) _ _, innerTy]) _ _) = + do okInnerTy <- xobjToTy innerTy + return (PointerTy okInnerTy) +xobjToTy (XObj (Lst (XObj (Sym (SymPath _ "Ptr")) _ _ : _)) _ _) = + do Nothing +xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ref")) _ _, innerTy]) _ _) = + do okInnerTy <- xobjToTy innerTy + return (RefTy okInnerTy) +xobjToTy (XObj (Lst (XObj (Sym (SymPath _ "Ref")) _ _ : _)) _ _) = + do Nothing +xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Fn")) _ _, XObj (Arr argTys) _ _, retTy]) _ _) = + do okArgTys <- mapM xobjToTy argTys + okRetTy <- xobjToTy retTy + return (FuncTy okArgTys okRetTy) +xobjToTy (XObj (Lst []) _ _) = Just UnitTy +xobjToTy (XObj (Lst (x:xs)) _ _) = + do okX <- xobjToTy x + okXS <- mapM xobjToTy xs + case okX of + (StructTy n []) -> return (StructTy n okXS) + _ -> Nothing +xobjToTy _ = Nothing + +-- | Generates the suffix added to polymorphic functions when they are instantiated. +-- For example (defn id [x] x) : t -> t +-- might be invoked like this (id 5) +-- which will generate int id__Int(int x) { return x; } +-- The "__Int" is the suffix! +polymorphicSuffix :: Ty -> Ty -> String +polymorphicSuffix signature actualType = + case evalState (visit signature actualType) [] of + [] -> "" + parts -> "__" ++ intercalate "_" parts + where visit :: Ty -> Ty -> State VisitedTypes [String] + visit sig actual = + case (sig, actual) of + (VarTy _, VarTy _) -> error $ "Unsolved variable in actual type: " ++ show sig ++ " => " ++ show actual ++ + " when calculating polymorphic suffix for " ++ + show signature ++ " => " ++ show actualType + (a@(VarTy _), b) -> do visitedTypeVariables <- get + if a `elem` visitedTypeVariables + then return [] + else do put (a : visitedTypeVariables) -- now it's visited + return [tyToC b] + (FuncTy argTysA retTyA, FuncTy argTysB retTyB) -> do visitedArgs <- fmap concat (zipWithM visit argTysA argTysB) + visitedRets <- visit retTyA retTyB + return (visitedArgs ++ visitedRets) + (StructTy _ a, StructTy _ b) -> fmap concat (zipWithM visit a b) + (PointerTy a, PointerTy b) -> visit a b + (RefTy a, RefTy b) -> visit a b + (_, _) -> return [] + +type VisitedTypes = [Ty] + +-- | Templates are like macros, but defined inside the compiler and with access to the types they are instantiated with +data Template = Template { templateSignature :: Ty + , templateDeclaration :: Ty -> [Token] -- Will this parameterization ever be useful? + , templateDefinition :: Ty -> [Token] + , templateDependencies :: Ty -> [XObj] + } + +instance Show Template where + show _ = "Template" + +-- TODO: What about this instance?! +instance Eq Template where + _ == _ = False + +-- | Tokens are used for emitting C code from templates. +data Token = TokTy Ty -- | Some kind of type, will be looked up if it's a type variable. + | TokC String -- | Plain C code. + | TokDecl -- | Will emit the declaration (i.e. "foo(int x)"), this is useful + -- for avoiding repetition in the definition part of the template. + | TokName -- | Will emit the name of the instantiated function/variable. + deriving (Eq, Ord) + +instance Show Token where + show (TokC s) = s + show (TokTy t) = tyToC t + show TokName = "" + show TokDecl = "" + +instantiateTemplate :: SymPath -> Ty -> Template -> (XObj, [XObj]) +instantiateTemplate path actualType template = + let defLst = [XObj (Instantiate template) Nothing Nothing, XObj (Sym path) Nothing Nothing] + deps = templateDependencies template actualType + in (XObj (Lst defLst) (Just dummyInfo) (Just actualType), deps) + +-- | Type aliases are used to create C-typedefs when those are needed. +defineTypeAlias :: String -> Ty -> XObj +defineTypeAlias name t = XObj (Lst [XObj (Defalias t) Nothing Nothing + ,XObj (Sym (SymPath [] name)) Nothing Nothing + ]) (Just dummyInfo) (Just TypeTy) + +defineFunctionTypeAlias :: Ty -> XObj +defineFunctionTypeAlias aliasTy = defineTypeAlias (tyToC aliasTy) aliasTy + +defineArrayTypeAlias :: Ty -> XObj +defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy "Array" []) + diff --git a/src/Parsing.hs b/src/Parsing.hs new file mode 100644 index 000000000..a159f6d66 --- /dev/null +++ b/src/Parsing.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Parsing (parse, validCharacters, balance) where + +import Text.Parsec ((<|>)) +import qualified Text.Parsec as Parsec +import qualified Data.Set as Set +import Obj +import Types + +newtype ParseState = ParseState { parseInfo :: Info } + +bumpIdentifier :: Parsec.Parsec String ParseState () +bumpIdentifier = do i <- fmap parseInfo Parsec.getState + let current = infoIdentifier i + Parsec.putState (ParseState (i { infoIdentifier = current + 1 })) + +createInfo :: Parsec.Parsec String ParseState (Maybe Info) +createInfo = do i <- fmap parseInfo Parsec.getState + bumpIdentifier + return (Just i) + +firstDigit :: Parsec.Parsec String ParseState Char +firstDigit = Parsec.choice [Parsec.digit, Parsec.char '-'] + +double :: Parsec.Parsec String ParseState XObj +double = do i <- createInfo + num0 <- firstDigit + num1 <- Parsec.many Parsec.digit + let num = num0 : num1 + incColumn (length num) + _ <- Parsec.char '.' + decimals <- Parsec.many1 Parsec.digit + incColumn (length decimals) + if num == "-" + then return (XObj (Sym (SymPath [] "-")) i Nothing) + else return (XObj (Num DoubleTy (read (num ++ "." ++ decimals))) i Nothing) + +float :: Parsec.Parsec String ParseState XObj +float = do i <- createInfo + num0 <- firstDigit + num1 <- Parsec.many Parsec.digit + let num = num0 : num1 + incColumn (length num) + _ <- Parsec.char '.' + incColumn 1 + decimals <- Parsec.many1 Parsec.digit + incColumn (length decimals) + _ <- Parsec.char 'f' + incColumn 1 + if num == "-" + then return (XObj (Sym (SymPath [] "-")) i Nothing) + else return (XObj (Num FloatTy (read (num ++ "." ++ decimals))) i Nothing) + +integer :: Parsec.Parsec String ParseState XObj +integer = do i <- createInfo + num0 <- firstDigit + num1 <- Parsec.many Parsec.digit + let num = num0 : num1 + incColumn (length num) + if num == "-" + then return (XObj (Sym (SymPath [] "-")) i Nothing) + else return (XObj (Num IntTy (read num)) i Nothing) + +number :: Parsec.Parsec String ParseState XObj +number = Parsec.try float <|> + Parsec.try double <|> + Parsec.try integer + +string :: Parsec.Parsec String ParseState XObj +string = do i <- createInfo + _ <- Parsec.char '"' + str <- Parsec.many (Parsec.noneOf ['"']) + _ <- Parsec.char '"' + incColumn (length str + 2) + return (XObj (Str str) i Nothing) + +aChar :: Parsec.Parsec String ParseState XObj +aChar = do i <- createInfo + _ <- Parsec.char '\\' + c <- Parsec.anyChar + incColumn 2 + return (XObj (Chr c) i Nothing) + +validCharacters :: [Char] +validCharacters = "+-*/?!><=_:" + +symbolSegment :: Parsec.Parsec String ParseState String +symbolSegment = do sym <- Parsec.many1 validInSymbol + incColumn (length sym) + return sym + where validInSymbol = Parsec.choice [Parsec.letter, Parsec.digit, Parsec.oneOf validCharacters] + +symbol :: Parsec.Parsec String ParseState XObj +symbol = do i <- createInfo + segments <- Parsec.sepBy1 symbolSegment (Parsec.char '.') + case last segments of + "defn" -> return (XObj Defn i Nothing) + "def" -> return (XObj Def i Nothing) + -- What about the other def- forms? + "do" -> return (XObj Do i Nothing) + "while" -> return (XObj While i Nothing) + -- "fn" -> return (XObj Fn i Nothing) + "let" -> return (XObj Let i Nothing) + "if" -> return (XObj If i Nothing) + "true" -> return (XObj (Bol True) i Nothing) + "false" -> return (XObj (Bol False) i Nothing) + "address" -> return (XObj Address i Nothing) + "set!" -> return (XObj SetBang i Nothing) + "the" -> return (XObj The i Nothing) + "ref" -> return (XObj Ref i Nothing) + name -> return (XObj (Sym (SymPath (init segments) name)) i Nothing) + +atom :: Parsec.Parsec String ParseState XObj +atom = Parsec.choice [number, string, aChar, symbol] + +incColumn :: Int -> Parsec.Parsec String ParseState () +incColumn x = do s <- Parsec.getState + let i = parseInfo s + line = infoLine i + column = infoColumn i + identifier = infoIdentifier i + newInfo = Info line (column + x) (Set.fromList []) identifier + Parsec.putState (s { parseInfo = newInfo }) + return () + +comment :: Parsec.Parsec String ParseState () +comment = do _ <- Parsec.char ';' + _ <- Parsec.many (Parsec.noneOf ['\n']) + return () + +linebreak :: Parsec.Parsec String ParseState () +linebreak = do s <- Parsec.getState + let i = parseInfo s + line = infoLine i + identifier = infoIdentifier i + newInfo = Info (line + 1) 0 (Set.fromList []) identifier + Parsec.putState (s { parseInfo = newInfo }) + _ <- Parsec.char '\n' + return () + +space :: Parsec.Parsec String ParseState () +space = do incColumn 1 + _ <- Parsec.char ' ' + return () + +tab :: Parsec.Parsec String ParseState () +tab = do incColumn 1 + _ <- Parsec.char '\t' + return () + +eof :: Parsec.Parsec String ParseState () +eof = do _ <- Parsec.char '\0' + return () + +emptyCharacters :: [Parsec.Parsec String ParseState ()] +emptyCharacters = [space, tab, linebreak, eof, comment] + +whitespace :: Parsec.Parsec String ParseState () +whitespace = do _ <- Parsec.many1 (Parsec.choice emptyCharacters) + return () + +whitespaceOrNothing :: Parsec.Parsec String ParseState () +whitespaceOrNothing = do _ <- Parsec.many (Parsec.choice emptyCharacters) + return () + +readObjs :: Parsec.Parsec String ParseState [XObj] +readObjs = do padding <- Parsec.many whitespace + incColumn (length padding) + Parsec.many sexpr + +array :: Parsec.Parsec String ParseState XObj +array = do i <- createInfo + _ <- Parsec.char '[' + incColumn 1 + objs <- readObjs + _ <- Parsec.char ']' + incColumn 1 + return (XObj (Arr objs) i Nothing) + +list :: Parsec.Parsec String ParseState XObj +list = do i <- createInfo + _ <- Parsec.char '(' + incColumn 1 + objs <- readObjs + _ <- Parsec.char ')' + incColumn 1 + return (XObj (Lst objs) i Nothing) + +ref :: Parsec.Parsec String ParseState XObj +ref = do i <- createInfo + _ <- Parsec.char '&' + expr <- sexpr + return (XObj (Lst [(XObj Ref Nothing Nothing), expr]) i Nothing) + +copy :: Parsec.Parsec String ParseState XObj +copy = do i1 <- createInfo + i2 <- createInfo + _ <- Parsec.char '@' + expr <- sexpr + return (XObj (Lst [(XObj (Sym (SymPath [] "copy")) i1 Nothing), expr]) i2 Nothing) + +sexpr :: Parsec.Parsec String ParseState XObj +sexpr = do x <- Parsec.choice [ref, copy, list, array, atom] + _ <- whitespaceOrNothing + return x + +lispSyntax :: Parsec.Parsec String ParseState [XObj] +lispSyntax = do padding <- Parsec.many whitespace + incColumn (length padding) + Parsec.sepBy sexpr whitespaceOrNothing + +parse :: String -> Either Parsec.ParseError [XObj] +parse text = let initState = ParseState (Info 1 0 (Set.fromList []) 0) + in Parsec.runParser lispSyntax initState "(source)" text + + + +-- | For detecting the parenthesis balance in a string, i.e. "((( ))" = 1 +balance :: String -> Int +balance text = + case Parsec.runParser parenSyntax [] "(parens)" text of + Left err -> error (show err) + Right ok -> ok + + where parenSyntax :: Parsec.Parsec String [Char] Int + parenSyntax = do _ <- Parsec.many character + parens <- Parsec.getState + return (length parens) + + character :: Parsec.Parsec String [Char] () + character = do c <- Parsec.anyChar + parens <- Parsec.getState + case parens of + [] -> push c + '"':xs -> case c of + '"' -> Parsec.putState xs -- close string + _ -> return () -- inside string + (x:xs) -> case (x, c) of + ('(', ')') -> Parsec.putState xs + ('[', ']') -> Parsec.putState xs + ('"', '"') -> Parsec.putState xs + --('\\', _) -> Parsec.putState xs -- ignore char after '\' + _ -> push c + + push :: Char -> Parsec.Parsec String String () + push c = + do parens <- Parsec.getState + case c of + '(' -> Parsec.putState (c : parens) + '[' -> Parsec.putState (c : parens) + '"' -> Parsec.putState (c : parens) + _ -> return () diff --git a/src/Template.hs b/src/Template.hs new file mode 100644 index 000000000..b9c43bded --- /dev/null +++ b/src/Template.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE LambdaCase #-} + +module Template where + +import qualified Text.Parsec as Parsec +import Text.Parsec ((<|>)) +import Debug.Trace + +import Util +import Types +import Obj +import Parsing +import Infer + +-- | Templates are instructions for the compiler to generate some C-code +-- | based on some template and the names and types to fill into the template. +-- | Templates are generic and need to be given an explicit type to generate the +-- | correct code. + +-- | Example: +-- | template1 : ((Array T) -> Int) = "int length__T( xs) { return xs->len; }" +-- | Given the type ((Array Float) -> Int) the following code is produced: +-- | "int length__Float(Array__Float xs) { return xs->len; }" + +-- | Create a binding pair used for adding a template definition to an environment. +defineTemplate :: SymPath -> Ty -> [Token] -> [Token] -> (Ty -> [XObj]) -> (String, Binder) +defineTemplate path t declaration definition depsFunc = + let (SymPath _ name) = path + template = Template t (const declaration) (const definition) depsFunc + defLst = [XObj (Deftemplate (TemplateCreator (\_ _ -> template))) Nothing Nothing, XObj (Sym path) Nothing Nothing] + in (name, Binder (XObj (Lst defLst) Nothing (Just t))) + +-- | The more advanced version of a template, where the code can vary depending on the type. +defineTypeParameterizedTemplate :: TemplateCreator -> SymPath -> Ty -> (String, Binder) +defineTypeParameterizedTemplate templateCreator path t = + let (SymPath _ name) = path + defLst = [XObj (Deftemplate templateCreator) Nothing Nothing, XObj (Sym path) Nothing Nothing] + in (name, Binder (XObj (Lst defLst) Nothing (Just t))) + +-- | Create a binding pair used for adding a template instantiation to an environment. +instanceBinder :: SymPath -> Ty -> Template -> (String, Binder) +instanceBinder path@(SymPath _ name) actualType template = + let (x, _) = instantiateTemplate path actualType template + in (name, Binder x) + +-- -- | Create a binding pair and don't discard the dependencies +instanceBinderWithDeps :: SymPath -> Ty -> Template -> ((String, Binder), [XObj]) +instanceBinderWithDeps path@(SymPath _ name) actualType template = + let (x, deps) = instantiateTemplate path actualType template + in ((name, Binder x), deps) + +-- | Concretizes the types used in @token +-- @cName is the name of the definition, i.e. the "foo" in "void foo() { ... }" +concretizeTypesInToken :: TypeMappings -> String -> [Token] -> Token -> [Token] +concretizeTypesInToken mappings cName decl token = + case token of + TokDecl -> concatMap (concretizeTypesInToken mappings cName (error "Nope.")) decl + TokName -> [TokC cName] + TokTy t -> [TokTy (replaceTyVars mappings t)] + _ -> [token] + +-- | High-level helper function for creating templates from strings of C code. +toTemplate :: String -> [Token] +toTemplate text = case Parsec.runParser templateSyntax 0 "(template)" text of + Right ok -> ok + Left err -> compilerError (show err) + where + templateSyntax :: Parsec.Parsec String Int [Token] + templateSyntax = Parsec.many parseTok + + parseTok = Parsec.try parseTokDecl <|> --- $DECL + Parsec.try parseTokName <|> --- $NAME + Parsec.try parseTokTyGrouped <|> --- i.e. $(Fn [Int] t) + Parsec.try parseTokTy <|> --- i.e. $t + parseTokC --- Anything else... + + parseTokDecl :: Parsec.Parsec String Int Token + parseTokDecl = do _ <- Parsec.string "$DECL" + return TokDecl + + parseTokName :: Parsec.Parsec String Int Token + parseTokName = do _ <- Parsec.string "$NAME" + return TokName + + parseTokC :: Parsec.Parsec String Int Token + parseTokC = do s <- Parsec.many1 validInSymbol + return (TokC s) + where validInSymbol = Parsec.choice [Parsec.letter, Parsec.digit, Parsec.oneOf validCharactersInTemplate] + validCharactersInTemplate = " ><{}()[]|;.,_-+*#/'^!?€%&=@\"\n\t" + + parseTokTy :: Parsec.Parsec String Int Token + parseTokTy = do _ <- Parsec.char '$' + s <- Parsec.many1 Parsec.letter + return (toTokTy s) + + parseTokTyGrouped :: Parsec.Parsec String Int Token + parseTokTyGrouped = do _ <- Parsec.char '$' + _ <- Parsec.char '(' + Parsec.putState 1 -- One paren to close. + s <- fmap ('(' :) (Parsec.many parseCharBalanced) + -- Note: The closing paren is read by parseCharBalanced. + return (toTokTy s) + + parseCharBalanced :: Parsec.Parsec String Int Char + parseCharBalanced = do balanceState <- Parsec.getState + if balanceState > 0 + then Parsec.try openParen <|> + Parsec.try closeParen <|> + Parsec.anyChar + else Parsec.char '\0' -- Should always fail which will end the string. + + openParen :: Parsec.Parsec String Int Char + openParen = do _ <- Parsec.char '(' + Parsec.modifyState (+1) + return '(' + + closeParen :: Parsec.Parsec String Int Char + closeParen = do _ <- Parsec.char ')' + Parsec.modifyState (\x -> x - 1) + return ')' + +toTokTy :: String -> Token +toTokTy s = + case parse s of + Left err -> compilerError (show err) + Right [] -> compilerError ("toTokTy got [] when parsing: '" ++ s ++ "'") + Right [xobj] -> case xobjToTy xobj of + Just ok -> TokTy ok + Nothing -> compilerError ("toTokTy failed to convert this s-expression to a type: " ++ pretty xobj) + Right xobjs -> compilerError ("toTokTy parsed too many s-expressions: " ++ joinWithSpace (map pretty xobjs)) + +---------------------------------------------------------------------------------------------------------- +-- | ACTUAL TEMPLATES: + +templateMap :: (String, Binder) +templateMap = + let fTy = FuncTy [VarTy "a"] (VarTy "b") + aTy = StructTy "Array" [VarTy "a"] + bTy = StructTy "Array" [VarTy "b"] + in defineTemplate + (SymPath ["Array"] "map") + (FuncTy [fTy, aTy] bTy) + (toTemplate "Array $NAME($(Fn [a] b) f, Array a)") + (toTemplate $ unlines + ["$DECL { " + ," Array b;" + ," b.len = a.len;" + ," b.data = malloc(sizeof($b) * a.len);" + ," for(int i = 0; i < a.len; ++i) {" + ," (($b*)b.data)[i] = f((($a*)a.data)[i]); " + ," }" + ," return b;" + ,"}" + ]) + (\(FuncTy [t, arrayType] _) -> [defineFunctionTypeAlias t, defineArrayTypeAlias arrayType]) + +templatePushBack :: (String, Binder) +templatePushBack = + let aTy = StructTy "Array" [VarTy "a"] + valTy = VarTy "a" + in defineTemplate + (SymPath ["Array"] "push-back") + (FuncTy [aTy, valTy] aTy) + (toTemplate "Array $NAME(Array a, $a value)") + (toTemplate $ unlines + ["$DECL { " + ," a.len++;" + ," void *pre = a.data;" + ," a.data = malloc(sizeof($a) * a.len);" + ," free(pre);" + --a.data = realloc(a.data, sizeof($a) * a.len);" + ," (($a*)a.data)[a.len - 1] = value;" + ," return a;" + ,"}" + ]) + (\(FuncTy [arrayType, _] _) -> [defineArrayTypeAlias arrayType]) + +templatePopBack :: (String, Binder) +templatePopBack = + let aTy = StructTy "Array" [VarTy "a"] + in defineTemplate + (SymPath ["Array"] "pop-back") + (FuncTy [aTy] aTy) + (toTemplate "Array $NAME(Array a)") + (toTemplate $ unlines + ["$DECL { " + ," a.len--;" + ," if(a.len > 0) {" + --," a.data = realloc(a.data, sizeof($a) * a.len);" + ," void *pre = a.data;" + ," a.data = malloc(sizeof($a) * a.len);" + ," free(pre);" + ," }" + ," return a;" + ,"}" + ]) + (\(FuncTy [arrayType] _) -> [defineArrayTypeAlias arrayType]) + +templateNth :: (String, Binder) +templateNth = + let t = VarTy "t" + in defineTemplate + (SymPath ["Array"] "nth") + (FuncTy [RefTy (StructTy "Array" [t]), IntTy] t) + (toTemplate "$t $NAME (Array *aRef, int n)") + (toTemplate $ unlines ["$DECL {" + ," Array a = *aRef;" + ," assert(n >= 0);" + ," assert(n < a.len);" + ," return (($t*)a.data)[n];" + ,"}"]) + (\(FuncTy [arrayType, _] _) -> [defineArrayTypeAlias arrayType]) + +templateReplicate :: (String, Binder) +templateReplicate = defineTemplate + (SymPath ["Array"] "replicate") + (FuncTy [IntTy, VarTy "t"] (StructTy "Array" [VarTy "t"])) + (toTemplate "Array $NAME(int n, $t elem)") + (toTemplate $ unlines [ "$DECL {" + , " Array a; a.len = n; a.data = malloc(sizeof($t) * n);" + , " for(int i = 0; i < n; ++i) {" + , " (($t*)a.data)[i] = elem;" + , " }" + , " return a;" + , "}"]) + (\(FuncTy [_, _] arrayType) -> [defineArrayTypeAlias arrayType]) + +templateRepeat :: (String, Binder) +templateRepeat = defineTemplate + (SymPath ["Array"] "repeat") + (FuncTy [IntTy, (FuncTy [] (VarTy "t"))] (StructTy "Array" [VarTy "t"])) + (toTemplate "Array $NAME(int n, $(Fn [] t) f)") + (toTemplate $ unlines [ "$DECL {" + , " Array a; a.len = n; a.data = malloc(sizeof($t) * n);" + , " for(int i = 0; i < n; ++i) {" + , " (($t*)a.data)[i] = f();" + , " }" + , " return a;" + , "}"]) + (\(FuncTy [_, t] arrayType) -> [defineArrayTypeAlias arrayType, defineFunctionTypeAlias t]) + +templateRaw :: (String, Binder) +templateRaw = defineTemplate + (SymPath ["Array"] "raw") + (FuncTy [StructTy "Array" [VarTy "t"]] (PointerTy (VarTy "t"))) + (toTemplate "$t* $NAME (Array a)") + (toTemplate "$DECL { return a.data; }") + (\(FuncTy [arrayType] _) -> [defineArrayTypeAlias arrayType]) + +templateAset :: (String, Binder) +templateAset = defineTemplate + (SymPath ["Array"] "aset") + (FuncTy [StructTy "Array" [VarTy "t"], IntTy, VarTy "t"] (StructTy "Array" [VarTy "t"])) + (toTemplate "Array $NAME (Array a, int n, $t newValue)") + (toTemplate $ unlines ["$DECL {" + ," assert(n >= 0);" + ," assert(n < a.len);" + ," (($t*)a.data)[n] = newValue;" + ," return a;" + ,"}"]) + (\(FuncTy [arrayType, _, _] _) -> [defineArrayTypeAlias arrayType]) + +templateAsetBang :: (String, Binder) +templateAsetBang = defineTemplate + (SymPath ["Array"] "aset!") + (FuncTy [RefTy (StructTy "Array" [VarTy "t"]), IntTy, VarTy "t"] UnitTy) + (toTemplate "void $NAME (Array *aRef, int n, $t newValue)") + (toTemplate $ unlines ["$DECL {" + ," Array a = *aRef;" + ," assert(n >= 0);" + ," assert(n < a.len);" + ," (($t*)a.data)[n] = newValue;" + ,"}"]) + (\(FuncTy [arrayType, _, _] _) -> [defineArrayTypeAlias arrayType]) + +templateCount :: (String, Binder) +templateCount = defineTemplate + (SymPath ["Array"] "count") + (FuncTy [RefTy (StructTy "Array" [VarTy "t"])] IntTy) + (toTemplate "int $NAME (Array *a)") + (toTemplate "$DECL { return (*a).len; }") + (\(FuncTy [arrayType] _) -> [defineArrayTypeAlias arrayType]) + +templateDeleteArray :: (String, Binder) +templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t + where templateCreator = TemplateCreator $ + \typeEnv env -> + Template + t + (const (toTemplate "void $NAME (Array a)")) + (\(FuncTy [arrayType] UnitTy) -> + [TokDecl, TokC "{\n"] ++ + (deleteTy env arrayType) ++ + [TokC "}\n"]) + (\(FuncTy [arrayType@(StructTy "Array" [insideType])] UnitTy) -> + defineArrayTypeAlias arrayType : insideArrayDeleteDeps typeEnv env insideType) + path = SymPath ["Array"] "delete" + t = (FuncTy [(StructTy "Array" [VarTy "a"])] UnitTy) + +deleteTy :: Env -> Ty -> [Token] +deleteTy env (StructTy "Array" [innerType]) = + [ TokC " for(int i = 0; i < a.len; i++) {\n" + , TokC $ " " ++ insideArrayDeletion env innerType + , TokC " }\n" + , TokC " free(a.data);\n" + ] +deleteTy _ _ = [] + +insideArrayDeletion :: Env -> Ty -> String +insideArrayDeletion env t + | isManaged t = + case filter ((\(Just t') -> areUnifiable (FuncTy [t] UnitTy) t') . ty . binderXObj . snd) (multiLookupALL "delete" env) of + [] -> " /* Can't find any delete-function for type inside Array: '" ++ show t ++ "' */\n" + [(_, Binder single)] -> + let Just t' = ty single + (SymPath pathStrings name) = getPath single + suffix = polymorphicSuffix t' (FuncTy [t] UnitTy) + concretizedPath = SymPath pathStrings (name ++ suffix) + in " " ++ pathToC concretizedPath ++ "(((" ++ tyToC t ++ "*)a.data)[i]);\n" + _ -> " /* Can't find a single delete-function for type inside Array: '" ++ show t ++ "' */\n" + | otherwise = " /* Ignore non-managed type inside Array: '" ++ show t ++ "' */\n" + +templateNoop :: (String, Binder) +templateNoop = defineTemplate + (SymPath [] "noop") + (FuncTy [(PointerTy (VarTy "a"))] UnitTy) + (toTemplate "void $NAME ($a* a)") + (toTemplate "$DECL { }") + (const []) + + + + + + + +--------------------------- + +templateCopyArray :: (String, Binder) +templateCopyArray = defineTypeParameterizedTemplate templateCreator path t + where templateCreator = TemplateCreator $ + \typeEnv env -> + Template + t + (const (toTemplate "Array $NAME (Array* a)")) + (\(FuncTy [(RefTy arrayType)] _) -> + [TokDecl, TokC "{\n"] ++ + [TokC " Array copy;\n"] ++ + [TokC " copy.len = a->len;\n"] ++ + [TokC " copy.data = malloc(sizeof(", TokTy (VarTy "a"), TokC ") * a->len);\n"] ++ + (copyTy env arrayType) ++ + [TokC " return copy;\n"] ++ + [TokC "}\n"]) + (\case + (FuncTy [(RefTy arrayType@(StructTy "Array" [insideType]))] _) -> + defineArrayTypeAlias arrayType : insideArrayCopyDeps typeEnv env insideType + err -> + error ("CAN'T MATCH: " ++ (show err)) + ) + path = SymPath ["Array"] "copy" + t = (FuncTy [(RefTy (StructTy "Array" [VarTy "a"]))] (StructTy "Array" [VarTy "a"])) + +copyTy :: Env -> Ty -> [Token] +copyTy env (StructTy "Array" [innerType]) = + [ TokC " for(int i = 0; i < a->len; i++) {\n" + , TokC $ " " ++ insideArrayCopying env innerType + , TokC " }\n" + ] +copyTy _ _ = [] + +insideArrayCopying :: Env -> Ty -> String +insideArrayCopying env t + | isManaged t = + case filter ((\(Just t') -> areUnifiable (FuncTy [(RefTy t)] t) t') . ty . binderXObj . snd) (multiLookupALL "copy" env) of + [] -> " /* Can't find any copy-function for type inside Array: '" ++ show t ++ "' */\n" + [(_, Binder single)] -> + let Just t' = ty single + (SymPath pathStrings name) = getPath single + suffix = polymorphicSuffix t' (FuncTy [(RefTy t)] t) + concretizedPath = SymPath pathStrings (name ++ suffix) + in " ((" ++ tyToC t ++ "*)(copy.data))[i] = " ++ pathToC concretizedPath ++ "(&(((" ++ tyToC t ++ "*)a->data)[i]));\n" + _ -> " /* Can't find a single copy-function for type inside Array: '" ++ show t ++ "' */\n" + | otherwise = " /* Ignore non-managed type inside Array: '" ++ show t ++ "' */\n" diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 000000000..0fefed703 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,184 @@ +module Types ( TypeMappings + , Ty(..) + , showMaybeTy + , tyToC + , typeIsGeneric + , SymPath(..) + , unifySignatures + , replaceTyVars + , mangle + , pathToC + , areUnifiable + , isManaged + ) where + +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Util + +-- | Carp types. +data Ty = IntTy + | BoolTy + | FloatTy + | DoubleTy + | StringTy + | CharTy + | FuncTy [Ty] Ty + | VarTy String + | UnitTy + | ModuleTy + | PointerTy Ty + | RefTy Ty + | StructTy String [Ty] + | TypeTy -- the type of types + | MacroTy + | DynamicTy -- the type of dynamic functions (used in REPL and macros) + deriving (Eq, Ord) + +instance Show Ty where + show IntTy = "Int" + show FloatTy = "Float" + show DoubleTy = "Double" + show BoolTy = "Bool" + show StringTy = "String" + show CharTy = "Char" + show (FuncTy argTys retTy) = "(λ [" ++ joinWithSpace (map show argTys) ++ "] " ++ show retTy ++ ")" + show (VarTy t) = t + show UnitTy = "()" + show ModuleTy = "Module" + show TypeTy = "Type" + show (StructTy s []) = s + show (StructTy s typeArgs) = "(" ++ s ++ " " ++ joinWithSpace (map show typeArgs) ++ ")" + show (PointerTy p) = "(Ptr " ++ show p ++ ")" + show (RefTy r) = "(Ref " ++ show r ++ ")" + show MacroTy = "Macro" + show DynamicTy = "Dynamic" + +showMaybeTy :: Maybe Ty -> String +showMaybeTy (Just t) = show t +showMaybeTy Nothing = "(missing-type)" + +tyToC :: Ty -> String +tyToC = tyToCManglePtr False + +tyToCManglePtr :: Bool -> Ty -> String +tyToCManglePtr _ IntTy = "int" +tyToCManglePtr _ BoolTy = "bool" +tyToCManglePtr _ FloatTy = "float" +tyToCManglePtr _ DoubleTy = "double" +tyToCManglePtr _ StringTy = "string" +tyToCManglePtr _ CharTy = "char" +tyToCManglePtr _ UnitTy = "void" +tyToCManglePtr _ (VarTy x) = x +tyToCManglePtr _ (FuncTy argTys retTy) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy +tyToCManglePtr _ ModuleTy = error "Can't emit module type." +tyToCManglePtr b (PointerTy p) = tyToCManglePtr b p ++ (if b then mangle "*" else "*") +tyToCManglePtr b (RefTy r) = tyToCManglePtr b r ++ (if b then mangle "*" else "*") +tyToCManglePtr _ (StructTy s []) = mangle s +tyToCManglePtr _ (StructTy s typeArgs) = mangle s ++ "__" ++ joinWithUnderscore (map (tyToCManglePtr True) typeArgs) +tyToCManglePtr _ TypeTy = compilerError "Can't emit the type of types." +tyToCManglePtr _ MacroTy = compilerError "Can't emit the type of macros." +tyToCManglePtr _ DynamicTy = compilerError "Can't emit the type of dynamic functions." + +typeIsGeneric :: Ty -> Bool +typeIsGeneric (VarTy _) = True +typeIsGeneric (FuncTy argTys retTy) = any typeIsGeneric argTys || typeIsGeneric retTy +typeIsGeneric (StructTy _ tyArgs) = any typeIsGeneric tyArgs +typeIsGeneric (PointerTy p) = typeIsGeneric p +typeIsGeneric (RefTy r) = typeIsGeneric r +typeIsGeneric _ = False + +-- | Map type variable names to actual types, eg. t0 => Int, t1 => Float +type TypeMappings = Map.Map String Ty + +-- | The path to a binding +data SymPath = SymPath [String] String deriving (Ord, Eq) + +instance Show SymPath where + show (SymPath modulePath symName) = + if null modulePath + then symName + else joinWithPeriod modulePath ++ "." ++ symName + +pathToC :: SymPath -> String +pathToC (SymPath modulePath name) = concatMap ((++ "_") . mangle) modulePath ++ mangle name + +-- | Replaces symbols not allowed in C-identifiers. +mangle :: String -> String +mangle = replaceChars (Map.fromList [('+', "_PLUS_") + ,('-', "_MINUS_") + ,('*', "_MUL_") + ,('/', "_DIV_") + ,('<', "_LT_") + ,('>', "_GT_") + ,('?', "_QMARK_") + ,('!', "_BANG_") + ,('=', "_EQ_")]) + +-- | From two types, one with type variables and one without (e.g. (Fn ["t0"] "t1") and (Fn [Int] Bool)) +-- create mappings that translate from the type variables to concrete types, e.g. "t0" => Int, "t1" => Bool +unifySignatures :: Ty -> Ty -> TypeMappings +unifySignatures v t = Map.fromList (unify v t) + where unify :: Ty -> Ty -> [(String, Ty)] + unify a@(VarTy _) b@(VarTy _) = compilerError ("Can't unify " ++ show a ++ " with " ++ show b) + unify (VarTy a) value = [(a, value)] + + unify (StructTy a aArgs) (StructTy b bArgs) | a == b = concat (zipWith unify aArgs bArgs) + | otherwise = compilerError ("Can't unify " ++ a ++ " with " ++ b) + unify a@(StructTy _ _) b = compilerError ("Can't unify " ++ show a ++ " with " ++ show b) + + unify (PointerTy a) (PointerTy b) = unify a b + unify a@(PointerTy _) b = compilerError ("Can't unify " ++ show a ++ " with " ++ show b) + + unify (RefTy a) (RefTy b) = unify a b + unify a@(RefTy _) b = compilerError ("Can't unify " ++ show a ++ " with " ++ show b) + + unify (FuncTy argTysA retTyA) (FuncTy argTysB retTyB) = let argToks = concat (zipWith unify argTysA argTysB) + retToks = unify retTyA retTyB + in argToks ++ retToks + unify a@(FuncTy _ _) b = compilerError ("Can't unify " ++ show a ++ " with " ++ show b) + unify a b | a == b = [] + | otherwise = compilerError ("Can't unify " ++ show a ++ " with " ++ show b) + +-- | Checks if two types will unify +areUnifiable :: Ty -> Ty -> Bool +areUnifiable (VarTy _) (VarTy _) = True +areUnifiable (VarTy _) _ = True +areUnifiable _ (VarTy _) = True +areUnifiable (StructTy a aArgs) (StructTy b bArgs) + | length aArgs /= length bArgs = False + | a == b = let argBools = zipWith areUnifiable aArgs bArgs + in all (== True) argBools + | otherwise = False +areUnifiable (StructTy _ _) _ = False +areUnifiable (PointerTy a) (PointerTy b) = areUnifiable a b +areUnifiable (PointerTy _) _ = False +areUnifiable (RefTy a) (RefTy b) = areUnifiable a b +areUnifiable (RefTy _) _ = False +areUnifiable (FuncTy argTysA retTyA) (FuncTy argTysB retTyB) + | length argTysA /= length argTysB = False + | otherwise = let argBools = zipWith areUnifiable argTysA argTysB + retBool = areUnifiable retTyA retTyB + in all (== True) (retBool : argBools) +areUnifiable (FuncTy _ _) _ = False +areUnifiable a b | a == b = True + | otherwise = False + +-- | Put concrete types into the places where there are type variables. +-- For example (Fn [a] b) => (Fn [Int] Bool) +-- NOTE: If a concrete type can't be found, the type variable will stay the same. +replaceTyVars :: TypeMappings -> Ty -> Ty +replaceTyVars mappings t = + case t of + (VarTy key) -> fromMaybe t (Map.lookup key mappings) + (FuncTy argTys retTy) -> FuncTy (map (replaceTyVars mappings) argTys) (replaceTyVars mappings retTy) + (StructTy name tyArgs) -> StructTy name (fmap (replaceTyVars mappings) tyArgs) + (PointerTy x) -> PointerTy (replaceTyVars mappings x) + (RefTy x) -> RefTy (replaceTyVars mappings x) + _ -> t + +-- | Is this type managed - does it need to be freed? +isManaged :: Ty -> Bool +isManaged (StructTy _ _) = True +isManaged StringTy = True +isManaged _ = False diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 index 000000000..70c376e32 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,39 @@ +module Util where + +import Data.List +import qualified Data.Map as Map + +joinWith :: String -> [String] -> String +joinWith s = concat . (intersperse s) + +joinWithSpace :: [String] -> String +joinWithSpace = joinWith " " + +joinWithComma :: [String] -> String +joinWithComma = joinWith ", " + +joinWithUnderscore :: [String] -> String +joinWithUnderscore = joinWith "_" + +joinWithPeriod :: [String] -> String +joinWithPeriod = joinWith "." + +pairwise :: Show a => [a] -> [(a, a)] +pairwise [] = [] +pairwise (x : y : xs) = (x, y) : pairwise xs +pairwise leftover = error ("An uneven number of forms sent to pairwise: " ++ show leftover) + +compilerError :: String -> a +compilerError msg = error ("Internal compiler error: " ++ msg) + +-- | Unwraps a Maybe value a to Right a, or returns a default value (Left b) if it was Nothing. +toEither :: Maybe a -> b -> Either b a +toEither a b = case a of + Just ok -> Right ok + Nothing -> Left b + +replaceChars :: Map.Map Char String -> String -> String +replaceChars dict input = concat (map replacer input) + where replacer c = case Map.lookup c dict of + Just s -> s + Nothing -> [c] diff --git a/src/Workbench.hs b/src/Workbench.hs new file mode 100644 index 000000000..542369fea --- /dev/null +++ b/src/Workbench.hs @@ -0,0 +1,172 @@ +module Workbench where + +import ColorText +import Obj +import Types +import Commands +import Template +import Parsing +import Infer +import Constraints +import Emit +import qualified Data.Map as Map + +-- | Not part of the cabal file, just for interactive repl sessions: + +pt :: XObj -> IO () +pt = putStrLn . prettyTyped + +-- hmm + +-- Testing + +-- (Right [p]) = parse "(defn f (x) (str (add x 10)))" +-- (Right [p]) = parse "(add 2 \"hej\")" +-- e = Env (Map.fromList [("f", (Binder "f" p3)), ("g", (Binder "g" p3))]) Nothing + +-- (defn f [] (println (id "hej"))) +-- (defn f [] (println (ID \"hej\"))) +-- (array-str (replicate 5 true)) + +a :: Env +a = Env { envBindings = bs, envParent = Nothing, envModuleName = Nothing, envImports = [], envMode = ExternalEnv } + where bs = Map.fromList [("str", Binder (XObj (Lst [XObj External Nothing Nothing, + XObj (Sym (SymPath ["A"] "str")) Nothing Nothing]) + Nothing (Just (FuncTy [(StructTy "Array" [(VarTy "t")])] StringTy)))), + ("fmap", Binder (XObj (Lst [XObj External Nothing Nothing, + XObj (Sym (SymPath ["A"] "fmap")) Nothing Nothing]) + Nothing (Just (FuncTy [] (VarTy "t")))))] + +b :: Env +b = Env { envBindings = bs, envParent = Nothing, envModuleName = Nothing, envImports = [], envMode = ExternalEnv } + where bs = Map.fromList [("fmap", Binder (XObj (Lst [XObj External Nothing Nothing, + XObj (Sym (SymPath ["B"] "fmap")) Nothing Nothing]) + Nothing (Just (FuncTy [(FuncTy [(VarTy "t")] (VarTy "t")), (StructTy "Array" [(VarTy "t")])] + (StructTy "Array" [(VarTy "t")])))))] + +arrayModule :: Env +arrayModule = Env { envBindings = bindings, envParent = Nothing, envModuleName = (Just "Array"), envImports = [], envMode = ExternalEnv } + where bindings = Map.fromList [ templateNth + , templateReplicate + , templateMap + , templateRaw + ] + +startingGlobalEnv :: Env +startingGlobalEnv = Env { envBindings = bs, envParent = Nothing, envModuleName = Nothing, envImports = [(SymPath [] "A"), + (SymPath [] "B")], + envMode = ExternalEnv } + where bs = Map.fromList [-- (register "fmap" (FuncTy [(VarTy "t")] (VarTy "s"))) + (register "str" (FuncTy [IntTy] StringTy)) + , (register "inc" (FuncTy [IntTy] IntTy)) + , (register "println" (FuncTy [StringTy] UnitTy)) + , (register "id" (FuncTy [(VarTy "t")] (VarTy "t"))) + , (register "SDL_RenderDrawLines" (FuncTy [(PointerTy (StructTy "Array" [IntTy])), IntTy] UnitTy)) + , ("A", Binder (XObj (Mod a) Nothing Nothing)) + , ("B", Binder (XObj (Mod b) Nothing Nothing)) + , ("Array", Binder (XObj (Mod arrayModule) Nothing Nothing)) + ] + +-- [t0 == t1,t2 == (λ [Float] t1)] +-- (defn main [] (SDL_RenderDrawLines (Array.raw [1 2 3]) 0)) +-- defn main [] (let [x \"HELLO\"] 12345) + +(Right [p]) = parse "(defn f [] (ref 123))" +-- xobjFullPath = setFullyQualifiedDefn p (SymPath [] (getName p)) +-- p' = setFullyQualifiedSymbols startingGlobalEnv xobjFullPath + +(Right p2) = initialTypes startingGlobalEnv p +(Right c) = genConstraints p2 +Right m = solve c +m0 = solve c +p3 = assignTypes m p2 +conc = concretizeXObj True startingGlobalEnv p3 +Right (p4, deps) = conc + +cc = putStrLn $ toC p4 + +(Right c') = genConstraints p4 +Right m' = solve c' +p3' = assignTypes m' p4 +conc2 = concretizeXObj True startingGlobalEnv p3' +Right (p5, deps2) = conc2 + +Right mem = manageMemory startingGlobalEnv p5 + +ccc = putStrLn $ toC mem +co = [Constraint (StructTy "Array" [t1]) (StructTy "Array" [t2]) x x + ,Constraint t1 IntTy x x + ,Constraint t2 FloatTy x x] + + +x = XObj External Nothing Nothing +t0 = VarTy "t0" +t1 = VarTy "t1" +t2 = VarTy "t2" +t3 = VarTy "t3" +t4 = VarTy "t4" +t5 = VarTy "t5" +t6 = VarTy "t6" + +-- con = [Constraint t1 (StructTy "Array" [t2]) x x +-- ,Constraint t2 (StructTy "Array" [t3]) x x +-- ,Constraint t3 FloatTy x x] + + +-- f' = setFullyQualifiedDefn p (SymPath [] (getName p)) +-- f'' = setFullyQualifiedSymbols startingGlobalEnv f' +-- f''' = annotate startingGlobalEnv f'' + + + + + +-- b :: Env +-- b = Env (Map.fromList [("f", Binder (XObj (Sym (SymPath [] "f")) Nothing Nothing))]) Nothing Nothing + +-- a :: Env +-- a = Env (Map.fromList [("B", Binder (XObj (Mod b) Nothing Nothing))]) Nothing Nothing + +-- glob :: Env +-- glob = Env (Map.fromList [("A", Binder (XObj (Mod a) Nothing Nothing))]) Nothing Nothing + +-- p = putStrLn (prettyEnvironment glob) +-- p' = putStrLn (prettyEnvironment (envInsertAt glob (SymPath ["A", "B"] "g") (XObj (Sym (SymPath [] "g")) Nothing Nothing))) + + + + +-- Matching types + + +blub = (FuncTy [(FuncTy [IntTy] IntTy), (StructTy "Array" [IntTy])] (StructTy "Array" [t3])) +flub = (FuncTy [(FuncTy [t1] t2), (StructTy "Array" [t1])] (StructTy "Array" [t2])) + +are = areUnifiable blub flub + + + + + + +aaa = (FuncTy [t1] t1) +bbb = (FuncTy [IntTy] t0) +solution = solve [Constraint aaa bbb x x] + + + + + + + + + + +Right (Just pointerTy) = fmap (xobjToTy . head) (parse "(Ptr a)") +otherTy = (PointerTy (VarTy "t")) + +u = solve [(Constraint pointerTy otherTy x x)] + + +q = solve [Constraint t1 (PointerTy (StructTy "Array" [IntTy])) x x + ,Constraint t1 (PointerTy t2) x x] diff --git a/src/assertions.h b/src/assertions.h deleted file mode 100644 index ef9091d17..000000000 --- a/src/assertions.h +++ /dev/null @@ -1,52 +0,0 @@ -#pragma once - -#define assert_or_return(assertion, ...) \ - if(!(assertion)) { \ - printf(_VA_ARGS_); \ - printf("\n"); \ - return; \ - } -#define assert_or_return_nil(assertion, ...) \ - if(!(assertion)) { \ - printf(_VA_ARGS_); \ - printf("\n"); \ - return; \ - } - -#define set_error(message, obj) \ - eval_error = concat_c_strings((message), obj_to_string(process, (obj) ? (obj) : nil)->s); \ - stack_push(process, nil); \ - return; - -#define set_error_return_nil(message, obj) \ - eval_error = concat_c_strings((message), obj_to_string(process, (obj) ? (obj) : nil)->s); \ - return nil; - -#define set_error_return_null(message, obj) \ - eval_error = concat_c_strings((message), obj_to_string(process, (obj) ? (obj) : nil)->s); \ - return NULL; - -#define set_error_and_return(message, obj) \ - eval_error = concat_c_strings((message), obj_to_string(process, (obj) ? (obj) : nil)->s); \ - return nil; - -#define assert_or_set_error(assertion, message, obj) \ - if(!(assertion)) { \ - set_error(message, obj); \ - } - -#define assert_or_set_error_return_nil(assertion, message, obj) \ - if(!(assertion)) { \ - set_error_return_nil(message, obj); \ - } - -#define assert_or_set_error_return_null(assertion, message, obj) \ - if(!(assertion)) { \ - set_error_return_null(message, obj); \ - } - -#define assert_or_fatal_error(assertion, message) \ - if(!(assertion)) { \ - puts(message); \ - exit(1); \ - } diff --git a/src/bytecode.c b/src/bytecode.c deleted file mode 100644 index 0d5850bcb..000000000 --- a/src/bytecode.c +++ /dev/null @@ -1,1113 +0,0 @@ -#include "bytecode.h" -#include "obj.h" -#include "obj_array.h" -#include "process.h" -#include "env.h" -#include "obj_string.h" -#include "assertions.h" -#include "eval.h" -#include "obj_conversions.h" - -#define OPTIMIZED_LOOKUP 0 -#define LOG_BYTECODE_EXECUTION 0 -#define LOG_BYTECODE_STACK 0 - -#define HEAD_EQ(str) (form->car->tag == 'Y' && strcmp(form->car->s, (str)) == 0) - -// 'a' push lambda -// 'c' call -// 'd' def -// 'e' discard -// 'g' catch -// 'i' jump if false -// 'j' jump (no matter what) -// 'l' push -// 'n' not -// 'o' do -// 'p' push nil -// 'r' reset! -// 't' let -// 'u' end of function (process->function_trace_pos--) -// 'v' pop let scope -// 'x' direct lookup -// 'y' lookup -// 'q' stop - -void bytecode_match(Process *process, Obj *env, Obj *value, Obj *attempts); -void visit_form(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form); - -void write_obj(Obj *bytecodeObj, int *position, Obj *form) { - Obj *literals = bytecodeObj->bytecode_literals; - int new_index = literals->count; - obj_array_mut_append(literals, form); - int *ip = (int *)(bytecodeObj->bytecode + *position); - *ip = new_index; - *position += sizeof(int); -} - -void add_literal(Obj *bytecodeObj, int *position, Obj *form) { - bytecodeObj->bytecode[*position] = 'l'; - *position += 1; - write_obj(bytecodeObj, position, form); -} - -void add_lambda(Obj *bytecodeObj, int *position, Obj *form) { - bytecodeObj->bytecode[*position] = 'a'; - *position += 1; - write_obj(bytecodeObj, position, form); -} - -void add_call(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - Obj *argp = form->cdr; - int arg_count = 0; - while(argp && argp->car) { - visit_form(process, env, bytecodeObj, position, argp->car); - argp = argp->cdr; - arg_count++; - } - visit_form(process, env, bytecodeObj, position, form->car); // the function position - bytecodeObj->bytecode[*position] = 'c'; - (*position) += 1; - - int *ip = (int *)(bytecodeObj->bytecode + *position); - *ip = arg_count; - (*position) += sizeof(int); -} - -void add_lookup(Obj *bytecodeObj, int *position, Obj *form) { - bytecodeObj->bytecode[*position] = 'y'; - *position += 1; - write_obj(bytecodeObj, position, form); -} - -void add_direct_lookup(Obj *bytecodeObj, int *position, Obj *pair) { - bytecodeObj->bytecode[*position] = 'x'; - *position += 1; - write_obj(bytecodeObj, position, pair); -} - -void add_if(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - assert_or_set_error(form->cdr->car, "Too few body forms in 'if' form: ", form); - assert_or_set_error(form->cdr->cdr->car, "Too few body forms in 'if' form: ", form); - assert_or_set_error(form->cdr->cdr->cdr->car, "Too few body forms in 'if' form: ", form); - assert_or_set_error(form->cdr->cdr->cdr->cdr->car == NULL, "Too many body forms in 'if' form (use explicit 'do').", form); - - visit_form(process, env, bytecodeObj, position, form->cdr->car); // expression - bytecodeObj->bytecode[*position] = 'i'; // if - *position += 1; - - int jump_to_false_pos = *position; - bytecodeObj->bytecode[*position] = '?'; // amount to jump when expression is false - *position += sizeof(int); - - visit_form(process, env, bytecodeObj, position, form->cdr->cdr->car); // true branch - - bytecodeObj->bytecode[*position] = 'j'; - *position += 1; - - int jump_from_true_pos = *position; - bytecodeObj->bytecode[*position] = '?'; // amount to jump when true is done - *position += sizeof(int); - - //printf("jump_to_false_pos = %d, jump_from_true_pos = %d\n", jump_to_false_pos, jump_from_true_pos); - - // Now we know where the false branch begins, jump here if the expression is true: - int *jump_to_false_int_p = (int *)(bytecodeObj->bytecode + jump_to_false_pos); - *jump_to_false_int_p = *position; // write int to the char array - - visit_form(process, env, bytecodeObj, position, form->cdr->cdr->cdr->car); // false branch - - // Now we know where the whole block ends, jump here when true branch is done: - int *jump_from_true_int_p = (int *)(bytecodeObj->bytecode + jump_from_true_pos); - *jump_from_true_int_p = *position; -} - -void add_while(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - int start = *position; - - visit_form(process, env, bytecodeObj, position, form->cdr->car); - - bytecodeObj->bytecode[*position] = 'i'; // if - *position += 1; - - int jump_pos = *position; - bytecodeObj->bytecode[*position] = '?'; // amount to jump - *position += sizeof(int); - - visit_form(process, env, bytecodeObj, position, form->cdr->cdr->car); - - bytecodeObj->bytecode[*position] = 'e'; // discard return value - *position += 1; - - bytecodeObj->bytecode[*position] = 'j'; // go back to start - *position += 1; - - bytecodeObj->bytecode[*position] = start; - *position += sizeof(int); - - // Now we know where to jump to if the while expression is false: - int *jump_int_p = (int *)(bytecodeObj->bytecode + jump_pos); - *jump_int_p = *position; - - bytecodeObj->bytecode[*position + 0] = 'p'; // the while loop produces nil as a value - *position += 1; -} - -void add_match(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - assert_or_set_error(form->cdr->car, "Too few body forms in 'match' form: ", form); - assert_or_set_error(form->cdr->cdr->car, "Too few body forms in 'match' form: ", form); - - visit_form(process, env, bytecodeObj, position, form->cdr->car); // the value to match on - - bytecodeObj->bytecode[*position] = 'm'; - *position += 1; - write_obj(bytecodeObj, position, form->cdr->cdr); -} - -void add_do(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - Obj *p = form->cdr; - while(p && p->car) { - visit_form(process, env, bytecodeObj, position, p->car); - if(p->cdr && p->cdr->cdr) { - // this is not the last form - bytecodeObj->bytecode[*position] = 'e'; // discard - *position += 1; - } - p = p->cdr; - } -} - -void add_not(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - assert_or_set_error(form->cdr->car, "Too few body forms in 'not' form: ", form); - assert_or_set_error(form->cdr->cdr->car == NULL, "Too many body forms in 'not' form: ", form); - visit_form(process, env, bytecodeObj, position, form->cdr->car); - bytecodeObj->bytecode[*position] = 'n'; - *position += 1; -} - -void add_ref(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - visit_form(process, env, bytecodeObj, position, form->cdr->car); -} - -void add_catch(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - assert_or_set_error(form->cdr->car, "Too few body forms in 'catch-error' form: ", form); - bytecodeObj->bytecode[*position + 0] = 'g'; - *position += 1; - write_obj(bytecodeObj, position, form->cdr->car); -} - -void add_let(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - - assert_or_set_error(form->cdr->car, "Too few body forms in 'let' form: ", form); - assert_or_set_error(form->cdr->car->tag == 'Y', "Must bind to symbol in 'let' form: ", form); - assert_or_set_error(form->cdr->cdr->car, "Too few body forms in 'let' form: ", form); - assert_or_set_error(form->cdr->cdr->cdr->car, "Too few body forms in 'let' form: ", form); - assert_or_set_error(form->cdr->cdr->cdr->cdr->car == NULL, "Too many body forms in 'let' form (use explicit 'do').", form); - - // forward define symbol: - /* bytecodeObj->bytecode[*position] = 'p'; */ - /* *position += 1; */ - /* bytecodeObj->bytecode[*position] = 'd'; */ - /* *position += 1; */ - /* write_obj(bytecodeObj, position, form->cdr->car); */ - - // normal let code: - Obj *key = form->cdr->car; - Obj *value = form->cdr->cdr->car; - Obj *body = form->cdr->cdr->cdr->car; - shadow_stack_push(process, key); - shadow_stack_push(process, value); - shadow_stack_push(process, body); - - visit_form(process, env, bytecodeObj, position, value); // inline the expression of the let block - - bytecodeObj->bytecode[*position] = 't'; // push frame and bind - *position += 1; - - write_obj(bytecodeObj, position, form->cdr->car); // key - - visit_form(process, env, bytecodeObj, position, body); // inline the body of the let block - - bytecodeObj->bytecode[*position] = 'v'; // pop frame - *position += 1; - - shadow_stack_pop(process); - shadow_stack_pop(process); - shadow_stack_pop(process); -} - -void add_def(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - assert_or_set_error(form->cdr->car, "Too few body forms in 'def' form: ", form); - assert_or_set_error(form->cdr->cdr->cdr->car == NULL, "Too many body forms in 'def' form: ", form); - - visit_form(process, env, bytecodeObj, position, form->cdr->cdr->car); - bytecodeObj->bytecode[*position] = 'd'; - *position += 1; - write_obj(bytecodeObj, position, form->cdr->car); -} - -void add_reset(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - assert_or_set_error(form->cdr->car, "Too few body forms in 'reset!' form: ", form); - assert_or_set_error(form->cdr->cdr->cdr->car == NULL, "Too many body forms in 'reset!' form: ", form); - - visit_form(process, env, bytecodeObj, position, form->cdr->cdr->car); - bytecodeObj->bytecode[*position] = 'r'; - *position += 1; - write_obj(bytecodeObj, position, form->cdr->car); -} - -void visit_form(Process *process, Obj *env, Obj *bytecodeObj, int *position, Obj *form) { - if(eval_error) { - return; - } - else if(form->tag == 'C') { - if(form->car == NULL) { - add_literal(bytecodeObj, position, nil); - } - else if(form->car->car == NULL) { - add_literal(bytecodeObj, position, nil); // is this case needed? - } - else if(HEAD_EQ("quote")) { - add_literal(bytecodeObj, position, form->cdr->car); - } - else if(HEAD_EQ("if")) { - add_if(process, env, bytecodeObj, position, form); - } - else if(HEAD_EQ("while")) { - add_while(process, env, bytecodeObj, position, form); - } - else if(HEAD_EQ("match")) { - add_match(process, env, bytecodeObj, position, form); - } - else if(HEAD_EQ("do")) { - add_do(process, env, bytecodeObj, position, form); - } - else if(HEAD_EQ("lets")) { - add_let(process, env, bytecodeObj, position, form); - } - else if(HEAD_EQ("def")) { - add_def(process, env, bytecodeObj, position, form); - } - else if(HEAD_EQ("reset!")) { - add_reset(process, env, bytecodeObj, position, form); - } - else if(HEAD_EQ("ref")) { - add_ref(process, env, bytecodeObj, position, form); - } - else if(HEAD_EQ("catch-error")) { - add_catch(process, env, bytecodeObj, position, form); - } - else if(HEAD_EQ("not")) { - add_not(process, env, bytecodeObj, position, form); - } - else if(HEAD_EQ("fn")) { - //printf("Creating fn with env: %s\n", obj_to_string(process, env)->s); - //printf("START Creating fn from form: %s\n", obj_to_string(process, form)->s); - - //printf("DONE Creating fn from form: %s\n", obj_to_string(process, form)->s); - add_lambda(bytecodeObj, position, form); - } - else if(HEAD_EQ("macro")) { - Obj *macro = obj_new_macro(form->cdr->car, form_to_bytecode(process, env, form->cdr->cdr->car, false), env, form); - add_literal(bytecodeObj, position, macro); - } - else { - Obj *lookup = env_lookup(process, env, form->car); - if(lookup && lookup->tag == 'M') { - Obj *macro = lookup; - - Obj *calling_env = obj_new_environment(macro->env); - - Obj *argp = form->cdr; - int arg_count = 0; - while(argp && argp->car) { - argp = argp->cdr; - arg_count++; - } - - //printf("Arg count: %d\n", arg_count); - - argp = form->cdr; - Obj *args = obj_new_array(arg_count); - for(int i = 0; i < arg_count; i++) { - args->array[i] = argp->car; - argp = argp->cdr; - } - - //printf("Args: %s\n", obj_to_string(process, args)->s); - - env_extend_with_args(process, calling_env, macro, arg_count, args->array, true); - if(eval_error) { - return; - } - - if(macro->body->tag != 'X') { - set_error("The body of the macro must be bytecode: ", macro); - return; - } - - Obj *expanded = bytecode_sub_eval_internal(process, calling_env, macro->body); - - if(eval_error) { - return; - } - - //printf("\nExpanded '%s' to %s\n", obj_to_string(process, form->car)->s, obj_to_string(process, expanded)->s); - - visit_form(process, env, bytecodeObj, position, expanded); - } - else { - add_call(process, env, bytecodeObj, position, form); - } - } - } - else if(form->tag == 'Y') { -#if OPTIMIZED_LOOKUP - Obj *binding_pair = env_lookup_binding(process, env, form); - if(binding_pair && binding_pair->car && binding_pair->cdr) { - //printf("Found binding: %s\n", obj_to_string(process, binding_pair)->s); - add_direct_lookup(bytecodeObj, position, binding_pair); - } - else { - //printf("Found no binding for: %s\n", obj_to_string(process, form)->s); - add_lookup(bytecodeObj, position, form); - } -#else - add_lookup(bytecodeObj, position, form); -#endif - } - else { - add_literal(bytecodeObj, position, form); - } -} - -Obj *form_to_bytecode(Process *process, Obj *env, Obj *form, bool insert_return_instruction) { - int code_max_length = 2048; - char *code = malloc(code_max_length); - Obj *bytecodeObj = obj_new_bytecode(code); - int position = 0; - visit_form(process, env, bytecodeObj, &position, form); - if(position > code_max_length) { - set_error_return_nil("Bytecode exceeded maximum allowed length for form: ", form); - } - /* if(insert_return_instruction) { */ - /* bytecodeObj->bytecode[position++] = 'u'; */ - /* } */ - bytecodeObj->bytecode[position++] = 'q'; - bytecodeObj->bytecode[position++] = '\0'; - //printf("Converted '%s' to bytecode: %s\n", obj_to_string(process, form)->s, obj_to_string(process, bytecodeObj)->s); - return bytecodeObj; -} - -Obj *bytecode_sub_eval_internal(Process *process, Obj *env, Obj *bytecode_obj) { - assert(process); - assert(env->tag == 'E'); - assert(bytecode_obj->tag == 'X'); - shadow_stack_push(process, bytecode_obj); - - //printf("bytecode_sub_eval_internal\n"); - - process->frame++; - process->frames[process->frame].p = 0; - process->frames[process->frame].bytecodeObj = bytecode_obj; - process->frames[process->frame].env = env; - process->frames[process->frame].trace = obj_new_string(""); - - int top_frame = process->frame; - - Obj *result = NULL; - while(!result) { - result = bytecode_eval_internal(process, bytecode_obj, 1000, top_frame); - if(eval_error) { - return NULL; - } - } - - shadow_stack_pop(process); // bytecode_obj - return result; -} - -void bytecode_frame_print(Process *process, BytecodeFrame frame) { - if(!frame.trace) { - printf("No trace."); - } - else if(frame.trace && frame.trace->tag == 'S') { - printf("%s", frame.trace->s); - } - else if(frame.trace->meta) { - Obj *o = frame.trace; - //printf("%s\n", obj_to_string(o->meta)->s); - char *func_name = ""; - Obj *func_name_data = NULL; - - if(o && o->meta) { - func_name_data = env_lookup(process, o->meta, obj_new_keyword("name")); - } - if(func_name_data) { - func_name = obj_to_string_not_prn(process, func_name_data)->s; - } - else { - func_name = obj_to_string(process, o)->s; - } - /* int line = env_lookup(process, o->meta, obj_new_keyword("line"))->i; */ - /* int pos = env_lookup(process, o->meta, obj_new_keyword("pos"))->i; */ - /* char *file_path = env_lookup(process, o->meta, obj_new_keyword("file"))->s; */ - /* char *file = file_path; */ - - /* int len = (int)strlen(file_path); */ - /* for(int i = len - 1; i >= 0; i--) { */ - /* if(file_path[i] == '/') { */ - /* file = strdup(file_path + i + 1); */ - /* break; */ - /* } */ - /* } */ - /* printf("%-30s %s %d:%d", func_name, file, line, pos); */ - printf("%s", func_name); - printf("\tp = %d", frame.p); - } - else { - printf("No meta data: %s\n", obj_to_string(process, frame.trace)->s); - } -} - -void bytecode_stack_print(Process *process) { - printf("----------------------------------------------------------------\n"); - for(int i = 0; i <= process->frame; i++) { - printf("%d\t", i); - bytecode_frame_print(process, process->frames[i]); - printf("\n"); - } - printf("----------------------------------------------------------------\n"); -} - -// returns NULL if not done yet -Obj *bytecode_eval_internal(Process *process, Obj *bytecodeObj, int steps, int top_frame) { - assert(process); - assert(bytecodeObj); - - Obj *literal, *function, *lookup, *result, *let_env, *binding, *key; - int arg_count, i; - int *jump_pos; - - for(int step = 0; step < steps; step++) { - - if(process->frame < 0) { - assert(false); - set_error_return_null("Bytecode stack underflow. ", bytecodeObj); - } - - if(eval_error) { - return NULL; - } - - Obj **literals_array = process->frames[process->frame].bytecodeObj->bytecode_literals->array; - char *bytecode = process->frames[process->frame].bytecodeObj->bytecode; - int p = process->frames[process->frame].p; - char c = bytecode[p]; - -#if LOG_BYTECODE_EXECUTION - printf("\n\nframe = %d, p = %d, c = %c\n", process->frame, p, c); -//printf("env: %s\n", obj_to_string(process, process->frames[process->frame].env)->s); -#endif - -#if LOG_BYTECODE_STACK - stack_print(process); -//bytecode_stack_print(process); -#endif - -#define LITERAL_INDEX (*(int *)(bytecode + process->frames[process->frame].p)); -#define STEP_ONE process->frames[process->frame].p += 1; -#define STEP_INT_SIZE process->frames[process->frame].p += sizeof(int); - - switch(c) { - case 'p': - stack_push(process, nil); - STEP_ONE; - break; - case 'e': - stack_pop(process); - STEP_ONE; - break; - case 'l': - STEP_ONE; - i = LITERAL_INDEX - process->frames[process->frame] - .p += sizeof(int); - assert(i >= 0); - literal = literals_array[i]; - //printf("Pushing literal "); obj_print_cout(literal); printf("\n"); - stack_push(process, literal); - break; - case 'a': - STEP_ONE; - i = LITERAL_INDEX; - STEP_INT_SIZE; - literal = literals_array[i]; - // TODO: compile lambda during normal compilation step, only set up the environment here - Obj *lambda_bytecode = form_to_bytecode(process, process->frames[process->frame].env, literal->cdr->cdr->car, true); - Obj *lambda = obj_new_lambda(literal->cdr->car, lambda_bytecode, - process->frames[process->frame].env, - literal); - //printf("Compiled lambda: "); obj_print_cout(lambda); printf("\n"); - stack_push(process, lambda); - break; - case 'm': - STEP_ONE; - i = LITERAL_INDEX; - STEP_INT_SIZE; - Obj *cases = literals_array[i]; - //printf("Cases: "); obj_print_cout(cases); printf("\n"); - Obj *value_to_match_on = stack_pop(process); - //printf("before match, frame: %d\n", process->frame); - bytecode_match(process, process->frames[process->frame].env, value_to_match_on, cases); - //printf("after match, frame: %d\n", process->frame); - //stack_push(process, ); - break; - case 'd': - STEP_ONE; - i = LITERAL_INDEX; - STEP_INT_SIZE; - literal = literals_array[i]; - Obj *value = stack_pop(process); - //printf("defining %s to be %s\n", obj_to_string(process, literal)->s, obj_to_string(process, value)->s); - result = env_extend(process->global_env, literal, value); - stack_push(process, result->cdr); - break; - case 'n': - if(is_true(stack_pop(process))) { - stack_push(process, lisp_false); - } - else { - stack_push(process, lisp_true); - } - STEP_ONE; - break; - case 'r': - STEP_ONE; - i = LITERAL_INDEX; - STEP_INT_SIZE; - literal = literals_array[i]; - binding = env_lookup_binding(process, process->frames[process->frame].env, literal); - if(binding->car) { - //printf("reset! binding: %s\n", obj_to_string(process, binding)->s); - - Obj *pair = binding; - if(pair->cdr->tag == 'R' && pair->cdr->meta) { - //pair->cdr->given_to_ffi = true; // needed? - //printf("Resetting a ptr-to-global.\n"); - Obj *type_meta = env_lookup(process, pair->cdr->meta, obj_new_keyword("type")); - if(type_meta && obj_eq(process, type_meta, type_int)) { - int *ip = pair->cdr->void_ptr; - *ip = stack_pop(process)->i; - } - else if(type_meta && obj_eq(process, type_meta, type_float)) { - float *fp = pair->cdr->void_ptr; - *fp = stack_pop(process)->f32; - } - else if(type_meta && obj_eq(process, type_meta, type_double)) { - double *dp = pair->cdr->void_ptr; - *dp = stack_pop(process)->f64; - } - else if(type_meta && obj_eq(process, type_meta, type_char)) { - char *cp = pair->cdr->void_ptr; - *cp = stack_pop(process)->character; - } - else if(type_meta && obj_eq(process, type_meta, type_bool)) { - bool *bp = pair->cdr->void_ptr; - *bp = stack_pop(process)->boolean; - } - else if(type_meta && obj_eq(process, type_meta, type_string)) { - char **sp = pair->cdr->void_ptr; - *sp = strdup(stack_pop(process)->s); // OBS! strdup!!! Without this the string will get GC:ed though... - } - else if(type_meta->tag == 'C' && type_meta->cdr->car && obj_eq(process, type_meta->car, obj_new_keyword("Array"))) { - void **pp = pair->cdr->void_ptr; - Obj *a = stack_pop(process); - assert_or_set_error_return_nil(a->tag == 'A', "Must reset! global to array: ", binding->car); - Array *carp_array = obj_array_to_carp_array(process, a); - *pp = carp_array; - } - else { - /* printf("No/invalid :type\n"); */ - /* pair->cdr = stack_pop(); */ - - void **pp = pair->cdr->void_ptr; - *pp = stack_pop(process)->void_ptr; - } - } - else { - // a normal binding - binding->cdr = stack_pop(process); - } - stack_push(process, binding->cdr); - } - else { - eval_error = obj_new_string("reset! can't find variable to reset: "); - obj_string_mut_append(eval_error, obj_to_string(process, literal)->s); - return NULL; - } - break; - case 't': - STEP_ONE; - i = LITERAL_INDEX; - STEP_INT_SIZE; - key = literals_array[i]; - let_env = obj_new_environment(process->frames[process->frame].env); - - value = stack_pop(process); - env_extend(let_env, key, value); - - //printf("bound %s to %s\n", obj_to_string(process, key)->s, obj_to_string(process, value)->s); - - process->frame++; - process->frames[process->frame].p = process->frames[process->frame - 1].p; - process->frames[process->frame].bytecodeObj = process->frames[process->frame - 1].bytecodeObj; - process->frames[process->frame].env = let_env; - process->frames[process->frame].trace = obj_new_string(" "); - obj_string_mut_append(process->frames[process->frame].trace, key->s); - - break; - case 'y': - STEP_ONE; - i = LITERAL_INDEX; - STEP_INT_SIZE; - literal = literals_array[i]; - - //bytecode_stack_print(process); - //printf("Looking up literal "); obj_print_cout(literal); printf("\n"); - - shadow_stack_push(process, literal); - lookup = env_lookup(process, process->frames[process->frame].env, literal); - if(!lookup) { - /* stack_print(process); */ - printf("env:\n%s\n", obj_to_string(process, process->frames[process->frame].env)->s); - set_error_return_null("Failed to lookup: ", literal); - } - stack_push(process, lookup); - shadow_stack_pop(process); // literal - break; - case 'x': - i = bytecode[p + 1] - 65; - Obj *binding_pair = literals_array[i]; - lookup = binding_pair->cdr; - stack_push(process, lookup); - process->frames[process->frame].p += 2; - break; - case 'i': - //printf("'i' env:\n%s\n", obj_to_string(process, process->frames[process->frame].env)->s); - if(is_true(stack_pop(process))) { - // don't jump, just skip over the next instruction (the jump position) - process->frames[process->frame].p += 1 + sizeof(int); - } - else { - // jump if false! - jump_pos = (int *)(bytecode + 1 + p); - process->frames[process->frame].p = *jump_pos; - } - break; - case 'j': - jump_pos = (int *)(bytecode + 1 + p); - process->frames[process->frame].p = *jump_pos; - break; - case 'g': - STEP_ONE; - i = LITERAL_INDEX; - STEP_INT_SIZE; - - int save_frame = process->frame; - int shadow_stack_size_save = process->shadow_stack_pos; - int stack_size_save = process->stack_pos; - Obj *form = literals_array[i]; - shadow_stack_push(process, form); - - /* printf("'g', form = %s, stack: \n", obj_to_string(process, form)->s); */ - /* stack_print(process); */ - - result = bytecode_sub_eval_form(process, process->frames[process->frame].env, form); - shadow_stack_pop(process); - - /* printf("result = %s, stack: \n", obj_to_string(process, result)->s); */ - /* stack_print(process); */ - - process->stack_pos = stack_size_save; - /* printf("restored stack size\n"); */ - /* stack_print(process); */ - - if(eval_error) { - //printf("Caught error: %s\n", obj_to_string(process, eval_error)->s); - stack_push(process, eval_error); - eval_error = NULL; - } - else { - //printf("No error\n"); - stack_push(process, nil); - } - process->frame = save_frame; - process->shadow_stack_pos = shadow_stack_size_save; - - /* printf("AFTER 'g':\n"); */ - /* stack_print(process); */ - - break; - case 'c': - function = stack_pop(process); - - STEP_ONE; - arg_count = LITERAL_INDEX; - STEP_INT_SIZE; - - //printf("will call %s with %d args.\n", obj_to_string(process, function)->s, arg_count); - - Obj **args = NULL; - if(arg_count > 0) { - args = malloc(sizeof(Obj *) * arg_count); - } - for(int i = 0; i < arg_count; i++) { - Obj *arg = stack_pop(process); - args[arg_count - i - 1] = arg; - //shadow_stack_push(process, arg); - } - - assert(arg_count >= 0); - /* printf("sending %d args to %s\n", arg_count, obj_to_string(process, function)->s); */ - /* for(int i = 0; i < arg_count; i++) { */ - /* printf("arg %d: %s\n", i, obj_to_string(process, args[i])->s); */ - /* } */ - - if(function->tag == 'P') { - stack_push(process, function->primop((struct Process *)process, args, arg_count)); - } - else if(function->tag == 'F') { - call_foreign_function(process, function, args, arg_count); - } - else if(function->tag == 'K') { - if(arg_count != 1) { - eval_error = obj_new_string("Args to keyword lookup must be a single arg: "); - obj_string_mut_append(eval_error, obj_to_string(process, function)->s); - obj_string_mut_append(eval_error, "\n\n"); - for(int i = 0; i < arg_count; i++) { - obj_string_mut_append(eval_error, "\n"); - obj_string_mut_append(eval_error, obj_to_string(process, args[i])->s); - } - } - else if(args[0]->tag != 'E') { - eval_error = obj_new_string("Arg 0 to keyword lookup must be a dictionary: "); - obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s); - } - else { - Obj *value = env_lookup(process, args[0], function); - if(value) { - stack_push(process, value); - } - else { - eval_error = obj_new_string("Failed to lookup keyword '"); - obj_string_mut_append(eval_error, obj_to_string(process, function)->s); - obj_string_mut_append(eval_error, "'"); - obj_string_mut_append(eval_error, " in \n"); - obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s); - obj_string_mut_append(eval_error, "\n"); - } - } - } - else if(function->tag == 'E' && obj_eq(process, env_lookup(process, function, obj_new_keyword("struct")), lisp_true)) { - if(obj_eq(process, env_lookup(process, function, obj_new_keyword("generic")), lisp_true)) { - //printf("Calling generic struct constructor.\n"); - Obj *function_call_symbol = obj_new_symbol("dynamic-generic-constructor-call"); - shadow_stack_push(process, function_call_symbol); - - Obj **copied_args = malloc(sizeof(Obj *) * arg_count); - for(int i = 0; i < arg_count; i++) { - copied_args[i] = obj_copy(process, args[i]); - if(args[i]->meta) { - copied_args[i]->meta = obj_copy(process, args[i]->meta); - } - } - - Obj *carp_array = obj_new_array(arg_count); - carp_array->array = copied_args; - - Obj *call_to_concretize_struct = obj_list(function_call_symbol, - function, - carp_array); - - shadow_stack_push(process, call_to_concretize_struct); - - Obj *result = bytecode_sub_eval_form(process, process->global_env, call_to_concretize_struct); - stack_push(process, result); - - shadow_stack_pop(process); // function_call_symbol - shadow_stack_pop(process); // call_to_concretize_struct - } - else { - call_struct_constructor(process, function, args, arg_count); - } - } - else if(function->tag == 'L') { - if(process->frame >= BYTECODE_FRAME_SIZE - 1) { - set_error_return_null("Bytecode stack overflow. ", nil); - } - - Obj *calling_env = obj_new_environment(function->env); - env_extend_with_args(process, calling_env, function, arg_count, args, true); - - process->frame++; - process->frames[process->frame].p = 0; - if(function->body->tag != 'X') { - set_error_return_null("The body of the lambda must be bytecode, ", function); - } - process->frames[process->frame].bytecodeObj = function->body; - process->frames[process->frame].env = calling_env; - process->frames[process->frame].trace = function; - - // printf("Pushing new stack frame with bytecode '%s'\n", process->frames[process->frame].bytecode); - // and env %s\n", process->frames[process->frame].bytecode, obj_to_string(process, calling_env)->s); - - /* printf("Entering new frame...\n"); */ - /* bytecode_stack_print(process); */ - } - else { - set_error_return_null("Can't call \n", function); - } - break; - case 'u': - process->frame++; - break; - case 'v': - //printf("\nv\n"); - process->frame--; - process->frames[process->frame].p = process->frames[process->frame + 1].p + 1; - break; - case 'q': - //printf("\nq\n"); - //set_error_return_null("Hit end of bytecode. \n", bytecodeObj); - process->frame--; - if(process->frame < top_frame) { - return stack_pop(process); - } - break; - default: - printf("Unhandled instruction: %c\n\n", c); - bytecode_stack_print(process); - exit(-1); - } - } - - return NULL; -} - -/* Obj *bytecode_eval_bytecode(Process *process, Obj *bytecodeObj) { */ -/* return bytecode_eval_bytecode_in_env(process, bytecodeObj, process->global_env); */ -/* } */ - -Obj *bytecode_eval_bytecode_in_env(Process *process, Obj *bytecodeObj, Obj *env, Obj *trace) { - - if(bytecodeObj->tag != 'X') { - set_error_return_nil("The code to eval must be bytecode:\n", bytecodeObj); - } - - //printf("bytecode_eval_bytecode_in_env\n"); - - shadow_stack_push(process, bytecodeObj); - - process->frames[process->frame].p = 0; - process->frames[process->frame].bytecodeObj = bytecodeObj; - process->frames[process->frame].env = env; - - if(trace) { - process->frames[process->frame].trace = trace; - } - else { - process->frames[process->frame].trace = obj_new_string(""); - } - - int top_frame = process->frame; - - Obj *final_result = NULL; - while(!final_result) { - final_result = bytecode_eval_internal(process, bytecodeObj, 100, top_frame); - if(eval_error) { - return nil; - } - } - //printf("Final result = %s\n", obj_to_string(process, final_result)->s); - - process->frame = top_frame; // must reset top frame after evaluation! the stack is one below top_frame (i.e. -1) - - shadow_stack_pop(process); - return final_result; -} - -// must *not* reset when it's a sub-evaluation in load-lisp or similar -// *must* reset after - -Obj *bytecode_eval_form(Process *process, Obj *env, Obj *form) { - Obj *bytecode = form_to_bytecode(process, env, form, false); - //printf("\nWill convert to bytecode and eval:\n%s\n%s\n\n", obj_to_string(process, bytecode)->s, obj_to_string(process, form)->s); - shadow_stack_push(process, bytecode); - Obj *result = bytecode_eval_bytecode_in_env(process, bytecode, env, form); - shadow_stack_pop(process); - //stack_push(process, result); - return result; -} - -Obj *bytecode_sub_eval_form(Process *process, Obj *env, Obj *form) { - process->frame++; - Obj *result = bytecode_eval_form(process, env, form); - process->frame--; - return result; -} - -// bytecode match TODO: move to match.c - -bool bytecode_obj_match(Process *process, Obj *env, Obj *attempt, Obj *value); - -bool bytecode_obj_match_lists(Process *process, Obj *env, Obj *attempt, Obj *value) { - //printf("Matching list %s with %s\n", obj_to_string(attempt)->s, obj_to_string(value)->s); - Obj *p1 = attempt; - Obj *p2 = value; - while(p1 && p1->car) { - if(obj_eq(process, p1->car, dotdotdot) && p1->cdr && p1->cdr->car) { - //printf("Matching & %s against %s\n", obj_to_string(p1->cdr->car)->s, obj_to_string(p2)->s); - bool matched_rest = bytecode_obj_match(process, env, p1->cdr->car, p2); - return matched_rest; - } - else if(!p2 || !p2->car) { - return false; - } - bool result = bytecode_obj_match(process, env, p1->car, p2->car); - if(!result) { - return false; - } - p1 = p1->cdr; - p2 = p2->cdr; - } - if(p2 && p2->car) { - return false; - } - else { - //printf("Found end of list, it's a match.\n"); - return true; - } -} - -bool bytecode_obj_match_arrays(Process *process, Obj *env, Obj *attempt, Obj *value) { - //printf("Matching arrays %s with %s\n", obj_to_string(attempt)->s, obj_to_string(value)->s); - int i; - for(i = 0; i < attempt->count; i++) { - Obj *o = attempt->array[i]; - if(obj_eq(process, o, dotdotdot) && ((i + 1) < attempt->count)) { - int rest_count = value->count - i; - //printf("rest_count: %d\n", rest_count); - Obj *rest = obj_new_array(rest_count); - for(int j = 0; j < rest_count; j++) { - rest->array[j] = value->array[i + j]; // copy the rest of the objects to a smaller array - } - //printf("rest: %s\n", obj_to_string(rest)->s); - Obj *symbol_after_dotdotdot = attempt->array[i + 1]; - //printf("symbol_after_dotdotdot: %s\n", obj_to_string(symbol_after_dotdotdot)->s); - bool matched_rest = bytecode_obj_match(process, env, symbol_after_dotdotdot, rest); - //printf("%s\n", matched_rest ? "match" : "no match"); - return matched_rest; - } - else if(i >= value->count) { - return false; - } - bool result = bytecode_obj_match(process, env, o, value->array[i]); - if(!result) { - return false; - } - } - if(i < value->count) { - //printf("The value list is too long.\n"); - return false; - } - else { - //printf("Found end of list, it's a match.\n"); - return true; - } -} - -bool bytecode_obj_match(Process *process, Obj *env, Obj *attempt, Obj *value) { - //printf("Matching %s with %s\n", obj_to_string(attempt)->s, obj_to_string(value)->s); - - if(attempt->tag == 'C' && obj_eq(process, attempt->car, lisp_quote) && attempt->cdr && attempt->cdr->car) { - // Dubious HACK to enable matching on quoted things... - // Don't want to extend environment in this case! - Obj *quoted_attempt = attempt->cdr->car; - return obj_eq(process, quoted_attempt, value); - } - else if(attempt->tag == 'Y' && strcmp(attempt->s, "nil") == 0) { - // Using 'nil' on the left side of a match will bind the right side to that symbol, which is NOT what you want! - return obj_eq(process, value, nil); - } - else if(attempt->tag == 'Y') { - //printf("Binding %s to value %s in match.\n", obj_to_string(attempt)->s, obj_to_string(value)->s); - env_extend(env, attempt, value); - return true; - } - else if(attempt->tag == 'C' && value->tag == 'C') { - return bytecode_obj_match_lists(process, env, attempt, value); - } - else if(attempt->tag == 'A' && value->tag == 'A') { - return bytecode_obj_match_arrays(process, env, attempt, value); - } - else if(obj_eq(process, attempt, value)) { - return true; - } - else { - /* printf("attempt %s (%c) is NOT equal to value %s (%c)\n", */ - /* obj_to_string(attempt)->s, */ - /* attempt->tag, */ - /* obj_to_string(value)->s, */ - /* value->tag); */ - return false; - } -} - -void bytecode_match(Process *process, Obj *env, Obj *value, Obj *attempts) { - Obj *p = attempts; - while(p && p->car) { - //printf("\nWill match %s with value %s\n", obj_to_string(p->car)->s, obj_to_string(value)->s); - Obj *new_env = obj_new_environment(env); - shadow_stack_push(process, new_env); - bool result = bytecode_obj_match(process, new_env, p->car, value); - - if(result) { - //printf("Match found, evaling %s in env\n", obj_to_string(process, p->cdr->car)->s); //, obj_to_string(new_env)->s); - - Obj *bytecode = form_to_bytecode(process, new_env, p->cdr->car, false); - - //printf("before sub eval, frame: %d\n", process->frame); - //stack_print(process); - assert(bytecode); - - Obj *result = bytecode_sub_eval_internal(process, new_env, bytecode); // eval the following form using the new environment - if(eval_error) { - return; - } - - stack_push(process, result); - - //printf("after sub eval, frame: %d\n", process->frame); - //stack_print(process); - - Obj *pop = shadow_stack_pop(process); // new_env - if(eval_error) { - return; - } - assert(pop == new_env); - return; - } - - if(!p->cdr) { - set_error("Uneven nr of forms in match.", attempts); - } - - p = p->cdr->cdr; - - Obj *e = shadow_stack_pop(process); // new_env - assert(e == new_env); - } - - set_error("Failed to find a suitable match for: ", value); -} diff --git a/src/bytecode.h b/src/bytecode.h deleted file mode 100644 index 2acb5235c..000000000 --- a/src/bytecode.h +++ /dev/null @@ -1,14 +0,0 @@ -#pragma once - -#include "obj.h" - -#define BYTECODE_EVAL 0 - -Obj *form_to_bytecode(Process *process, Obj *env, Obj *form, bool insert_return_instruction); -//Obj *bytecode_eval_bytecode(Process *process, Obj *bytecodeObj); -Obj *bytecode_eval_bytecode_in_env(Process *process, Obj *bytecodeObj, Obj *env, Obj *trace); -Obj *bytecode_eval_form(Process *process, Obj *env, Obj *form); -Obj *bytecode_sub_eval_form(Process *process, Obj *env, Obj *form); -Obj *bytecode_eval_internal(Process *process, Obj *bytecodeObj, int steps, int top_frame); -Obj *bytecode_sub_eval_internal(Process *process, Obj *env, Obj *bytecode_obj); -void bytecode_stack_print(Process *process); diff --git a/src/call_ffi.c b/src/call_ffi.c deleted file mode 100644 index 4a2be0c9e..000000000 --- a/src/call_ffi.c +++ /dev/null @@ -1,372 +0,0 @@ -#include "call_ffi.h" -#include "obj_string.h" -#include "eval.h" -#include "assertions.h" -#include "obj_conversions.h" -#include "primops.h" -#include "../shared/types.h" -#include "env.h" - -#define ALLOW_SENDING_LAMBDA_TO_FFI 1 -#define LABELED_DISPATCH 0 - -void call_lambda_from_ffi(ffi_cif *cif, void *ret, void *args[], LambdaAndItsType *lambda_and_its_type) { - //printf("Calling lambda %s from ffi function!\n", obj_to_string(lambda_and_its_type->lambda)->s); - - int arg_count = cif->nargs; - //printf("arg count: %d\n", arg_count); - - Obj **obj_args = malloc(sizeof(Obj *) * arg_count); - //Obj *obj_args[arg_count]; - Obj *lambda_type_signature = lambda_and_its_type->signature; // TODO: shadow stack?! - Obj *lambda_return_type = lambda_type_signature->cdr->cdr->car; - Obj *lambda_arg_type_list_p = lambda_type_signature->cdr->car; - - //printf("Lambda signature: %s\n", obj_to_string(lambda_type_signature)->s); - - Process *process = lambda_and_its_type->process; - - for(int i = 0; i < arg_count; i++) { - - Obj *lambda_arg_type_p = lambda_arg_type_list_p->car; - - if(!lambda_arg_type_p) { - printf("Too many arguments (%d) sent to lambda with signature: %s\n", arg_count, obj_to_string(process, lambda_type_signature)->s); - eval_error = obj_new_string("Too many args."); - return; - } - - // Unwrap ref args - if(lambda_arg_type_p->tag == 'C' && lambda_arg_type_p->car && lambda_arg_type_p->cdr && lambda_arg_type_p->cdr->car && obj_eq(process, lambda_arg_type_p->car, obj_new_keyword("ref"))) { - lambda_arg_type_p = lambda_arg_type_p->cdr->car; // the second element of the list - } - //printf("Lambda arg p: %s\n", obj_to_string(lambda_arg_type_p)->s); - - if(cif->arg_types[i] == &ffi_type_sint) { - int *x = args[i]; - obj_args[i] = obj_new_int(*x); - } - else if(cif->arg_types[i] == &ffi_type_float) { - float *x = args[i]; - obj_args[i] = obj_new_float(*x); - } - else if(cif->arg_types[i] == &ffi_type_double) { - double *x = args[i]; - obj_args[i] = obj_new_double(*x); - } - else if(cif->arg_types[i] == &ffi_type_schar) { - char *x = args[i]; - obj_args[i] = obj_new_char(*x); - } - else { - if(obj_eq(process, lambda_arg_type_p, type_string)) { - char **x = args[i]; - assert(*x); - char *new_s = strdup(*x); - //printf("new_s: %s\n", new_s); - obj_args[i] = obj_new_string(new_s); - } - else { - //printf("Lambda called from ffi with arg %d of type %s\n", i, obj_to_string(lambda_arg_type_p)->s); - /* printf("Can't handle arg type %p when calling ffi function.\n", cif->arg_types[i]); */ - /* set_error("FFI function failed to call lambda: ", lambda_and_its_type->lambda); */ - /* return; */ - void **ptr = args[i]; - obj_args[i] = obj_new_ptr(*ptr); - } - } - //printf("arg %d: %s\n", i, obj_to_string(obj_args[i])->s); - lambda_arg_type_list_p = lambda_arg_type_list_p->cdr; - - //shadow_stack_push(obj_args[i]); - } - - apply(process, lambda_and_its_type->lambda, obj_args, cif->nargs); - Obj *result = stack_pop(process); - free(obj_args); - - // unwrap ref - if(lambda_return_type->tag == 'C' && lambda_return_type->car && lambda_return_type->cdr && lambda_return_type->cdr->car && obj_eq(process, lambda_return_type->car, obj_new_keyword("ref"))) { - lambda_return_type = lambda_return_type->cdr->car; // the second element of the list - } - - // TODO: extract this and refactor to common helper function - if(obj_eq(process, lambda_return_type, type_int)) { - assert_or_set_error(result->tag == 'I', "Invalid type of return value: ", result); - int *integer = ret; - *integer = result->i; - } - else if(obj_eq(process, lambda_return_type, type_bool)) { - assert_or_set_error(result->tag == 'Y', "Invalid type of return value ", result); - bool b = is_true(result); - bool *boolean = ret; - *boolean = b; - } - else if(obj_eq(process, lambda_return_type, type_char)) { - assert_or_set_error(result->tag == 'T', "Invalid type of return value ", result); - char c = result->character; - char *character = ret; - *character = c; - } - else if(obj_eq(process, lambda_return_type, type_float)) { - assert_or_set_error(result->tag == 'V', "Invalid type of return value ", result); - float *x = ret; - *x = result->f32; - } - else if(obj_eq(process, lambda_return_type, type_double)) { - assert_or_set_error(result->tag == 'W', "Invalid type of return value ", result); - double *x = ret; - *x = result->f64; - } - else if(obj_eq(process, lambda_return_type, type_string)) { - assert_or_set_error(result->tag == 'S', "Invalid type of return value ", result); - char **s = ret; - *s = result->s; - } - else if(obj_eq(process, lambda_return_type, type_void)) { - } - else { - //set_error("Calling lambda from FFI can't handle return type ", lambda_return_type); - assert_or_set_error(result->tag == 'Q', "Invalid type of return value ", result); - void **p = ret; - *p = result->void_ptr; - } - - /* for(int i = 0; i < arg_count; i++) { */ - /* shadow_stack_pop(process); */ - /* } */ -} - -void call_foreign_function(Process *process, Obj *function, Obj **args, int arg_count) { - assert(function); - - if(!function->funptr) { - eval_error = obj_new_string("Can't call foregin function, it's funptr is NULL. May be a stub function with just a signature?"); - return; - } - - assert(function->cif); - assert(function->arg_types); - assert(function->return_type); - - // TODO: change name to 'arg_values' or something like that - void **values = calloc(sizeof(void *), arg_count); - assert(values); - -#define assert_or_free_values_and_set_error(assertion, message, object) \ - if(!(assertion)) { \ - free(values); \ - } \ - assert_or_set_error((assertion), (message), (object)); - - Obj *p = function->arg_types; - for(int i = 0; i < arg_count; i++) { - if(p && p->cdr) { - assert(p->car); - Obj *type_obj = p->car; - - // Handle ref types by unwrapping them: (:ref x) -> x - if(type_obj->tag == 'C' && type_obj->car && type_obj->cdr && type_obj->cdr->car && obj_eq(process, type_obj->car, type_ref)) { - type_obj = type_obj->cdr->car; // the second element of the list - } - - args[i]->given_to_ffi = true; // This makes the GC ignore this value when deleting internal C-data, like inside a string - - if(obj_eq(process, type_obj, type_int)) { - assert_or_free_values_and_set_error(args[i]->tag == 'I', "Invalid (expected int) type of arg: ", args[i]); - values[i] = &args[i]->i; - } - else if(obj_eq(process, type_obj, type_bool)) { - assert_or_free_values_and_set_error(args[i]->tag == 'B', "Invalid (expected bool) type of arg: ", args[i]); - bool b = args[i]->boolean; - values[i] = &b; - } - else if(obj_eq(process, type_obj, type_char)) { - assert_or_free_values_and_set_error(args[i]->tag == 'T', "Invalid (expected char) type of arg: ", args[i]); - char c = args[i]->character; - values[i] = &c; - } - else if(obj_eq(process, type_obj, type_float)) { - assert_or_free_values_and_set_error(args[i]->tag == 'V', "Invalid (expected float) type of arg: ", args[i]); - values[i] = &args[i]->f32; - } - else if(obj_eq(process, type_obj, type_double)) { - assert_or_free_values_and_set_error(args[i]->tag == 'W', "Invalid (expected double) type of arg: ", args[i]); - values[i] = &args[i]->f64; - } - else if(obj_eq(process, type_obj, type_string)) { - assert_or_free_values_and_set_error(args[i]->tag == 'S', "Invalid (expected string) type of arg: ", args[i]); - //args[i]->s = strdup(args[i]->s); // OBS! Duplicating string here. TODO: Think about if this is the correct thing to do! - values[i] = &args[i]->s; - } - else { - //printf("Calling function with expected parameter of type %s. Argument is of type %c.\n", obj_to_string(process, p->car)->s, args[i]->tag); - //printf("%s\n", STR(args[i])); // <- WARNING! This is an infinite loop! - - if(args[i]->tag == 'Q') { - -#ifdef CHECKING - if(args[i]->void_ptr == NULL || obj_eq(type_obj, obj_new_keyword("any"))) { - goto hack; - } - - assert_or_free_values_and_set_error(args[i]->meta, "Argument is missing meta data: ", args[i]); - Obj *meta_type_tag = env_lookup(args[i]->meta, obj_new_keyword("type")); // TODO: make this keyword to a "singleton" - assert_or_free_values_and_set_error(meta_type_tag, "Argument is missing meta 'type' tag: ", args[i]); - - bool eq = obj_eq(meta_type_tag, type_obj); - if(!eq) { - eval_error = obj_new_string("Invalid type of argument sent to function expecting '"); - obj_string_mut_append(eval_error, obj_to_string(type_obj)->s); - obj_string_mut_append(eval_error, "' type: "); - obj_string_mut_append(eval_error, obj_to_string(meta_type_tag)->s); - return; - } - - hack:; -#endif - - bool argExpectsRef = p->car->tag == 'C' && obj_eq(process, p->car->car, type_ref); - //printf("argExpectsRef: %d\n", argExpectsRef); - - if(args[i] == NULL || args[i]->meta == NULL) { - goto noCopyOfArg; - } - if(!argExpectsRef) { - Obj *type = env_lookup(process, args[i]->meta, obj_new_keyword("type")); - if(type) { - - /* printf("Sending void_ptr as argument to ffi function %s, ", STR(function)); */ - /* //printf(" it's value is '%s' ", STR(args[i])); */ - /* printf("type %s and tag %c, this should be copied! (for correctness)\n", STR(type), args[i]->tag); */ - - Obj *copy = obj_copy(process, args[i]); - - if(eval_error) { - return; - } - - copy->meta = args[i]->meta; - shadow_stack_push(process, copy); - //printf("Copy with tag '%c': %s\n", copy->tag, STR(copy)); - shadow_stack_pop(process); - values[i] = ©->void_ptr; - } - else { - printf("No type meta on %s, won't copy it.\n", STR(args[i])); - goto noCopyOfArg; - } - } - else { - noCopyOfArg:; - values[i] = &args[i]->void_ptr; - } - } - else if(args[i]->tag == 'A') { - // TODO: Do some type checking here!!! - Array *a = obj_array_to_carp_array(process, args[i]); - if(eval_error) { - return; - } - assert(a); - values[i] = &a; - } - else if(args[i]->tag == 'F') { - values[i] = &args[i]->funptr; - } - else if(args[i]->tag == 'L') { - if(ALLOW_SENDING_LAMBDA_TO_FFI) { - //printf("Will call unbaked lambda from ffi function. Lambda should have types: %s\n", obj_to_string(type_obj)->s); - - ffi_type *closure_args[1]; - ffi_closure *closure; - void (*closure_fun_ptr)(); - closure = ffi_closure_alloc(sizeof(ffi_closure), (void **)&closure_fun_ptr); - - if(closure) { - /* Initialize the argument info vectors */ - closure_args[0] = &ffi_type_pointer; - - /* ffi_cif cif_static; */ - /* ffi_cif *cif = &cif_static; */ - /* ffi_prep_cif(cif, FFI_DEFAULT_ABI, 0, &ffi_type_void, closure_args); */ - - //printf("Type obj: %s\n", obj_to_string(type_obj)->s); - - Obj *lambda_arg_types = type_obj->cdr->car; - Obj *lambda_return_type = type_obj->cdr->cdr->car; - int lambda_arg_count = 0; - Obj *p = lambda_arg_types; - while(p && p->car) { - p = p->cdr; - lambda_arg_count++; - } - - ffi_cif *cif = create_cif(process, lambda_arg_types, lambda_arg_count, lambda_return_type, "TODO:proper-name"); - - Obj *lambda_arg = args[i]; - LambdaAndItsType *lambda_and_its_type = malloc(sizeof(LambdaAndItsType)); // TODO: free! - lambda_and_its_type->lambda = lambda_arg; // the uncompiled lambda that was passed to the ffi function - lambda_and_its_type->signature = type_obj; - lambda_and_its_type->process = process; - - typedef void (*LambdaCallback)(ffi_cif *, void *, void **, void *); - - if(ffi_prep_closure_loc(closure, cif, (LambdaCallback)call_lambda_from_ffi, lambda_and_its_type, closure_fun_ptr) == FFI_OK) { - //printf("Closure preparation done.\n"); - values[i] = &closure_fun_ptr; - } - else { - set_error("Closure prep failed. ", nil); - } - } - else { - set_error("Failed to allocate closure. ", nil); - } - } - else { - free(values); - set_error("Can't send argument of lambda type (tag 'L') to ffi function, you need to compile it to a C function using (bake ...) first:\n", args[i]); - } - } - else { - free(values); - printf("INVALID ARG TYPE: %c\n", args[i]->tag); - printf("ARG: %s\n", obj_to_string(process, args[i])->s); - set_error("Can't send argument of invalid type to foreign function taking parameter of type ", p->car); - } - } - p = p->cdr; - } - else { - free(values); - set_error("Too many arguments to ", function); - } - } - - if(p && p->car) { - free(values); - set_error("Too few arguments to ", function); - } - - // Handle refs: - Obj *return_type = function->return_type; - if(return_type->tag == 'C' && return_type->car && return_type->cdr && - return_type->cdr->car && obj_eq(process, return_type->car, type_ref)) { - return_type = return_type->cdr->car; // the second element of the list - } - - void *result; - ffi_call(function->cif, function->funptr, &result, values); - - Obj *obj_result = primitive_to_obj(process, result, return_type); - - free(values); - - if(!obj_result) { - printf("obj_result == NULL, return_type = %s\n", obj_to_string(process, return_type)->s); - return; // something went wrong - } - - stack_push(process, obj_result); -} diff --git a/src/call_ffi.h b/src/call_ffi.h deleted file mode 100644 index 3caf77688..000000000 --- a/src/call_ffi.h +++ /dev/null @@ -1,12 +0,0 @@ -#pragma once - -#include "process.h" - -typedef struct { - Obj *lambda; - Obj *signature; - Process *process; -} LambdaAndItsType; - -void call_lambda_from_ffi(ffi_cif *cif, void *ret, void *args[], LambdaAndItsType *lambda_and_its_type); -void call_foreign_function(Process *process, Obj *function, Obj **args, int arg_count); diff --git a/src/constants.h b/src/constants.h deleted file mode 100644 index b0c718fa7..000000000 --- a/src/constants.h +++ /dev/null @@ -1,4 +0,0 @@ -#pragma once - -#define STACK_SIZE 1024 -#define SHADOW_STACK_SIZE 5000 diff --git a/src/env.c b/src/env.c deleted file mode 100644 index 1de78fad1..000000000 --- a/src/env.c +++ /dev/null @@ -1,166 +0,0 @@ -#include "env.h" -#include "eval.h" -#include "obj_string.h" -#include "assertions.h" - -Obj *env_lookup(Process *process, Obj *env, Obj *symbol) { - assert(env->tag == 'E'); - Obj *p = env->bindings; - while(p && p->car) { - Obj *pair = p->car; - if(obj_eq(process, pair->car, symbol)) { - return pair->cdr; - } - else { - p = p->cdr; - } - } - if(env->parent) { - return env_lookup(process, env->parent, symbol); - } - else { - return NULL; - } -} - -Obj *env_lookup_binding(Process *process, Obj *env, Obj *symbol) { - Obj *p = env->bindings; - while(p && p->car) { - Obj *pair = p->car; - if(obj_eq(process, pair->car, symbol)) { - return pair; - } - else { - p = p->cdr; - } - } - if(env->parent) { - return env_lookup_binding(process, env->parent, symbol); - } - else { - return nil; - } -} - -Obj *env_extend(Obj *env, Obj *key, Obj *value) { - assert(env->tag == 'E'); - - Obj *pair = obj_new_cons(key, value); - Obj *cons = obj_new_cons(pair, env->bindings); - - env->bindings = cons; - - return pair; -} - -void env_extend_with_args(Process *process, Obj *calling_env, Obj *function, int arg_count, Obj **args, bool allow_restargs) { - - // TODO: remove the whole 'C' branch and only allow arrays for parameters - - Obj *paramp = function->params; - if(paramp->tag == 'C') { - for(int i = 0; i < arg_count; i++) { - if(allow_restargs && obj_eq(process, paramp->car, dotdotdot)) { - printf("Found dotdotdot\n"); - if(paramp->cdr->car) { - int rest_count = arg_count - i; - printf("Rest count: %d\n", rest_count); - Obj *rest_array = obj_new_array(rest_count); - for(int j = 0; j < rest_count; j++) { - rest_array->array[j] = args[i + j]; - } - env_extend(calling_env, paramp->cdr->car, rest_array); - return; - } - else { - printf("No arguments after dotdotdot\n"); - return; - } - } - if(!paramp || !paramp->car) { - set_error("Too many arguments (C) to function: ", function); - } - env_extend(calling_env, paramp->car, args[i]); - paramp = paramp->cdr; - } - if(paramp && paramp->cdr) { - set_error("Too few arguments to function: ", function); - } - } - else if(paramp->tag == 'A') { - - int i = 0; - for(; i < arg_count; i++) { - if(allow_restargs && obj_eq(process, paramp->array[i], dotdotdot)) { - int rest_count = arg_count - i; - Obj *rest_list = obj_new_cons(NULL, NULL); - Obj *last = rest_list; - for(int j = 0; j < rest_count; j++) { - Obj *new_element = args[i + j]; - last->car = new_element; - Obj *new_last = obj_new_cons(NULL, NULL); - last->cdr = new_last; - last = new_last; - } - env_extend(calling_env, paramp->array[i + 1], rest_list); - return; - } - - env_extend(calling_env, paramp->array[i], args[i]); - } - - if(i < paramp->count) { - if(allow_restargs && obj_eq(process, paramp->array[i], dotdotdot)) { - env_extend(calling_env, paramp->array[i + 1], obj_new_array(0)); - } - else { - set_error("Too few arguments to function/macro: ", function); - } - } - - if(arg_count > paramp->count) { - printf("arguments: %s\n", obj_to_string(process, paramp)->s); - //printf("meta: %s\n", (function->meta ? obj_to_string(process, function->meta)->s : "NULL")); - Obj *name = function; - if(function->meta) { - Obj *name_lookup = env_lookup(process, function->meta, obj_new_keyword("name")); - if(name_lookup) { - name = name_lookup; - } - } - set_error("Too many arguments (A) to function/macro: ", name); - } - } -} - -void global_env_extend(Process *process, Obj *key, Obj *val) { - assert(process->global_env); - Obj *existing_binding = env_lookup_binding(process, process->global_env, key); - if(existing_binding->car) { - existing_binding->cdr = val; - } - else { - env_extend(process->global_env, key, val); - } -} - -Obj *env_assoc(Process *process, Obj *env, Obj *key, Obj *value) { - Obj *pair = env_lookup_binding(process, env, key); - if(pair && pair->car && pair->cdr) { - pair->cdr = value; - } - else { - //printf("Pair not found, will add new key.\n"); - Obj *new_pair = obj_new_cons(key, value); - Obj *new_cons = obj_new_cons(new_pair, env->bindings); - env->bindings = new_cons; - } - return env; -} - -void obj_set_meta(Obj *o, Obj *key, Obj *value) { - if(!o->meta) { - o->meta = obj_new_environment(NULL); - } - env_extend(o->meta, key, value); -} diff --git a/src/env.h b/src/env.h deleted file mode 100644 index 23a7518f0..000000000 --- a/src/env.h +++ /dev/null @@ -1,16 +0,0 @@ -#pragma once - -#include "obj.h" -#include "process.h" - -Obj *env_lookup(Process *process, Obj *env, Obj *symbol); -Obj *env_lookup_binding(Process *process, Obj *env, Obj *symbol); - -Obj *env_assoc(Process *process, Obj *env, Obj *key, Obj *value); - -Obj *env_extend(Obj *env, Obj *key, Obj *value); -void env_extend_with_args(Process *process, Obj *calling_env, Obj *function, int arg_count, Obj **args, bool allow_restargs); - -void global_env_extend(Process *process, Obj *key, Obj *val); - -void obj_set_meta(Obj *o, Obj *key, Obj *value); diff --git a/src/eval.c b/src/eval.c deleted file mode 100644 index de3fcf820..000000000 --- a/src/eval.c +++ /dev/null @@ -1,962 +0,0 @@ -#include "eval.h" -#include "env.h" -#include "assertions.h" -#include "reader.h" -#include "gc.h" -#include "primops.h" -#include "obj.h" -#include "obj_conversions.h" -#include "constants.h" -#include "../shared/types.h" -#include "match.h" -#include "bytecode.h" - -#define LOG_EVAL 0 -#define SHOW_MACRO_EXPANSION 0 -#define LOG_FUNC_APPLICATION 0 -#define GC_COLLECT_AFTER_EACH_FORM 0 - -bool in_macro_expansion = false; - -void call_struct_constructor(Process *process, Obj *function, Obj **args, int arg_count) { - // Evaluation of a struct-definition (a dictionary) in function position (which means that it is used as a constructor) - Obj *name_obj = env_lookup(process, function, obj_new_keyword("name")); - assert_or_set_error(name_obj, "no key 'name' on struct definition: ", function); - char *name = name_obj->s; - - Obj *struct_size_obj = env_lookup(process, function, obj_new_keyword("size")); - assert_or_set_error(struct_size_obj, "no key 'size' on struct definition: ", function); - int struct_size = struct_size_obj->i; - - Obj *struct_member_count_obj = env_lookup(process, function, obj_new_keyword("member-count")); - assert_or_set_error(struct_member_count_obj, "no key 'member-count' on struct definition: ", function); - int member_count = struct_member_count_obj->i; - - Obj *offsets_obj = env_lookup(process, function, obj_new_keyword("member-offsets")); - assert_or_set_error(offsets_obj, "no key 'member-offsets' on struct definition: ", function); - assert_or_set_error(offsets_obj->tag == 'A', "offsets must be an array: ", function); - Obj **offsets = offsets_obj->array; - - Obj *member_types_obj = env_lookup(process, function, obj_new_keyword("member-types")); - assert_or_set_error(member_types_obj, "no key 'member-types' on struct definition: ", function); - assert_or_set_error(member_types_obj->tag == 'A', "member-types must be an array: ", function); - Obj **member_types = member_types_obj->array; - - //printf("Will create a %s of size %d and member count %d.\n", name, size, member_count); - void *p = malloc(struct_size); - Obj *new_struct = obj_new_ptr(p); - - shadow_stack_push(process, new_struct); - - if(!new_struct->meta) { - new_struct->meta = obj_new_environment(NULL); - } - env_assoc(process, new_struct->meta, obj_new_keyword("type"), obj_new_keyword(name)); - - assert_or_set_error(!(arg_count < member_count), "Too few args to struct constructor: ", obj_new_string(name)); - assert_or_set_error(!(arg_count > member_count), "Too many args to struct constructor: ", obj_new_string(name)); - - for(int i = 0; i < arg_count; i++) { - Obj *member_type = member_types[i]; - int offset = offsets[i]->i; - if(args[i]->tag == 'V') { - assert_or_set_error(obj_eq(process, member_type, type_float), "Can't assign float to a member of type ", obj_to_string(process, member_type)); - float *fp = (float *)(((char *)new_struct->void_ptr) + offset); - float f = args[i]->f32; - //printf("Setting member %d at offset %d to %f.\n", i, offset, f); - *fp = f; - } - else if(args[i]->tag == 'I') { - assert_or_set_error(obj_eq(process, member_type, type_int), "Can't assign int to a member of type ", obj_to_string(process, member_type)); - int *xp = (int *)(((char *)new_struct->void_ptr) + offset); - int x = args[i]->i; - *xp = x; - } - else if(args[i]->tag == 'B') { - assert_or_set_error(obj_eq(process, member_type, type_bool), "Can't assign bool to a member of type ", obj_to_string(process, member_type)); - bool *xp = (bool *)(((char *)new_struct->void_ptr) + offset); - bool x = args[i]->boolean; - *xp = x; - } - else if(args[i]->tag == 'Q') { - assert_or_set_error(!obj_eq(process, member_type, type_char), "Can't assign char to a member of type ", obj_to_string(process, member_type)); - assert_or_set_error(!obj_eq(process, member_type, type_int), "Can't assign int to a member of type ", obj_to_string(process, member_type)); - assert_or_set_error(!obj_eq(process, member_type, type_float), "Can't assign float to a member of type ", obj_to_string(process, member_type)); - assert_or_set_error(!obj_eq(process, member_type, type_string), "Can't assign string to a member of type ", obj_to_string(process, member_type)); - void **vp = (void **)(((char *)new_struct->void_ptr) + offset); - *vp = args[i]->void_ptr; - } - else if(args[i]->tag == 'S') { - assert_or_set_error(obj_eq(process, member_type, type_string), "Can't assign int to a member of type ", obj_to_string(process, member_type)); - char **sp = (char **)(((char *)new_struct->void_ptr) + offset); - *sp = strdup(args[i]->s); // must strdup or the struct will ref Obj's on the stack that will get gc:ed - } - else if(args[i]->tag == 'T') { - assert_or_set_error(obj_eq(process, member_type, type_char), "Can't assign char to a member of type ", obj_to_string(process, member_type)); - char *cp = (char *)(((char *)new_struct->void_ptr) + offset); - *cp = args[i]->character; - } - else if(args[i]->tag == 'A') { - //assert_or_set_error(obj_eq(member_type, type_array), "Can't assign array to a member of type ", obj_to_string(member_type)); - - // TODO: use this code for sending arrays to normal FFI functions too!!! - // TODO: use the SAME code for sending data to FFI and struct constructors. - // TODO: check that we send the expected type to the constructor - - Array *a = obj_array_to_carp_array(process, args[i]); - if(!a) { - return; - } - - void **ap = (void **)(((char *)new_struct->void_ptr) + offset); - *ap = a; - } - else { - eval_error = obj_new_string("Can't set member "); - char buffer[32]; - sprintf(buffer, "%d", i); - obj_string_mut_append(eval_error, buffer); - obj_string_mut_append(eval_error, " of struct "); - obj_string_mut_append(eval_error, name); - obj_string_mut_append(eval_error, " to "); - obj_string_mut_append(eval_error, obj_to_string(process, args[i])->s); - obj_string_mut_append(eval_error, " (handled type)."); - return; - } - } - shadow_stack_pop(process); // pop new_struct - stack_push(process, new_struct); -} - -void apply(Process *process, Obj *function, Obj **args, int arg_count) { - if(function->tag == 'L') { - -//printf("Calling lambda "); obj_print_cout(function); printf(" with params: "); obj_print_cout(function->params); printf("\n"); -//printf("Applying %s with arg count %d\n", obj_to_string(process, function)->s, arg_count); - -#if BYTECODE_EVAL - - Obj *calling_env = obj_new_environment(function->env); - - bool allow_rest_args = true; - env_extend_with_args(process, calling_env, function, arg_count, args, allow_rest_args); - - //printf("calling_env: %s\n", obj_to_string(process, calling_env)->s); - - shadow_stack_push(process, function); - shadow_stack_push(process, calling_env); - - /* printf("before\n"); */ - /* shadow_stack_print(process); */ - - Obj *result = bytecode_sub_eval_internal(process, calling_env, function->body); - - if(eval_error) { - return; - } - assert(result); - - //printf("result = %s\n", obj_to_string(process, result)->s); - stack_push(process, result); // put it back on stack (TODO: fix this unnecessary work?) - - /* printf("after\n"); */ - /* shadow_stack_print(process); */ - - Obj *pop1 = shadow_stack_pop(process); - Obj *pop2 = shadow_stack_pop(process); - assert(pop1 == calling_env); - assert(pop2 == function); - -#else - - Obj *calling_env = obj_new_environment(function->env); - bool allow_rest_args = true; - env_extend_with_args(process, calling_env, function, arg_count, args, allow_rest_args); - //printf("Lambda env: %s\n", obj_to_string(calling_env)->s); - - shadow_stack_push(process, function); - shadow_stack_push(process, calling_env); - - if(function->body->tag == 'X') { - eval_error = obj_new_string("Can't apply lambda with bytecode body."); - } - else { - eval_internal(process, calling_env, function->body); - } - - if(eval_error) { - return; - } - - Obj *pop1 = shadow_stack_pop(process); - Obj *pop2 = shadow_stack_pop(process); - assert(pop1 == calling_env); - assert(pop2 == function); -#endif - } - else if(function->tag == 'P') { - Obj *result = function->primop((struct Process *)process, args, arg_count); - stack_push(process, result); - } - else if(function->tag == 'F') { - call_foreign_function(process, function, args, arg_count); - } - else if(function->tag == 'K') { - if(arg_count != 1) { - eval_error = obj_new_string("Args to keyword lookup must be a single arg."); - } - else if(args[0]->tag != 'E') { - eval_error = obj_new_string("Arg 0 to keyword lookup must be a dictionary: "); - obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s); - } - else { - Obj *value = env_lookup(process, args[0], function); - if(value) { - stack_push(process, value); - } - else { - eval_error = obj_new_string("Failed to lookup keyword '"); - obj_string_mut_append(eval_error, obj_to_string(process, function)->s); - obj_string_mut_append(eval_error, "'"); - obj_string_mut_append(eval_error, " in \n"); - obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s); - obj_string_mut_append(eval_error, "\n"); - } - } - } - else if(function->tag == 'E' && obj_eq(process, env_lookup(process, function, obj_new_keyword("struct")), lisp_true)) { - //printf("Calling struct: %s\n", obj_to_string(process, function)->s); - if(obj_eq(process, env_lookup(process, function, obj_new_keyword("generic")), lisp_true)) { - //printf("Calling generic struct constructor.\n"); - Obj *function_call_symbol = obj_new_symbol("dynamic-generic-constructor-call"); - shadow_stack_push(process, function_call_symbol); - - Obj **copied_args = malloc(sizeof(Obj *) * arg_count); - for(int i = 0; i < arg_count; i++) { - copied_args[i] = obj_copy(process, args[i]); - if(args[i]->meta) { - copied_args[i]->meta = obj_copy(process, args[i]->meta); - } - } - - Obj *carp_array = obj_new_array(arg_count); - carp_array->array = copied_args; - - Obj *call_to_concretize_struct = obj_list(function_call_symbol, - function, - carp_array); - - shadow_stack_push(process, call_to_concretize_struct); - eval_internal(process, process->global_env, call_to_concretize_struct); - - shadow_stack_pop(process); - shadow_stack_pop(process); - } - else { - call_struct_constructor(process, function, args, arg_count); - } - } - else { - set_error("Can't call non-function: ", function); - } -} - -#define HEAD_EQ(str) (o->car->tag == 'Y' && strcmp(o->car->s, (str)) == 0) - -void eval_list(Process *process, Obj *env, Obj *o) { - assert(o); - - //printf("Evaling list %s\n", obj_to_string(o)->s); - if(!o->car) { - stack_push(process, o); // nil, empty list - return; - } - -#if LABELED_DISPATCH - static void *dispatch_table[] = { - NULL, // index 0 means no dispatch - &&dispatch_do, // 1 - &&dispatch_let, // 2 - &&dispatch_not, // 3 - &&dispatch_or, // 4 - &&dispatch_and, // 5 - &&dispatch_quote, // 6 - &&dispatch_while, // 7 - &&dispatch_if, // 8 - &&dispatch_match, // 9 - &&dispatch_reset, // 10 - &&dispatch_fn, // 11 - &&dispatch_macro, // 12 - &&dispatch_def, // 13 - &&dispatch_defp, // 14 - &&dispatch_ref, // 15 - &&dispatch_catch, // 16 - }; - - Obj *head = o->car; - if(head->tag == 'Y') { - if(head->dispatch_index) { - //printf("Will dispatch instruction %d\n", head->dispatch_index); - goto *dispatch_table[head->dispatch_index]; - } - else { - //printf("Will dispatch non-special form symbol: %s\n", obj_to_string(head)->s); - goto dispatch_function_evaluation; - } - } - else { - //printf("Will dispatch non-symbol: %s\n", obj_to_string(head)->s); - goto dispatch_function_evaluation; - } - assert(false); // Don't go past here, it's SLOW. -#endif - - if(HEAD_EQ("do")) { -#if LABELED_DISPATCH - dispatch_do:; -#endif - Obj *p = o->cdr; - while(p && p->car) { - eval_internal(process, env, p->car); - if(eval_error) { - return; - } - p = p->cdr; - if(p && p->car) { - stack_pop(process); // remove result from form that is not last - } - } - } - else if(HEAD_EQ("let")) { -#if LABELED_DISPATCH - dispatch_let:; -#endif - Obj *let_env = obj_new_environment(env); - shadow_stack_push(process, let_env); - //Obj *p = o->cdr->car; - assert_or_set_error(o->cdr->car, "No bindings in 'let' form: ", o); - assert_or_set_error(o->cdr->car->tag == 'A', "Bindings in 'let' form must be an array: ", o); - Obj *a = o->cdr->car; - for(int i = 0; i < a->count; i += 2) { - if(i + 1 == a->count) { - set_error("Uneven nr of forms in let: ", o); // TODO: add error code for this kind of error, return error map instead - } - assert_or_set_error(a->array[i]->tag == 'Y', "Trying to bind to non-symbol in let form: ", a->array[i]); - eval_internal(process, let_env, a->array[i + 1]); - if(eval_error) { - return; - } - Obj *value = stack_pop(process); - env_extend(let_env, a->array[i], value); - //printf("let %s to %s\n", obj_to_string(a->array[i])->s, obj_to_string(a->array[i + 1])->s); - //obj_set_meta(value, obj_new_keyword("name"), a->array[i]); // TODO: only do this in certain situations - } - assert_or_set_error(o->cdr->cdr->car, "No body in 'let' form.", o); - assert_or_set_error(o->cdr->cdr->cdr->car == NULL, "Too many body forms in 'let' form (use explicit 'do').", o); - eval_internal(process, let_env, o->cdr->cdr->car); - shadow_stack_pop(process); // let_env - } - else if(HEAD_EQ("not")) { -#if LABELED_DISPATCH - dispatch_not:; -#endif - Obj *p = o->cdr; - while(p) { - if(p->car) { - eval_internal(process, env, p->car); - if(eval_error) { - return; - } - if(is_true(stack_pop(process))) { - stack_push(process, lisp_false); - return; - } - } - p = p->cdr; - } - stack_push(process, lisp_true); - } - else if(HEAD_EQ("or")) { -#if LABELED_DISPATCH - dispatch_or:; -#endif - Obj *p = o->cdr; - while(p) { - if(p->car) { - eval_internal(process, env, p->car); - if(eval_error) { - return; - } - if(is_true(stack_pop(process))) { - stack_push(process, lisp_true); - return; - } - } - p = p->cdr; - } - stack_push(process, lisp_false); - } - else if(HEAD_EQ("and")) { -#if LABELED_DISPATCH - dispatch_and:; -#endif - Obj *p = o->cdr; - while(p) { - if(p->car) { - eval_internal(process, env, p->car); - if(eval_error) { - return; - } - if(!is_true(stack_pop(process))) { - stack_push(process, lisp_false); - return; - } - } - p = p->cdr; - } - stack_push(process, lisp_true); - } - else if(HEAD_EQ("quote")) { -#if LABELED_DISPATCH - dispatch_quote:; -#endif - if(o->cdr == nil) { - stack_push(process, nil); - } - else { - //assert_or_set_error(o->cdr->cdr->car, "Too many forms in 'quote' form: ", o); - if(o->cdr->cdr->car) { - printf("Too many forms in 'quote' form: %s\n", obj_to_string(process, o)->s); - } - stack_push(process, o->cdr->car); - } - } - else if(HEAD_EQ("while")) { -#if LABELED_DISPATCH - dispatch_while:; -#endif - assert_or_set_error(o->cdr->car, "Too few body forms in 'while' form: ", o); - assert_or_set_error(o->cdr->cdr->cdr->car == NULL, "Too many body forms in 'while' form (use explicit 'do').", o); - eval_internal(process, env, o->cdr->car); - if(eval_error) { - return; - } - while(is_true(stack_pop(process))) { - eval_internal(process, env, o->cdr->cdr->car); - stack_pop(process); - eval_internal(process, env, o->cdr->car); - if(eval_error) { - return; - } - } - stack_push(process, nil); - } - else if(HEAD_EQ("if")) { -#if LABELED_DISPATCH - dispatch_if:; -#endif - assert_or_set_error(o->cdr->car, "Too few body forms in 'if' form: ", o); - assert_or_set_error(o->cdr->cdr->car, "Too few body forms in 'if' form: ", o); - assert_or_set_error(o->cdr->cdr->cdr->car, "Too few body forms in 'if' form: ", o); - assert_or_set_error(o->cdr->cdr->cdr->cdr->car == NULL, "Too many body forms in 'if' form (use explicit 'do').", o); - eval_internal(process, env, o->cdr->car); - if(eval_error) { - return; - } - else if(is_true(stack_pop(process))) { - eval_internal(process, env, o->cdr->cdr->car); - } - else { - eval_internal(process, env, o->cdr->cdr->cdr->car); - } - } - else if(HEAD_EQ("match")) { -#if LABELED_DISPATCH - dispatch_match:; -#endif - eval_internal(process, env, o->cdr->car); - if(eval_error) { - return; - } - Obj *value = stack_pop(process); - Obj *p = o->cdr->cdr; - match(process, env, value, p); - } - else if(HEAD_EQ("reset!")) { -#if LABELED_DISPATCH - dispatch_reset:; -#endif - assert_or_set_error(o->cdr->car->tag == 'Y', "Must use 'reset!' on a symbol.", o->cdr->car); - Obj *pair = env_lookup_binding(process, env, o->cdr->car); - if(!pair->car || pair->car->tag != 'Y') { - printf("Can't reset! binding '%s', it's '%s'\n", o->cdr->car->s, obj_to_string(process, pair)->s); - stack_push(process, nil); - return; - } - - eval_internal(process, env, o->cdr->cdr->car); - if(eval_error) { - return; - } - - if(pair->cdr->tag == 'R' && pair->cdr->meta) { - //pair->cdr->given_to_ffi = true; // needed? - //printf("Resetting a ptr-to-global.\n"); - Obj *type_meta = env_lookup(process, pair->cdr->meta, obj_new_keyword("type")); - if(type_meta && obj_eq(process, type_meta, type_int)) { - int *ip = pair->cdr->void_ptr; - *ip = stack_pop(process)->i; - } - else if(type_meta && obj_eq(process, type_meta, type_float)) { - float *fp = pair->cdr->void_ptr; - *fp = stack_pop(process)->f32; - } - else if(type_meta && obj_eq(process, type_meta, type_double)) { - double *dp = pair->cdr->void_ptr; - *dp = stack_pop(process)->f64; - } - else if(type_meta && obj_eq(process, type_meta, type_char)) { - char *cp = pair->cdr->void_ptr; - *cp = stack_pop(process)->character; - } - else if(type_meta && obj_eq(process, type_meta, type_bool)) { - bool *bp = pair->cdr->void_ptr; - *bp = stack_pop(process)->boolean; - } - else if(type_meta && obj_eq(process, type_meta, type_string)) { - char **sp = pair->cdr->void_ptr; - *sp = strdup(stack_pop(process)->s); // OBS! strdup!!! Without this the string will get GC:ed though... - } - else if(type_meta->tag == 'C' && type_meta->cdr->car && obj_eq(process, type_meta->car, obj_new_keyword("Array"))) { - void **pp = pair->cdr->void_ptr; - Obj *a = stack_pop(process); - assert_or_set_error(a->tag == 'A', "Must reset! global to array: ", o); - Array *carp_array = obj_array_to_carp_array(process, a); - *pp = carp_array; - } - else { - /* printf("No/invalid :type\n"); */ - /* pair->cdr = stack_pop(); */ - - void **pp = pair->cdr->void_ptr; - *pp = stack_pop(process)->void_ptr; - } - } - else { - pair->cdr = stack_pop(process); - } - stack_push(process, pair->cdr); - } - else if(HEAD_EQ("fn")) { -#if LABELED_DISPATCH - dispatch_fn:; -#endif - assert_or_set_error(o->cdr, "Lambda form too short (no parameter list or body).", o); - assert_or_set_error(o->cdr->car, "No parameter list in lambda.", o); - Obj *params = o->cdr->car; - if(params->tag == 'C') { - static int depcount = 0; - depcount++; - //printf("NOTE: Please use [] in lambda parameter list now, () is deprecated. %d\n", depcount); // %s, %d:%d\n", file_path, line, pos); - } - assert_or_set_error(o->cdr->cdr, "Lambda form too short (no body).", o); - assert_or_set_error(o->cdr->cdr->car, "No body in lambda: ", o); - Obj *body = o->cdr->cdr->car; - //printf("Creating lambda with env: %s\n", obj_to_string(env)->s); - Obj *lambda = obj_new_lambda(params, body, env, o); - shadow_stack_push(process, lambda); - obj_copy_meta(process, lambda, o); - shadow_stack_pop(process); - stack_push(process, lambda); - } - else if(HEAD_EQ("macro")) { -#if LABELED_DISPATCH - dispatch_macro:; -#endif - assert_or_set_error(o->cdr, "Macro form too short (no parameter list or body): ", o); - assert_or_set_error(o->cdr->car, "No parameter list in macro: ", o); - Obj *params = o->cdr->car; - assert_or_set_error(o->cdr->cdr, "Macro form too short (no body): ", o); - assert_or_set_error(o->cdr->cdr->car, "No body in macro: ", o); - Obj *body = o->cdr->cdr->car; - Obj *macro = obj_new_macro(params, body, env, o); - shadow_stack_push(process, macro); - obj_copy_meta(process, macro, o); - shadow_stack_pop(process); - stack_push(process, macro); - } - else if(HEAD_EQ("def")) { -#if LABELED_DISPATCH - dispatch_def:; -#endif - assert_or_set_error(o->cdr, "Too few args to 'def': ", o); - assert_or_set_error(o->cdr->car, "Can't assign to nil: ", o); - assert_or_set_error(o->cdr->car->tag == 'Y', "Can't assign to non-symbol: ", o); - Obj *key = o->cdr->car; - eval_internal(process, env, o->cdr->cdr->car); // eval the second arg to 'def', the value to assign - if(eval_error) { - return; - } // don't define it if there was an error - Obj *val = stack_pop(process); - global_env_extend(process, key, val); - //printf("def %s to %s\n", obj_to_string(key)->s, obj_to_string(val)->s); - //obj_set_meta(val, obj_new_keyword("name"), obj_to_string(key)); - stack_push(process, val); - } - else if(HEAD_EQ("def?")) { -#if LABELED_DISPATCH - dispatch_defp:; -#endif - //assert_or_set_error(o->cdr, "Too few args to 'def?': ", o); - //assert_or_set_error(o->cdr->cdr, "Too few args to 'def?': ", o); - eval_internal(process, env, o->cdr->car); - if(eval_error) { - return; - } - Obj *key = stack_pop(process); - assert_or_set_error(key->tag == 'Y', "Can't call 'def?' on non-symbol: ", key); - if(obj_eq(process, nil, env_lookup_binding(process, process->global_env, key))) { - stack_push(process, lisp_false); - } - else { - stack_push(process, lisp_true); - } - } - else if(HEAD_EQ("ref")) { -#if LABELED_DISPATCH - dispatch_ref:; -#endif - assert_or_set_error(o->cdr, "Too few args to 'ref': ", o); - eval_internal(process, env, o->cdr->car); - } - else if(HEAD_EQ("catch-error")) { -#if LABELED_DISPATCH - dispatch_catch:; -#endif - assert_or_set_error(o->cdr, "Too few args to 'catch-error': ", o); - int shadow_stack_size_save = process->shadow_stack_pos; - int stack_size_save = process->stack_pos; - int function_trace_save = process->function_trace_pos; - eval_internal(process, env, o->cdr->car); - - process->shadow_stack_pos = shadow_stack_size_save; - process->stack_pos = stack_size_save + 1; - process->function_trace_pos = function_trace_save; - - if(eval_error) { - stack_push(process, eval_error); - eval_error = NULL; - return; - } - else { - stack_pop(process); - stack_push(process, nil); - return; - } - } - else if(HEAD_EQ("macroexpand")) { - assert_or_set_error(o->cdr, "Wrong argument count to 'macroexpand'.", nil); - in_macro_expansion = true; // TODO: this is an ugly global variable to avoid threading of state - eval_internal(process, env, o->cdr->car); - in_macro_expansion = false; - } - else { -#if LABELED_DISPATCH - dispatch_function_evaluation:; -#endif - - shadow_stack_push(process, o); - - // Lambda, primop or macro - eval_internal(process, env, o->car); - if(eval_error) { - return; - } - - Obj *function = stack_pop(process); - assert_or_set_error(function, "Can't call NULL.", o); - shadow_stack_push(process, function); - - bool eval_args = function->tag != 'M'; // macros don't eval their args - Obj *p = o->cdr; - int count = 0; - - while(p && p->car) { - if(eval_error) { - shadow_stack_pop(process); - return; - } - - if(eval_args) { - eval_internal(process, env, p->car); - } - else { - stack_push(process, p->car); // push non-evaled - } - count++; - p = p->cdr; - } - - if(eval_error) { - shadow_stack_pop(process); - return; - } - - //printf("Popping args!\n"); - Obj **args = NULL; - if(count > 0) { - args = malloc(sizeof(Obj *) * count); - } - for(int i = 0; i < count; i++) { - Obj *arg = stack_pop(process); - args[count - i - 1] = arg; - shadow_stack_push(process, arg); - } - - if(function->tag == 'M') { - Obj *calling_env = obj_new_environment(function->env); - env_extend_with_args(process, calling_env, function, count, args, true); - shadow_stack_push(process, calling_env); - eval_internal(process, calling_env, function->body); - if(eval_error) { - free(args); - return; - } - Obj *expanded = stack_pop(process); - if(SHOW_MACRO_EXPANSION) { - //printf("Meta of macro: %s\n", obj_to_string(function->meta)->s); - printf("Expanded macro: %s\n", obj_to_string(process, expanded)->s); - } - shadow_stack_push(process, expanded); - if(in_macro_expansion) { - stack_push(process, expanded); - } - else { - eval_internal(process, env, expanded); - } - if(eval_error) { - return; - } - Obj *pop1 = shadow_stack_pop(process); // expanded - Obj *pop2 = shadow_stack_pop(process); // calling_env - assert(pop1 == expanded); - assert(pop2 == calling_env); - } - else { - if(process->function_trace_pos > STACK_SIZE - 1) { - printf("Out of function trace stack.\n"); - stack_print(process); - function_trace_print(process); - exit(1); - } - - if(LOG_FUNC_APPLICATION) { - printf("evaluating form %s\n", obj_to_string(process, o)->s); - } - - StackTraceCallSite call_site = {.caller = o, .callee = function}; - process->function_trace[process->function_trace_pos] = call_site; - process->function_trace_pos++; - - //printf("apply start: "); obj_print_cout(function); printf("\n"); - apply(process, function, args, count); - //printf("apply end\n"); - - if(!eval_error) { - process->function_trace_pos--; - } - } - - if(!eval_error) { - //printf("time to pop!\n"); - for(int i = 0; i < count; i++) { - shadow_stack_pop(process); - } - Obj *pop = shadow_stack_pop(process); - assert(pop == function); - - Obj *oo = shadow_stack_pop(process); // o - if(o != oo) { - printf("o != oo\n"); - printf("o: %p ", o); - obj_print_cout(o); - printf("\n"); - printf("oo: %p ", oo); - obj_print_cout(oo); - printf("\n"); - assert(false); - } - } - - free(args); - } -} - -void eval_internal(Process *process, Obj *env, Obj *o) { - if(eval_error) { - return; - } - - //shadow_stack_print(); - - if(BYTECODE_EVAL) { - assert(false); - } - - if(LOG_EVAL) { - printf("> "); - obj_print_cout(o); - printf("\n"); - } - if(obj_total > obj_total_max) { - //printf("obj_total = %d\n", obj_total); - if(LOG_GC_POINTS) { - printf("Running GC in eval:\n"); - } - gc(process); - obj_total_max += 1000; - //printf("new obj_total_max = %d\n", obj_total_max); - } - else { - //printf("%d/%d\n", obj_total, obj_total_max); - } - - if(!o) { - stack_push(process, nil); - } - else if(o->tag == 'C') { - eval_list(process, env, o); - } - else if(o->tag == 'E') { - Obj *new_env = obj_copy(process, o); - shadow_stack_push(process, new_env); - obj_copy_meta(process, new_env, o); - shadow_stack_pop(process); - shadow_stack_push(process, new_env); - Obj *p = new_env->bindings; - while(p && p->car) { - Obj *pair = p->car; - eval_internal(process, env, pair->cdr); - if(eval_error) { - return; - } - //printf("Evaling env-binding %s, setting cdr to %s.\n", obj_to_string(pair)->s, obj_to_string(stack[stack_pos - 1])->s); - pair->cdr = stack_pop(process); - p = p->cdr; - } - stack_push(process, new_env); - Obj *pop = shadow_stack_pop(process); // new_env - assert(pop == new_env); - } - else if(o->tag == 'A') { - Obj *new_array = obj_new_array(o->count); - shadow_stack_push(process, new_array); - obj_copy_meta(process, new_array, o); - shadow_stack_pop(process); - shadow_stack_push(process, new_array); - for(int i = 0; i < o->count; i++) { - eval_internal(process, env, o->array[i]); - if(eval_error) { - return; - } - new_array->array[i] = stack_pop(process); - } - stack_push(process, new_array); - Obj *pop = shadow_stack_pop(process); // new_array - assert(pop == new_array); - } - else if(o->tag == 'Y') { - shadow_stack_push(process, o); - Obj *result = env_lookup(process, env, o); - shadow_stack_push(process, result); - if(!result) { - char buffer[256]; - snprintf(buffer, 256, "Can't find '%s' in environment.", obj_to_string(process, o)->s); - eval_error = obj_new_string(buffer); - stack_push(process, nil); - } - else { - stack_push(process, result); - - shadow_stack_pop(process); // result - shadow_stack_pop(process); // o - } - } - else { - stack_push(process, o); - } -} - -Obj *eval(Process *process, Obj *env, Obj *form) { - eval_error = NULL; - //function_trace_pos = 0; - eval_internal(process, env, form); - Obj *result = stack_pop(process); - return result; -} - -void eval_text(Process *process, Obj *env, char *text, bool print, Obj *filename) { - Obj *forms = read_string(process, env, text, filename); - Obj *form = forms; - stack_push(process, forms); - while(form && form->car) { - -#if BYTECODE_EVAL - Obj *result = bytecode_eval_form(process, env, form->car); -#else - Obj *result = eval(process, env, form->car); -#endif - - if(eval_error) { - Obj *lookup_message = NULL; - if(eval_error->tag == 'E') { - lookup_message = env_lookup(process, eval_error, obj_new_keyword("message")); - } - if(lookup_message) { - printf("\e[31m%s\e[0m\n", obj_to_string_not_prn(process, lookup_message)->s); - } - else { - printf("\e[31mERROR: %s\e[0m\n", obj_to_string_not_prn(process, eval_error)->s); - } - bool show_stacktrace = true; - if(eval_error->tag == 'E') { - Obj *lookup_show_stacktrace = env_lookup(process, eval_error, obj_new_keyword("show-stacktrace")); - if(lookup_show_stacktrace && !is_true(lookup_show_stacktrace)) { - show_stacktrace = false; - } - } - if(show_stacktrace) { -#if BYTECODE_EVAL - bytecode_stack_print(process); -#else - function_trace_print(process); -#endif - } - /* printf("\n"); */ - /* stack_print(); */ - eval_error = NULL; - if(LOG_GC_POINTS) { - printf("Running GC after error occured:\n"); - } - gc(process); - return; - } - if(print) { - if(result) { - obj_print(process, result); - } - else { - printf("Result was NULL when evaling %s\n", obj_to_string(process, form->car)->s); - } - printf("\n"); - } - form = form->cdr; - if(GC_COLLECT_AFTER_EACH_FORM) { - if(LOG_GC_POINTS) { - printf("Running GC after evaluation of single form in eval_text:\n"); - } - gc(process); - } - } - stack_pop(process); // pop the 'forms' that was pushed above -} diff --git a/src/eval.h b/src/eval.h deleted file mode 100644 index 5b2a2c8c8..000000000 --- a/src/eval.h +++ /dev/null @@ -1,16 +0,0 @@ -#pragma once - -#include "obj.h" -#include "obj_string.h" -#include "constants.h" - -#define LOG_GC_POINTS 0 - -void apply(Process *process, Obj *function, Obj **args, int arg_count); - -Obj *eval(Process *process, Obj *env, Obj *form); -void eval_internal(Process *process, Obj *env, Obj *o); -void eval_text(Process *process, Obj *env, char *text, bool print, Obj *filename); - -void call_foreign_function(Process *process, Obj *function, Obj **args, int arg_count); -void call_struct_constructor(Process *process, Obj *function, Obj **args, int arg_count); diff --git a/src/gc.c b/src/gc.c deleted file mode 100644 index 9def8c591..000000000 --- a/src/gc.c +++ /dev/null @@ -1,159 +0,0 @@ -#include "gc.h" - -#define LOG_GC_KILL_COUNT 0 -#define LOG_FREE 0 - -void obj_mark_alive(Obj *o) { - if(!o || o->alive) { - return; - } - - //printf("marking %p alive: ", o); obj_print_cout(o); printf("\n"); - - o->alive = true; - obj_mark_alive(o->meta); - - if(o->tag == 'C') { - obj_mark_alive(o->car); - obj_mark_alive(o->cdr); - } - else if(o->tag == 'A') { - for(int i = 0; i < o->count; i++) { - obj_mark_alive(o->array[i]); - } - } - else if(o->tag == 'L' || o->tag == 'M') { - obj_mark_alive(o->params); - obj_mark_alive(o->body); - obj_mark_alive(o->env); - obj_mark_alive(o->code); - } - else if(o->tag == 'E') { - obj_mark_alive(o->parent); - obj_mark_alive(o->bindings); - } - else if(o->tag == 'F') { - obj_mark_alive(o->arg_types); - obj_mark_alive(o->return_type); - } - else if(o->tag == 'X') { - obj_mark_alive(o->bytecode_literals); - } - - // TODO: remove data pointed to by void_ptr:s! (tag 'Q') -} - -void free_internal_data(Obj *dead) { - if(dead->given_to_ffi) { - // ignore this object - } - else if(dead->tag == 'F') { - free(dead->cif); - free(dead->name); - } - else if(dead->tag == 'S' || dead->tag == 'Y' || dead->tag == 'K') { - /* if(dead->tag == 'S') { */ - /* printf("freeing '%s'\n", dead->s); */ - /* dead->deathwish = dead->s; */ - /* return; */ - /* } */ - free(dead->s); - } - else if(dead->tag == 'A') { - free(dead->array); - } - else if(dead->tag == 'X') { - free(dead->bytecode); - } -} - -void gc_sweep() { - int kill_count = 0; - Obj **p = &obj_latest; - while(*p) { - if(!(*p)->alive) { - Obj *dead = *p; - - if(LOG_FREE) { - printf("free "); - printf("%p %c ", dead, dead->tag); - //obj_print_cout(dead); - printf("\n"); - } - - *p = dead->prev; - free_internal_data(dead); - - //memset(dead, 0, sizeof(Obj)); - free(dead); - - /* if(dead->tag == 'A') free(dead); */ - /* else if(dead->tag == 'B') free(dead); */ - /* else if(dead->tag == 'C') free(dead); */ - /* else if(dead->tag == 'D') free(dead); */ - /* else if(dead->tag == 'E') free(dead); */ - /* else if(dead->tag == 'F') free(dead); */ - /* else if(dead->tag == 'G') free(dead); */ - /* else if(dead->tag == 'H') free(dead); */ - /* else if(dead->tag == 'I') free(dead); */ - /* else if(dead->tag == 'K') free(dead); */ - /* else if(dead->tag == 'L') free(dead); */ - /* else if(dead->tag == 'M') free(dead); */ - /* else if(dead->tag == 'N') free(dead); */ - /* else if(dead->tag == 'O') free(dead); */ - /* else if(dead->tag == 'P') free(dead); */ - /* else if(dead->tag == 'Q') free(dead); */ - /* else if(dead->tag == 'R') free(dead); */ - /* else if(dead->tag == 'S') free(dead); */ - /* else if(dead->tag == 'T') free(dead); */ - /* else if(dead->tag == 'U') free(dead); */ - /* else if(dead->tag == 'V') free(dead); */ - /* else if(dead->tag == 'X') free(dead); */ - /* else if(dead->tag == 'Y') free(dead); */ - /* else if(dead->tag == 'Z') free(dead); */ - /* else { */ - /* printf("Can't free object with invalid tag: %c\n", dead->tag); */ - /* } */ - - obj_total--; - kill_count++; - } - else { - (*p)->alive = false; // for next gc collect - p = &(*p)->prev; - } - } - if(LOG_GC_KILL_COUNT) { - printf("\e[33mGC:d %d Obj:s, %d left.\e[0m\n", kill_count, obj_total); - } -} - -void gc(Process *process) { - obj_mark_alive(process->global_env); - for(int i = 0; i < process->stack_pos; i++) { - obj_mark_alive(process->stack[i]); - } - for(int i = 0; i < process->shadow_stack_pos; i++) { - obj_mark_alive(process->shadow_stack[i]); - } - for(int i = 0; i < process->function_trace_pos; i++) { - obj_mark_alive(process->function_trace[i].caller); - obj_mark_alive(process->function_trace[i].callee); - } - - // WHAT NEEDS TO BE ROOTED?! - /* if(process->bytecodeObj) { */ - /* obj_mark_alive(process->bytecodeObj); */ - /* } */ - for(int i = 0; i <= process->frame; i++) { - obj_mark_alive(process->frames[i].bytecodeObj); - obj_mark_alive(process->frames[i].env); - obj_mark_alive(process->frames[i].trace); - //obj_mark_alive(process->frames[i].); - } - gc_sweep(); -} - -void gc_all() { - gc_sweep(); -} diff --git a/src/gc.h b/src/gc.h deleted file mode 100644 index 7b897cef2..000000000 --- a/src/gc.h +++ /dev/null @@ -1,8 +0,0 @@ -#pragma once - -#include "obj.h" -#include "eval.h" -#include "process.h" - -void gc(Process *process); -void gc_all(); diff --git a/src/main.c b/src/main.c deleted file mode 100644 index 5606031ba..000000000 --- a/src/main.c +++ /dev/null @@ -1,87 +0,0 @@ -#include "../shared/shared.h" -#include "repl.h" -#include "eval.h" -#include "gc.h" -#include -#include "bytecode.h" - -#define HANDLE_SIGNALS 0 -#define BOOT 1 - -void signal_handler(int sig) { - printf("\e[31m"); - printf("Got signal: "); - switch(sig) { - case SIGABRT: - printf("SIGABRT\n"); - break; - case SIGFPE: - printf("SIGFPE\n"); - break; - case SIGILL: - printf("SIGILL\n"); - break; - case SIGINT: - printf("SIGINT\n"); - break; - case SIGSEGV: - printf("SIGSEGV\n"); - printf("\e[0m"); - printf("Will try to resume in 1 second...\n"); - sleep(1); - longjmp(jumpbuffer, 0); - break; - case SIGTERM: - printf("SIGTERM\n"); - break; - default: - printf("Unhandled %d\n", sig); - } - exit(-1); -} - -int main(int argc, char **argv) { - - if(HANDLE_SIGNALS) { - signal(SIGABRT, signal_handler); - signal(SIGFPE, signal_handler); - signal(SIGILL, signal_handler); - signal(SIGSEGV, signal_handler); - signal(SIGTERM, signal_handler); - //signal(SIGINT, signal_handler); - } - - /* printf("%ld %ld %ld \n", sizeof(float), sizeof(int), sizeof(void*)); */ - carp_platform_init(); - obj_total_max = 100000; - parallell = NULL; - - Process *process = process_new(); - - if(BYTECODE_EVAL) { - eval_text(process, process->global_env, "(def BYTECODE_EVAL true)", false, obj_new_string("main.c")); - } - else { - eval_text(process, process->global_env, "(def BYTECODE_EVAL false)", false, obj_new_string("main.c")); - } - -#if BOOT - eval_text(process, - process->global_env, - "(load-lisp (str (getenv \"CARP_DIR\") \"lisp/boot.carp\"))", - false, - obj_new_string("main.c")); -#endif - - if(argc == 2) { - char load_file[512]; - snprintf(load_file, 512, "(load-lisp (str \"%s\"))", argv[1]); - eval_text(process, process->global_env, load_file, false, obj_new_string("main.c")); - } - - repl(process); - - carp_platform_shutdown(); - gc_all(); - assert(obj_total == 0); -} diff --git a/src/match.c b/src/match.c deleted file mode 100644 index c5daf6e14..000000000 --- a/src/match.c +++ /dev/null @@ -1,141 +0,0 @@ -#include "match.h" -#include "env.h" -#include "eval.h" -#include "assertions.h" - -bool obj_match(Process *process, Obj *env, Obj *attempt, Obj *value); - -bool obj_match_lists(Process *process, Obj *env, Obj *attempt, Obj *value) { - //printf("Matching list %s with %s\n", obj_to_string(attempt)->s, obj_to_string(value)->s); - Obj *p1 = attempt; - Obj *p2 = value; - while(p1 && p1->car) { - if(obj_eq(process, p1->car, dotdotdot) && p1->cdr && p1->cdr->car) { - //printf("Matching & %s against %s\n", obj_to_string(p1->cdr->car)->s, obj_to_string(p2)->s); - bool matched_rest = obj_match(process, env, p1->cdr->car, p2); - return matched_rest; - } - else if(!p2 || !p2->car) { - return false; - } - bool result = obj_match(process, env, p1->car, p2->car); - if(!result) { - return false; - } - p1 = p1->cdr; - p2 = p2->cdr; - } - if(p2 && p2->car) { - return false; - } - else { - //printf("Found end of list, it's a match.\n"); - return true; - } -} - -bool obj_match_arrays(Process *process, Obj *env, Obj *attempt, Obj *value) { - //printf("Matching arrays %s with %s\n", obj_to_string(attempt)->s, obj_to_string(value)->s); - int i; - for(i = 0; i < attempt->count; i++) { - Obj *o = attempt->array[i]; - if(obj_eq(process, o, dotdotdot) && ((i + 1) < attempt->count)) { - int rest_count = value->count - i; - //printf("rest_count: %d\n", rest_count); - Obj *rest = obj_new_array(rest_count); - for(int j = 0; j < rest_count; j++) { - rest->array[j] = value->array[i + j]; // copy the rest of the objects to a smaller array - } - //printf("rest: %s\n", obj_to_string(rest)->s); - Obj *symbol_after_dotdotdot = attempt->array[i + 1]; - //printf("symbol_after_dotdotdot: %s\n", obj_to_string(symbol_after_dotdotdot)->s); - bool matched_rest = obj_match(process, env, symbol_after_dotdotdot, rest); - //printf("%s\n", matched_rest ? "match" : "no match"); - return matched_rest; - } - else if(i >= value->count) { - return false; - } - bool result = obj_match(process, env, o, value->array[i]); - if(!result) { - return false; - } - } - if(i < value->count) { - //printf("The value list is too long.\n"); - return false; - } - else { - //printf("Found end of list, it's a match.\n"); - return true; - } -} - -bool obj_match(Process *process, Obj *env, Obj *attempt, Obj *value) { - //printf("Matching %s with %s\n", obj_to_string(attempt)->s, obj_to_string(value)->s); - - if(attempt->tag == 'C' && obj_eq(process, attempt->car, lisp_quote) && attempt->cdr && attempt->cdr->car) { - // Dubious HACK to enable matching on quoted things... - // Don't want to extend environment in this case! - Obj *quoted_attempt = attempt->cdr->car; - return obj_eq(process, quoted_attempt, value); - } - else if(attempt->tag == 'Y' && strcmp(attempt->s, "nil") == 0) { - // Using 'nil' on the left side of a match will bind the right side to that symbol, which is NOT what you want! - return obj_eq(process, value, nil); - } - else if(attempt->tag == 'Y') { - //printf("Binding %s to value %s in match.\n", obj_to_string(attempt)->s, obj_to_string(value)->s); - env_extend(env, attempt, value); - return true; - } - else if(attempt->tag == 'C' && value->tag == 'C') { - return obj_match_lists(process, env, attempt, value); - } - else if(attempt->tag == 'A' && value->tag == 'A') { - return obj_match_arrays(process, env, attempt, value); - } - else if(obj_eq(process, attempt, value)) { - return true; - } - else { - /* printf("attempt %s (%c) is NOT equal to value %s (%c)\n", */ - /* obj_to_string(attempt)->s, */ - /* attempt->tag, */ - /* obj_to_string(value)->s, */ - /* value->tag); */ - return false; - } -} - -void match(Process *process, Obj *env, Obj *value, Obj *attempts) { - Obj *p = attempts; - while(p && p->car) { - //printf("\nWill match %s with value %s\n", obj_to_string(p->car)->s, obj_to_string(value)->s); - Obj *new_env = obj_new_environment(env); - shadow_stack_push(process, new_env); - bool result = obj_match(process, new_env, p->car, value); - - if(result) { - //printf("Match found, evaling %s in env\n", obj_to_string(p->cdr->car)->s); //, obj_to_string(new_env)->s); - eval_internal(process, new_env, p->cdr->car); // eval the following form using the new environment - Obj *pop = shadow_stack_pop(process); // new_env - if(eval_error) { - return; - } - assert(pop == new_env); - return; - } - - if(!p->cdr) { - set_error("Uneven nr of forms in match.", attempts); - } - - p = p->cdr->cdr; - - Obj *e = shadow_stack_pop(process); // new_env - assert(e == new_env); - } - - set_error("Failed to find a suitable match for: ", value); -} diff --git a/src/match.h b/src/match.h deleted file mode 100644 index aa3fa4f07..000000000 --- a/src/match.h +++ /dev/null @@ -1,5 +0,0 @@ -#pragma once - -#include "process.h" - -void match(Process *process, Obj *env, Obj *value, Obj *attempts); diff --git a/src/obj.c b/src/obj.c deleted file mode 100644 index 05104aeff..000000000 --- a/src/obj.c +++ /dev/null @@ -1,845 +0,0 @@ -#include "obj.h" -#include "obj_string.h" -#include "env.h" -#include "bytecode.h" -#include "eval.h" -#include "assertions.h" - -#define LOG_ALLOCS 0 - -Obj *obj_latest = NULL; -int obj_total = 0; - -Obj *obj_new(char tag) { - Obj *o = malloc(sizeof(Obj)); - assert_or_fatal_error(o, "obj_new: call to malloc failed"); - o->prev = obj_latest; - o->alive = false; - o->given_to_ffi = false; - o->tag = tag; - o->meta = NULL; - o->hash = 0; - obj_latest = o; - obj_total++; - if(LOG_ALLOCS) { - printf("alloc %p %c\n", o, o->tag); - } - return o; -} - -Obj *obj_new_cons(Obj *car, Obj *cdr) { - Obj *o = obj_new('C'); - o->car = car; - o->cdr = cdr; - return o; -} - -Obj *obj_new_int(int i) { - Obj *o = obj_new('I'); - o->i = i; - return o; -} - -Obj *obj_new_float(float x) { - Obj *o = obj_new('V'); - o->f32 = x; - return o; -} - -Obj *obj_new_double(double x) { - Obj *o = obj_new('W'); - o->f64 = x; - return o; -} - -Obj *obj_new_string(char *s) { - assert(s); - Obj *o = obj_new('S'); - o->s = strdup(s); - return o; -} - -Obj *obj_new_symbol(char *s) { - Obj *o = obj_new('Y'); - o->s = strdup(s); - - if(strcmp(s, "do") == 0) { - o->dispatch_index = 1; - } - else if(strcmp(s, "let") == 0) { - o->dispatch_index = 2; - } - else if(strcmp(s, "not") == 0) { - o->dispatch_index = 3; - } - else if(strcmp(s, "or") == 0) { - o->dispatch_index = 4; - } - else if(strcmp(s, "and") == 0) { - o->dispatch_index = 5; - } - else if(strcmp(s, "quote") == 0) { - o->dispatch_index = 6; - } - else if(strcmp(s, "while") == 0) { - o->dispatch_index = 7; - } - else if(strcmp(s, "if") == 0) { - o->dispatch_index = 8; - } - else if(strcmp(s, "match") == 0) { - o->dispatch_index = 9; - } - else if(strcmp(s, "reset!") == 0) { - o->dispatch_index = 10; - } - else if(strcmp(s, "fn") == 0) { - o->dispatch_index = 11; - } - else if(strcmp(s, "macro") == 0) { - o->dispatch_index = 12; - } - else if(strcmp(s, "def") == 0) { - o->dispatch_index = 13; - } - else if(strcmp(s, "def?") == 0) { - o->dispatch_index = 14; - } - else if(strcmp(s, "ref") == 0) { - o->dispatch_index = 15; - } - else if(strcmp(s, "catch-error") == 0) { - o->dispatch_index = 16; - } - else { - o->dispatch_index = 0; - } - - return o; -} - -Obj *obj_new_keyword(char *s) { - Obj *o = obj_new('K'); - o->s = strdup(s); - return o; -} - -Obj *obj_new_primop(Primop p) { - Obj *o = obj_new('P'); - o->primop = (struct Obj * (*)(struct Process *, struct Obj **, int))p; - return o; -} - -Obj *obj_new_dylib(void *dylib) { - Obj *o = obj_new('D'); - o->primop = dylib; - return o; -} - -Obj *obj_new_ptr(void *ptr) { - Obj *o = obj_new('Q'); - o->void_ptr = ptr; - return o; -} - -Obj *obj_new_ptr_to_global(void *ptr) { - Obj *o = obj_new('R'); - o->void_ptr = ptr; - return o; -} - -Obj *obj_new_ffi(const char *name, ffi_cif *cif, VoidFn funptr, Obj *arg_types, Obj *return_type_obj) { - assert(cif); - assert(name); - assert(arg_types); - assert(arg_types->tag == 'C'); - assert(return_type_obj); - Obj *o = obj_new('F'); - o->cif = cif; - o->name = strdup(name); - o->funptr = funptr; - o->arg_types = arg_types; - o->return_type = return_type_obj; - return o; -} - -Obj *obj_new_lambda(Obj *params, Obj *body, Obj *env, Obj *code) { - assert(params); - assert(params->tag == 'C' || params->tag == 'A'); - assert(body); - assert(env); - assert(env->tag == 'E'); - assert(code); - Obj *o = obj_new('L'); - o->params = params; - o->body = body; - o->env = env; - o->code = code; - return o; -} - -Obj *obj_new_macro(Obj *params, Obj *body, Obj *env, Obj *code) { - assert(params); - assert(params->tag == 'C' || params->tag == 'A'); - assert(body); - assert(env); - assert(env->tag == 'E'); - Obj *o = obj_new('M'); - o->params = params; - o->body = body; - o->env = env; - o->code = code; - return o; -} - -Obj *obj_new_environment(Obj *parent) { - //obj_print_cout(parent); - Obj *o = obj_new('E'); - o->parent = parent; - o->bindings = NULL; - return o; -} - -Obj *obj_new_char(char character) { - Obj *o = obj_new('T'); - o->character = character; - return o; -} - -Obj *obj_new_array(int count) { - Obj *o = obj_new('A'); - o->array = calloc(sizeof(Obj *), count); - o->count = count; - return o; -} - -Obj *obj_new_bool(bool b) { - Obj *o = obj_new('B'); - o->boolean = b; - return o; -} - -Obj *obj_new_bytecode(char *bytecode) { - Obj *o = obj_new('X'); - o->bytecode = bytecode; - o->bytecode_literals = obj_new_array(0); - return o; -} - -Obj *obj_copy(Process *process, Obj *o) { - assert(o); - if(o->tag == 'C') { - //printf("Making a copy of the list: %s\n", obj_to_string(o)->s); - Obj *list = obj_new_cons(NULL, NULL); - Obj *prev = list; - Obj *p = o; - while(p && p->car) { - Obj *new = obj_new_cons(NULL, NULL); - shadow_stack_push(process, new); - prev->car = obj_copy(process, p->car); - shadow_stack_pop(process); - if(p->cdr) { - prev->cdr = obj_copy(process, p->cdr); - return list; // early break when copying dotted pairs! TODO: is this case always selected?! - } - else { - prev->cdr = obj_new_cons(NULL, NULL); - prev = new; - p = p->cdr; - } - } - return list; - } - else if(o->tag == 'A') { - Obj *copy = obj_new_array(o->count); - shadow_stack_push(process, copy); - for(int i = 0; i < o->count; i++) { - copy->array[i] = obj_copy(process, o->array[i]); - } - shadow_stack_pop(process); // copy - return copy; - } - else if(o->tag == 'E') { - //printf("Making a copy of the env: %s\n", obj_to_string(o)->s); - Obj *new_env = obj_new_environment(NULL); - shadow_stack_push(process, new_env); - new_env->bindings = obj_copy(process, o->bindings); - shadow_stack_pop(process); - return new_env; - } - else if(o->tag == 'Q' || o->tag == 'R') { - Obj *type_meta = env_lookup(process, o->meta, obj_new_keyword("type")); - if(type_meta) { - //printf("COPY type_meta: %s\n", STR(type_meta)); - - shadow_stack_push(process, o); - - Obj *reffed_arg_type = obj_list(obj_new_keyword("ref"), type_meta); - Obj *args_type = obj_list(reffed_arg_type); - Obj *signature = obj_list(obj_new_keyword("fn"), args_type, type_meta); - Obj *quoted_sig = obj_list(lisp_quote, signature); - - shadow_stack_push(process, quoted_sig); - - // Figure out the name - Obj *generic_name_result = generic_name(process, "copy", quoted_sig); - if(eval_error) { - return NULL; - } - shadow_stack_push(process, generic_name_result); - //printf("generic_name_result: %s\n", STR(generic_name_result)); - - //printf("Will bake 'copy' with quoted signature: %s\n", STR(quoted_sig)); - - // Bake - bake_generic_primop_auto(process, "copy", quoted_sig); - if(eval_error) { - return NULL; - } - else { - //printf("Baked copying function: %s\n", generic_name_result->s); - } - - // Call - char *s = obj_to_string_not_prn(process, generic_name_result)->s; - Obj *call_to_copy = obj_list(obj_new_symbol(s), o); - shadow_stack_push(process, call_to_copy); - - //printf("call_to_copy: %s\n", STR(call_to_copy)); - - Obj *copy_result = NULL; - if(BYTECODE_EVAL) { - copy_result = bytecode_sub_eval_form(process, process->global_env, call_to_copy); - } - else { - copy_result = eval(process, process->global_env, call_to_copy); - //printf("copy_result: %s with tag %c\n", STR(copy_result), copy_result->tag); - } - - shadow_stack_push(process, copy_result); - - if(eval_error) { - printf("Error when calling 'copy' function for void ptr of type '%s':\n", STR(type_meta)); - printf("%s\n", obj_to_string(process, eval_error)->s); - return NULL; - } - - Obj *pop1 = shadow_stack_pop(process); - assert(pop1 == copy_result); - - Obj *pop2 = shadow_stack_pop(process); - assert(pop2 == call_to_copy); - - Obj *pop3 = shadow_stack_pop(process); // generic_name_result - assert(pop3 == generic_name_result); - - Obj *pop4 = shadow_stack_pop(process); // quoted_sig - assert(pop4 == quoted_sig); - - Obj *pop5 = shadow_stack_pop(process); // o - assert(pop5 == o); - - return copy_result; - } - else { - // shallow copy - printf("COPY no type_meta\n"); - return obj_new_ptr(o->void_ptr); - } - } - else if(o->tag == 'I') { - return obj_new_int(o->i); - } - else if(o->tag == 'V') { - return obj_new_float(o->f32); - } - else if(o->tag == 'W') { - return obj_new_float(o->f64); - } - else if(o->tag == 'S') { - return obj_new_string(strdup(o->s)); - } - else if(o->tag == 'Y') { - return obj_new_symbol(strdup(o->s)); - } - else if(o->tag == 'K') { - return obj_new_keyword(strdup(o->s)); - } - else if(o->tag == 'P') { - return obj_new_primop((Primop)o->primop); - } - else if(o->tag == 'D') { - return obj_new_dylib(o->dylib); - } - else if(o->tag == 'F') { - Obj *arg_types_copy = obj_copy(process, o->arg_types); - return obj_new_ffi(o->name, o->cif, o->funptr, arg_types_copy, obj_copy(process, o->return_type)); - } - else if(o->tag == 'L') { - return o; - } - else if(o->tag == 'M') { - return o; - } - else if(o->tag == 'T') { - return obj_new_char(o->character); - } - else if(o->tag == 'B') { - return obj_new_bool(o->boolean); - } - else if(o->tag == 'X') { - Obj *copy = obj_new_bytecode(strdup(o->bytecode)); - shadow_stack_push(process, copy); - copy->bytecode_literals = obj_copy(process, o->bytecode_literals); - shadow_stack_pop(process); - return copy; - } - else { - printf("obj_copy() can't handle type tag %c (%d).\n", o->tag, o->tag); - return NULL; - assert(false); - } -} - -int string_to_hash(char *str) { - unsigned long hash = 5381; - int c; - while((c = *str++)) { - hash = ((hash << 5) + hash) + c; /* hash * 33 + c */ - } - if(hash == 0) { - hash = 1; // hash 0 means no hash - } - return hash; -} - -int obj_hash(Process *process, Obj *o) { - assert(o); - - shadow_stack_push(process, o); - int hash = 123456789; - - if(o->tag == 'C') { - Obj *p = o; - int h = 1234; - while(p && p->car) { - h += obj_hash(process, p->car); - if(p->cdr && p->cdr->tag != 'C') { - // dotted pair - h += obj_hash(process, p->cdr); - break; - } - else { - // normal list - p = p->cdr; - } - } - hash = h; - } - else if(o->tag == 'A') { - int h = 5381; - for(int i = 0; i < o->count; i++) { - h = ((h << 5) + h) + obj_hash(process, o->array[i]); - } - hash = h; - } - else if(o->tag == 'E') { - int h = o->bindings ? obj_hash(process, o->bindings) : 0; - hash = h + 666; - } - else if(o->tag == 'Q') { - hash = (int)o->void_ptr; - } - else if(o->tag == 'I') { - hash = o->i; - } - else if(o->tag == 'V') { - hash = (int)o->f32; - } - else if(o->tag == 'W') { - hash = (int)o->f64; - } - else if(o->tag == 'S') { - hash = string_to_hash(o->s); - } - else if(o->tag == 'Y') { - hash = string_to_hash(o->s); - } - else if(o->tag == 'K') { - hash = string_to_hash(o->s); - } - else if(o->tag == 'P') { - hash = (int)o->primop; - } - else if(o->tag == 'D') { - hash = (int)o->dylib; - } - else if(o->tag == 'F') { - hash = (int)o->funptr; - } - else if(o->tag == 'L') { - // ??? - } - else if(o->tag == 'M') { - // ??? - } - else if(o->tag == 'T') { - hash = (int)o->character; - } - else if(o->tag == 'B') { - hash = o->boolean ? 29843 : 42391; - } - else if(o->tag == 'X') { - // ??? - } - else { - printf("obj_hash() can't handle type tag %c (%d).\n", o->tag, o->tag); - return 0; - assert(false); - } - - shadow_stack_pop(process); // o - - //printf("hash for %s is %d\n", obj_to_string(process, o)->s, hash->i); - - return hash; -} - -Obj *obj_list_internal(Obj *objs[]) { - Obj *list = obj_new_cons(NULL, NULL); - Obj **o = objs; - Obj *prev = list; - while(*o) { - prev->car = *o; - Obj *new = obj_new_cons(NULL, NULL); - prev->cdr = new; - prev = new; - o++; - } - return list; -} - -bool is_true(Obj *o) { - //printf("is_true? %s\n", obj_to_string(o)->s); - if(o->tag == 'B' && !o->boolean) { - return false; - } - else { - return true; - } -} - -void obj_print_cout(Obj *o) { - if(!o) { - printf("NULL"); - } - else if(o->tag == 'C') { - printf("("); - Obj *p = o; - while(p && p->car && p->tag == 'C') { - obj_print_cout(p->car); - if(p->cdr && p->cdr->tag == 'C' && p->cdr->cdr) { - printf(" "); - } - p = p->cdr; - } - printf(")"); - } - else if(o->tag == 'A') { - printf("["); - for(int i = 0; i < o->count; i++) { - obj_print_cout(o->array[i]); - if(i < o->count - 1) { - printf(" "); - } - } - printf("]"); - } - else if(o->tag == 'B') { - printf("%s", o->boolean ? "true" : "false"); - } - else if(o->tag == 'X') { - printf("(Bytecode %s)", o->bytecode); - } - else if(o->tag == 'E') { - printf("{ ... }"); - } - else if(o->tag == 'Q') { - printf("%p", o->void_ptr); - } - else if(o->tag == 'I') { - printf("%d", o->i); - } - else if(o->tag == 'V') { - printf("%f", o->f32); - } - else if(o->tag == 'W') { - printf("%f", o->f64); - } - else if(o->tag == 'S') { - printf("\"%s\"", o->s); - } - else if(o->tag == 'Y') { - printf("%s", o->s); - } - else if(o->tag == 'K') { - printf(":%s", o->s); - } - else if(o->tag == 'P') { - printf("", o->primop); - } - else if(o->tag == 'D') { - printf("", o->dylib); - } - else if(o->tag == 'F') { - printf(""); - } - else if(o->tag == 'L') { - printf("(fn "); - obj_print_cout(o->params); - printf(" "); - obj_print_cout(o->body); - printf(")"); - } - else if(o->tag == 'M') { - printf("%p", o); - } - else { - printf("obj_print_cout() can't handle type tag %c (%d).\n", o->tag, o->tag); - assert(false); - } -} - -void obj_set_line_info(Process *process, Obj *o, int line, int pos, Obj *filename) { - if(!o->meta) { - o->meta = obj_new_environment(NULL); - } - env_assoc(process, o->meta, obj_new_keyword("line"), obj_new_int(line)); - env_assoc(process, o->meta, obj_new_keyword("pos"), obj_new_int(pos)); - env_assoc(process, o->meta, obj_new_keyword("file"), filename); -} - -void obj_copy_meta(Process *process, Obj *to, Obj *from) { - if(from->meta) { - to->meta = obj_copy(process, from->meta); - } -} - -bool obj_eq(Process *process, Obj *a, Obj *b) { - //printf("Comparing %s with %s.\n", obj_to_string(process, a)->s, obj_to_string(process, b)->s); - - if(a == b) { - return true; - } - else if(a == NULL || b == NULL) { - return false; - } - else if(a->tag != b->tag) { - return false; - } - - if(a->hash != 0 && b->hash != 0) { - if(a->hash != b->hash) { - /* Obj *a_str = obj_to_string(process, a); */ - /* shadow_stack_push(process, a_str); */ - /* Obj *b_str = obj_to_string(process, b); */ - /* shadow_stack_push(process, b_str); */ - /* printf("Hash of %s and %s are not equal: %d vs %d\n", a_str->s, b_str->s, a->hash, b->hash); */ - /* shadow_stack_pop(process); */ - /* shadow_stack_pop(process); */ - return false; - } - } - - if(a->tag == 'B') { - return a->boolean == b->boolean; - } - else if(a->tag == 'S' || a->tag == 'Y' || a->tag == 'K') { - return (strcmp(a->s, b->s) == 0); - } - else if(a->tag == 'T') { - return a->character == b->character; - } - else if(a->tag == 'Q') { - return a->void_ptr == b->void_ptr; - } - else if(a->tag == 'I') { - return a->i == b->i; - } - else if(a->tag == 'V') { - return a->f32 == b->f32; - } - else if(a->tag == 'X') { - return a == b; - } - else if(a->tag == 'D') { - return a->dylib == b->dylib; - } - - if(a->tag == 'C') { - Obj *pa = a; - Obj *pb = b; - while(1) { - if(obj_eq(process, pa->car, pb->car)) { - if(!pa->cdr && !pb->cdr) { - return true; - } - else if(pa->cdr && !pb->cdr) { - return false; - } - else if(!pa->cdr && pb->cdr) { - return false; - } - else { - pa = pa->cdr; - pb = pb->cdr; - } - } - else { - return false; - } - } - } - else if(a->tag == 'A') { - if(a->count != b->count) { - return false; - } - else { - for(int i = 0; i < a->count; i++) { - if(!obj_eq(process, a->array[i], b->array[i])) { - return false; - } - } - return true; - } - } - else if(a->tag == 'E') { - - /* if(!a->meta) { */ - /* printf("dict is missing meta: %s\n", obj_to_string(process, a)->s); */ - /* } */ - /* if(!b->meta) { */ - /* printf("dict is missing meta: %s\n", obj_to_string(process, b)->s); */ - /* } */ - - if(!obj_eq(process, a->parent, b->parent)) { - return false; - } - - { - Obj *pa = a->bindings; - while(pa && pa->cdr) { - Obj *pair = pa->car; - //printf("Will lookup %s\n", obj_to_string(process, pair->car)->s); - Obj *binding = env_lookup_binding(process, b, pair->car); - if(binding) { - //printf("Found binding: %s\n", obj_to_string(process, binding)->s); - bool eq = obj_eq(process, pair->cdr, binding->cdr); - if(!binding->car) { - //printf("binding->car was NULL\n"); - return false; - } - else if(!eq) { - //printf("%s != %s\n", obj_to_string(process, pair->cdr)->s, obj_to_string(process, binding->cdr)->s); - return false; - } - } - else { - return false; - } - pa = pa->cdr; - } - } - - { - Obj *pb = b->bindings; - while(pb && pb->cdr) { - Obj *pair = pb->car; - //printf("Will lookup %s\n", obj_to_string(process, pair->car)->s); - Obj *binding = env_lookup_binding(process, a, pair->car); - if(binding) { - //printf("Found binding: %s\n", obj_to_string(process, binding)->s); - bool eq = obj_eq(process, pair->cdr, binding->cdr); - if(!binding->car) { - //printf("binding->car was NULL\n"); - return false; - } - else if(!eq) { - //printf("%s != %s\n", obj_to_string(process, pair->cdr)->s, obj_to_string(process, binding->cdr)->s); - return false; - } - } - else { - return false; - } - pb = pb->cdr; - } - } - - return true; - } - else { - char buffer[512]; - snprintf(buffer, 512, "Can't compare %s with %s.\n", obj_to_string(process, a)->s, obj_to_string(process, b)->s); - eval_error = obj_new_string(strdup(buffer)); - return false; - } -} - -Obj *generic_name(Process *process, char *function_name, Obj *quoted_sig) { - Obj *call_to_generic_name = obj_list(obj_new_symbol("generic-name"), obj_new_string(function_name), quoted_sig); - shadow_stack_push(process, call_to_generic_name); - Obj *generic_name_result = NULL; - - if(BYTECODE_EVAL) { - generic_name_result = bytecode_sub_eval_form(process, process->global_env, call_to_generic_name); - } - else { - generic_name_result = eval(process, process->global_env, call_to_generic_name); - } - - shadow_stack_push(process, generic_name_result); - - if(eval_error) { - printf("Error when calling 'generic-name':\n"); - printf("%s\n", obj_to_string(process, eval_error)->s); - return NULL; - } - else { - //printf("Generic name: %s\n", obj_to_string_not_prn(process, generic_name_result)->s); - } - - Obj *pop1 = shadow_stack_pop(process); - assert(pop1 == generic_name_result); - - Obj *pop2 = shadow_stack_pop(process); - assert(pop2 == call_to_generic_name); - - return generic_name_result; -} - -void bake_generic_primop_auto(Process *process, char *function_name, Obj *quoted_sig) { - Obj *call_to_bake_generic_primop_auto = obj_list(obj_new_symbol("bake-generic-primop-auto"), obj_new_string(function_name), quoted_sig); - shadow_stack_push(process, call_to_bake_generic_primop_auto); - - if(BYTECODE_EVAL) { - bytecode_sub_eval_form(process, process->global_env, call_to_bake_generic_primop_auto); - } - else { - //printf("CALL: %s\n", STR(call_to_bake_generic_primop_auto)); - eval(process, process->global_env, call_to_bake_generic_primop_auto); - } - - if(eval_error) { - printf("Error when calling bake-generic-primop-auto '%s' from C code: ", function_name); - printf("%s\n", obj_to_string(process, eval_error)->s); - //function_trace_print(process); - return; - } - else { - //printf("%s should now exists\n", obj_to_string_not_prn(process, generic_name_result)->s); - } - - Obj *pop1 = shadow_stack_pop(process); - assert(pop1 == call_to_bake_generic_primop_auto); -} diff --git a/src/obj.h b/src/obj.h deleted file mode 100644 index bcb24391e..000000000 --- a/src/obj.h +++ /dev/null @@ -1,231 +0,0 @@ -#pragma once - -#ifdef WIN32 -/* For correct linking against static libffi */ -#define FFI_BUILDING -#endif -#include -#include -#include -#include -#include -#include -#include "constants.h" -#include "../shared/types.h" - -#define BYTECODE_FRAME_SIZE 1024 - -typedef void (*VoidFn)(void); - -/* Type tags - A = Array - B = Bool - C = Cons cell - D = Dylib - E = Environment - F = libffi function - G - H - I = Integer - J - K = Keyword (:keyword) - L = Lambda - M = Macro - N - O - P = Primop / raw C function pointer - Q = Void pointer - R = Global variable - S = String - T = Char - U - V = Float - W = Double (not implemented yet) - X = Bytecode - Y = Symbol - Z -*/ - -struct Process; - -typedef struct Obj { - union { - // Cons cells - struct { - struct Obj *car; - struct Obj *cdr; - }; - // Integers - int i; - // Strings, symbols and keywords - struct { - char *s; - int dispatch_index; // used for quick dispatch of special forms in eval - }; - // Lambdas / Macros - struct { - struct Obj *params; - struct Obj *body; - struct Obj *env; - struct Obj *code; - }; - // Environment - struct { - struct Obj *parent; - struct Obj *bindings; - }; - // Primitive C function pointer f(process, arglist, argcount) - struct Obj *(*primop)(struct Process *, struct Obj **, int); - // Libffi function - struct { - ffi_cif *cif; - VoidFn funptr; - char *name; - struct Obj *arg_types; - struct Obj *return_type; - }; - // Array - struct { - struct Obj **array; - int count; - }; - // Bytecode - struct { - char *bytecode; - struct Obj *bytecode_literals; - }; - // Dylib - void *dylib; - // Void pointer / global variable - void *void_ptr; - // Float - float f32; - // Double - double f64; - // Char - char character; - // Bool - bool boolean; - }; - struct Obj *meta; - int hash; - // GC - struct Obj *prev; - char alive; - char given_to_ffi; - // Type tag (see table above) - char tag; -} Obj; - -typedef struct StackTraceCallSite { - Obj *caller; - Obj *callee; -} StackTraceCallSite; - -typedef struct BytecodeFrame { - int p; - Obj *bytecodeObj; - Obj *env; - Obj *trace; -} BytecodeFrame; - -typedef struct Process { - Obj *stack[STACK_SIZE]; - int stack_pos; - - Obj *shadow_stack[SHADOW_STACK_SIZE]; - int shadow_stack_pos; - - StackTraceCallSite function_trace[STACK_SIZE]; - int function_trace_pos; - - Obj *final_result; - - bool dead; - struct Obj *global_env; - - Obj *bytecodeObj; - BytecodeFrame frames[BYTECODE_FRAME_SIZE]; - int frame; -} Process; - -typedef Obj *(*Primop)(Process *, Obj **, int); - -Obj *obj_new_cons(Obj *car, Obj *cdr); -Obj *obj_new_int(int i); -Obj *obj_new_float(float x); -Obj *obj_new_double(double x); -Obj *obj_new_string(char *s); -Obj *obj_new_symbol(char *s); -Obj *obj_new_keyword(char *s); -Obj *obj_new_primop(Primop p); -Obj *obj_new_dylib(void *dylib); -Obj *obj_new_ptr(void *ptr); -Obj *obj_new_ptr_to_global(void *ptr); -Obj *obj_new_ffi(const char *name, ffi_cif *cif, VoidFn funptr, Obj *arg_types, Obj *return_type_obj); -Obj *obj_new_lambda(Obj *params, Obj *body, Obj *env, Obj *code); -Obj *obj_new_macro(Obj *params, Obj *body, Obj *env, Obj *code); -Obj *obj_new_environment(Obj *parent); -Obj *obj_new_char(char character); -Obj *obj_new_array(int count); -Obj *obj_new_bool(bool b); -Obj *obj_new_bytecode(char *bytecode); - -Obj *obj_copy(Process *process, Obj *o); -int obj_hash(Process *process, Obj *o); -bool obj_eq(Process *process, Obj *a, Obj *b); - -Obj *obj_list_internal(Obj *objs[]); -#define obj_list(...) obj_list_internal((Obj *[]){__VA_ARGS__, NULL}); - -void obj_set_line_info(Process *process, Obj *o, int line, int pos, Obj *filename); - -bool is_true(Obj *o); - -void obj_print_cout(Obj *o); -void obj_copy_meta(Process *process, Obj *to, Obj *from); - -Obj *obj_latest; -int obj_total; -int obj_total_max; - -Obj *eval_error; - -Obj *nil; -Obj *lisp_false; -Obj *lisp_true; -Obj *lisp_quote; -Obj *lisp_NULL; - -Obj *ampersand; // "&" -Obj *hash; // "#" -Obj *dotdotdot; // "..." -Obj *hash; // ":hash" - -Obj *type_int; -Obj *type_bool; -Obj *type_string; -Obj *type_list; -Obj *type_lambda; -Obj *type_primop; -Obj *type_foreign; -Obj *type_env; -Obj *type_keyword; -Obj *type_symbol; -Obj *type_macro; -Obj *type_void; -Obj *type_float; -Obj *type_double; -Obj *type_ptr; -Obj *type_ref; -Obj *type_char; -Obj *type_array; -Obj *type_ptr_to_global; - -Obj *prompt; -Obj *prompt_unfinished_form; - -Obj *generic_name(Process *process, char *function_name, Obj *quoted_sig); -void bake_generic_primop_auto(Process *process, char *function_name, Obj *quoted_sig); - -#define STR(the_object) (obj_to_string(process, (the_object))->s) diff --git a/src/obj_array.c b/src/obj_array.c deleted file mode 100644 index 0cc6f8921..000000000 --- a/src/obj_array.c +++ /dev/null @@ -1,8 +0,0 @@ -#include "obj_array.h" - -void obj_array_mut_append(Obj *a, Obj *o) { - int count = a->count; - a->array = realloc(a->array, sizeof(Obj *) * (count + 1)); - a->array[count] = o; - a->count = count + 1; -} diff --git a/src/obj_array.h b/src/obj_array.h deleted file mode 100644 index 7c1713501..000000000 --- a/src/obj_array.h +++ /dev/null @@ -1,5 +0,0 @@ -#pragma once - -#include "obj.h" - -void obj_array_mut_append(Obj *a, Obj *o); diff --git a/src/obj_conversions.c b/src/obj_conversions.c deleted file mode 100644 index 03ab55578..000000000 --- a/src/obj_conversions.c +++ /dev/null @@ -1,211 +0,0 @@ -#include "obj_conversions.h" -#include "assertions.h" -#include "env.h" -#include "obj_string.h" - -Obj *primitive_array_to_obj_array(Process *process, Array *carp_array, Obj *inner_type) { - - Obj *new_array = obj_new_array(carp_array->count); - - //printf("Converting primitive array to Obj-array, inner type: %s\n", obj_to_string(inner_type)->s); - - if(obj_eq(process, inner_type, type_int)) { - int *int_array = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - new_array->array[i] = obj_new_int(int_array[i]); - } - } - else if(obj_eq(process, inner_type, type_float)) { - float *int_array = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - new_array->array[i] = obj_new_float(int_array[i]); - } - } - else if(obj_eq(process, inner_type, type_double)) { - double *int_array = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - new_array->array[i] = obj_new_double(int_array[i]); - } - } - else if(obj_eq(process, inner_type, type_bool)) { - bool *int_array = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - new_array->array[i] = obj_new_bool(int_array[i]); - } - } - else if(obj_eq(process, inner_type, type_char)) { - char *char_array = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - new_array->array[i] = obj_new_char(char_array[i]); - } - } - else if(obj_eq(process, inner_type, type_string)) { - char **int_array = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - new_array->array[i] = obj_new_string(int_array[i]); - } - } - else { - /* eval_error = obj_new_string("Can't convert primitive Array to Obj-array, inner type: "); */ - /* obj_string_mut_append(eval_error, obj_to_string(inner_type)->s); */ - /* return NULL; */ - void **ptr_array = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - new_array->array[i] = primitive_to_obj(process, ptr_array[i], inner_type); - } - } - - return new_array; -} - -Obj *primitive_to_obj(Process *process, void *primitive, Obj *return_type) { - - //printf("Will turn %s to primitive type.\n", obj_to_string(return_type)->s); - - Obj *obj_result = NULL; - if(obj_eq(process, return_type, type_string)) { - //printf("Returning string.\n"); - char *c = primitive; - if(c == NULL) { - // TODO: have an error here instead? - //printf("Return value of type string from ffi function is null.\n"); - obj_result = obj_new_string(""); - } - else { - obj_result = obj_new_string(c); - } - } - else if(obj_eq(process, return_type, type_int)) { - //printf("Returning int.\n"); - ffi_sarg result = (ffi_sarg)primitive; - obj_result = obj_new_int(result); - } - else if(obj_eq(process, return_type, type_bool)) { - //printf("Returning bool.\n"); - ffi_arg result = (ffi_arg)primitive; - obj_result = result ? lisp_true : lisp_false; - } - else if(obj_eq(process, return_type, type_char)) { - ffi_sarg result = (ffi_sarg)primitive; - obj_result = obj_new_char(result); - } - else if(obj_eq(process, return_type, type_float)) { - //printf("Returning float.\n"); - float result = *(float *)&primitive; - obj_result = obj_new_float(result); - } - else if(obj_eq(process, return_type, type_double)) { - double result = *(double *)&primitive; - obj_result = obj_new_double(result); - } - else if(obj_eq(process, return_type, type_void)) { - //printf("Returning void.\n"); - //ffi_sarg result = (ffi_sarg)primitive; - obj_result = nil; - } - else if(return_type->tag == 'C' && return_type->car && obj_eq(process, return_type->car, obj_new_keyword("Array")) && return_type->cdr && return_type->cdr->car) { - //printf("Returning an Array.\n"); - void *result = primitive; - Obj *inner_type = return_type->cdr->car; - obj_result = primitive_array_to_obj_array(process, result, inner_type); - if(!obj_result) { - return NULL; - } - //printf("obj_result = %s\n", obj_to_string(obj_result)->s); - } - else { - //set_error("Returning what? ", function->return_type); - // Assume it's a user defined type: - void *result = primitive; - obj_result = obj_new_ptr(result); - obj_set_meta(obj_result, obj_new_keyword("type"), return_type); - } - - assert(obj_result); - return obj_result; -} - -Array *obj_array_to_carp_array(Process *process, Obj *obj_array) { - Array *carp_array = malloc(sizeof(Array)); - carp_array->count = obj_array->count; - - Obj **oa = obj_array->array; - - if(obj_array->count == 0) { - } - else if(oa[0]->tag == 'I') { - carp_array->data = malloc(sizeof(int) * carp_array->count); - int *data = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - assert_or_set_error_return_null(oa[i]->tag == 'I', "All elements in array must be integers: ", oa[i]); - data[i] = oa[i]->i; - } - } - else if(oa[0]->tag == 'V') { - carp_array->data = malloc(sizeof(int) * carp_array->count); - int *data = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - assert_or_set_error_return_null(oa[i]->tag == 'V', "All elements in array must be floats: ", oa[i]); - data[i] = oa[i]->f32; - } - } - else if(oa[0]->tag == 'W') { - carp_array->data = malloc(sizeof(float) * carp_array->count); - int *data = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - assert_or_set_error_return_null(oa[i]->tag == 'W', "All elements in array must be doubles: ", oa[i]); - data[i] = oa[i]->f64; - } - } - else if(oa[0]->tag == 'B') { - carp_array->data = malloc(sizeof(double) * carp_array->count); - bool *data = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - assert_or_set_error_return_null(oa[i]->tag == 'B', "All elements in array must be booleans: ", oa[i]); - data[i] = oa[i]->boolean; - } - } - else if(oa[0]->tag == 'T') { - carp_array->data = malloc(sizeof(char) * carp_array->count); - char *data = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - assert_or_set_error_return_null(oa[i]->tag == 'T', "All elements in array must be chars: ", oa[i]); - data[i] = oa[i]->character; - } - } - else if(oa[0]->tag == 'S') { - carp_array->data = malloc(sizeof(char *) * carp_array->count); - char **data = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - assert_or_set_error_return_null(oa[i]->tag == 'S', "All elements in array must be strings: ", oa[i]); - data[i] = strdup(oa[i]->s); // strdup! - } - } - else if(oa[0]->tag == 'Q') { - carp_array->data = malloc(sizeof(void *) * carp_array->count); - void **data = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - assert_or_set_error_return_null(oa[i]->tag == 'Q', "All elements in array must be ptr:s ", oa[i]); - data[i] = oa[i]->void_ptr; - } - } - else if(oa[0]->tag == 'A') { - carp_array->data = malloc(sizeof(void *) * carp_array->count); - Array **data = carp_array->data; - for(int i = 0; i < carp_array->count; i++) { - Array *inner_array = obj_array_to_carp_array(process, oa[i]); - if(eval_error) { - return NULL; - } - data[i] = inner_array; - } - } - else { - eval_error = obj_new_string("Can't handle this kind of array element as argument: "); - obj_string_mut_append(eval_error, obj_to_string(process, oa[0])->s); - //printf("FAIL %s\n", obj_to_string(eval_error)->s); - return NULL; - } - - return carp_array; -} diff --git a/src/obj_conversions.h b/src/obj_conversions.h deleted file mode 100644 index 315bf5e37..000000000 --- a/src/obj_conversions.h +++ /dev/null @@ -1,9 +0,0 @@ -#pragma once - -#include "obj.h" -#include "../shared/types.h" - -Obj *primitive_to_obj(Process *process, void *primitive, Obj *return_type); -Obj *primitive_array_to_obj_array(Process *process, Array *carp_array, Obj *inner_type); - -Array *obj_array_to_carp_array(Process *process, Obj *obj_array); diff --git a/src/obj_string.c b/src/obj_string.c deleted file mode 100644 index 5e5e566d1..000000000 --- a/src/obj_string.c +++ /dev/null @@ -1,523 +0,0 @@ -#include "obj_string.h" -#include "env.h" -#include "eval.h" -#include "gc.h" -#include "obj_conversions.h" -#include "process.h" -#include "bytecode.h" - -bool setting_print_lambda_body = true; - -void obj_string_mut_append(Obj *string_obj, const char *s2) { - assert(string_obj); - assert(string_obj->tag == 'S'); - assert(string_obj->s); - assert(s2); - int string_obj_len = (int)strlen(string_obj->s); - int s2_len = (int)strlen(s2); - int total_length = (string_obj_len + s2_len); - //printf("mut append '%s' (%d) << '%s' (%d)\n", string_obj->s, string_obj_len, s2, s2_len); - char *s3 = realloc(string_obj->s, sizeof(char) * (total_length + 1)); - s3[total_length] = '\0'; - strncpy(s3 + string_obj_len, s2, s2_len); - string_obj->s = s3; - string_obj->hash = 0; // todo: calculate new hash instead! -} - -Obj *concat_c_strings(char *a, const char *b) { - Obj *s = obj_new_string(a); - obj_string_mut_append(s, b); - return s; -} - -void print_generic_array_or_struct(Process *process, Obj *total, Obj *type_lookup, struct Obj *arg_to_str_obj) { - assert(total); - assert(total->tag == 'S'); - assert(type_lookup); - assert(arg_to_str_obj); - - shadow_stack_push(process, total); - shadow_stack_push(process, type_lookup); - shadow_stack_push(process, arg_to_str_obj); - - Obj *reffed_arg_type = obj_list(obj_new_keyword("ref"), type_lookup); // HACK: ref needed when sending arrays into str - Obj *args_type = obj_list(reffed_arg_type); - Obj *signature = obj_list(obj_new_keyword("fn"), args_type, type_string); - Obj *quoted_sig = obj_list(lisp_quote, signature); - - //printf("quoted_sig: %s\n", obj_to_string(quoted_sig)->s); - - Obj *generic_name_result = generic_name(process, "prn", quoted_sig); - if(eval_error) { - return; - } - shadow_stack_push(process, generic_name_result); - - bake_generic_primop_auto(process, "prn", quoted_sig); - if(eval_error) { - return; - } - - // TODO: why this conversion? - char *generic_name = obj_to_string_not_prn(process, generic_name_result)->s; - //printf("generic_name 1: %s\n", generic_name); - - Obj *call_to_str = obj_list(obj_new_symbol(generic_name), (struct Obj *)arg_to_str_obj); - - // OBS!!! - // - // Calling obj_to_string on the call_to_str form will result in an infinite loop: - // printf("Call to str: %s\n", obj_to_string(call_to_str)->s); - // - // DON'T DO IT!!! - - shadow_stack_push(process, call_to_str); - - Obj *array_to_string_result = NULL; - if(BYTECODE_EVAL) { - array_to_string_result = bytecode_sub_eval_form(process, process->global_env, call_to_str); - } - else { - array_to_string_result = eval(process, process->global_env, call_to_str); - } - - shadow_stack_push(process, array_to_string_result); - if(eval_error) { - printf("Error when calling str function for void ptr of type '%s':\n", obj_to_string(process, type_lookup)->s); - printf("%s\n", obj_to_string(process, eval_error)->s); - assert(false); - stack_pop(process); - obj_string_mut_append(total, "FAIL"); - return; - } - obj_string_mut_append(total, obj_to_string_not_prn(process, array_to_string_result)->s); - - Obj *pop1 = shadow_stack_pop(process); - assert(pop1 == array_to_string_result); - shadow_stack_pop(process); - shadow_stack_pop(process); - shadow_stack_pop(process); - shadow_stack_pop(process); - Obj *pop8 = shadow_stack_pop(process); - assert(pop8 == total); - - return; -} - -void add_indentation(Obj *total, int indent) { - for(int i = 0; i < indent; i++) { - obj_string_mut_append(total, " "); - } -} - -void obj_to_string_internal(Process *process, Obj *total, const Obj *o, bool prn, int indent) { - assert(o); - int x = indent; - if(o->tag == 'C') { - obj_string_mut_append(total, "("); - x++; - int save_x = x; - const Obj *p = o; - while(p && p->car) { - obj_to_string_internal(process, total, p->car, true, x); - if(p->cdr && p->cdr->tag != 'C') { - obj_string_mut_append(total, " . "); - obj_to_string_internal(process, total, o->cdr, true, x); - break; - } - else if(p->cdr && p->cdr->car) { - if(/* p->car->tag == 'C' || */ p->car->tag == 'E') { - obj_string_mut_append(total, "\n"); - x = save_x; - add_indentation(total, x); - } - else { - obj_string_mut_append(total, " "); - x++; - } - } - p = p->cdr; - } - obj_string_mut_append(total, ")"); - x++; - } - else if(o->tag == 'A') { - //printf("Will print Obj Array with count %d\n", o->count); - shadow_stack_push(process, (struct Obj *)o); - x++; - //int save_x = x; - obj_string_mut_append(total, "["); - for(int i = 0; i < o->count; i++) { - obj_to_string_internal(process, total, o->array[i], true, x); - if(i < o->count - 1) { - /* if(o->array[i]->car->tag == 'Q' || o->array[i]->car->tag == 'E') { */ - /* obj_string_mut_append(total, "\n"); */ - /* x = save_x; */ - /* add_indentation(total, x); */ - /* } */ - /* else { */ - /* obj_string_mut_append(total, " "); */ - /* x++; */ - /* } */ - obj_string_mut_append(total, " "); - } - } - obj_string_mut_append(total, "]"); - shadow_stack_pop(process); - x++; - } - else if(o->tag == 'E') { - shadow_stack_push(process, (struct Obj *)o); - - if(o == process->global_env) { - obj_string_mut_append(total, "{ GLOBAL ENVIRONMENT }"); - return; - } - - obj_string_mut_append(total, "{"); - x++; - Obj *p = o->bindings; - while(p && p->car) { - char *key_s = obj_to_string(process, p->car->car)->s; - obj_string_mut_append(total, key_s); - obj_string_mut_append(total, " "); - obj_to_string_internal(process, total, p->car->cdr, true, x + (int)strlen(key_s) + 1); - p = p->cdr; - if(p && p->car && p->car->car) { - obj_string_mut_append(total, ", \n"); - add_indentation(total, x); - } - } - obj_string_mut_append(total, "}"); - if(o->parent) { - obj_string_mut_append(total, " -> \n"); - Obj *parent_printout = obj_to_string(process, o->parent); - obj_string_mut_append(total, parent_printout->s); - } - shadow_stack_pop(process); - } - else if(o->tag == 'I') { - static char temp[64]; - snprintf(temp, 64, "%d", o->i); - obj_string_mut_append(total, temp); - } - else if(o->tag == 'V') { - static char temp[64]; - snprintf(temp, 64, "%f", o->f32); - obj_string_mut_append(total, temp); - obj_string_mut_append(total, "f"); - } - else if(o->tag == 'W') { - static char temp[64]; - snprintf(temp, 64, "%f", o->f64); - obj_string_mut_append(total, temp); - } - else if(o->tag == 'S') { - if(prn) { - obj_string_mut_append(total, "\""); - } - obj_string_mut_append(total, o->s); - if(prn) { - obj_string_mut_append(total, "\""); - } - } - else if(o->tag == 'Y') { - obj_string_mut_append(total, o->s); - } - else if(o->tag == 'K') { - obj_string_mut_append(total, ":"); - obj_string_mut_append(total, o->s); - } - else if(o->tag == 'P') { - obj_string_mut_append(total, "primop); - obj_string_mut_append(total, temp); - if(o->meta) { - Obj *name = env_lookup(process, o->meta, obj_new_keyword("name")); - if(name) { - obj_string_mut_append(total, ":"); - obj_string_mut_append(total, obj_to_string_not_prn(process, name)->s); - } - } - obj_string_mut_append(total, ">"); - } - else if(o->tag == 'D') { - obj_string_mut_append(total, "primop); - obj_string_mut_append(total, temp); - obj_string_mut_append(total, ">"); - } - else if(o->tag == 'Q') { - shadow_stack_push(process, (struct Obj *)o); - Obj *type_lookup; - if(o->meta && (type_lookup = env_lookup(process, o->meta, obj_new_keyword("type")))) { - if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(process, type_lookup->car, obj_new_keyword("Array"))) { - print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)o); - } - else { - print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)o); - /* obj_string_mut_append(total, "s); */ - /* obj_string_mut_append(total, ">"); */ - } - } - else { - obj_string_mut_append(total, "primop); - obj_string_mut_append(total, temp); - obj_string_mut_append(total, " of unknown type"); - obj_string_mut_append(total, ">"); - } - shadow_stack_pop(process); - } - else if(o->tag == 'R') { - shadow_stack_push(process, (struct Obj *)o); - - if(!o->void_ptr) { - eval_error = obj_new_string("Pointer to global is NULL.\n"); - return; - } - - Obj *type_lookup; - //printf("o %p %p\n", o, o->void_ptr); - - if(o->void_ptr == NULL) { - obj_string_mut_append(total, "NULL"); - } - else if(o->meta && (type_lookup = env_lookup(process, o->meta, obj_new_keyword("type")))) { - //printf("type %s\n", obj_to_string(type_lookup)->s); - if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(process, type_lookup->car, obj_new_keyword("Array"))) { - void *dereffed = *(void **)o->void_ptr; - assert(dereffed); - Obj *x = primitive_to_obj(process, dereffed, type_lookup); - shadow_stack_push(process, x); - obj_string_mut_append(total, obj_to_string(process, x)->s); - shadow_stack_pop(process); // x - } - else if(obj_eq(process, type_lookup, type_int)) { - //int i = 123; - void *dereffed = *(void **)o->void_ptr; - assert(dereffed); - Obj *x = primitive_to_obj(process, dereffed, type_int); - obj_string_mut_append(total, obj_to_string(process, x)->s); - } - else if(obj_eq(process, type_lookup, type_float)) { - //int i = 123; - void *dereffed = *(void **)o->void_ptr; - assert(dereffed); - Obj *x = primitive_to_obj(process, dereffed, type_float); - obj_string_mut_append(total, obj_to_string(process, x)->s); - } - else if(obj_eq(process, type_lookup, type_double)) { - void *dereffed = *(void **)o->void_ptr; - assert(dereffed); - Obj *x = primitive_to_obj(process, dereffed, type_double); - obj_string_mut_append(total, obj_to_string(process, x)->s); - } - else if(obj_eq(process, type_lookup, type_bool)) { - void *dereffed = *(void **)o->void_ptr; - // can't assert since false == NULL - Obj *x = primitive_to_obj(process, dereffed, type_bool); - obj_string_mut_append(total, obj_to_string(process, x)->s); - } - else if(obj_eq(process, type_lookup, type_string)) { - void *dereffed = *(void **)o->void_ptr; - assert(dereffed); - Obj *x = primitive_to_obj(process, dereffed, type_string); - obj_string_mut_append(total, x->s); - } - else if(obj_eq(process, type_lookup, type_char)) { - void *dereffed = *(void **)o->void_ptr; - assert(dereffed); - Obj *x = primitive_to_obj(process, dereffed, type_char); - obj_string_mut_append(total, obj_to_string(process, x)->s); - } - else { - void *dereffed = *(void **)o->void_ptr; - assert(dereffed); - Obj *x = primitive_to_obj(process, dereffed, type_lookup); - print_generic_array_or_struct(process, total, type_lookup, (struct Obj *)x); - /* obj_string_mut_append(total, "s); */ - /* obj_string_mut_append(total, ">"); */ - } - } - - obj_string_mut_append(total, " ; ptr-to-global"); - - shadow_stack_pop(process); - } - else if(o->tag == 'F') { - obj_string_mut_append(total, "funptr); - obj_string_mut_append(total, temp); - if(o->meta) { - Obj *name = env_lookup(process, o->meta, obj_new_keyword("name")); - if(name) { - obj_string_mut_append(total, ":"); - obj_string_mut_append(total, obj_to_string_not_prn(process, name)->s); - } - } - else { - } - obj_string_mut_append(total, ">"); - } - else if(o->tag == 'L') { - if(setting_print_lambda_body) { - obj_string_mut_append(total, "(fn"); - obj_string_mut_append(total, " "); - obj_string_mut_append(total, obj_to_string(process, o->params)->s); - obj_string_mut_append(total, " "); - obj_string_mut_append(total, obj_to_string(process, o->body)->s); - obj_string_mut_append(total, ")"); - } - else { - obj_string_mut_append(total, ""); - } - } - else if(o->tag == 'M') { - if(setting_print_lambda_body) { - obj_string_mut_append(total, "(macro"); - obj_string_mut_append(total, " "); - obj_string_mut_append(total, obj_to_string(process, o->params)->s); - obj_string_mut_append(total, " "); - obj_string_mut_append(total, obj_to_string(process, o->body)->s); - obj_string_mut_append(total, ")"); - } - else { - obj_string_mut_append(total, ""); - } - } - else if(o->tag == 'T') { - char s[2] = {o->character, '\0'}; - if(prn) { - obj_string_mut_append(total, "\\"); - } - obj_string_mut_append(total, s); - } - else if(o->tag == 'B') { - if(o->boolean) { - obj_string_mut_append(total, "true"); - } - else { - obj_string_mut_append(total, "false"); - } - } - else if(o->tag == 'X') { - obj_string_mut_append(total, "(\n"); - - for(char *p = o->bytecode; *p != '\0';) { - const int buffer_size = 128; - char buffer[buffer_size]; - - snprintf(buffer, buffer_size, "%4d ", (int)(p - o->bytecode)); - obj_string_mut_append(total, buffer); - - char c = *p; - p++; - - if(c == 'l') { - snprintf(buffer, buffer_size, "LOAD LIT %d", *((int*)p)); - p += sizeof(int); - } - else if(c == 'a') { - snprintf(buffer, buffer_size, "LOAD λ %d", *((int*)p)); - p += sizeof(int); - } - else if(c == 'c') { - snprintf(buffer, buffer_size, "CALL %d", *((int*)p)); - p += sizeof(int); - } - else if(c == 'd') { - snprintf(buffer, buffer_size, "DEFINE %d", *((int*)p)); - p += sizeof(int); - } - else if(c == 'y') { - snprintf(buffer, buffer_size, "LOOKUP %d", *((int*)p)); - p += sizeof(int); - } - else if(c == 'i') { - snprintf(buffer, buffer_size, "JUMP IF NOT %d", *((int*)p)); - p += sizeof(int); - } - else if(c == 'j') { - snprintf(buffer, buffer_size, "JUMP %d", *((int*)p)); - p += sizeof(int); - } - else if(c == 'r') { - snprintf(buffer, buffer_size, "RESET %d", *((int*)p)); - p += sizeof(int); - } - else if(c == 't') { - snprintf(buffer, buffer_size, "LET %d", *((int*)p)); - p += sizeof(int); - } - else if(c == 'e') { - snprintf(buffer, buffer_size, "DISCARD"); - } - else if(c == 'g') { - snprintf(buffer, buffer_size, "CATCH"); - } - else if(c == 'n') { - snprintf(buffer, buffer_size, "NOT"); - } - else if(c == 'p') { - snprintf(buffer, buffer_size, "PUSH NIL"); - } - else if(c == 'v') { - snprintf(buffer, buffer_size, "POP LET-SCOPE"); - } - else if(c == 'x') { - snprintf(buffer, buffer_size, "DIRECT LOOKUP"); - } - else if(c == 'q') { - snprintf(buffer, buffer_size, "END"); - } - else { - snprintf(buffer, buffer_size, "UNHANDLED OP (%c)", *p); - p++; - } - - obj_string_mut_append(total, buffer); - obj_string_mut_append(total, "\n"); - } - - obj_string_mut_append(total, "Literals: "); - obj_string_mut_append(total, obj_to_string(process, o->bytecode_literals)->s); - obj_string_mut_append(total, "\n"); - obj_string_mut_append(total, ")"); - } - else { - printf("obj_to_string() can't handle type tag %c (%d).\n", o->tag, o->tag); - assert(false); - } -} - -Obj *obj_to_string(Process *process, const Obj *o) { - Obj *s = obj_new_string(""); - obj_to_string_internal(process, s, o, true, 0); - return s; -} - -Obj *obj_to_string_not_prn(Process *process, const Obj *o) { - Obj *s = obj_new_string(""); - shadow_stack_push(process, s); - obj_to_string_internal(process, s, o, false, 0); - shadow_stack_pop(process); - return s; -} - -void obj_print(Process *process, Obj *o) { - assert(o); - Obj *s = obj_to_string(process, o); - printf("%s", s->s); -} - -void obj_print_not_prn(Process *process, Obj *o) { - Obj *s = obj_to_string_not_prn(process, o); - printf("%s", s->s); -} diff --git a/src/obj_string.h b/src/obj_string.h deleted file mode 100644 index c01cafa74..000000000 --- a/src/obj_string.h +++ /dev/null @@ -1,13 +0,0 @@ -#pragma once - -#include "obj.h" -#include "process.h" - -void obj_string_mut_append(Obj *string_obj, const char *s2); -Obj *concat_c_strings(char *a, const char *b); - -Obj *obj_to_string(Process *process, const Obj *o); -Obj *obj_to_string_not_prn(Process *process, const Obj *o); - -void obj_print(Process *process, Obj *o); -void obj_print_not_prn(Process *process, Obj *o); diff --git a/src/primops.c b/src/primops.c deleted file mode 100644 index 8cfea76d3..000000000 --- a/src/primops.c +++ /dev/null @@ -1,2402 +0,0 @@ -#include "primops.h" - -#ifdef WIN32 -#include -#else -#include -#endif - -#include "assertions.h" -#include "obj_string.h" -#include "env.h" -#include "eval.h" -#include "reader.h" -#include "gc.h" -#include "obj_conversions.h" -#include "bytecode.h" -#include "../shared/types.h" - -void register_primop(Process *process, char *name, Primop primop) { - Obj *o = obj_new_primop(primop); - env_extend(process->global_env, obj_new_symbol(name), o); - o->meta = obj_new_environment(NULL); - env_assoc(process, o->meta, obj_new_keyword("name"), obj_new_string(name)); -} - -Obj *open_file(Process *process, const char *filename) { - assert(filename); - - char *buffer = 0; - long length; - FILE *f = fopen(filename, "rb"); - - if(f) { - fseek(f, 0, SEEK_END); - length = ftell(f); - fseek(f, 0, SEEK_SET); - buffer = malloc(length + 1); - if(buffer) { - fread(buffer, 1, length, f); - buffer[length] = '\0'; - } - fclose(f); - } - else { - set_error_and_return("Failed to open file: ", obj_new_string((char *)filename)); - } - - if(buffer) { - return obj_new_string(buffer); - } - else { - set_error_and_return("Failed to open buffer from file: ", obj_new_string((char *)filename)); - } -} - -Obj *save_file(Process *process, const char *filename, const char *contents) { - FILE *f = fopen(filename, "w"); - if(f) { - fprintf(f, "%s", contents); - fclose(f); - return nil; - } - else { - set_error_and_return("Failed to save file: ", obj_new_string((char *)filename)); - } -} - -Obj *p_open_file(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - return nil; - } - if(args[0]->tag != 'S') { - return nil; - } - return open_file(process, args[0]->s); -} - -Obj *p_save_file(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - return nil; - } - if(args[0]->tag != 'S') { - return nil; - } - if(args[1]->tag != 'S') { - return nil; - } - return save_file(process, args[0]->s, args[1]->s); -} - -Obj *p_add(Process *process, Obj **args, int arg_count) { - if(arg_count == 0 || args[0]->tag == 'I') { - int sum = 0; - for(int i = 0; i < arg_count; i++) { - if(args[i]->tag != 'I') { - eval_error = obj_new_string("Args to add must be integers.\n"); - return nil; - } - sum += args[i]->i; - } - return obj_new_int(sum); - } - else if(args[0]->tag == 'V') { - float sum = 0; - for(int i = 0; i < arg_count; i++) { - if(args[i]->tag != 'V') { - eval_error = obj_new_string("Args to add must be floats.\n"); - return nil; - } - sum += args[i]->f32; - } - return obj_new_float(sum); - } - else if(args[0]->tag == 'W') { - double sum = 0; - for(int i = 0; i < arg_count; i++) { - if(args[i]->tag != 'W') { - eval_error = obj_new_string("Args to add must be doubles.\n"); - return nil; - } - sum += args[i]->f64; - } - return obj_new_double(sum); - } - else { - eval_error = obj_new_string("Can't add non-numbers together."); - return nil; - } -} - -Obj *p_sub(Process *process, Obj **args, int arg_count) { - if(arg_count == 0 || args[0]->tag == 'I') { - if(arg_count == 1) { - return obj_new_int(-args[0]->i); - } - int sum = args[0]->i; - for(int i = 1; i < arg_count; i++) { - sum -= args[i]->i; - } - return obj_new_int(sum); - } - else if(args[0]->tag == 'V') { - if(arg_count == 1) { - return obj_new_int((int)-args[0]->f32); - } - float sum = args[0]->f32; - for(int i = 1; i < arg_count; i++) { - sum -= args[i]->f32; - } - return obj_new_float(sum); - } - else if(args[0]->tag == 'W') { - if(arg_count == 1) { - return obj_new_int((int)-args[0]->f64); - } - double sum = args[0]->f64; - for(int i = 1; i < arg_count; i++) { - sum -= args[i]->f64; - } - return obj_new_double(sum); - } - else { - eval_error = obj_new_string("Can't subtract non-numbers."); - return nil; - } -} - -Obj *p_mul(Process *process, Obj **args, int arg_count) { - if(arg_count == 0) { - return obj_new_int(1); - } - - if(args[0]->tag == 'I') { - int prod = args[0]->i; - for(int i = 1; i < arg_count; i++) { - prod *= args[i]->i; - } - return obj_new_int(prod); - } - else if(args[0]->tag == 'V') { - float prod = args[0]->f32; - for(int i = 1; i < arg_count; i++) { - prod *= args[i]->f32; - } - return obj_new_float(prod); - } - else if(args[0]->tag == 'W') { - double prod = args[0]->f64; - for(int i = 1; i < arg_count; i++) { - prod *= args[i]->f64; - } - return obj_new_double(prod); - } - else { - eval_error = obj_new_string("Can't multiply non-numbers."); - return nil; - } -} - -Obj *p_div(Process *process, Obj **args, int arg_count) { - if(arg_count == 0) { - return obj_new_int(1); - } - - if(args[0]->tag == 'I') { - int prod = args[0]->i; - for(int i = 1; i < arg_count; i++) { - prod /= args[i]->i; - } - return obj_new_int(prod); - } - else if(args[0]->tag == 'V') { - float prod = args[0]->f32; - for(int i = 1; i < arg_count; i++) { - prod /= args[i]->f32; - } - return obj_new_float(prod); - } - else if(args[0]->tag == 'W') { - double prod = args[0]->f64; - for(int i = 1; i < arg_count; i++) { - prod /= args[i]->f64; - } - return obj_new_double(prod); - } - else { - eval_error = obj_new_string("Can't divide non-numbers."); - return nil; - } -} - -/* Obj *p_mod(Obj** args, int arg_count) { */ -/* if(arg_count == 0) { */ -/* return obj_new_int(1); */ -/* } */ -/* int prod = args[0]->i; */ -/* for(int i = 1; i < arg_count; i++) { */ -/* prod %= args[i]->i; */ -/* } */ -/* return obj_new_int(prod); */ -/* } */ - -Obj *p_eq(Process *process, Obj **args, int arg_count) { - if(arg_count < 2) { - printf("The function '=' requires at least 2 arguments.\n"); - return nil; - } - for(int i = 0; i < arg_count - 1; i++) { - if(!obj_eq(process, args[i], args[i + 1])) { - return lisp_false; - } - } - return lisp_true; -} - -Obj *p_list(Process *process, Obj **args, int arg_count) { - if(arg_count == 0) { - return nil; // TODO: don't use a hack like this - } - Obj *first = NULL; - Obj *prev = NULL; - for(int i = 0; i < arg_count; i++) { - Obj *new = obj_new_cons(args[i], nil); - if(!first) { - first = new; - } - if(prev) { - prev->cdr = new; - } - prev = new; - } - return first; -} - -Obj *p_array(Process *process, Obj **args, int arg_count) { - Obj *a = obj_new_array(arg_count); - for(int i = 0; i < arg_count; i++) { - a->array[i] = args[i]; - } - return a; -} - -Obj *p_dictionary(Process *process, Obj **args, int arg_count) { - Obj *e = obj_new_environment(NULL); - - //printf("creating dictionary with %d args\n", arg_count); - - if(arg_count == 0) { - e->bindings = nil; - } - else { - if(arg_count % 2 == 1) { - set_error_return_nil("Uneven nr of arguments to 'dictionary'. ", nil); - } - - Obj *first = NULL; - Obj *prev = NULL; - - for(int i = 0; i < arg_count; i += 2) { - Obj *pair = obj_new_cons(args[i], args[i + 1]); - Obj *new = obj_new_cons(pair, nil); - if(!first) { - first = new; - } - if(prev) { - prev->cdr = new; - } - prev = new; - } - e->bindings = first; - } - - //sprintf("Created dictionary:\n%s\n", obj_to_string(process, e)->s); - - e->hash = obj_hash(process, e); - - return e; -} - -Obj *p_str(Process *process, Obj **args, int arg_count) { - Obj *s = obj_new_string(""); - shadow_stack_push(process, s); - for(int i = 0; i < arg_count; i++) { - shadow_stack_push(process, args[i]); - } - for(int i = 0; i < arg_count; i++) { - obj_string_mut_append(s, obj_to_string_not_prn(process, args[i])->s); - } - for(int i = 0; i < arg_count; i++) { - shadow_stack_pop(process); // args - } - shadow_stack_pop(process); - return s; -} - -Obj *p_str_append_bang(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - eval_error = obj_new_string("'str-append!' takes exactly two arguments"); - return nil; - } - if(args[0]->tag != 'S') { - eval_error = obj_new_string("'str-append!' arg0 invalid"); - return nil; - } - if(args[1]->tag != 'S') { - eval_error = obj_new_string("'str-append!' arg1 invalid"); - return nil; - } - Obj *s = args[0]; - obj_string_mut_append(s, args[1]->s); - return s; -} - -Obj *p_join(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - eval_error = obj_new_string("'join' takes exactly two arguments"); - return nil; - } - if(args[0]->tag != 'S') { - eval_error = obj_new_string("First arg to 'join' must be a string"); - return nil; - } - - if(args[1]->tag == 'C') { - Obj *s = obj_new_string(""); - shadow_stack_push(process, s); - Obj *p = args[1]; - while(p && p->car) { - obj_string_mut_append(s, obj_to_string_not_prn(process, p->car)->s); - if(p->cdr && p->cdr->cdr) { - obj_string_mut_append(s, args[0]->s); - } - p = p->cdr; - } - shadow_stack_pop(process); - return s; - } - else if(args[1]->tag == 'A') { - Obj *s = obj_new_string(""); - shadow_stack_push(process, s); - Obj *a = args[1]; - for(int i = 0; i < a->count; i++) { - obj_string_mut_append(s, obj_to_string_not_prn(process, a->array[i])->s); - if(i < a->count - 1) { - obj_string_mut_append(s, args[0]->s); - } - } - shadow_stack_pop(process); - return s; - } - else { - eval_error = obj_new_string("Second arg to 'join' must be a list"); - return nil; - } -} - -char *str_replace(const char *str, const char *old, const char *new) { - - /* Adjust each of the below values to suit your needs. */ - - /* Increment positions cache size initially by this number. */ - size_t cache_sz_inc = 16; - /* Thereafter, each time capacity needs to be increased, - * multiply the increment by this factor. */ - const size_t cache_sz_inc_factor = 3; - /* But never increment capacity by more than this number. */ - const size_t cache_sz_inc_max = 1048576; - - char *pret, *ret = NULL; - const char *pstr2, *pstr = str; - size_t i, count = 0; - ptrdiff_t *pos_cache = NULL; - size_t cache_sz = 0; - size_t cpylen, orglen, retlen, newlen, oldlen = strlen(old); - - /* Find all matches and cache their positions. */ - while((pstr2 = strstr(pstr, old)) != NULL) { - count++; - - /* Increase the cache size when necessary. */ - if(cache_sz < count) { - cache_sz += cache_sz_inc; - pos_cache = realloc(pos_cache, sizeof(*pos_cache) * cache_sz); - if(pos_cache == NULL) { - goto end_repl_str; - } - cache_sz_inc *= cache_sz_inc_factor; - if(cache_sz_inc > cache_sz_inc_max) { - cache_sz_inc = cache_sz_inc_max; - } - } - - pos_cache[count - 1] = pstr2 - str; - pstr = pstr2 + oldlen; - } - - orglen = pstr - str + strlen(pstr); - - /* Allocate memory for the post-replacement string. */ - if(count > 0) { - newlen = strlen(new); - retlen = orglen + (newlen - oldlen) * count; - } - else - retlen = orglen; - ret = malloc(retlen + 1); - if(ret == NULL) { - goto end_repl_str; - } - - if(count == 0) { - /* If no matches, then just duplicate the string. */ - strcpy(ret, str); - } - else { - /* Otherwise, duplicate the string whilst performing - * the replacements using the position cache. */ - pret = ret; - memcpy(pret, str, pos_cache[0]); - pret += pos_cache[0]; - for(i = 0; i < count; i++) { - memcpy(pret, new, newlen); - pret += newlen; - pstr = str + pos_cache[i] + oldlen; - cpylen = (i == count - 1 ? orglen : pos_cache[i + 1]) - pos_cache[i] - oldlen; - memcpy(pret, pstr, cpylen); - pret += cpylen; - } - ret[retlen] = '\0'; - } - -end_repl_str: - /* Free the cache and return the post-replacement string, - * which will be NULL in the event of an error. */ - free(pos_cache); - return ret; -} - -Obj *p_str_replace(Process *process, Obj **args, int arg_count) { - if(arg_count != 3) { - eval_error = obj_new_string("'str-replace' takes exactly three arguments"); - return nil; - } - if(args[0]->tag != 'S') { - eval_error = obj_new_string("'str-replace' arg0 invalid: "); - obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s); - return nil; - } - if(args[1]->tag != 'S') { - eval_error = obj_new_string("'str-replace' arg1 invalid"); - return nil; - } - if(args[2]->tag != 'S') { - eval_error = obj_new_string("'str-replace' arg2 invalid"); - return nil; - } - - char *s = args[0]->s; - char *lookup = args[1]->s; - char *replacement = args[2]->s; - char *replaced = str_replace(s, lookup, replacement); - return obj_new_string(replaced); -} - -Obj *p_copy(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - eval_error = obj_new_string("'copy' takes exactly one argument"); - return nil; - } - Obj *a = args[0]; - - if(!a) { - set_error_return_nil("Trying to copy NULL", nil); - } - - //printf("Will make a copy of: %s\n", obj_to_string(a)->s); - Obj *b = obj_copy(process, a); - return b; -} - -Obj *p_print(Process *process, Obj **args, int arg_count) { - for(int i = 0; i < arg_count; i++) { - obj_print_not_prn(process, args[i]); - } - return nil; -} - -Obj *p_prn(Process *process, Obj **args, int arg_count) { - Obj *s = obj_new_string(""); - shadow_stack_push(process, s); - for(int i = 0; i < arg_count; i++) { - shadow_stack_push(process, args[i]); - } - for(int i = 0; i < arg_count; i++) { - Obj *s2 = obj_to_string(process, args[i]); - obj_string_mut_append(s, s2->s); - } - for(int i = 0; i < arg_count; i++) { - shadow_stack_pop(process); - } - shadow_stack_pop(process); // s - return s; -} - -Obj *p_println(Process *process, Obj **args, int arg_count) { - for(int i = 0; i < arg_count; i++) { - obj_print_not_prn(process, args[i]); - /* if(i < arg_count - 1) { */ - /* printf(" "); */ - /* } */ - } - printf("\n"); - return nil; -} - -Obj *p_system(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - printf("Wrong argument count to 'system'\n"); - return nil; - } - if(args[0]->tag != 'S') { - printf("'system' takes a string as its argument\n"); - return nil; - } - system(args[0]->s); - return nil; -} - -Obj *p_get(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - printf("Wrong argument count to 'get'\n"); - return nil; - } - if(args[0]->tag == 'E') { - Obj *o = env_lookup(process, args[0], args[1]); - if(o) { - return o; - } - else { - Obj *s = obj_new_string("Can't get key '"); - shadow_stack_push(process, s); - obj_string_mut_append(s, obj_to_string(process, args[1])->s); - obj_string_mut_append(s, "' in dict:\n"); - obj_string_mut_append(s, obj_to_string(process, args[0])->s); - obj_string_mut_append(s, ""); - eval_error = s; - shadow_stack_pop(process); - return nil; - } - } - else if(args[0]->tag == 'C') { - if(args[1]->tag != 'I') { - eval_error = obj_new_string("get requires arg 1 to be an integer\n"); - return nil; - } - int i = 0; - int n = args[1]->i; - Obj *p = args[0]; - while(p && p->car) { - if(i == n) { - return p->car; - } - p = p->cdr; - i++; - } - eval_error = obj_new_string("Index "); - obj_string_mut_append(eval_error, obj_to_string(process, obj_new_int(i))->s); - obj_string_mut_append(eval_error, " out of bounds in"); - obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s); - return nil; - } - else { - eval_error = obj_new_string("'get' requires arg 0 to be a dictionary or list: "); - obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s); - return nil; - } -} - -Obj *p_get_maybe(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - printf("Wrong argument count to 'get-maybe'\n"); - return nil; - } - if(args[0]->tag == 'E') { - Obj *o = env_lookup(process, args[0], args[1]); - if(o) { - return o; - } - else { - return nil; - } - } - else if(args[0]->tag == 'C') { - if(args[1]->tag != 'I') { - eval_error = obj_new_string("get-maybe requires arg 1 to be an integer\n"); - return nil; - } - int i = 0; - int n = args[1]->i; - Obj *p = args[0]; - while(p && p->car) { - if(i == n) { - return p->car; - } - p = p->cdr; - i++; - } - return nil; - } - else { - set_error_return_nil("'get-maybe' requires arg 0 to be a dictionary or list:\n", args[0]); - } -} - -Obj *p_dict_set_bang(Process *process, Obj **args, int arg_count) { - if(arg_count != 3) { - printf("Wrong argument count to 'dict-set!'\n"); - return nil; - } - if(args[0]->tag == 'E') { - return env_assoc(process, args[0], args[1], args[2]); - } - else if(args[0]->tag == 'C') { - if(args[1]->tag != 'I') { - eval_error = obj_new_string("dict-set! requires arg 1 to be an integer\n"); - return nil; - } - int i = 0; - int n = args[1]->i; - Obj *p = args[0]; - while(p && p->car) { - if(i == n) { - p->car = args[2]; - return nil; - } - p = p->cdr; - i++; - } - eval_error = obj_new_string("Index "); - obj_string_mut_append(eval_error, obj_to_string(process, obj_new_int(i))->s); - obj_string_mut_append(eval_error, " out of bounds in"); - obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s); - return nil; - } - else { - printf("'dict-set!' requires arg 0 to be a dictionary: %s\n", obj_to_string(process, args[0])->s); - return nil; - } -} - -Obj *p_dict_remove_bang(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - printf("Wrong argument count to 'dict-remove!'\n"); - return nil; - } - if(args[0]->tag != 'E') { - printf("'dict-remove!' requires arg 0 to be a dictionary: %s\n", obj_to_string(process, args[0])->s); - return nil; - } - - Obj *prev = NULL; - Obj *p = args[0]->bindings; - while(p && p->car) { - Obj *pair = p->car; - if(obj_eq(process, pair->car, args[1])) { - if(prev) { - prev->cdr = p->cdr; - } - else { - args[0]->bindings = p->cdr; - } - break; - } - else { - prev = p; - p = p->cdr; - } - } - - return args[0]; -} - -Obj *p_first(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - set_error_return_nil("Wrong argument count to 'first'. ", nil); - } - if(args[0]->tag != 'C') { - set_error_return_nil("'first' requires arg 0 to be a list: ", args[0]); - } - if(args[0]->car == NULL) { - set_error_return_nil("Can't take first element of empty list. ", nil); - return nil; - } - return args[0]->car; -} - -Obj *p_rest(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - printf("Wrong argument count to 'rest'\n"); - return nil; - } - if(args[0]->tag != 'C') { - char buffer[512]; - snprintf(buffer, 512, "'rest' requires arg 0 to be a list: %s\n", obj_to_string(process, args[0])->s); - eval_error = obj_new_string(strdup(buffer)); - return nil; - } - if(args[0]->cdr == NULL) { - set_error_return_nil("Can't take rest of empty list. ", nil); - return nil; - } - return args[0]->cdr; -} - -Obj *p_cons(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - printf("Wrong argument count to 'cons'\n"); - return nil; - } - if(args[1]->tag != 'C') { - char buffer[512]; - snprintf(buffer, 512, "'cons' requires arg 1 to be a list: %s\n", obj_to_string(process, args[1])->s); - eval_error = obj_new_string(strdup(buffer)); - return nil; - } - Obj *new_cons = obj_new_cons(args[0], args[1]); - return new_cons; -} - -Obj *p_cons_last(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - printf("Wrong argument count to 'cons'\n"); - return nil; - } - if(args[0]->tag != 'C') { - printf("'rest' requires arg 0 to be a list: %s\n", obj_to_string(process, args[1])->s); - return nil; - } - Obj *new_list = obj_copy(process, args[0]); - Obj *p = new_list; - while(p->cdr) { - p = p->cdr; - } - Obj *last = p; - Obj *new_nil = obj_new_cons(NULL, NULL); - last->car = args[1]; - last->cdr = new_nil; - return new_list; -} - -Obj *p_concat(Process *process, Obj **args, int arg_count) { - if(arg_count == 0) { - return nil; - } - - for(int i = 0; i < arg_count; i++) { - if(args[i]->tag != 'C') { - eval_error = obj_new_string("'concat' requires all args to be lists\n"); - return nil; - } - } - - int i = 0; - Obj *new = obj_copy(process, args[i]); - - while(!new->car) { - ++i; - if(i >= arg_count) { - return nil; - } - new = args[i]; - } - - Obj *last = new; - - for(i++; i < arg_count; i++) { - //printf("Will concat %s\n", obj_to_string(args[i])->s); - if(!last->cdr) { - // continue - } - else { - while(last->cdr->cdr) { - last = last->cdr; - } - Obj *o = args[i]; - if(o->car) { - last->cdr = obj_copy(process, o); - } - } - } - return new; -} - -Obj *p_nth(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - eval_error = obj_new_string("Wrong argument count to 'nth'\n"); - return nil; - } - if(args[1]->tag != 'I') { - set_error_return_nil("'nth' requires arg 1 to be an integer: ", args[1]); - } - if(args[0]->tag == 'C') { - int i = 0; - int n = args[1]->i; - Obj *p = args[0]; - while(p && p->car) { - if(i == n) { - return p->car; - } - p = p->cdr; - i++; - } - eval_error = obj_new_string("Index "); - obj_string_mut_append(eval_error, obj_to_string(process, args[1])->s); - obj_string_mut_append(eval_error, " out of bounds in "); - obj_string_mut_append(eval_error, obj_to_string(process, args[0])->s); - return nil; - } - else if(args[0]->tag == 'A') { - Obj *a = args[0]; - int index = args[1]->i; - if(index < 0 || index >= a->count) { - set_error_return_nil("Index out of bounds in ", a); - } - else { - return a->array[index]; - } - } - else { - set_error_return_nil("'nth' requires arg 0 to be a list or array\n", args[0]); - } -} - -Obj *p_count(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - set_error_return_nil("Wrong argument count to 'count'. ", nil); - } - if(args[0]->tag == 'C') { - int i = 0; - Obj *p = args[0]; - while(p && p->car) { - p = p->cdr; - i++; - } - return obj_new_int(i); - } - else if(args[0]->tag == 'A') { - return obj_new_int(args[0]->count); - } - else { - set_error_return_nil("'count' requires arg 0 to be a list or array: ", args[0]); - } -} - -bool is_callable(Obj *obj) { - return obj->tag == 'P' || obj->tag != 'L' || obj->tag != 'F'; -} - -Obj *p_map(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - eval_error = obj_new_string("Wrong argument count to 'map'."); - return nil; - } - if(!is_callable(args[0])) { - set_error_return_nil("'map' requires arg 0 to be a function or lambda: \n", args[0]); - } - Obj *f = args[0]; - if(args[1]->tag == 'C') { - Obj *p = args[1]; - Obj *list = obj_new_cons(NULL, NULL); - shadow_stack_push(process, list); - Obj *prev = list; - int shadow_count = 0; - while(p && p->car) { - Obj *arg[1] = {p->car}; - apply(process, f, arg, 1); - prev->car = stack_pop(process); - Obj *new = obj_new_cons(NULL, NULL); - shadow_stack_push(process, new); - shadow_count++; - prev->cdr = new; - prev = new; - p = p->cdr; - } - for(int i = 0; i < shadow_count; i++) { - shadow_stack_pop(process); - } - shadow_stack_pop(process); // list - return list; - } - else if(args[1]->tag == 'A') { - Obj *a = args[1]; - Obj *new_a = obj_new_array(a->count); - shadow_stack_push(process, new_a); - for(int i = 0; i < a->count; i++) { - Obj *arg[1] = {a->array[i]}; - apply(process, f, arg, 1); - new_a->array[i] = stack_pop(process); - } - shadow_stack_pop(process); // new_a - return new_a; - } - - Obj *type_lookup; - Obj *o = args[1]; - if(o->meta && (type_lookup = env_lookup(process, o->meta, obj_new_keyword("type")))) { - if(type_lookup->tag == 'C' && type_lookup->cdr->car && obj_eq(process, type_lookup->car, obj_new_keyword("Array"))) { - Obj *inner_type = type_lookup->cdr->car; - Array *a = o->void_ptr; - Obj *new_a = obj_new_array(a->count); - shadow_stack_push(process, new_a); - for(int i = 0; i < a->count; i++) { - Obj *arg[1]; - if(obj_eq(process, inner_type, type_string)) { - arg[0] = obj_new_string(((char **)(a->data))[i]); - } - else if(obj_eq(process, inner_type, type_char)) { - arg[0] = obj_new_char(((char *)(a->data))[i]); - } - else if(obj_eq(process, inner_type, type_float)) { - arg[0] = obj_new_float(((float *)(a->data))[i]); - } - else if(obj_eq(process, inner_type, type_double)) { - arg[0] = obj_new_double(((float *)(a->data))[i]); - } - else if(obj_eq(process, inner_type, type_int)) { - arg[0] = obj_new_int(((int *)(a->data))[i]); - } - else { - arg[0] = obj_new_ptr(((void **)(a->data))[i]); - //set_error_return_nil("Map over void_ptr to array can't handle type: ", inner_type); - } - apply(process, f, arg, 1); - new_a->array[i] = stack_pop(process); - } - shadow_stack_pop(process); // new_a - return new_a; - } - } - - set_error_return_nil("'map' requires arg 1 to be a list or array: ", args[1]); -} - -Obj *p_map2(Process *process, Obj **args, int arg_count) { - if(arg_count != 3) { - set_error_return_nil("Wrong argument count to 'map2'. ", nil); - } - if(!is_callable(args[0])) { - set_error_return_nil("'map2' requires arg 0 to be a function or lambda: ", args[0]); - } - Obj *f = args[0]; - if(args[1]->tag == 'C' && args[2]->tag == 'C') { - Obj *p = args[1]; - Obj *p2 = args[2]; - Obj *list = obj_new_cons(NULL, NULL); - shadow_stack_push(process, list); - Obj *prev = list; - int shadow_count = 0; - while(p && p->car && p2 && p2->car) { - Obj *argz[2] = {p->car, p2->car}; - apply(process, f, argz, 2); - prev->car = stack_pop(process); - Obj *new = obj_new_cons(NULL, NULL); - shadow_stack_push(process, new); - shadow_count++; - prev->cdr = new; - prev = new; - p = p->cdr; - p2 = p2->cdr; - } - for(int i = 0; i < shadow_count; i++) { - shadow_stack_pop(process); - } - shadow_stack_pop(process); // list - return list; - } - else if(args[1]->tag == 'A' && args[2]->tag == 'A') { - if(args[1]->count != args[2]->count) { - eval_error = obj_new_string("Arrays to map2 are of different length."); - return nil; - } - Obj *a = args[1]; - Obj *b = args[2]; - Obj *new_a = obj_new_array(a->count); - shadow_stack_push(process, new_a); - for(int i = 0; i < a->count; i++) { - Obj *fargs[2] = {a->array[i], b->array[i]}; - apply(process, f, fargs, 2); - new_a->array[i] = stack_pop(process); - } - shadow_stack_pop(process); // new_a - return new_a; - } - else { - eval_error = obj_new_string("'map2' requires both arg 1 and 2 to be lists or arrays:\n"); - obj_string_mut_append(eval_error, obj_to_string(process, args[1])->s); - obj_string_mut_append(eval_error, "\n"); - obj_string_mut_append(eval_error, obj_to_string(process, args[2])->s); - return nil; - } -} - -Obj *p_keys(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - printf("Wrong argument count to 'keys'\n"); - return nil; - } - if(args[0]->tag != 'E') { - printf("'keys' requires arg 0 to be a dictionary.\n"); - return nil; - } - Obj *p = args[0]->bindings; - Obj *list = obj_new_cons(NULL, NULL); - Obj *prev = list; - while(p && p->car) { - Obj *new = obj_new_cons(NULL, NULL); - prev->car = p->car->car; - prev->cdr = new; - prev = new; - p = p->cdr; - } - return list; -} - -Obj *p_values(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - printf("Wrong argument count to 'values'\n"); - return nil; - } - if(args[0]->tag != 'E') { - printf("'values' requires arg 0 to be a dictionary.\n"); - return nil; - } - Obj *p = args[0]->bindings; - Obj *list = obj_new_cons(NULL, NULL); - Obj *prev = list; - while(p && p->car) { - Obj *new = obj_new_cons(NULL, NULL); - prev->car = p->car->cdr; - prev->cdr = new; - prev = new; - p = p->cdr; - } - return list; -} - -Obj *p_signature(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - eval_error = obj_new_string("Wrong argument count to 'signature'"); - return nil; - } - if(args[0]->tag == 'F') { - Obj *a = obj_copy(process, args[0]->arg_types); - Obj *b = args[0]->return_type; - Obj *sig = obj_list(obj_new_keyword("fn"), a, b); - return sig; - } - else if(args[0]->tag == 'P' || args[0]->tag == 'L') { - if(!args[0]->meta) { - return nil; - } - Obj *sig = env_lookup(process, args[0]->meta, obj_new_keyword("signature")); - if(sig) { - return sig; - } - else { - return nil; - } - } - else { - eval_error = obj_new_string("'signature' requires arg 0 to be some kind of function."); - return nil; - } -} - -Obj *p_null_predicate(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - eval_error = obj_new_string("Wrong argument count to 'null?'"); - return nil; - } - if(args[0]->tag != 'Q') { - eval_error = obj_new_string("Argument to 'null?' must be void pointer."); - return nil; - } - if(args[0]->void_ptr == NULL) { - return lisp_true; - } - else { - return lisp_false; - } -} - -Obj *p_filter(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - set_error_return_nil("Wrong argument count to 'filter'.", nil); - } - if(!is_callable(args[0])) { - set_error_return_nil("'filter' requires arg 0 to be a function or lambda: ", args[0]); - } - Obj *f = args[0]; - if(args[1]->tag == 'C') { - Obj *p = args[1]; - Obj *list = obj_new_cons(NULL, NULL); - shadow_stack_push(process, list); - Obj *prev = list; - int shadow_count = 0; - while(p && p->car) { - Obj *arg[1] = {p->car}; - apply(process, f, arg, 1); - Obj *result = stack_pop(process); - if(is_true(result)) { - Obj *new = obj_new_cons(NULL, NULL); - shadow_stack_push(process, new); - shadow_count++; - prev->car = p->car; - prev->cdr = new; - prev = new; - } - p = p->cdr; - } - for(int i = 0; i < shadow_count; i++) { - shadow_stack_pop(process); - } - shadow_stack_pop(process); // list - return list; - } - else if(args[1]->tag == 'A') { - Obj *a = args[1]; - Obj **temp = malloc(sizeof(Obj *) * a->count); - int count = 0; - for(int i = 0; i < a->count; i++) { - Obj *arg[1] = {a->array[i]}; - apply(process, f, arg, 1); - Obj *result = stack_pop(process); - if(is_true(result)) { - temp[count] = a->array[i]; - count++; - } - } - Obj *a_new = obj_new_array(count); - for(int i = 0; i < count; i++) { - a_new->array[i] = temp[i]; - } - free(temp); - return a_new; - } - else { - set_error_return_nil("'filter' requires arg 1 to be a list or array: ", args[1]); - } -} - -Obj *p_reduce(Process *process, Obj **args, int arg_count) { - if(arg_count != 3) { - printf("Wrong argument count to 'reduce'\n"); - return nil; - } - if(!is_callable(args[0])) { - set_error_return_nil("'reduce' requires arg 0 to be a function or lambda: %s (%c)\n", args[0]); - } - Obj *f = args[0]; - Obj *total = args[1]; - if(args[2]->tag == 'C') { - Obj *p = args[2]; - while(p && p->car) { - Obj *args[2] = {total, p->car}; - apply(process, f, args, 2); - total = stack_pop(process); - p = p->cdr; - } - return total; - } - else if(args[2]->tag == 'A') { - Obj *a = args[2]; - for(int i = 0; i < a->count; i++) { - Obj *args[2] = {total, a->array[i]}; - apply(process, f, args, 2); - total = stack_pop(process); - } - return total; - } - else { - set_error_return_nil("'reduce' requires arg 2 to be a list or array: ", args[2]); - } -} - -Obj *p_apply(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - printf("'apply' takes two arguments.\n"); - return nil; - } - if(args[0]->tag != 'P' && args[0]->tag != 'L' && args[0]->tag != 'F') { - printf("'apply' requires arg 0 to be a function or lambda: %s (%c)\n", obj_to_string(process, args[0])->s, args[0]->tag); - eval_error = obj_new_string(""); - return nil; - } - if(args[1]->tag != 'C') { - printf("'apply' requires arg 1 to be a list: %s (%c)\n", obj_to_string(process, args[0])->s, args[0]->tag); - eval_error = obj_new_string(""); - return nil; - } - Obj *p = args[1]; - int apply_arg_count = 0; - while(p && p->car) { - apply_arg_count++; - p = p->cdr; - } - Obj **apply_args = NULL; - if(apply_arg_count > 0) { - apply_args = malloc(sizeof(Obj *) * apply_arg_count); - } - Obj *q = args[1]; - for(int i = 0; i < apply_arg_count; i++) { - apply_args[i] = q->car; - q = q->cdr; - } - apply(process, args[0], apply_args, apply_arg_count); - free(apply_args); - return stack_pop(process); -} - -Obj *p_type(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - printf("'type' takes one argument.\n"); - return nil; - } - if(args[0]->tag == 'S') { - return type_string; - } - else if(args[0]->tag == 'I') { - return type_int; - } - else if(args[0]->tag == 'V') { - return type_float; - } - else if(args[0]->tag == 'W') { - return type_double; - } - else if(args[0]->tag == 'C') { - return type_list; - } - else if(args[0]->tag == 'L') { - return type_lambda; - } - else if(args[0]->tag == 'P') { - return type_primop; - } - else if(args[0]->tag == 'F') { - return type_foreign; - } - else if(args[0]->tag == 'E') { - return type_env; - } - else if(args[0]->tag == 'Y') { - return type_symbol; - } - else if(args[0]->tag == 'K') { - return type_keyword; - } - else if(args[0]->tag == 'Q') { - return type_ptr; - } - else if(args[0]->tag == 'M') { - return type_macro; - } - else if(args[0]->tag == 'T') { - return type_char; - } - else if(args[0]->tag == 'A') { - return type_array; - } - else if(args[0]->tag == 'B') { - return type_bool; - } - else if(args[0]->tag == 'R') { - return type_ptr_to_global; - } - else { - printf("Unknown type tag: %c\n", args[0]->tag); - //eval_error = obj_new_string("Unknown type."); - return nil; - } -} - -Obj *p_lt(Process *process, Obj **args, int arg_count) { - if(arg_count == 0) { - return lisp_true; - } - if(args[0]->tag == 'I') { - int smallest = args[0]->i; - for(int i = 1; i < arg_count; i++) { - assert_or_set_error_return_nil(args[i]->tag == 'I', "< for ints called with non-int: ", args[0]); - if(smallest >= args[i]->i) { - return lisp_false; - } - smallest = args[i]->i; - } - return lisp_true; - } - else if(args[0]->tag == 'V') { - float smallest = args[0]->f32; - for(int i = 1; i < arg_count; i++) { - assert_or_set_error_return_nil(args[i]->tag == 'V', "< for floats called with non-float: ", args[0]); - if(smallest >= args[i]->f32) { - return lisp_false; - } - smallest = args[i]->f32; - } - return lisp_true; - } - else if(args[0]->tag == 'W') { - double smallest = args[0]->f64; - for(int i = 1; i < arg_count; i++) { - assert_or_set_error_return_nil(args[i]->tag == 'W', "< for doubles called with non-double: ", args[0]); - if(smallest >= args[i]->f64) { - return lisp_false; - } - smallest = args[i]->f64; - } - return lisp_true; - } - else { - eval_error = obj_new_string("Can't call < on non-numbers."); - return lisp_false; - } -} - -/* - int current_timestamp() { - struct timeval te; - gettimeofday(&te, NULL); // get current time - long long milliseconds = te.tv_sec * 1000LL + te.tv_usec / 1000; // calculate milliseconds - return milliseconds; - } -*/ - -Obj *p_now(Process *process, Obj **args, int arg_count) { - if(arg_count != 0) { - printf("Wrong argument count to 'now'\n"); - return nil; - } - return obj_new_int(carp_millitime()); -} - -Obj *p_name(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - eval_error = obj_new_string("Wrong arg count to 'name'."); - return nil; - } - if(args[0]->tag != 'S' && args[0]->tag != 'Y' && args[0]->tag != 'K') { - Obj *s = obj_new_string("Argument to 'name' must be string, keyword or symbol: "); - shadow_stack_push(process, s); - obj_string_mut_append(s, obj_to_string(process, args[0])->s); - eval_error = s; - shadow_stack_pop(process); - return nil; - } - return obj_new_string(args[0]->s); -} - -Obj *p_symbol(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - eval_error = obj_new_string("Wrong arg count to 'symbol'."); - return nil; - } - if(args[0]->tag != 'S') { - Obj *s = obj_new_string("Argument to 'symbol' must be string: "); - shadow_stack_push(process, s); - obj_string_mut_append(s, obj_to_string(process, args[0])->s); - eval_error = s; - shadow_stack_pop(process); - return nil; - } - return obj_new_symbol(args[0]->s); -} - -Obj *p_keyword(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - eval_error = obj_new_string("Wrong arg count to 'keyword'."); - return nil; - } - if(args[0]->tag != 'S') { - Obj *s = obj_new_string("Argument to 'keyword' must be string: "); - shadow_stack_push(process, s); - obj_string_mut_append(s, obj_to_string(process, args[0])->s); - eval_error = s; - shadow_stack_pop(process); - return nil; - } - return obj_new_keyword(args[0]->s); -} - -Obj *p_error(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - eval_error = obj_new_string("Wrong argument count to 'error'\n"); - return nil; - } - eval_error = args[0]; - return nil; -} - -Obj *p_env(Process *process, Obj **args, int arg_count) { -#if BYTECODE_EVAL - return process->frames[process->frame].env; -#else - return process->global_env->bindings; -#endif -} - -Obj *p_def_QMARK(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - eval_error = obj_new_string("Wrong argument count to 'def?'\n"); - return nil; - } - if(args[0]->tag != 'Y') { - eval_error = obj_new_string("Must send symbol to 'def?'\n"); - return nil; - } - Obj *binding = env_lookup_binding(process, process->global_env, args[0]); - if(binding && binding->car && binding->cdr) { - //printf("Binding exists: %s\n", obj_to_string(process, binding)->s); - return lisp_true; - } - else { - return lisp_false; - } -} - -Obj *p_load_lisp(Process *process, Obj **args, int arg_count) { - Obj *file_string = open_file(process, args[0]->s); - shadow_stack_push(process, file_string); - if(file_string->tag == 'S') { - Obj *forms = read_string(process, process->global_env, file_string->s, args[0]); - shadow_stack_push(process, forms); - Obj *form = forms; - while(form && form->car) { -#if BYTECODE_EVAL - /* Obj *discarded_result = */ bytecode_sub_eval_form(process, process->global_env, form->car); -#else - eval_internal(process, process->global_env, form->car); - /*Obj *discarded_result = */ stack_pop(process); -#endif - if(eval_error) { - return nil; - } - form = form->cdr; - } - shadow_stack_pop(process); // forms - } - shadow_stack_pop(process); // file_string - return nil; -} - -Obj *p_load_dylib(Process *process, Obj **args, int arg_count) { - char *filename = args[0]->s; - carp_library_t handle = carp_load_library(filename); - if(!handle) { - set_error_and_return("Failed to open dylib: ", args[0]); - return nil; - } - const char *load_error; - if((load_error = carp_get_load_library_error()) != NULL) { - set_error_and_return("Failed to load dylib: ", args[0]); - } - //printf("dlopen %p\n", handle); - return obj_new_dylib(handle); -} - -Obj *p_unload_dylib(Process *process, Obj **args, int arg_count) { - //assert_or_return_nil(arg_count == 1, "'unload-dylib' must take one argument."); - //assert_or_return_nil(args[0]->tag, "'unload-dylib' must take dylib as argument.", args[0]); - if(!(args[0]->tag == 'D')) { - set_error_and_return("unload-dylib takes a dylib as argument: ", args[0]); - return nil; - } - carp_library_t handle = args[0]->dylib; - if(!handle) { - return obj_new_symbol("no handle to unload"); - } - //printf("dlclose %p\n", handle); - int result = carp_unload_library(handle); - if(result) { - eval_error = obj_new_string(carp_get_load_library_error()); - return nil; - } - else { - return obj_new_keyword("done"); - } -} - -Obj *p_read(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - set_error_and_return("'read' takes one argument: ", args[0]); - return nil; - } - if(args[0]->tag != 'S') { - set_error_and_return("'read' takes a string as argument: ", args[0]); - return nil; - } - Obj *forms = read_string(process, process->global_env, args[0]->s, obj_new_string("p_read")); - return forms->car; -} - -Obj *p_read_many(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - set_error_and_return("'read-many' takes one argument: ", args[0]); - return nil; - } - if(args[0]->tag != 'S') { - set_error_and_return("'read-many' takes a string as argument: ", args[0]); - return nil; - } - Obj *forms = read_string(process, process->global_env, args[0]->s, obj_new_string("p_read_many")); - return forms; -} - -Obj *p_eval(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - eval_error = obj_new_string("Wrong argument count to 'eval'"); - return nil; - } - shadow_stack_push(process, args[0]); - -#if BYTECODE_EVAL - - Obj *result = bytecode_sub_eval_form(process, process->global_env, args[0]); - shadow_stack_pop(process); - return result; - -#else - - eval_internal(process, process->global_env, args[0]); - Obj *result = stack_pop(process); - shadow_stack_pop(process); - return result; - -#endif -} - -Obj *p_code(Process *process, Obj **args, int arg_count) { - if(args[0]->tag != 'L' && args[0]->tag != 'M') { - set_error_and_return("'code' must take lambda/macro as argument: ", args[0]); - } - if(!args[0]->code) { - set_error_and_return("code of lambda/macro is NULL: ", args[0]); - } - Obj *code = args[0]->code; - return code; -} - -ffi_type *lisp_type_to_ffi_type(Process *process, Obj *type_obj) { - - // Is it a ref type? (borrowed) - if(type_obj->tag == 'C' && type_obj->car && type_obj->cdr && type_obj->cdr->car && obj_eq(process, type_obj->car, type_ref)) { - type_obj = type_obj->cdr->car; // the second element of the list - //printf("Found ref type, inner type is: %s\n", obj_to_string(type_obj)->s); - } - - if(obj_eq(process, type_obj, type_string)) { - return &ffi_type_pointer; - } - else if(obj_eq(process, type_obj, type_int)) { - return &ffi_type_sint; - } - else if(obj_eq(process, type_obj, type_float)) { - return &ffi_type_float; - } - else if(obj_eq(process, type_obj, type_double)) { - return &ffi_type_double; - } - else if(obj_eq(process, type_obj, type_void)) { - return &ffi_type_uint; - } - else if(obj_eq(process, type_obj, type_bool)) { - return &ffi_type_uint; - } - else if(obj_eq(process, type_obj, type_char)) { - return &ffi_type_schar; - } - else { - return &ffi_type_pointer; // Assume it's a user defined type - /* error = obj_new_string("Unhandled return type for foreign function: "); */ - /* obj_string_mut_append(error, obj_to_string(type_obj)->s); */ - /* return NULL; */ - } -} - -char *lispify(char *name) { - char *s0 = str_replace(name, "_", "-"); - char *s1 = str_replace(s0, "BANG", "!"); - char *s2 = str_replace(s1, "QMARK", "?"); - char *s3 = str_replace(s2, "PTR", "*"); - char *s4 = str_replace(s3, "LT", "<"); - char *s5 = str_replace(s4, "GT", ">"); - char *s6 = str_replace(s5, "EQ", "="); - free(s0); - free(s1); - free(s2); - free(s3); - free(s4); - free(s5); - return s6; -} - -ffi_type **make_arg_type_array(Process *process, Obj *args, int arg_count, char *func_name) { - ffi_type **arg_types_c_array = malloc(sizeof(ffi_type *) * (arg_count + 1)); - - Obj *p = args; - for(int i = 0; i < arg_count; i++) { - ffi_type *arg_type = lisp_type_to_ffi_type(process, p->car); - if(!arg_type) { - free(arg_types_c_array); - char buffer[512]; - snprintf(buffer, 512, "Arg %d for function %s has invalid type: %s\n", i, func_name, obj_to_string(process, p->car)->s); - eval_error = obj_new_string(strdup(buffer)); - return NULL; - } - arg_types_c_array[i] = arg_type; - p = p->cdr; - } - arg_types_c_array[arg_count] = NULL; // ends with a NULL so we don't need to store arg_count - return arg_types_c_array; -} - -ffi_cif *create_cif(Process *process, Obj *args, int arg_count, Obj *return_type_obj, char *func_name) { - ffi_type **arg_types_c_array = make_arg_type_array(process, args, arg_count, func_name); - - if(!arg_types_c_array) { - return NULL; - } - - ffi_type *return_type = lisp_type_to_ffi_type(process, return_type_obj); - - if(!return_type) { - free(arg_types_c_array); - return NULL; - } - - //printf("Registering %s with %d args\n", func_name, arg_count); - - ffi_cif *cif = malloc(sizeof(ffi_cif)); - int init_result = ffi_prep_cif(cif, - FFI_DEFAULT_ABI, - arg_count, - return_type, - arg_types_c_array); - - if(init_result != FFI_OK) { - printf("Registration of foreign function %s failed.\n", func_name); - return NULL; - } - - return cif; -} - -Obj *register_ffi_internal(Process *process, char *name, VoidFn funptr, Obj *args, Obj *return_type_obj, bool builtin) { - - if(!funptr) { - printf("funptr for %s is NULL\n", name); - return nil; - } - - int arg_count = 0; - Obj *p = args; - while(p && p->car) { - p = p->cdr; - arg_count++; - } - //printf("Arg count for %s: %d\n", name, arg_count); - - ffi_cif *cif = create_cif(process, args, arg_count, return_type_obj, name); - if(!cif) { - return nil; - } - - //printf("Registration of '%s' OK.\n", name); - - Obj *ffi = obj_new_ffi(name, cif, funptr, args, return_type_obj); - - if(!ffi->meta) { - ffi->meta = obj_new_environment(NULL); - } - env_assoc(process, ffi->meta, obj_new_keyword("name"), obj_new_string(name)); - - char *lispified_name = lispify(name); - //printf("Registering %s\n", lispified_name); - - global_env_extend(process, obj_new_symbol(lispified_name), ffi); - - return ffi; -} - -Obj *register_ffi_variable_internal(Process *process, char *name, void *varptr, Obj *var_type_obj) { - - if(!varptr) { - printf("varptr for %s is NULL\n", name); - return nil; - } - - /* Obj *new_variable_value; */ - - /* if(obj_eq(process, var_type_obj, type_int)) { */ - /* int *i = varptr; */ - /* new_variable_value = obj_new_int(*i); */ - /* } */ - /* else { */ - /* eval_error = obj_new_string("Invalid variable type."); */ - /* return nil; */ - /* } */ - - /* Obj *ovar = primitive_to_obj(varptr, var_type_obj); */ - /* printf("ovar = %s\n", obj_to_string(ovar)->s); */ - - Obj *variable_ptr = obj_new_ptr_to_global(varptr); - obj_set_meta(variable_ptr, obj_new_keyword("type"), var_type_obj); - - char *lispified_name = lispify(name); - //printf("Registering variable %s\n", lispified_name); - global_env_extend(process, obj_new_symbol(lispified_name), variable_ptr); - - return variable_ptr; -} - -// (register ) -Obj *p_register(Process *process, Obj **args, int arg_count) { - if(arg_count != 4 || args[0]->tag != 'D' || args[1]->tag != 'S' || args[2]->tag != 'C') { - printf("Args to register must be: (handle, function-name, argument-types, return-type)"); - printf("Arg count: %d\n", arg_count); - printf("Args %c %c %c %c\n", args[0]->tag, args[1]->tag, args[2]->tag, args[3]->tag); - return nil; - } - carp_library_t handle = args[0]->dylib; - char *name = args[1]->s; - - VoidFn f = carp_find_symbol(handle, name); - - if(!f) { - printf("Failed to load dynamic C function with name '%s' from %s\n", name, obj_to_string(process, args[0])->s); - return nil; - } - - return register_ffi_internal(process, name, f, args[2], args[3], false); -} - -Obj *p_register_variable(Process *process, Obj **args, int arg_count) { - if(arg_count != 3 || args[0]->tag != 'D' || args[1]->tag != 'S') { - printf("Args to register-variable must be: (handle, variable-name, type)"); - printf("Arg count: %d\n", arg_count); - printf("Args %c %c %c\n", args[0]->tag, args[1]->tag, args[2]->tag); - return nil; - } - - carp_library_t handle = args[0]->dylib; - char *name = args[1]->s; - - void *variable = carp_find_symbol(handle, name); - - if(!variable) { - printf("Failed to load dynamic C variable with name '%s' from %s\n", name, obj_to_string(process, args[0])->s); - return nil; - } - - return register_ffi_variable_internal(process, name, variable, args[2]); -} - -Obj *p_register_builtin(Process *process, Obj **args, int arg_count) { - if(arg_count != 3 || args[0]->tag != 'S' || args[1]->tag != 'C') { - printf("Args to register-builtin must be: (function-name, argument-types, return-type)\n"); - printf("Arg count: %d\n", arg_count); - printf("Args %c %c %c\n", args[0]->tag, args[1]->tag, args[2]->tag); - return nil; - } - char *name = args[0]->s; - VoidFn f = carp_find_symbol(NULL, name); - - if(!f) { - printf("Failed to load dynamic C function with name '%s' from executable.\n", name); - return nil; - } - - return register_ffi_internal(process, name, f, args[1], args[2], true); -} - -Obj *p_meta_set_BANG(Process *process, Obj **args, int arg_count) { - if(arg_count != 3) { - eval_error = obj_new_string("Invalid argument to meta-set!"); - return nil; - } - Obj *o = args[0]; - if(!o->meta) { - o->meta = obj_new_environment(NULL); - } - env_assoc(process, o->meta, args[1], args[2]); - return o; -} - -Obj *p_meta_get(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - eval_error = obj_new_string("Invalid argument to meta-get"); - return nil; - } - Obj *o = args[0]; - if(o->meta) { - Obj *lookup = env_lookup(process, o->meta, args[1]); - if(lookup) { - return lookup; - } - else { - return nil; - } - } - else { - return nil; - } -} - -Obj *p_meta_get_all(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - eval_error = obj_new_string("Invalid argument to meta-get-all"); - return nil; - } - Obj *o = args[0]; - if(o->meta) { - return o->meta; - } - else { - return nil; - } -} - -Obj *p_array_to_list(Process *process, Obj **args, int arg_count) { - Obj *a = args[0]; - assert_or_set_error_return_nil(a->tag == 'A', "array-to-list must take array as argument: ", args[0]); - Obj *list = obj_new_cons(NULL, NULL); - Obj *prev = list; - for(int i = 0; i < a->count; i++) { - Obj *new = obj_new_cons(NULL, NULL); - prev->car = a->array[i]; - prev->cdr = new; - prev = new; - } - return list; -} - -/* Obj *p_array(Process *process, Obj** args, int arg_count) { */ -/* Obj *new_array = obj_new_array(arg_count); */ -/* for(int i = 0; i < arg_count; i++) { */ -/* new_array->array[i] = args[i]; */ -/* } */ -/* return new_array; */ -/* } */ - -Obj *p_array_of_size(Process *process, Obj **args, int arg_count) { - int array_count = args[0]->i; - Obj *new_array = obj_new_array(array_count); - for(int i = 0; i < array_count; i++) { - new_array->array[i] = nil; - } - return new_array; -} - -Obj *p_array_set_BANG(Process *process, Obj **args, int arg_count) { - assert_or_set_error_return_nil(arg_count == 3, "array-set! must take 3 arguments: ", args[0]); - Obj *a = args[0]; - assert_or_set_error_return_nil(a->tag == 'A', "array-set! must take an array as first arg: ", args[0]); - Obj *i = args[1]; - assert_or_set_error_return_nil(i->tag == 'I', "array-set! must take an int as second arg: ", args[1]); - Obj *o = args[2]; - a->array[i->i] = o; - return nil; -} - -Obj *p_array_set(Process *process, Obj **args, int arg_count) { - assert_or_set_error_return_nil(arg_count == 3, "array-set must take 3 arguments: ", args[0]); - Obj *a = args[0]; - assert_or_set_error_return_nil(a->tag == 'A', "array-set must take an array as first arg: ", args[0]); - Obj *i = args[1]; - assert_or_set_error_return_nil(i->tag == 'I', "array-set must take an int as second arg: ", args[1]); - Obj *o = args[2]; - Obj *new_array = obj_copy(process, a); - new_array->array[i->i] = o; - return new_array; -} - -/* Obj *p_new(Process *process, Obj** args, int arg_count) { */ -/* // This is used for baking of struct constructors */ -/* eval_error = obj_new_string("The primop 'new' should never be called in dynamic code."); */ -/* return nil; */ -/* } */ - -Obj *p_gc(Process *process, Obj **args, int arg_count) { - gc(process); - return nil; -} - -Obj *p_delete(Process *process, Obj **args, int arg_count) { - // no op? - return nil; -} - -Obj *p_stop(Process *process, Obj **args, int arg_count) { - process->dead = true; - return nil; -} - -Obj *p_parallell(Process *process, Obj **args, int arg_count) { - parallell = process_clone(process); - process_eval(parallell, args[0]); - return nil; -} - -Obj *p_bytecode(Process *process, Obj **args, int arg_count) { - assert_or_set_error_return_nil(arg_count == 1, "bytecode must take 1 arguments. ", nil); - Obj *bytecode = form_to_bytecode(process, process->global_env, args[0], false); - return bytecode; -} - -Obj *p_bytecode_eval(Process *process, Obj **args, int arg_count) { - assert_or_set_error_return_nil(arg_count == 1, "eval-bytecode must take 1 arguments. ", nil); - Obj *bytecode = args[0]; - return bytecode_eval_bytecode_in_env(process, bytecode, process->global_env, NULL); -} - -Obj *p_lookup_in_substs_fast(Process *process, Obj **args, int arg_count) { - assert_or_set_error_return_nil(arg_count == 2, "lookup-in-substs-fast must take 2 arguments. ", nil); - Obj *substs = args[0]; - Obj *b = args[1]; - - if(substs->tag == 'K' && strcmp(substs->s, "fail")) { - return substs; - } - else if(substs->tag == 'E') { - if(b->tag == 'C') { - Obj *list = obj_new_cons(NULL, NULL); - shadow_stack_push(process, list); - Obj *prev = list; - int shadow_count = 0; - Obj *p = b; - while(p && p->car) { - Obj *args[2] = {substs, p->car}; - prev->car = p_lookup_in_substs_fast(process, args, 2); - Obj *new = obj_new_cons(NULL, NULL); - shadow_stack_push(process, new); - shadow_count++; - prev->cdr = new; - prev = new; - p = p->cdr; - } - for(int i = 0; i < shadow_count; i++) { - shadow_stack_pop(process); - } - shadow_stack_pop(process); // list - return list; - } - else { - Obj *result = NULL; - shadow_stack_push(process, substs); - shadow_stack_push(process, b); - Obj *lookup = env_lookup(process, substs, b); - if(lookup) { - if(obj_eq(process, b, lookup)) { - result = lookup; - } - else { - if(lookup->tag == 'S') { - Obj *args[2] = {substs, lookup}; - result = p_lookup_in_substs_fast(process, args, 2); - } - else { - result = lookup; - } - } - } - else { - result = b; - } - shadow_stack_pop(process); - shadow_stack_pop(process); - return result; - } - } - else { - set_error_return_nil("First arg to lookup-in-substs-fast must be a dictionary: ", substs); - } - assert(false); -} - -void replace_from_right_in_list(Process *process, Obj *list, Obj *existing, Obj *new_value) { - Obj *listp = list; - while(listp && listp->car) { - Obj *value = listp->car; - - if(value->tag == 'C') { - replace_from_right_in_list(process, value, existing, new_value); - } - else if(obj_eq(process, value, existing)) { - listp->car = new_value; - } - else { - // do nothing - } - - listp = listp->cdr; - } -} - -Obj *p_replace_subst_from_right_fast(Process *process, Obj **args, int arg_count) { - assert_or_set_error_return_nil(arg_count == 3, "replace-substs-from-right-fast must take 3 arguments. ", nil); - assert_or_set_error_return_nil(args[0]->tag == 'E', "First argument to lookup-in-substs-fast must be dictionary. ", args[0]); - - Obj *mut_substs = obj_copy(process, args[0]); // COPY! - Obj *existing = args[1]; - Obj *new_value = args[2]; - - shadow_stack_push(process, mut_substs); - - Obj *bindings = mut_substs->bindings; - Obj *p = bindings; - while(p && p->car) { - Obj *pair = p->car; - Obj *value = pair->cdr; - - if(value->tag == 'C') { - replace_from_right_in_list(process, value, existing, new_value); - } - else if(obj_eq(process, value, existing)) { - pair->cdr = new_value; - } - else { - // do nothing - } - - p = p->cdr; - } - - shadow_stack_pop(process); // mut_substs - - return mut_substs; -} - -Obj *p_types_exactly_eq(Process *process, Obj **args, int arg_count) { - assert_or_set_error_return_nil(arg_count == 2, "types-exactly-eq? must take 2 arguments. ", nil); - Obj *a = args[0]; - Obj *b = args[1]; - if(a->tag == 'C' && b->tag == 'C') { - Obj *p = a; - Obj *p2 = b; - while(p && p->car) { - if(!p2 || !p2->car) { - return lisp_false; - } - Obj *inner_args[2] = {p->car, p2->car}; - Obj *result = p_types_exactly_eq(process, inner_args, 2); - if(result == lisp_false) { - return lisp_false; - } - p = p->cdr; - p2 = p2->cdr; - } - return lisp_true; - } - else if(a->tag == 'K' && strcmp(a->s, "any") == 0) { - return lisp_true; - } - else if(b->tag == 'K' && strcmp(b->s, "any") == 0) { - return lisp_true; - } - else { - return obj_eq(process, a, b) ? lisp_true : lisp_false; - } -} - -Obj *p_extend_substitutions_fast(Process *process, Obj **args, int arg_count) { - assert_or_set_error_return_nil(arg_count == 3, "extend-substitutions-fast must take 3 arguments. ", nil); - - Obj *substs = args[0]; - Obj *lhs = args[1]; - Obj *value = args[2]; - - if(substs->tag == 'K' && strcmp(substs->s, "fail")) { - printf("FAIL\n"); - return substs; - } - else { - Obj *result = NULL; - //printf("substs: %s\n", obj_to_string(process, substs)->s); - Obj *lookup_args[2] = {substs, value}; - Obj *lookup = p_lookup_in_substs_fast(process, lookup_args, 2); - - shadow_stack_push(process, lookup); - shadow_stack_push(process, lhs); - shadow_stack_push(process, value); - - /* printf("Will extend %s with %s, lookup: %s, substs:\n%s\n\n", */ - /* obj_to_string(process, lhs)->s, */ - /* obj_to_string(process, value)->s, */ - /* obj_to_string(process, lookup)->s, */ - /* obj_to_string(process, substs)->s); */ - - if(lhs->tag == 'S') { - //printf("lhs is a typevar\n"); - Obj *existing = env_lookup(process, substs, lhs); - if(existing == NULL) { - //printf("not existing\n"); - Obj *new_substs = env_assoc(process, substs, lhs, lookup); - Obj *replace_args[3] = {new_substs, existing, lookup}; - result = p_replace_subst_from_right_fast(process, replace_args, 3); - } - else { - //printf("lhs exists\n"); - - if(existing->tag == 'C') { - //printf("existing is a list\n"); - - if(lookup->tag == 'C') { - //printf("lookup is a list\n"); - - Obj *final_substs = substs; - Obj *p1 = existing; - Obj *p2 = lookup; - while(p1 && p1->car) { - assert(p2); - assert(p2->car); - - if(final_substs->tag == 'K' && strcmp(final_substs->s, "fail") == 0) { - result = final_substs; - break; - } - - Obj *extend_args[3] = {final_substs, p1->car, p2->car}; - final_substs = p_extend_substitutions_fast(process, extend_args, 3); - - p1 = p1->cdr; - p2 = p2->cdr; - } - result = final_substs; - } - else { - //printf("lookup is not a list\n"); - result = substs; - } - } - else if(existing->tag == 'S') { - //printf("existing is a typevar\n"); - Obj *replace_args[3] = {substs, existing, lookup}; - result = p_replace_subst_from_right_fast(process, replace_args, 3); - } - else if(lookup->s) { - result = substs; - } - else if(lhs->tag == 'K' && strcmp(lhs->s, "any") == 0) { - result = substs; - } - else { - //printf("existing is a not a typevar or list\n"); - // The existing binding is not a typevar, must match exactly or the unification will fail - Obj *exactly_eq_args[2] = {existing, lookup}; - Obj *are_eq = p_types_exactly_eq(process, exactly_eq_args, 2); - if(are_eq == lisp_true) { - result = substs; - } - else { - //printf("FAIL in typevar, else\n"); - result = obj_new_keyword("fail"); - } - } - } - } - else { - // lhs is not a typevar - //printf("lhs is not a typevar: %s\n", obj_to_string(process, lhs)->s); - - if(lhs->tag == 'C') { - //printf("lhs is a list\n"); - - if(lookup->tag == 'C') { - //printf("lookup is a list\n"); - - Obj *final_substs = substs; - Obj *p1 = lhs; - Obj *p2 = lookup; - - /* printf("substs: %s\n", obj_to_string(process, final_substs)->s); */ - /* printf("p1: %s\n", obj_to_string(process, p1)->s); */ - /* printf("p2: %s\n", obj_to_string(process, p2)->s); */ - - while(p1 && p1->car) { - assert(p2); - assert(p2->car); - - if(final_substs->tag == 'K' && strcmp(final_substs->s, "fail") == 0) { - result = final_substs; - break; - } - - // (extend-substitutions-fast {"b" (list "t0" "t1")} (list :int "x") "b") - - Obj *extend_args[3] = {final_substs, p1->car, p2->car}; - final_substs = p_extend_substitutions_fast(process, extend_args, 3); - - //shadow_stack_push(process, final_substs); - //printf("new final substs: %s %c\n", obj_to_string(process, final_substs)->s, final_substs->tag); - - p1 = p1->cdr; - p2 = p2->cdr; - } - result = final_substs; - } - else { - //printf("lookup is NOT a list\n"); - result = substs; - } - } - else { - //printf("lhs is NOT a list\n"); - - if(obj_eq(process, lhs, lookup)) { - result = substs; - } - else if(lookup->tag == 'S') { - result = substs; // WHY IS THIS CASE NECESSARY?! make it not so... - } - else if(lookup->tag == 'K' && strcmp(lookup->s, "any") == 0) { - result = substs; - } - else if(lhs->tag == 'K' && strcmp(lhs->s, "any") == 0) { - result = substs; - } - else { - //printf("FAIL in not typevar, not list\n"); - result = obj_new_keyword("fail"); - } - } - } - - shadow_stack_pop(process); // value - shadow_stack_pop(process); // lhs - shadow_stack_pop(process); // lookup - - //printf("result = %s\n", obj_to_string(process, result)->s); - return result; - } -} - -Obj *sort_internal(Process *process, Obj *f, Obj *xs) { - Obj *left = obj_new_cons(NULL, NULL); - Obj *right = obj_new_cons(NULL, NULL); - Obj *left_prev = left; - Obj *right_prev = right; - Obj *sorted = NULL; - - if(!xs->car) { - printf("nil\n"); - return nil; - } - else if(xs->cdr == NULL) { - //printf("will print\n"); - printf("single value: %s\n", obj_to_string(process, xs->car)->s); - //printf("did print\n"); - return xs->car; - } - - shadow_stack_push(process, left); - shadow_stack_push(process, right); - - Obj *mid = xs->car; - //printf("mid: %s\n", obj_to_string(process, xs->car)->s); - - Obj *p = xs->cdr; - while(p && p->car) { - - Obj *arg[2] = {p->car, mid}; - apply(process, f, arg, 2); - Obj *result = stack_pop(process); - Obj *new = obj_new_cons(NULL, NULL); - - printf("p->car: %s\n", obj_to_string(process, p->car)->s); - - if(is_true(result)) { - left_prev->car = p->car; - left_prev->cdr = new; - left_prev = new; - } - else { - right_prev->car = p->car; - right_prev->cdr = new; - right_prev = new; - } - - p = p->cdr; - } - - shadow_stack_push(process, left); - shadow_stack_push(process, right); - - /* printf("left: %s\n", obj_to_string(process, left)->s); */ - /* printf("right: %s\n", obj_to_string(process, right)->s); */ - - Obj *sorted_left = sort_internal(process, f, left); - Obj *sorted_right = sort_internal(process, f, right); - - /* printf("sorted_left: %s\n", obj_to_string(process, sorted_left)->s); */ - /* printf("sorted_right: %s\n", obj_to_string(process, sorted_right)->s); */ - - //printf("%c %c\n", sorted_left->tag, sorted_right->tag); - - shadow_stack_push(process, sorted_left); - shadow_stack_push(process, sorted_right); - - Obj *args[3] = {sorted_left, obj_new_cons(mid, nil), sorted_right}; - - assert_or_set_error_return_nil(sorted_left->tag == 'C', "sorted left is not list: ", sorted_left); - assert_or_set_error_return_nil(sorted_right->tag == 'C', "sorted right is not list: ", sorted_right); - - sorted = p_concat(process, args, 3); - - shadow_stack_pop(process); - shadow_stack_pop(process); - shadow_stack_pop(process); - shadow_stack_pop(process); - shadow_stack_pop(process); - shadow_stack_pop(process); - - assert(sorted); - return sorted; -} - -Obj *p_sort_by(Process *process, Obj **args, int arg_count) { - if(arg_count != 2) { - eval_error = obj_new_string("Wrong argument count to 'sort-by'."); - return nil; - } - if(!is_callable(args[0])) { - set_error_return_nil("'sort-by' requires arg 0 to be a function or lambda: \n", args[0]); - } - Obj *f = args[0]; - Obj *xs = args[1]; - Obj *result = sort_internal(process, f, xs); - return result; -} - -Obj *p_hash(Process *process, Obj **args, int arg_count) { - if(arg_count != 1) { - eval_error = obj_new_string("Wrong argument count to 'hash'."); - return nil; - } - return obj_new_int(obj_hash(process, args[0])); -} - -/* shadow_stack_push(process, list); */ - -/* int shadow_count = 0; */ -/* Obj *p = b; */ -/* while(p && p->car) { */ -/* Obj *args[2] = { substs, p->car }; */ -/* prev->car = p_lookup_in_substs_fast(process, args, 2); */ -/* Obj *new = obj_new_cons(NULL, NULL); */ -/* shadow_stack_push(process, new); */ -/* shadow_count++; */ -/* prev->cdr = new; */ -/* prev = new; */ -/* p = p->cdr; */ -/* } */ diff --git a/src/primops.h b/src/primops.h deleted file mode 100644 index 2fcc1816e..000000000 --- a/src/primops.h +++ /dev/null @@ -1,95 +0,0 @@ -#pragma once - -#include "obj.h" - -void register_primop(Process *process, char *name, Primop primop); - -// PLEASE NOTE -// All primops must be very careful to put any temp variables on the shadow stack. -// All calls to the rest of the lisp system might trigger GC and remove the fresh locals! - -Obj *p_open_file(Process *process, Obj **args, int arg_count); -Obj *p_save_file(Process *process, Obj **args, int arg_count); -Obj *p_add(Process *process, Obj **args, int arg_count); -Obj *p_sub(Process *process, Obj **args, int arg_count); -Obj *p_mul(Process *process, Obj **args, int arg_count); -Obj *p_div(Process *process, Obj **args, int arg_count); -//Obj *p_mod(Process *process, Obj** args, int arg_count); -Obj *p_eq(Process *process, Obj **args, int arg_count); -Obj *p_list(Process *process, Obj **args, int arg_count); -Obj *p_array(Process *process, Obj **args, int arg_count); -Obj *p_dictionary(Process *process, Obj **args, int arg_count); -Obj *p_def_QMARK(Process *process, Obj **args, int arg_count); -Obj *p_str(Process *process, Obj **args, int arg_count); -Obj *p_str_append_bang(Process *process, Obj **args, int arg_count); -Obj *p_join(Process *process, Obj **args, int arg_count); -Obj *p_str_replace(Process *process, Obj **args, int arg_count); -Obj *p_copy(Process *process, Obj **args, int arg_count); -Obj *p_print(Process *process, Obj **args, int arg_count); -Obj *p_prn(Process *process, Obj **args, int arg_count); -Obj *p_println(Process *process, Obj **args, int arg_count); -Obj *p_system(Process *process, Obj **args, int arg_count); -Obj *p_get(Process *process, Obj **args, int arg_count); -Obj *p_get_maybe(Process *process, Obj **args, int arg_count); -Obj *p_dict_set_bang(Process *process, Obj **args, int arg_count); -Obj *p_dict_remove_bang(Process *process, Obj **args, int arg_count); -Obj *p_rest(Process *process, Obj **args, int arg_count); -Obj *p_cons(Process *process, Obj **args, int arg_count); -Obj *p_cons_last(Process *process, Obj **args, int arg_count); -Obj *p_concat(Process *process, Obj **args, int arg_count); -Obj *p_nth(Process *process, Obj **args, int arg_count); -Obj *p_count(Process *process, Obj **args, int arg_count); -Obj *p_map(Process *process, Obj **args, int arg_count); -Obj *p_map2(Process *process, Obj **args, int arg_count); -Obj *p_register(Process *process, Obj **args, int arg_count); -Obj *p_register_variable(Process *process, Obj **args, int arg_count); -Obj *p_register_builtin(Process *process, Obj **args, int arg_count); -Obj *p_first(Process *process, Obj **args, int arg_count); -Obj *p_filter(Process *process, Obj **args, int arg_count); -Obj *p_reduce(Process *process, Obj **args, int arg_count); -Obj *p_apply(Process *process, Obj **args, int arg_count); -Obj *p_type(Process *process, Obj **args, int arg_count); -Obj *p_lt(Process *process, Obj **args, int arg_count); -Obj *p_env(Process *process, Obj **args, int arg_count); -Obj *p_load_lisp(Process *process, Obj **args, int arg_count); -Obj *p_load_dylib(Process *process, Obj **args, int arg_count); -Obj *p_unload_dylib(Process *process, Obj **args, int arg_count); -Obj *p_read(Process *process, Obj **args, int arg_count); -Obj *p_read_many(Process *process, Obj **args, int arg_count); -Obj *p_code(Process *process, Obj **args, int arg_count); -Obj *p_now(Process *process, Obj **args, int arg_count); -Obj *p_name(Process *process, Obj **args, int arg_count); -Obj *p_symbol(Process *process, Obj **args, int arg_count); -Obj *p_keyword(Process *process, Obj **args, int arg_count); -Obj *p_error(Process *process, Obj **args, int arg_count); -Obj *p_keys(Process *process, Obj **args, int arg_count); -Obj *p_values(Process *process, Obj **args, int arg_count); -Obj *p_signature(Process *process, Obj **args, int arg_count); -Obj *p_eval(Process *process, Obj **args, int arg_count); -Obj *p_builtin_p(Process *process, Obj **args, int arg_count); -Obj *p_meta_set_BANG(Process *process, Obj **args, int arg_count); -Obj *p_meta_get(Process *process, Obj **args, int arg_count); -Obj *p_meta_get_all(Process *process, Obj **args, int arg_count); -Obj *p_array_to_list(Process *process, Obj **args, int arg_count); -Obj *p_spork(Process *process, Obj **args, int arg_count); -Obj *p_array_of_size(Process *process, Obj **args, int arg_count); -//Obj *p_array(Process *process, Obj** args, int arg_count); -Obj *p_array_set_BANG(Process *process, Obj **args, int arg_count); -Obj *p_array_set(Process *process, Obj **args, int arg_count); -//Obj *p_new(Process *process, Obj** args, int arg_count); -Obj *p_gc(Process *process, Obj **args, int arg_count); -Obj *p_delete(Process *process, Obj **args, int arg_count); -Obj *p_stop(Process *process, Obj **args, int arg_count); -Obj *p_parallell(Process *process, Obj **args, int arg_count); -Obj *p_bytecode(Process *process, Obj **args, int arg_count); -Obj *p_bytecode_eval(Process *process, Obj **args, int arg_count); -Obj *p_lookup_in_substs_fast(Process *process, Obj **args, int arg_count); -Obj *p_replace_subst_from_right_fast(Process *process, Obj **args, int arg_count); -Obj *p_types_exactly_eq(Process *process, Obj **args, int arg_count); -Obj *p_extend_substitutions_fast(Process *process, Obj **args, int arg_count); -Obj *p_sort_by(Process *process, Obj **args, int arg_count); -Obj *p_hash(Process *process, Obj **args, int arg_count); - -Obj *register_ffi_internal(Process *process, char *name, VoidFn funptr, Obj *args, Obj *return_type_obj, bool builtin); - -ffi_cif *create_cif(Process *process, Obj *args, int arg_count, Obj *return_type_obj, char *func_name); diff --git a/src/process.c b/src/process.c deleted file mode 100644 index 87b0add85..000000000 --- a/src/process.c +++ /dev/null @@ -1,374 +0,0 @@ -#include "process.h" -#include "obj_string.h" -#include "env.h" -#include "repl.h" -#include "primops.h" -#include "bytecode.h" -#include "obj_string.h" - -#define define(name, value) env_extend(process->global_env, obj_new_symbol(name), value); - -#define LOG_STACK 0 -#define LOG_SHADOW_STACK 0 - -#ifdef WIN32 -#define PROMPT "CARP> " -#define PROMPT_UNFINISHED_FORM " _> " -#else -#define PROMPT "λ> " // "\e[36mλ>\e[0m " -#define PROMPT_UNFINISHED_FORM "_> " // "\e[36m_>\e[0m " -#endif - -Process *process_new() { - Process *process = malloc(sizeof(Process)); - process->dead = false; - process->final_result = NULL; - -#if BYTECODE_EVAL - process->frame = 0; -#else - process->frame = -1; -#endif - - process->bytecodeObj = NULL; - pop_stacks_to_zero(process); - - process->global_env = obj_new_environment(NULL); - - nil = obj_new_cons(NULL, NULL); - define("nil", nil); - - lisp_false = obj_new_bool(false); - define("false", lisp_false); - - lisp_true = obj_new_bool(true); - define("true", lisp_true); - - lisp_quote = obj_new_symbol("quote"); - define("quote", lisp_quote); - - ampersand = obj_new_symbol("&"); - define("&", ampersand); - - dotdotdot = obj_new_symbol("dotdotdot"); - define("dotdotdot", dotdotdot); - - hash = obj_new_keyword("hash"); - define("hash", hash); - - lisp_NULL = obj_new_ptr(NULL); - define("NULL", lisp_NULL); - - type_ref = obj_new_keyword("ref"); - define("type_ref", type_ref); - - type_int = obj_new_keyword("int"); - define("type-int", type_int); // without this it will get GC'd! - - type_bool = obj_new_keyword("bool"); - define("type-bool", type_bool); - - type_float = obj_new_keyword("float"); - define("type-float", type_float); - - type_double = obj_new_keyword("double"); - define("type-double", type_double); - - type_string = obj_new_keyword("string"); - define("type-string", type_string); - - type_symbol = obj_new_keyword("symbol"); - define("type-symbol", type_symbol); - - type_keyword = obj_new_keyword("keyword"); - define("type-keyword", type_keyword); - - type_foreign = obj_new_keyword("foreign"); - define("type-foreign", type_foreign); - - type_primop = obj_new_keyword("primop"); - define("type-primop", type_primop); - - type_env = obj_new_keyword("env"); - define("type-env", type_env); - - type_macro = obj_new_keyword("macro"); - define("type-macro", type_macro); - - type_lambda = obj_new_keyword("lambda"); - define("type-lambda", type_lambda); - - type_list = obj_new_keyword("list"); - define("type-list", type_list); - - type_void = obj_new_keyword("void"); - define("type-void", type_void); - - type_ptr = obj_new_keyword("ptr"); - define("type-ptr", type_ptr); - - type_char = obj_new_keyword("char"); - define("type-char", type_char); - - type_array = obj_new_keyword("array"); - define("type-array", type_array); - - type_ptr_to_global = obj_new_keyword("ptr-to-global"); - define("type-ptr-to-global", type_ptr_to_global); - - prompt = define("prompt", obj_new_string(PROMPT)); - prompt_unfinished_form = define("prompt-unfinished-form", obj_new_string(PROMPT_UNFINISHED_FORM)); - - register_primop(process, "open", p_open_file); - register_primop(process, "save", p_save_file); - register_primop(process, "+", p_add); - register_primop(process, "-", p_sub); - register_primop(process, "*", p_mul); - register_primop(process, "/", p_div); - //register_primop(process, "mod", p_mod); - register_primop(process, "=", p_eq); - register_primop(process, "list", p_list); - register_primop(process, "array", p_array); - register_primop(process, "dictionary", p_dictionary); - register_primop(process, "str", p_str); - register_primop(process, "str-append!", p_str_append_bang); - register_primop(process, "str-replace", p_str_replace); - register_primop(process, "join", p_join); - register_primop(process, "register", p_register); - register_primop(process, "register-variable", p_register_variable); - register_primop(process, "register-builtin", p_register_builtin); - register_primop(process, "print", p_print); - register_primop(process, "println", p_println); - register_primop(process, "prn", p_prn); - register_primop(process, "def?", p_def_QMARK); - //register_primop(process, "system", p_system); - register_primop(process, "get", p_get); - register_primop(process, "get-maybe", p_get_maybe); - register_primop(process, "dict-set!", p_dict_set_bang); - register_primop(process, "dict-remove!", p_dict_remove_bang); - register_primop(process, "first", p_first); - register_primop(process, "rest", p_rest); - register_primop(process, "cons", p_cons); - register_primop(process, "cons-last", p_cons_last); - register_primop(process, "concat", p_concat); - register_primop(process, "nth", p_nth); - register_primop(process, "count", p_count); - register_primop(process, "map", p_map); - register_primop(process, "map-copy", p_map); // only matters when compiling to C - register_primop(process, "map2", p_map2); - register_primop(process, "filter", p_filter); - register_primop(process, "reduce", p_reduce); - register_primop(process, "apply", p_apply); - register_primop(process, "type", p_type); - register_primop(process, "<", p_lt); - register_primop(process, "env", p_env); - register_primop(process, "load-lisp", p_load_lisp); - register_primop(process, "load-dylib", p_load_dylib); - register_primop(process, "unload-dylib", p_unload_dylib); - register_primop(process, "read", p_read); - register_primop(process, "read-many", p_read_many); - register_primop(process, "code", p_code); - register_primop(process, "copy", p_copy); - register_primop(process, "now", p_now); - register_primop(process, "name", p_name); - register_primop(process, "symbol", p_symbol); - register_primop(process, "keyword", p_keyword); - register_primop(process, "error", p_error); - register_primop(process, "keys", p_keys); - register_primop(process, "values", p_values); - register_primop(process, "signature", p_signature); - register_primop(process, "eval", p_eval); - register_primop(process, "meta-set!", p_meta_set_BANG); - register_primop(process, "meta-get", p_meta_get); - register_primop(process, "meta-get-all", p_meta_get_all); - register_primop(process, "array-to-list", p_array_to_list); - register_primop(process, "array-of-size", p_array_of_size); - register_primop(process, "array-set!", p_array_set_BANG); - register_primop(process, "array-set", p_array_set); - register_primop(process, "gc", p_gc); - register_primop(process, "hash", p_hash); - register_primop(process, "delete", p_delete); - register_primop(process, "stop", p_stop); - register_primop(process, "parallell", p_parallell); - register_primop(process, "bytecode", p_bytecode); - register_primop(process, "eval-bytecode", p_bytecode_eval); - register_primop(process, "lookup-in-substs-fast", p_lookup_in_substs_fast); - register_primop(process, "replace-subst-from-right-fast", p_replace_subst_from_right_fast); - register_primop(process, "types-exactly-eq?", p_types_exactly_eq); - register_primop(process, "extend-substitutions-fast", p_extend_substitutions_fast); - register_primop(process, "sort-by-fast", p_sort_by); - - Obj *abs_args = obj_list(type_int); - register_ffi_internal(process, "abs", (VoidFn)abs, abs_args, type_int, true); - - Obj *exit_args = obj_list(type_int); - register_ffi_internal(process, "exit", (VoidFn)exit, exit_args, type_void, true); - - Obj *getenv_args = obj_list(type_string); - register_ffi_internal(process, "getenv", (VoidFn)getenv, getenv_args, type_string, true); - - //printf("Global env: %s\n", obj_to_string(env)->s); - - return process; -} - -Process *process_clone(Process *parent) { - Process *clone = malloc(sizeof(Process)); - clone->dead = false; - clone->global_env = parent->global_env; - clone->final_result = NULL; - clone->frame = 0; - pop_stacks_to_zero(clone); - return clone; -} - -void process_reset(Process *process) { - process->frame = 0; - process->function_trace_pos = 0; -} - -void stack_print(Process *process) { - printf("----- STACK -----\n"); - for(int i = 0; i < process->stack_pos; i++) { - printf("%d\t%s\n", i, obj_to_string(process, process->stack[i])->s); - } - printf("----- END -----\n\n"); -} - -void stack_push(Process *process, Obj *o) { - assert(o); - if(LOG_STACK) { - printf("Pushing %s\n", obj_to_string(process, o)->s); - } - if(process->stack_pos >= STACK_SIZE) { - printf("Stack overflow:\n"); - stack_print(process); - exit(1); - } - process->stack[process->stack_pos++] = o; - if(LOG_STACK) { - stack_print(process); - } -} - -Obj *stack_pop(Process *process) { - if(eval_error) { - return nil; - } - if(process->stack_pos <= 0) { - printf("Stack underflow.\n"); - assert(false); - } - if(LOG_STACK) { - printf("Popping %s\n", obj_to_string(process, process->stack[process->stack_pos - 1])->s); - } - Obj *o = process->stack[--process->stack_pos]; - if(LOG_STACK) { - stack_print(process); - } - return o; -} - -void shadow_stack_print(Process *process) { - printf("----- SHADOW STACK -----\n"); - for(int i = 0; i < process->shadow_stack_pos - 1; i++) { - printf("%d\t", i); - obj_print_cout(process->shadow_stack[i]); - printf("\n"); - } - printf("----- END -----\n\n"); -} - -void shadow_stack_push(Process *process, Obj *o) { - if(LOG_SHADOW_STACK) { - printf("Pushing to shadow stack: %p ", o); - obj_print_cout(o); - printf("\n"); - } - if(process->shadow_stack_pos >= SHADOW_STACK_SIZE) { - printf("Shadow stack overflow.\n"); - shadow_stack_print(process); - printf("\n\nNormal stack:\n\n"); - stack_print(process); - exit(1); - } - process->shadow_stack[process->shadow_stack_pos++] = o; -} - -Obj *shadow_stack_pop(Process *process) { - if(process->shadow_stack_pos <= 0) { - printf("Shadow stack underflow.\n"); - assert(false); - } - Obj *o = process->shadow_stack[--process->shadow_stack_pos]; - if(LOG_SHADOW_STACK) { - printf("Popping from shadow stack: %p ", o); - obj_print_cout(o); - printf("\n"); - } - return o; -} - -void function_trace_print(Process *process) { - printf(" ----------------------------------------------------------------\n"); - - for(int i = process->function_trace_pos - 1; i >= 0; i--) { - printf("%3d ", i); - - StackTraceCallSite call_site = process->function_trace[i]; - Obj *o = call_site.caller; - Obj *function = call_site.callee; - - if(o->meta) { - //printf("%s\n", obj_to_string(o->meta)->s); - char *func_name = ""; - Obj *func_name_data = NULL; - if(function && function->meta) { - func_name_data = env_lookup(process, function->meta, obj_new_keyword("name")); - } - if(func_name_data) { - func_name = obj_to_string_not_prn(process, func_name_data)->s; - } - else { - func_name = "???"; // obj_to_string(function)->s; - } - int line = env_lookup(process, o->meta, obj_new_keyword("line"))->i; - int pos = env_lookup(process, o->meta, obj_new_keyword("pos"))->i; - char *file_path = env_lookup(process, o->meta, obj_new_keyword("file"))->s; - char *file = file_path; - - int len = (int)strlen(file_path); - for(int i = len - 1; i >= 0; i--) { - if(file_path[i] == '/') { - file = strdup(file_path + i + 1); - break; - } - } - printf("%-30s %s %d:%d", func_name, file, line, pos); - } - else { - printf("No meta data."); //"%s", obj_to_string(function)->s); - } - printf("\n"); - } - - printf(" ----------------------------------------------------------------\n"); -} - -void process_eval(Process *process, Obj *form) { - process->bytecodeObj = form_to_bytecode(process, process->global_env, form, false); - //printf("Process will eval bytecode: %s\n", obj_to_string(process, process->bytecodeObj)->s); - process->frames[process->frame].p = 0; - process->frames[process->frame].bytecodeObj = process->bytecodeObj; - process->frames[process->frame].env = process->global_env; - process->final_result = NULL; - stack_push(process, process->bytecodeObj); // make it not be GC:ed - return; -} - -Obj *process_tick(Process *process) { - if(!process->final_result) { - process->final_result = bytecode_eval_internal(process, process->bytecodeObj, 100, 0); - } - return process->final_result; -} diff --git a/src/process.h b/src/process.h deleted file mode 100644 index 12e2dcc76..000000000 --- a/src/process.h +++ /dev/null @@ -1,24 +0,0 @@ -#pragma once - -#include "obj.h" - -Process *process_new(); -Process *process_clone(Process *parent); - -Process *parallell; - -void process_reset(Process *process); -void process_eval(Process *process, Obj *form); -Obj *process_tick(Process *process); - -void stack_print(Process *process); -void stack_push(Process *process, Obj *o); -Obj *stack_pop(Process *process); - -void shadow_stack_push(Process *process, Obj *o); -Obj *shadow_stack_pop(Process *process); -void shadow_stack_print(Process *process); - -void function_trace_print(Process *process); - -void pop_stacks_to_zero(Process *process); diff --git a/src/reader.c b/src/reader.c deleted file mode 100644 index 00c7d61eb..000000000 --- a/src/reader.c +++ /dev/null @@ -1,386 +0,0 @@ -#include "reader.h" -#include -#include "env.h" -#include "obj_string.h" - -int read_line_nr; -int read_line_pos; -int read_pos = 0; -#define CURRENT s[read_pos] - -bool is_ok_in_symbol(char c, bool initial) { - if(isdigit(c) && initial) { - return false; - } - else if(c == '\'' && initial) { - return true; - } - else if(c == '!' || c == '?' || c == '<' || c == '>' || c == '=' || c == '%' || - c == '+' || c == '*' || c == '/' || c == '-' || c == '_' || c == '#') { - return true; - } - else if(isalpha(c) || isdigit(c)) { - return true; - } - else { - return false; - } -} - -bool is_whitespace(char c) { - return c == ' ' || c == '\r' || c == '\t' || c == '\n' || c == ','; -} - -void hit_new_line() { - read_line_nr++; - read_line_pos = 0; -} - -void skip_whitespace(char *s) { - while(is_whitespace(CURRENT)) { - if(CURRENT == '\n') { - hit_new_line(); - } - read_pos++; - } - if(CURRENT == ';') { - while(CURRENT != '\n' && CURRENT != '\0') { - read_pos++; - } - hit_new_line(); - read_pos++; - skip_whitespace(s); - } -} - -void print_read_pos() { - printf("Line: %d, pos: %d.\n", read_line_nr, read_line_pos); -} - -Obj *read_internal(Process *process, Obj *env, char *s, Obj *filename) { - skip_whitespace(s); - - if(CURRENT == ')' || CURRENT == ']') { - read_pos++; - printf("Too many parenthesis at the end.\n"); - print_read_pos(); - return nil; - } - else if(CURRENT == '(') { - Obj *list = obj_new_cons(NULL, NULL); - obj_set_line_info(process, list, read_line_nr, read_line_pos, filename); - Obj *prev = list; - read_pos++; - while(1) { - skip_whitespace(s); - if(CURRENT == '\0') { - printf("Missing parenthesis at the end.\n"); - print_read_pos(); - return nil; - } - if(CURRENT == ')') { - read_pos++; - break; - } - Obj *o = read_internal(process, env, s, filename); - Obj *new = obj_new_cons(NULL, NULL); - prev->car = o; - prev->cdr = new; - prev = new; - } - return list; - } - else if(CURRENT == '[') { -//const int max_count = 512; // MSVC thinks that this is not a constant. What the ... -#define MAX_COUNT 512 - Obj *temp[MAX_COUNT]; - int count = 0; - int line = read_line_nr; - int pos = read_line_pos; - - read_pos++; - while(1) { - skip_whitespace(s); - if(CURRENT == '\0') { - printf("Missing ']' at the end of array.\n"); - print_read_pos(); - return nil; - } - if(CURRENT == ']') { - read_pos++; - break; - } - Obj *o = read_internal(process, env, s, filename); - temp[count] = o; - count++; - if(count >= MAX_COUNT) { - eval_error = obj_new_string("Can't read more than 512 values in literal. Please talk to the creator of this language about this."); - } - } - - Obj *new_array = obj_new_array(count); - for(int i = 0; i < count; i++) { - new_array->array[i] = temp[i]; - } - obj_set_line_info(process, new_array, line, pos, filename); - return new_array; - } - else if(CURRENT == '{') { - int line = read_line_nr; - int pos = read_line_pos; - - Obj *list = obj_new_cons(NULL, NULL); - obj_set_line_info(process, list, read_line_nr, read_line_pos, filename); - Obj *prev = list; - read_pos++; - while(1) { - skip_whitespace(s); - if(CURRENT == '\0') { - printf("Missing '}' at the end.\n"); - print_read_pos(); - return nil; - } - if(CURRENT == '}') { - read_pos++; - break; - } - Obj *o = read_internal(process, env, s, filename); - Obj *new = obj_new_cons(NULL, NULL); - prev->car = o; - prev->cdr = new; - prev = new; - } - Obj *call_to_dict = obj_new_cons(obj_new_symbol("dictionary"), list); - //printf("Read dictionary literal: %s\n", obj_to_string(process, call_to_dict)->s); - obj_set_line_info(process, call_to_dict, line, pos, filename); - return call_to_dict; - } - else if(CURRENT == '&') { - int line = read_line_nr, pos = read_line_pos; - read_pos++; - Obj *inner = read_internal(process, env, s, filename); - Obj *cons2 = obj_new_cons(inner, nil); - Obj *cons1 = obj_new_cons(obj_new_symbol("ref"), cons2); - obj_set_line_info(process, cons1, line, pos, filename); - return cons1; - } - else if(CURRENT == '.' && s[read_pos + 1] == '.' && s[read_pos + 2] == '.') { - read_pos += 3; - return dotdotdot; - } - else if(CURRENT == '\\') { - read_pos++; - char b = CURRENT; - read_pos++; - return obj_new_char(b); - } - else if(isdigit(CURRENT) || (CURRENT == '-' && isdigit(s[read_pos + 1]))) { - int line = read_line_nr, pos = read_line_pos; - int negator = 1; - if(CURRENT == '-') { - negator = -1; - read_pos++; - } - bool has_period = false; - bool is_double = false; - bool is_float = false; - char scratch[32]; - int i = 0; - while(isdigit(CURRENT)) { - scratch[i++] = CURRENT; - read_pos++; - if(CURRENT == '.' && !has_period) { - scratch[i++] = CURRENT; - has_period = true; - read_pos++; - } - if(CURRENT == 'f') { - is_float = true; - read_pos++; - break; - } - if(CURRENT == 'd') { - is_double = true; - read_pos++; - break; - } - } - scratch[i] = '\0'; - if(has_period && !is_float) { - double x = atof(scratch) * negator; - Obj *new_double = obj_new_double(x); - obj_set_line_info(process, new_double, line, pos, filename); - return new_double; - } - else if(is_float) { - float x = (float)atof(scratch) * negator; - Obj *new_float = obj_new_float(x); - obj_set_line_info(process, new_float, line, pos, filename); - return new_float; - } - else { - int num = atoi(scratch) * negator; - Obj *new_int = obj_new_int(num); - obj_set_line_info(process, new_int, line, pos, filename); - return new_int; - } - } - else if(CURRENT == '@') { - read_pos++; - Obj *inner = read_internal(process, env, s, filename); - Obj *cons2 = obj_new_cons(inner, nil); - Obj *cons1 = obj_new_cons(obj_new_symbol("copy"), cons2); - return cons1; - } - else if(CURRENT == '\'') { - read_pos++; - Obj *inner = read_internal(process, env, s, filename); - Obj *cons2 = obj_new_cons(inner, nil); - Obj *cons1 = obj_new_cons(lisp_quote, cons2); - return cons1; - } - else if(CURRENT == '`') { - read_pos++; - Obj *inner = read_internal(process, env, s, filename); - Obj *cons2 = obj_new_cons(inner, nil); - Obj *cons1 = obj_new_cons(obj_new_symbol("quasiquote"), cons2); - //printf("Read quasiquote.\n"); - return cons1; - } - else if(CURRENT == '~') { - read_pos++; - if(CURRENT == '@') { - read_pos++; - Obj *sym = read_internal(process, env, s, filename); - Obj *cons2 = obj_new_cons(sym, nil); - Obj *cons1 = obj_new_cons(obj_new_symbol("dequote-splicing"), cons2); - return cons1; - } - else { - Obj *sym = read_internal(process, env, s, filename); - Obj *cons2 = obj_new_cons(sym, nil); - Obj *cons1 = obj_new_cons(obj_new_symbol("dequote"), cons2); - return cons1; - } - } - else if(CURRENT == '^') { - read_pos++; - Obj *key_symbol = read_internal(process, env, s, filename); - - if(key_symbol->tag != 'Y') { - eval_error = obj_new_string("Invalid key for meta data."); - return nil; - } - - Obj *key = obj_new_keyword(key_symbol->s); - Obj *value = read_internal(process, env, s, filename); - Obj *form = read_internal(process, env, s, filename); - Obj *head = obj_new_symbol("meta-set!"); - - Obj *new_form = obj_list(head, form, key, value); - - return new_form; - } - else if(is_ok_in_symbol(CURRENT, true)) { - int line = read_line_nr, pos = read_line_pos; - char name[512]; - int i = 0; - while(is_ok_in_symbol(CURRENT, false)) { - name[i++] = CURRENT; - read_pos++; - } - name[i] = '\0'; - Obj *symbol = obj_new_symbol(name); - obj_set_line_info(process, symbol, line, pos, filename); - symbol->hash = obj_hash(process, symbol); - return symbol; - } - else if(CURRENT == ':') { - int line = read_line_nr, pos = read_line_pos; - read_pos++; - char name[512]; - int i = 0; - while(is_ok_in_symbol(CURRENT, false)) { - name[i++] = CURRENT; - read_pos++; - } - name[i] = '\0'; - - Obj *new_keyword = obj_new_keyword(name); - obj_set_line_info(process, new_keyword, line, pos, filename); - new_keyword->hash = obj_hash(process, new_keyword); - return new_keyword; - } - else if(CURRENT == '"') { - read_pos++; - int line = read_line_nr; - int pos = read_line_pos; - char str[512]; - int i = 0; - while(CURRENT != '"') { - if(CURRENT == '\0') { - printf("Missing quote in string\n"); - break; - } - else if(CURRENT == '\\') { - read_pos++; - if(CURRENT == 'n') { - str[i++] = '\n'; - } - else if(CURRENT == '"') { - str[i++] = '"'; - } - else if(CURRENT == '\\') { - str[i++] = '\\'; - } - else { - printf("Can't read '%c' after backslash (%d)\n", CURRENT, CURRENT); - read_pos++; - return nil; - } - read_pos++; - } - else { - str[i++] = CURRENT; - read_pos++; - } - } - str[i] = '\0'; - read_pos++; - Obj *new_string = obj_new_string(str); - obj_new_string(str); - obj_set_line_info(process, new_string, line, pos, filename); - new_string->hash = obj_hash(process, new_string); - return new_string; - } - else if(CURRENT == 0) { - return nil; - } - else { - printf("Can't read '%c' (%d)\n", CURRENT, CURRENT); - read_pos++; - return nil; - } -} - -Obj *read_string(Process *process, Obj *env, char *s, Obj *filename) { - read_line_nr = 1; - read_line_pos = 0; - read_pos = 0; - Obj *top_forms = NULL; - Obj *prev = NULL; - while(s[read_pos] != '\0') { - Obj *o = read_internal(process, env, s, filename); - Obj *cons = obj_new_cons(NULL, NULL); - cons->car = o; - if(!top_forms) { - top_forms = cons; - } - if(prev) { - prev->cdr = cons; - } - prev = cons; - skip_whitespace(s); - } - return top_forms; -} diff --git a/src/reader.h b/src/reader.h deleted file mode 100644 index 59ebbd9ec..000000000 --- a/src/reader.h +++ /dev/null @@ -1,5 +0,0 @@ -#pragma once - -#include "obj.h" - -Obj *read_string(Process *process, Obj *env, char *s, Obj *filename); diff --git a/src/repl.c b/src/repl.c deleted file mode 100644 index 7ebd511ce..000000000 --- a/src/repl.c +++ /dev/null @@ -1,115 +0,0 @@ -#include "repl.h" -#include "eval.h" -#include "gc.h" -#include "obj_string.h" -#include "reader.h" -#include "eval.h" -#include "env.h" -#include "primops.h" -#include "process.h" - -jmp_buf jumpbuffer; - -#define MAX_INPUT_BUFFER_SIZE (2048 * 32) -char input[MAX_INPUT_BUFFER_SIZE]; - -#define GC_COLLECT_BEFORE_REPL_INPUT 0 - -int paren_balance(char *s) { - char ignore = '\0'; - //printf("s = %s\n", s); - int balance = 0; - for(int i = 0; s[i] != '\0'; i++) { - char c = s[i]; - if(ignore == '\0') { - if(c == '(') balance++; - if(c == ')') balance--; - if(c == '[') balance++; - if(c == ']') balance--; - if(c == '{') balance++; - if(c == '}') balance--; - if(c == '"') { - ignore = '"'; - } - if(c == ';') { - //printf("Start ignoring comment.\n"); - ignore = ';'; - } - } - else { - //printf("ignoring '%c' %d, ignore = '%c'\n", c, c, ignore); - - if(c == '"' && c == ignore) { - //printf("back from ignoring string\n"); - ignore = '\0'; - } - else if(c == '\\' && ignore == '"') { - i++; - } - else if(c == '\n' && ignore == ';') { - //printf("back from ignoring comment\n"); - ignore = '\0'; - } - } - } - return balance; -} - -void repl(Process *process) { - while(1) { - - /* int r = */ setjmp(jumpbuffer); - //printf("r = %d\n", r); - - if(GC_COLLECT_BEFORE_REPL_INPUT) { - if(LOG_GC_POINTS) { - printf("Running GC before taking REPL input:\n"); - } - gc(process); - } - if(prompt) { - printf("%s", prompt->cdr->s); - } - int read_offset = 0; - - read_more:; - void *eof = fgets(input + read_offset, MAX_INPUT_BUFFER_SIZE - read_offset, stdin); - if(eof == NULL) { - break; - } - if(paren_balance(input) <= 0) { - process_reset(process); - eval_text(process, process->global_env, input, true, obj_new_string("repl")); - pop_stacks_to_zero(process); - printf("\n"); - if(process->dead) { - break; - } - } - else { - //printf("Unbalanced, waiting for ending parenthesis.\n"); - if(prompt_unfinished_form) { - printf("%s", prompt_unfinished_form->cdr->s); - } - read_offset = strlen(input); - goto read_more; - } - //assert(stack_pos == 0); - //stack_print(); - - if(parallell) { - process_tick(parallell); - printf("Ticked parallell process with result: %s\n", parallell->final_result ? obj_to_string(process, parallell->final_result)->s : "NULL"); - if(parallell->final_result) { - parallell = NULL; - } - } - } - gc(process); -} - -void pop_stacks_to_zero(Process *process) { - process->stack_pos = 0; - process->shadow_stack_pos = 0; - process->function_trace_pos = 0; -} diff --git a/src/repl.h b/src/repl.h deleted file mode 100644 index a24689630..000000000 --- a/src/repl.h +++ /dev/null @@ -1,8 +0,0 @@ -#pragma once - -#include "obj.h" -#include - -void repl(Process *process); - -extern jmp_buf jumpbuffer; diff --git a/src/unify.c b/src/unify.c deleted file mode 100644 index bb987d487..000000000 --- a/src/unify.c +++ /dev/null @@ -1 +0,0 @@ -#include "unify.h" diff --git a/src/unify.h b/src/unify.h deleted file mode 100644 index 2929edadf..000000000 --- a/src/unify.h +++ /dev/null @@ -1,5 +0,0 @@ -#pragma once - -#include "obj.h" - -void unify(Obj *a, Obj *b); diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 000000000..d2808f4d9 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-8.12 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.2" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 000000000..8059d5940 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,194 @@ +import Test.HUnit +import qualified Data.Map as Map +import qualified Data.Set as Set +import Constraints +import Types +import Obj +import Parsing +import Infer +import Eval + +main :: IO () +main = do _ <- runTestTT (groupTests "Constraints" testConstraints) + _ <- runTestTT (groupTests "Memory Management" testMemoryManagement) + return () + +groupTests :: String -> [Test] -> Test +groupTests label testCases = + TestList (zipWith TestLabel (map ((\s -> label ++ " Test " ++ s) . show) [1..]) testCases) + +-- | Helper functions for testing unification of Constraints +isUnificationFailure :: Either UnificationFailure TypeMappings -> Bool +isUnificationFailure (Left _) = True +isUnificationFailure (Right _) = False + +assertUnificationFailure :: [Constraint] -> Test +assertUnificationFailure constraints = TestCase $ + assertBool "Failure" (isUnificationFailure (solve constraints)) + +assertSolution :: [Constraint] -> [(String, Ty)] -> Test +assertSolution constraints solution = TestCase $ + assertEqual "Solution" (Right (Map.fromList solution)) (solve constraints) + +-- | A dummy XObj +x = XObj External Nothing Nothing + +-- | Some type variables +t0 = VarTy "t0" +t1 = VarTy "t1" +t2 = VarTy "t2" +t3 = VarTy "t3" + +-- | Test constraints +testConstraints = [testConstr1, testConstr2, testConstr3, testConstr4, testConstr5 + ,testConstr6, testConstr7, testConstr8, testConstr9, testConstr10 + ,testConstr11, testConstr12, testConstr13 + ,testConstr20, testConstr21, testConstr22, testConstr23, testConstr24 + ,testConstr30, testConstr31, testConstr32, testConstr33 + ] + +testConstr1 = assertUnificationFailure + [Constraint FloatTy IntTy x x] + +testConstr2 = assertSolution + [Constraint IntTy t0 x x] + [("t0", IntTy)] + +testConstr3 = assertSolution + [Constraint t0 IntTy x x] + [("t0", IntTy)] + +testConstr4 = assertSolution + [Constraint t0 t1 x x, Constraint t0 IntTy x x] + [("t0", IntTy), ("t1", IntTy)] + +testConstr5 = assertSolution + [Constraint t0 t1 x x, Constraint t1 IntTy x x] + [("t0", IntTy), ("t1", IntTy)] + +testConstr6 = assertSolution + [Constraint t0 t1 x x, Constraint t1 t3 x x, Constraint t2 IntTy x x, Constraint t3 IntTy x x] + [("t0", IntTy), ("t1", IntTy), ("t2", IntTy), ("t3", IntTy)] + +testConstr7 = assertUnificationFailure + [Constraint t0 IntTy x x, Constraint t0 FloatTy x x] + +testConstr8 = assertSolution + [Constraint t0 IntTy x x, Constraint t0 t0 x x] + [("t0", IntTy)] + +testConstr9 = assertSolution + [Constraint t0 IntTy x x, Constraint t0 t1 x x] + [("t0", IntTy), ("t1", IntTy)] + +testConstr10 = assertSolution + [Constraint (PointerTy (VarTy "a")) (PointerTy (VarTy "b")) x x] + [("a", (VarTy "a")), ("b", (VarTy "a"))] + +testConstr11 = assertSolution + [Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy "Monkey" [])) x x] + [("a", (StructTy "Monkey" []))] + +testConstr12 = assertSolution + [Constraint t1 (PointerTy (StructTy "Array" [IntTy])) x x + ,Constraint t1 (PointerTy t2) x x] + [("t1", (PointerTy (StructTy "Array" [IntTy]))) + ,("t2", (StructTy "Array" [IntTy]))] + +testConstr13 = assertSolution + [Constraint t1 CharTy x x + ,Constraint t1 CharTy x x] + [("t1", CharTy)] + +-- -- Should collapse type variables into minimal set: +-- testConstr10 = assertSolution +-- [Constraint t0 t1 x x, Constraint t1 t2 x x, Constraint t2 t3 x x] +-- [("t0", VarTy "t0"), ("t1", VarTy "t0"), ("t2", VarTy "t0")] +-- m7 = solve ([Constraint t1 t2 x x, Constraint t0 t1 x x]) + +-- Struct types +testConstr20 = assertSolution + [Constraint t0 (StructTy "Vector" [t1]) x x + ,Constraint t0 (StructTy "Vector" [IntTy]) x x] + [("t0", (StructTy "Vector" [IntTy])), ("t1", IntTy)] + +testConstr21 = assertSolution + [Constraint t1 (StructTy "Array" [t2]) x x + ,Constraint t1 (StructTy "Array" [t3]) x x + ,Constraint t3 BoolTy x x] + [("t1", (StructTy "Array" [BoolTy])) + ,("t2", BoolTy) + ,("t3", BoolTy)] + +testConstr22 = assertSolution + [Constraint t1 (StructTy "Array" [t2]) x x + ,Constraint t2 (StructTy "Array" [t3]) x x + ,Constraint t3 FloatTy x x] + [("t1", (StructTy "Array" [(StructTy "Array" [FloatTy])])) + ,("t2", (StructTy "Array" [FloatTy])) + ,("t3", FloatTy)] + +testConstr23 = assertUnificationFailure + [Constraint (StructTy "Array" [t1]) (StructTy "Array" [t2]) x x + ,Constraint t1 IntTy x x + ,Constraint t2 FloatTy x x] + +testConstr24 = assertUnificationFailure + [Constraint t2 FloatTy x x + ,Constraint t1 IntTy x x + ,Constraint (StructTy "Array" [t1]) (StructTy "Array" [t2]) x x] + +-- m9 = solve [Constraint (StructTy "Vector" [IntTy]) (StructTy "Vector" [t1]) x x] +-- m10 = solve [Constraint (StructTy "Vector" [t1]) (StructTy "Vector" [t2]) x x] + +-- Func types +testConstr30 = assertSolution + [Constraint t2 (FuncTy [t0] t1) x x + ,Constraint t2 (FuncTy [IntTy] BoolTy) x x] + [("t0", IntTy), ("t1", BoolTy), ("t2", (FuncTy [IntTy] BoolTy))] + +testConstr31 = assertSolution + [Constraint (FuncTy [t0] t1) (FuncTy [IntTy] BoolTy) x x] + [("t0", IntTy), ("t1", BoolTy)] + +testConstr32 = assertSolution + [Constraint t0 (FuncTy [IntTy] BoolTy) x x] + [("t0", (FuncTy [IntTy] BoolTy))] + +testConstr33 = assertSolution + [Constraint t1 (FuncTy [t2] IntTy) x x + ,Constraint t1 (FuncTy [t3] IntTy) x x + ,Constraint t3 BoolTy x x] + [("t1", (FuncTy [BoolTy] IntTy)) + ,("t2", BoolTy) + ,("t3", BoolTy)] + + + +-- | Test memory management + +testMemoryManagement = [testMem1] + +testEnv :: Env +testEnv = Env { envBindings = bs, envParent = Nothing, envModuleName = Nothing, envImports = [], envMode = ExternalEnv } + where bs = Map.fromList [] + +assertMem :: String -> [Deleter] -> Test +assertMem code deleters = + let Right [parsed] = parse code + Right expanded = expandAll testEnv parsed + xobjFullSymbols = setFullyQualifiedSymbols testEnv expanded + Right (ann : _) = annotate testEnv xobjFullSymbols + Just i = info ann + in TestCase $ assertEqual "Memory" (infoDelete i) (Set.fromList deleters) + +testMem1 = assertMem "(defn f [] (let [s \"HELLO\"] 12345))" [] + + +-- case expandAll env xobj of +-- Left err -> executeCommand ctx (ReplMacroError (show err)) +-- Right expanded -> +-- let xobjFullPath = setFullyQualifiedDefn expanded (SymPath pathStrings (getName xobj)) +-- xobjFullSymbols = setFullyQualifiedSymbols innerEnv xobjFullPath +-- in case annotate env xobjFullSymbols of + diff --git a/xcode.sh b/xcode.sh deleted file mode 100755 index 75a02ec8b..000000000 --- a/xcode.sh +++ /dev/null @@ -1,6 +0,0 @@ -mkdir build -cd build -mkdir xcode -cd xcode -cmake ../../ -G Xcode -open carp-repl.xcodeproj