String interpolation

control-flow.lisp

@@ -9,7 +9,6 @@
                 :until (and (consp form) (find (car form) '(:then :else-if :else)))
                 :collect form
                 :finally (setf body tail)))
-        (else-if-forms nil)
         (else-forms nil))
     ;; Handle :THEN, :ELSE, and :ELSE-IF clauses
     (loop :for tail :on body

fun-utils.lisp

@@ -0,0 +1,23 @@
+(in-package #:syrup)
+
+(defmacro curry ((fun &rest args) &key (blank '*) (rest nil))
+  "Construct a lambda around FUN, where arguments not marked with * are pre-filled with the specified forms.
+  e.g. (curry (- * 2)) => (lambda (x) (- x 2))
+  :BLANK (default *) - specify the blank symbol
+  :REST (default NIL) - if true, add a &rest argument to the end of the lambda"
+  (let ((outer-args nil) (inner-args nil))
+    (dolist (arg args)
+      (if (eql arg blank)
+          (let ((sym (gensym)))
+            (push sym outer-args)
+            (push sym inner-args))
+          ;; else
+          (push arg inner-args)))
+    ;; reverse the lists, since we used PUSH to build them
+    (setf outer-args (nreverse outer-args)
+          inner-args (nreverse inner-args))
+    ;; now create the lambda
+    (if rest
+        (let ((rest-sym (gensym)))
+          `(lambda (,@outer-args &rest ,rest-sym) (apply (function ,fun) ,@inner-args ,rest-sym)))
+        `(lambda ,outer-args (,fun ,@inner-args)))))

strings.lisp

@@ -0,0 +1,117 @@
+(in-package #:syrup)
+;; Support for standard escape sequences and expression interpolation in strings.
+
+(defmacro read-char* (stream)
+  `(read-char ,stream t nil t))
+(defmacro peek-char* (stream)
+  `(peek-char nil ,stream t nil t))
+
+(defparameter *string-escapes-alist*
+  `((#\t . #\Tab)
+    (#\n . #\Newline)
+    (#\r . #\Return)
+    (#\f . #\Page)
+    (#\b . #\Backspace)
+    (#\a . ,(code-char #x07))
+    (#\e . ,(code-char #x1b)))
+  "Mapping of escape sequence characters to the values they represent.")
+
+(defun read-number* (stream radix &key (max most-positive-fixnum))
+  (let ((val 0))
+    (loop :for n :from 0 :below max
+          :for digit := (digit-char-p (peek-char* stream) radix)
+          :while digit
+          :do (read-char* stream)
+              (setf val (+ (* val radix) digit)))
+    val))
+
+(defun read-syrup-string (stream quote-char &optional arg)
+  (declare (ignore arg))
+  (let ((buf (make-array 0 :element-type 'character :fill-pointer t :adjustable t))
+        (interp-list ()))
+    (loop :for ch := (read-char* stream)
+          :until (char= ch quote-char)
+          :do
+          (if (char= ch #\\)
+              (let ((ch2 (read-char* stream)))
+                (case ch2
+                  (#\Newline ;; skip whitespace
+                   (loop :for ch3 := (peek-char* stream)
+                         :while (or (char= ch3 #\Space)
+                                    (not (or (graphic-char-p ch3) (char= ch3 #\Newline))))
+                         :do (read-char* stream)))
+                  (#\c ;; control code: \cA
+                   (vector-push-extend (code-char (logxor #x40 (char-code (char-upcase ch2)))) buf))
+                  ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) ;; octal: \033
+                   (unread-char ch2 stream)
+                   (vector-push-extend (code-char (read-number* stream 8 :max 3)) buf))
+                  (#\x ;; hex: \xFF or \x{10FFFF}
+                   (if (char= (peek-char* stream) #\{)
+                       (progn
+                         (read-char* stream)
+                         (let ((val (read-number* stream 16)))
+                           (unless (char= (peek-char* stream) #\})
+                             (error 'simple-reader-error
+                                    :stream stream
+                                    :format-control "Expected } after \\x{ sequence"
+                                    :format-arguments nil))
+                           (read-char* stream)
+                           (vector-push-extend (code-char val) buf)))
+                       (vector-push-extend (code-char (read-number* stream 16 :max 2)) buf)))
+                  (#\U ;; hex, but as \Uxxxxxx or \U+xxxxxx
+                   (when (char= (peek-char* stream) #\+)
+                     (read-char* stream))
+                   (vector-push-extend (code-char (read-number* stream 16)) buf))
+                  (#\N ;; named char: \N{greek:sigma}
+                   (unless (char= (peek-char* stream) #\{)
+                     (error 'simple-reader-error
+                            :stream stream
+                            :format-control "Expected { after \\N"
+                            :format-arguments nil))
+                   (read-char* stream)
+                   (let ((name (make-array 0 :element-type 'character :fill-pointer t :adjustable t))
+                         (cl-unicode:*try-abbreviations-p* t)
+                         (cl-unicode:*try-hex-notation-p* t))
+                     (loop :for ch3 := (read-char* stream)
+                           :until (char= ch3 #\})
+                           :do (vector-push-extend ch3 name))
+                     (vector-push-extend (cl-unicode:character-named name) buf)))
+                  (#\~ ;; format interpolation
+                   (let ((directive (make-array 0 :element-type 'character :fill-pointer t :adjustable t)))
+                     (vector-push-extend #\~ directive)
+                     (loop :for ch3 := (read-char* stream)
+                           :until (char= ch3 #\()
+                           :do (vector-push-extend ch3 directive)
+                           (if (char= ch3 #\') ;; apostrophe marks a character, which might be left-bracket
+                               (vector-push-extend (read-char* stream) directive)))
+                     (setf interp-list
+                           (nconc interp-list `((,(length buf) ,directive . ,(read-bracketed-list stream #\()))))
+                     ))
+                  (t ;; regular escape w/ no custom meaning
+                   (vector-push-extend (or (cdr (assoc ch2 *string-escapes-alist*)) ch2) buf))))
+              ;; else
+              (vector-push-extend ch buf)))
+    (if interp-list
+        (process-string-interp buf interp-list)
+        (coerce buf 'simple-string))))
+
+(defun process-string-interp (string interp-list)
+  (let* ((stream (gensym))
+         (last-pos 0)
+         (forms
+          (loop :for (pos directive . form) :in interp-list
+                :append
+                `(,@(prog1
+                        (if (> pos last-pos)
+                            `((write-string ,(subseq string last-pos pos) ,stream))
+                            nil)
+                      (setf last-pos pos))
+                  (format ,stream ,directive (progn ,@form)))))
+         (final-str (subseq string last-pos)))
+    `(with-output-to-string (,stream)
+       ,@forms
+       ,@(if (> (length final-str) 0)
+             `((write-string ,final-str ,stream))
+             nil))))
+
+(set-dispatch-macro-character #\# #\" #'read-syrup-string)

syrup.asd

@@ -4,7 +4,10 @@
   :author "~keith <keith@keithhacks.cyou>"
   :homepage "https://bytes.keithhacks.cyou/keith/syrup"
   :license "Public Domain/CC0"
+  :depends-on ("cl-unicode")
   :components ((:file "syrup")
                (:file "exports")
-               (:file "control-flow"))
+               (:file "control-flow")
+               (:file "fun-utils")
+               (:file "strings"))
   :serial t)

syrup.lisp

@@ -6,6 +6,8 @@
    #:export* #:defpackage*
    ;; control-flow.lisp
    #:if* #:while
+   ;; fun-utils.lisp
+   #:curry
    ))
 (in-package #:syrup)
 
@@ -16,6 +18,7 @@
 (defun read-bracketed-list (stream begin-char)
   (let* ((end-char (cond ((char= begin-char #\[) #\])
                          ((char= begin-char #\{) #\})
+                         ((char= begin-char #\() #\))
                          (t (error 'simple-reader-error
                                    :stream stream
                                    :format-control "Invalid bracket ~S"