carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-08-15 16:20:40 +03:00
Code Issues Projects Releases Wiki Activity

Merge

Browse Source
This commit is contained in:
Jorge Acereda 2020-05-11 16:10:35 +02:00
parent 83e8c1a874
commit 9b08b6df3c
23 changed files with 326 additions and 278 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
core/GLFW.carp
View File

@ -15,11 +15,11 @@
(register set-gamma-ramp (λ [(Ptr GLFWmonitor) (Ptr GLFWgammaramp)] ()) "glfwSetGammaRamp")
(register default-window-hints (λ [] ()) "glfwDefaultWindowHints")
(register window-hint (λ [Int Int] ()) "glfwWindowHint")
(register create-window (λ [Int Int (Ptr Char) (Ptr GLFWmonitor) (Ptr GLFWwindow)] (Ptr GLFWwindow)) "glfwCreateWindow")
(register create-window (λ [Int Int (Ptr CChar) (Ptr GLFWmonitor) (Ptr GLFWwindow)] (Ptr GLFWwindow)) "glfwCreateWindow")
(register destroy-window (λ [(Ptr GLFWwindow)] ()) "glfwDestroyWindow")
(register window-should-close (λ [(Ptr GLFWwindow)] Int) "glfwWindowShouldClose")
(register set-window-should-close (λ [(Ptr GLFWwindow) Int] ()) "glfwSetWindowShouldClose")
(register set-window-title (λ [(Ptr GLFWwindow) (Ptr Char)] ()) "glfwSetWindowTitle")
(register set-window-title (λ [(Ptr GLFWwindow) (Ptr CChar)] ()) "glfwSetWindowTitle")
(register set-window-icon (λ [(Ptr GLFWwindow) Int (Ptr GLFWimage)] ()) "glfwSetWindowIcon")
(register get-window-pos (λ [(Ptr GLFWwindow) (Ptr Int) (Ptr Int)] ()) "glfwGetWindowPos")
(register set-window-pos (λ [(Ptr GLFWwindow) Int Int] ()) "glfwSetWindowPos")
@ -71,7 +71,7 @@
(register set-drop-callback (λ [(Ptr GLFWwindow) GLFWdropfun] GLFWdropfun) "glfwSetDropCallback")
(register joystick-present (λ [Int] Int) "glfwJoystickPresent")
(register set-joystick-callback (λ [GLFWjoystickfun] GLFWjoystickfun) "glfwSetJoystickCallback")
(register set-clipboard-string (λ [(Ptr GLFWwindow) (Ptr Char)] ()) "glfwSetClipboardString")
(register set-clipboard-string (λ [(Ptr GLFWwindow) (Ptr CChar)] ()) "glfwSetClipboardString")
(register get-time (λ [] Double) "glfwGetTime")
(register set-time (λ [Double] ()) "glfwSetTime")
(register get-timer-value (λ [] uint64_t) "glfwGetTimerValue")
@ -80,10 +80,10 @@
(register get-current-context (λ [] (Ptr GLFWwindow)) "glfwGetCurrentContext")
(register swap-buffers (λ [(Ptr GLFWwindow)] ()) "glfwSwapBuffers")
(register swap-interval (λ [Int] ()) "glfwSwapInterval")
(register extension-supported (λ [(Ptr Char)] Int) "glfwExtensionSupported")
(register get-proc-address (λ [(Ptr Char)] GLFWglproc) "glfwGetProcAddress")
(register extension-supported (λ [(Ptr CChar)] Int) "glfwExtensionSupported")
(register get-proc-address (λ [(Ptr CChar)] GLFWglproc) "glfwGetProcAddress")
(register vulkan-supported (λ [] Int) "glfwVulkanSupported")
(register get-instance-proc-address (λ [VkInstance (Ptr Char)] GLFWvkproc) "glfwGetInstanceProcAddress")
(register get-instance-proc-address (λ [VkInstance (Ptr CChar)] GLFWvkproc) "glfwGetInstanceProcAddress")
(register get-physical-device-presentation-support (λ [VkInstance VkPhysicalDevice uint32_t] Int) "glfwGetPhysicalDevicePresentationSupport")
(register create-window-surface (λ [VkInstance (Ptr GLFWwindow) (Ptr VkAllocationCallbacks) (Ptr VkSurfaceKHR)] VkResult) "glfwCreateWindowSurface")
)

2
core/IO.carp
View File

@ -74,7 +74,7 @@
(private getenv-)
(hidden getenv-)
(register getenv- (Fn [String] (Ptr Char)) "getenv")
(register getenv- (Fn [String] (Ptr CChar)) "getenv")
(defn getenv [s]
(let [e (getenv- s)]
(if (null? e)

2
core/OpenGL.carp
View File

@ -1,5 +1,7 @@
(mac-only
(add-lib "-framework OpenGL"))
(linux-only
(add-lib "-lGL"))
(defmodule GL

8
core/SDL.carp
View File

@ -42,15 +42,15 @@
(register INIT_EVERYTHING Int)
(register init (Fn [Int] ()) "SDL_Init")
(register create-window-and-renderer (Fn [Int Int Int (Ptr (Ptr SDL_Window)) (Ptr (Ptr SDL_Renderer))] ()) "SDL_CreateWindowAndRenderer")
(register set-window-title (Fn [(Ptr SDL_Window) (Ptr Char)] ()) "SDL_SetWindowTitle")
(register set-window-title (Fn [(Ptr SDL_Window) (Ptr CChar)] ()) "SDL_SetWindowTitle")
(register delay (Fn [Int] ()) "SDL_Delay")
(register destroy-window (Fn [(Ptr SDL_Window)] ()) "SDL_DestroyWindow")
(register quit (Fn [] ()) "SDL_Quit")
(defmodule Hint
(register set (Fn [(Ptr Char) (Ptr Char)] ()) "SDL_SetHint")
(register render-vsync (Ptr Char) "SDL_HINT_RENDER_VSYNC")
(register video-mac-fullscreen-spaces (Ptr Char) "SDL_HINT_VIDEO_MAC_FULLSCREEN_SPACES"))
(register set (Fn [(Ptr CChar) (Ptr CChar)] ()) "SDL_SetHint")
(register render-vsync (Ptr CChar) "SDL_HINT_RENDER_VSYNC")
(register video-mac-fullscreen-spaces (Ptr CChar) "SDL_HINT_VIDEO_MAC_FULLSCREEN_SPACES"))
(defmodule Event
(register init (Fn [] SDL_Event))

4
core/SDL_image.carp
View File

@ -8,6 +8,6 @@
(add-lib (str sdl-windows-library-path "SDL2_image.lib ")))
(defmodule IMG
(register load-texture (Fn [(Ptr SDL_Renderer) (Ptr Char)] (Ptr SDL_Texture)) "IMG_LoadTexture")
(register load (Fn [(Ptr Char)] (Ptr SDL_Surface)) "IMG_Load")
(register load-texture (Fn [(Ptr SDL_Renderer) (Ptr CChar)] (Ptr SDL_Texture)) "IMG_LoadTexture")
(register load (Fn [(Ptr CChar)] (Ptr SDL_Surface)) "IMG_Load")
)

8
core/SDL_mixer.carp
View File

@ -28,11 +28,11 @@
;; Loading
(register load-wav
(Fn [(Ptr Char)] (Ptr Mix_Chunk))
(Fn [(Ptr CChar)] (Ptr Mix_Chunk))
"Mix_LoadWAV")
(register load-music
(Fn [(Ptr Char)] (Ptr Mix_Music))
(Fn [(Ptr CChar)] (Ptr Mix_Music))
"Mix_LoadMUS")
;; Playing samples (Mix_Chunk:s)
@ -53,7 +53,7 @@
;; This function seems flakey, returns NULL?
(register get-music-decoder
(Fn [Int] (Ptr Char))
(Fn [Int] (Ptr CChar))
"Mix_GetMusicDecoder")
(register play-music
@ -64,7 +64,7 @@
;; Error handling
(register get-error
(Fn [] (Ptr Char))
(Fn [] (Ptr CChar))
"Mix_GetError")
;; Helpers

12
core/SDL_ttf.carp
View File

@ -7,10 +7,10 @@
(defmodule TTF
(register init (Fn [] Int) "TTF_Init")
(register quit (Fn [] ()) "TTF_Quit")
(register get-error (Fn [] (Ptr Char)) "TTF_GetError")
(register get-error (Fn [] (Ptr CChar)) "TTF_GetError")
;; Loading / unloading
(register open-font (Fn [(Ptr Char) Int] (Ptr TTF_Font)) "TTF_OpenFont")
(register open-font (Fn [(Ptr CChar) Int] (Ptr TTF_Font)) "TTF_OpenFont")
(register close-font (Fn [(Ptr TTF_Font)] ()) "TTF_CloseFont")
;; Styles
@ -23,19 +23,19 @@
;; Render
(register render-text-solid
(Fn [(Ptr TTF_Font) (Ptr Char) SDL_Color] (Ptr SDL_Surface))
(Fn [(Ptr TTF_Font) (Ptr CChar) SDL_Color] (Ptr SDL_Surface))
"TTF_RenderText_Solid")
(register render-text-shaded
(Fn [(Ptr TTF_Font) (Ptr Char) SDL_Color SDL_Color] (Ptr SDL_Surface))
(Fn [(Ptr TTF_Font) (Ptr CChar) SDL_Color SDL_Color] (Ptr SDL_Surface))
"TTF_RenderText_Shaded")
(register render-text-blended
(Fn [(Ptr TTF_Font) (Ptr Char) SDL_Color] (Ptr SDL_Surface))
(Fn [(Ptr TTF_Font) (Ptr CChar) SDL_Color] (Ptr SDL_Surface))
"TTF_RenderText_Blended")
(register render-text-blended-wrapped
(Fn [(Ptr TTF_Font) (Ptr Char) SDL_Color Int] (Ptr SDL_Surface))
(Fn [(Ptr TTF_Font) (Ptr CChar) SDL_Color Int] (Ptr SDL_Surface))
"TTF_RenderText_Blended_Wrapped")
;; Helpers to make everything a bit nicer

4
core/String.carp
View File

@ -9,8 +9,8 @@
(register delete (Fn [String] ()))
(register copy (Fn [&String] String))
(register length (Fn [&String] Int))
(register cstr (Fn [&String] (Ptr Char)))
(register from-cstr (Fn [(Ptr Char)] String))
(register cstr (Fn [&String] (Ptr CChar)))
(register from-cstr (Fn [(Ptr CChar)] String))
(register str (Fn [&String] String))
(register prn (Fn [&String] String))
(register index-of (Fn [&String Char] Int))

16
core/carp_char.h
View File

@ -1,24 +1,24 @@
bool Char__EQ_(char a, char b) {
bool Char__EQ_(Char a, Char b) {
return a == b;
}
bool Char__LT_(char a, char b) {
bool Char__LT_(Char a, Char b) {
return a < b;
}
bool Char__GT_(char a, char b) {
bool Char__GT_(Char a, Char b) {
return a > b;
}
int Char_to_MINUS_int(char c) {
return (int)(unsigned char)c;
int Char_to_MINUS_int(Char c) {
return (int)c;
}
char Char_from_MINUS_int(int i) {
return (char)i;
Char Char_from_MINUS_int(int i) {
return (Char)i;
}
char Char_copy(const char *c) {
Char Char_copy(const Char *c) {
return *c;
}

16
core/carp_pattern.h
View File

@ -9,7 +9,7 @@
#endif
/* macro to 'unsign' a character */
#define uchar(c) ((unsigned char)(c))
#define uchar(c) ((Char)(c))
/*
** Some sizes are better limited to fit in 'int', but must also fit in
@ -28,7 +28,7 @@ typedef struct PatternMatchState {
String p_end; /* end ('\0') of Pattern */
int matchdepth; /* control for recursive depth (to avoid C stack overflow)
*/
unsigned char level; /* total number of captures (finished or unfinished) */
uint8_t level; /* total number of captures (finished or unfinished) */
struct {
String init;
ptrdiff_t len;
@ -87,9 +87,7 @@ String Pattern_internal_classend(PatternMatchState *ms, String p) {
} while (*p != ']');
return p + 1;
}
default: {
return p;
}
default: { return p; }
}
}
@ -156,7 +154,7 @@ int Pattern_internal_singlematch(PatternMatchState *ms, String s, String p,
if (s >= ms->src_end) {
return 0;
} else {
int c = uchar(*s);
Char c = uchar(*s);
switch (*p) {
case '.':
return 1; /* matches any char */
@ -286,7 +284,7 @@ init: /* using goto's to optimize tail recursion */
}
case 'f': { /* frontier? */
String ep;
char previous;
Char previous;
p += 2;
if (*p != '[')
carp_regerror("missing '[' after '%cf' in Pattern",
@ -307,7 +305,7 @@ init: /* using goto's to optimize tail recursion */
case 'r': /* carriage return? */
case 'n': /* newline? */
case 't': { /* tab? */
char h = *(p + 1);
Char h = *(p + 1);
p += 2;
if ((*s == '\r' && h == 'r') ||
(*s == '\n' && h == 'n') ||
@ -665,7 +663,7 @@ Array Pattern_global_MINUS_match(Pattern *p, String *s) {
return res;
}
String Pattern_internal_add_char(String a, char b) {
String Pattern_internal_add_char(String a, Char b) {
if (!a) {
String buffer = CARP_MALLOC(2);
sprintf(buffer, "%c", b);

36
core/carp_string.h
View File

@ -120,23 +120,45 @@ String String_format(const String *str, const String *s) {
return buffer;
}
static size_t utf8len(const char *s) {
size_t l = 0;
for (size_t i = 0; s[i]; i++) l += (s[i] & 0xC0) != 0x80;
return l;
}
static size_t wutf8len(const wchar_t *s, size_t cnt) {
size_t l = 0;
for (size_t i = 0; i < cnt; i++) l += snprintf(0, 0, "%lc", s[i]);
return l;
}
Array String_chars(const String *s) {
int r;
Char *data;
Array chars;
chars.len = strlen(*s);
chars.capacity = chars.len;
chars.data = String_copy(s);
chars.len = utf8len(*s);
chars.capacity = chars.len + 1;
data = CARP_MALLOC(chars.capacity * sizeof(*data));
r = sscanf(*s, "%l[^￿]", (wchar_t *)data);
chars.data = data;
assert(r == 1 || chars.len == 0);
return chars;
}
String String_from_MINUS_chars(const Array *a) {
String s = CARP_MALLOC(a->len + 1);
memcpy(s, a->data, a->len);
s[a->len] = '\0';
wchar_t *data = (wchar_t *)a->data;
size_t cnt = a->len;
size_t sz = wutf8len(data, cnt) + 1;
String s = CARP_MALLOC(sz);
size_t sofar = 0;
for (size_t i = 0; i < cnt; i++)
sofar += snprintf(s + sofar, sz - sofar, "%lc", data[i]);
s[sofar] = 0;
return s;
}
String String_tail(const String *s) {
int len = strlen(*s);
size_t len = strlen(*s);
String news = CARP_MALLOC(len);
memcpy(news, (*s) + 1, len - 1);
news[len - 1] = '\0';

2
core/core.h
View File

@ -13,6 +13,8 @@ typedef SSIZE_T ssize_t;
typedef char *String;
typedef char *Pattern;
typedef int64_t Long;
typedef uint32_t Char;
typedef char CChar;
#if defined NDEBUG
#define CHK_INDEX(i, n)

4
default.nix
View File

@ -10,7 +10,7 @@ let
, darwin, glfw3, SDL2, SDL2_image, SDL2_gfx, SDL2_mixer, SDL2_ttf
, clang , makeWrapper
, libXext, libXcursor, libXinerama, libXi, libXrandr, libXScrnSaver, libXxf86vm
, libXext, libXcursor, libXinerama, libXi, libXrandr, libXScrnSaver, libXxf86vm, libpthreadstubs, libXdmcp, libGL
}:
mkDerivation {
pname = "CarpHask";
@ -29,7 +29,7 @@ let
];
pkgconfigDepends =
[ glfw3 SDL2 SDL2_image SDL2_gfx SDL2_mixer SDL2_ttf ]
++ stdenv.lib.optionals stdenv.isLinux [ libXext libXcursor libXinerama libXi libXrandr libXScrnSaver libXxf86vm ];
++ stdenv.lib.optionals stdenv.isLinux [ libXext libXcursor libXinerama libXi libXrandr libXScrnSaver libXxf86vm libpthreadstubs libXdmcp libGL];
executableHaskellDepends = [
base cmdargs containers directory haskeline parsec process
clang

4
docs/core/String.html
View File

@ -438,7 +438,7 @@
external
</div>
<p class="sig">
(Fn [(Ref String a)] (Ptr Char))
(Fn [(Ref String a)] (Ptr CChar))
</p>
<span>
@ -535,7 +535,7 @@
external
</div>
<p class="sig">
(Fn [(Ptr Char)] String)
(Fn [(Ptr CChar)] String)
</p>
<span>

4
docs/sdl/IMG.html
View File

@ -66,7 +66,7 @@
external
</div>
<p class="sig">
(Fn [(Ptr Char)] (Ptr SDL_Surface))
(Fn [(Ptr CChar)] (Ptr SDL_Surface))
</p>
<span>
@ -85,7 +85,7 @@
external
</div>
<p class="sig">
(Fn [(Ptr SDL_Renderer), (Ptr Char)] (Ptr SDL_Texture))
(Fn [(Ptr SDL_Renderer), (Ptr CChar)] (Ptr SDL_Texture))
</p>
<span>

8
docs/sdl/Mixer.html
View File

@ -142,7 +142,7 @@
external
</div>
<p class="sig">
(Fn [] (Ptr Char))
(Fn [] (Ptr CChar))
</p>
<span>
@ -161,7 +161,7 @@
external
</div>
<p class="sig">
(Fn [Int] (Ptr Char))
(Fn [Int] (Ptr CChar))
</p>
<span>
@ -199,7 +199,7 @@
external
</div>
<p class="sig">
(Fn [(Ptr Char)] (Ptr Mix_Music))
(Fn [(Ptr CChar)] (Ptr Mix_Music))
</p>
<span>
@ -218,7 +218,7 @@
external
</div>
<p class="sig">
(Fn [(Ptr Char)] (Ptr Mix_Chunk))
(Fn [(Ptr CChar)] (Ptr Mix_Chunk))
</p>
<span>

2
docs/sdl/SDL.html
View File

@ -959,7 +959,7 @@
external
</div>
<p class="sig">
(Fn [(Ptr SDL_Window), (Ptr Char)] ())
(Fn [(Ptr SDL_Window), (Ptr CChar)] ())
</p>
<span>

12
docs/sdl/TTF.html
View File

@ -85,7 +85,7 @@
external
</div>
<p class="sig">
(Fn [] (Ptr Char))
(Fn [] (Ptr cChar))
</p>
<span>
@ -142,7 +142,7 @@
external
</div>
<p class="sig">
(Fn [(Ptr Char), Int] (Ptr TTF_Font))
(Fn [(Ptr CChar), Int] (Ptr TTF_Font))
</p>
<span>
@ -180,7 +180,7 @@
external
</div>
<p class="sig">
(Fn [(Ptr TTF_Font), (Ptr Char), SDL_Color] (Ptr SDL_Surface))
(Fn [(Ptr TTF_Font), (Ptr CChar), SDL_Color] (Ptr SDL_Surface))
</p>
<span>
@ -199,7 +199,7 @@
external
</div>
<p class="sig">
(Fn [(Ptr TTF_Font), (Ptr Char), SDL_Color, Int] (Ptr SDL_Surface))
(Fn [(Ptr TTF_Font), (Ptr CChar), SDL_Color, Int] (Ptr SDL_Surface))
</p>
<span>
@ -218,7 +218,7 @@
external
</div>
<p class="sig">
(Fn [(Ptr TTF_Font), (Ptr Char), SDL_Color, SDL_Color] (Ptr SDL_Surface))
(Fn [(Ptr TTF_Font), (Ptr CChar), SDL_Color, SDL_Color] (Ptr SDL_Surface))
</p>
<span>
@ -237,7 +237,7 @@
external
</div>
<p class="sig">
(Fn [(Ptr TTF_Font), (Ptr Char), SDL_Color] (Ptr SDL_Surface))
(Fn [(Ptr TTF_Font), (Ptr CChar), SDL_Color] (Ptr SDL_Surface))
</p>
<span>

2
examples/fonts.carp
View File

@ -47,4 +47,4 @@
(do (set! font (TTF.open-font (cstr "resources/Hasklig.otf") 20))
(set! text1 (TTF.render-text-to-texture rend font "Carp!" (SDL.rgb 0 0 0)))
(SDLApp.run-with-callbacks &app event-handler id draw 0))
(println* "Failed to initialize SDL_ttf: " &(str (TTF.get-error)))))))
(println* "Failed to initialize SDL_ttf: " &(from-cstr (TTF.get-error)))))))

6
examples/sounds.carp
View File

@ -33,16 +33,16 @@
(do
(let [flags Mixer.mp3-support]
(when (/= flags (Mixer.init flags))
(println* "Mixer.init error: " &(str (Mixer.get-error)))))
(println* "Mixer.init error: " &(from-cstr (Mixer.get-error)))))
(if (Mixer.ok? (Mixer.open-audio 22050 Mixer.default-format 2 4096))
()
(println* "Mixer.open-audio error: " &(str (Mixer.get-error))))
(println* "Mixer.open-audio error: " &(from-cstr (Mixer.get-error))))
(set! fx1 (Mixer.load-wav (cstr "resources/fx1.wav")))
(assert (not-null? fx1))
(let-do [n (Mixer.nr-of-music-decoders)]
(println* "Nr of music decoders: " n)
(for [i 0 n]
(println* " - " &(str (Mixer.get-music-decoder i)))))
(println* " - " &(from-cstr (Mixer.get-music-decoder i)))))
(let-do [music (Mixer.load-music (cstr "resources/song.mp3"))]
(println* "Music is " (if (null? music) "null." "not null."))
(println* "Play result: " (Mixer.play-music music -1))

2
src/Types.hs
View File

@ -146,7 +146,7 @@ tyToCManglePtr _ LongTy = "Long"
tyToCManglePtr _ ByteTy = "uint8_t"
tyToCManglePtr _ StringTy = "String"
tyToCManglePtr _ PatternTy = "Pattern"
tyToCManglePtr _ CharTy = "char"
tyToCManglePtr _ CharTy = "Char"
tyToCManglePtr _ UnitTy = "void"
tyToCManglePtr _ (VarTy x) = x
tyToCManglePtr _ (FuncTy argTys retTy _) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy

4
test/pointer.carp
View File

@ -13,8 +13,8 @@
; these tests are sadly a little unsafe
(deftest test
(assert-equal test
1l
; we assume that the width of a char is 1
4l
; we assume that the width of a char is 4
(width (Array.raw (the (Array Char) [])))
"Pointer.width works as expected"
)

24
test/unicode.carp Normal file
View File

@ -0,0 +1,24 @@
(use String)
(load "Test.carp")
(load "Array.carp")
(use Test)
(deftest test
(assert-equal test
&[\s \v \e \d \ä \n \g]
&(chars "svedäng")
"chars works as expected")
(assert-equal test
"svedäng"
&(from-chars &[\s \v \e \d \ä \n \g])
"from-chars works as expected")
(assert-equal test
&[\😀 \😀 \😀]
&(chars "😀😀😀")
"chars splits emoji")
(assert-equal test
"😀😀😀"
&(from-chars &[\😀 \😀 \😀])
"from-chars joins emoji")
)