Merge pull request #36 from compmstr/sbcl-text-fix

Fixed double free issue in SBCL for sdl2-ttf

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 ()

src/package.lisp

@@ -148,4 +148,5 @@
            :with-font
            :set-font
            :text
+           :text-line-image
            ))

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)