From f7699308a7a1b2fb12bcd372ef76f647b5cf39a5 Mon Sep 17 00:00:00 2001
From: Corey Williams <corey@undimk5>
Date: Mon, 13 Apr 2020 18:51:41 -0400
Subject: [PATCH] Fixed double free issue in SBCL for sdl2-ttf

As per https://github.com/Failproofshark/cl-sdl2-ttf/issues/16,
  sdl2-ttf uses finalizers to free the SDL surfaces generated when
  rendering text.
This was causing sketch to crash (at least on Linux/SBCL) whenever I
  had text being rendered.
I updated the `make-image-from-surface` function to optionally take in
  a :free-surface keyword, which if nil, means it won't free the
  surface manually.

I also moved the text line image generation into it's own function, so
  that static text can be cached and reused instead of being rendered
  and sent to the GPU every frame.

I didn't seem to have the same issue with CCL on OSX, but making this
  change definitely fixed the constant crashes in SBCL, and it still
  works within CCL from my testing.

Leaving the app running with this new code didn't appear to have any
  effect on memory usage.
---
 src/font.lisp      | 41 +++++++++++++++++++++++------------------
 src/package.lisp   |  1 +
 src/resources.lisp |  4 ++--
 3 files changed, 26 insertions(+), 20 deletions(-)

diff --git a/src/font.lisp b/src/font.lisp
index da07b26..971c08a 100644
--- a/src/font.lisp
+++ b/src/font.lisp
@@ -54,30 +54,35 @@
 	((eq align :center) (- (round (/ width 2))))
 	(t 0)))
 
+(defun text-line-image (line)
+  (let* ((font (env-font *env*))
+         (typeface (and font (load-resource (typeface-filename (font-face font))
+                                            :size (font-size font)))))
+    (destructuring-bind (r g b a) (color-rgba-255 (font-color font))
+      (make-image-from-surface (sdl2-ttf:render-utf8-blended
+                                (typeface-pointer typeface)
+                                line r g b a)
+                               :free-surface nil))))
+
 (defun text (text-string x y &optional width height)
   (let* ((font (env-font *env*))
          (typeface (and font (load-resource (typeface-filename (font-face font))
                                             :size (font-size font)))))
     (when (and font (> (length text-string) 0))
       (with-pen (make-pen :stroke nil)
-	(destructuring-bind (r g b a) (color-rgba-255 (font-color font))
-	  (let* ((top 0)
-		 (lines (split-sequence:split-sequence #\newline text-string))
-		 (resources (mapcar (lambda (line)
-				      (make-image-from-surface
-				       (sdl2-ttf:render-utf8-blended
-					(typeface-pointer typeface) line r g b a)))
-				    lines))
-		 (spacing (* (font-size font) (font-line-height font)))
-		 (scale (text-scale resources spacing width height)))
-	    (dolist (resource resources)
-	      (image resource
-		     (+ x (text-align (font-align font) (* (first scale) (image-width resource))))
-		     (+ y top)
-		     (* (first scale) (image-width resource))
-		     (* (second scale) (image-height resource)))
-	      (incf top (* (second scale) spacing))
-	      (gl:delete-textures (list (image-texture resource))))))))))
+        (let* ((top 0)
+               (lines (split-sequence:split-sequence #\newline text-string))
+               (resources (mapcar #'text-line-image lines))
+               (spacing (* (font-size font) (font-line-height font)))
+               (scale (text-scale resources spacing width height)))
+          (dolist (resource resources)
+            (image resource
+                   (+ x (text-align (font-align font) (* (first scale) (image-width resource))))
+                   (+ y top)
+                   (* (first scale) (image-width resource))
+                   (* (second scale) (image-height resource)))
+            (incf top (* (second scale) spacing))
+            (gl:delete-textures (list (image-texture resource)))))))))
 
 (let ((font))
   (defun make-default-font ()
diff --git a/src/package.lisp b/src/package.lisp
index d85a747..a0e6e25 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -148,4 +148,5 @@
            :with-font
            :set-font
            :text
+           :text-line-image
            ))
diff --git a/src/resources.lisp b/src/resources.lisp
index f0b6aa0..5fd98de 100644
--- a/src/resources.lisp
+++ b/src/resources.lisp
@@ -77,7 +77,7 @@
       (error (format nil "~a's type cannot be deduced." filename))
       (error (format nil "Unsupported resource type ~a" type))))
 
-(defun make-image-from-surface (surface)
+(defun make-image-from-surface (surface &key (free-surface t))
   (let ((texture (car (gl:gen-textures 1))))
     (gl:bind-texture :texture-2d texture)
     (gl:tex-parameter :texture-2d :texture-min-filter :linear)
@@ -92,7 +92,7 @@
                                 :width (sdl2:surface-width surface)
                                 :height (sdl2:surface-height surface)
                                 :texture texture)))
-      (sdl2:free-surface surface)
+      (when free-surface (sdl2:free-surface surface))
       image)))
 
 (defmethod load-typed-resource (filename (type (eql :image)) &key &allow-other-keys)