fork download
copy 
  1. ;;;; -*- mode:lisp;coding:utf-8 -*-
  2. ;;;;**************************************************************************
  3. ;;;;FILE:               c-string-reader.lisp
  4. ;;;;LANGUAGE:           Common-Lisp
  5. ;;;;SYSTEM:             Common-Lisp
  6. ;;;;USER-INTERFACE:     NONE
  7. ;;;;DESCRIPTION
  8. ;;;;
  9. ;;;;    A C string reader, implementing C string back-slash escapes.
  10. ;;;;    Also includes a writer to print strings with C back-slash escapes.
  11. ;;;;
  12. ;;;;AUTHORS
  13. ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
  14. ;;;;MODIFICATIONS
  15. ;;;;    2013-05-22 <PJB> Added character-code-reader-macro, factorized
  16. ;;;;                     out c-escaped-character-map.
  17. ;;;;                     Published as http://p...content-available-to-author-only...p.org/display/137262
  18. ;;;;    2011-05-21 <PJB> Updated from http://p...content-available-to-author-only...p.org/display/69905 (lost).
  19. ;;;;BUGS
  20. ;;;;LEGAL
  21. ;;;;    AGPL3
  22. ;;;;
  23. ;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
  24. ;;;;
  25. ;;;;    This program is free software: you can redistribute it and/or modify
  26. ;;;;    it under the terms of the GNU Affero General Public License as published by
  27. ;;;;    the Free Software Foundation, either version 3 of the License, or
  28. ;;;;    (at your option) any later version.
  29. ;;;;
  30. ;;;;    This program is distributed in the hope that it will be useful,
  31. ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
  32. ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  33. ;;;;    GNU Affero General Public License for more details.
  34. ;;;;
  35. ;;;;    You should have received a copy of the GNU Affero General Public License
  36. ;;;;    along with this program.  If not, see <http://w...content-available-to-author-only...u.org/licenses/>.
  37. ;;;;**************************************************************************
  38.  
  39. (eval-when (:compile-toplevel :load-toplevel :execute)
  40.   (ql:quickload "babel"))
  41.  
  42. (defpackage "COM.INFORMATIMAGO.COMMON-LISP.C-STRING"
  43.   (:use "COMMON-LISP" "BABEL")
  44.   (:export "ENABLE-C-STRING-READER-MACRO"))
  45. (in-package "COM.INFORMATIMAGO.COMMON-LISP.C-STRING")
  46.  
  47.  
  48. (defun c-escaped-character-map (escaped-character)
  49.   (case escaped-character
  50.     ((#\' #\" #\? #\\) escaped-character)
  51.     ((#\newline) -1)
  52.     ((#\a)        7)
  53.     ((#\b)        8)
  54.     ((#\t)        9)
  55.     ((#\n)       10)
  56.     ((#\v)       11)
  57.     ((#\f)       12)
  58.     ((#\r)       13)
  59.     ((#\x)       :hexa)
  60.     ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) :octal)
  61.     (otherwise   :default)))
  62.  
  63.  
  64.  
  65. (defun char-unicode (character)
  66.   (let ((bytes (babel:string-to-octets (string character)
  67.                                        :encoding :utf-32be
  68.                                        :use-bom nil)))
  69.     (+ (* 256 (+ (* 256 (+ (* 256 (aref bytes 0))
  70.                            (aref bytes 1)))
  71.                  (aref bytes 2)))
  72.        (aref bytes 3))))
  73.  
  74.  
  75. (defun character-code-reader-macro (stream quotation-mark)
  76.   (declare (ignore quotation-mark))
  77.   (flet ((encode (ch) (char-unicode ch)))
  78.     (let ((ch (read-char stream)))
  79.       (if (char/= #\\ ch)
  80.           (encode ch)
  81.           (let* ((ch (read-char stream))
  82.                  (code (c-escaped-character-map ch)))
  83.             (flet ((read-code (*read-base* base-name)
  84.                      (let ((code (read stream)))
  85.                        (if (and (integerp code) (<= 0 code (1- char-code-limit)))
  86.                            code
  87.                            (error "Invalid ~A character code: ~A" base-name code)))))
  88.               (case code
  89.                 (:hexa  (read-code 16 "hexadecimal"))
  90.                 (:octal (unread-char ch stream) (read-code  8 "octal"))
  91.                 (:default ;; In emacs ?\x = ?x
  92.                  (encode ch))
  93.                 (otherwise
  94.                  (if (characterp code)
  95.                      (encode code)
  96.                      code)))))))))
  97.  
  98. (set-macro-character #\? 'character-code-reader-macro t)
  99. ;; (set-macro-character #\? 'character-code-reader-macro t)
  100.  
  101.  
  102. (defun read-c-string (stream)
  103.   "Read a C string from the STREAM
  104. The initial double-quote must have been read already."
  105.   (let ((buffer (make-array 80 :element-type 'character
  106.                             :adjustable t :fill-pointer 0))
  107.         (state :in-string)
  108.         (start  0))
  109.     (flet ((process-token (ch)
  110.              (ecase state
  111.                ((:in-string)
  112.                 (setf state (case ch
  113.                               ((#\")     :out)
  114.                               ((#\\)     :escape)
  115.                               (otherwise (vector-push-extend ch buffer)
  116.                                          :in-string)))
  117.                 nil)
  118.                ((:escape)
  119.                 (setf state :in-string)
  120.                 (let ((code (c-escaped-character-map ch)))
  121.                   (case code
  122.                     (:hexa
  123.                      (setf state :in-hexa
  124.                            start (fill-pointer buffer)))
  125.                     (:octal
  126.                      (setf state :in-octal
  127.                            start (fill-pointer buffer))
  128.                      (vector-push-extend ch buffer))
  129.                     (:default
  130.                      (error "Invalid escape character \\~C at position ~D"
  131.                             ch (fill-pointer buffer)))
  132.                     (otherwise
  133.                      (cond
  134.                        ((characterp code) (vector-push-extend code buffer))
  135.                        ((eql -1 code) #|remove it|#)
  136.                        (t (vector-push-extend (aref #(- - - - - - -
  137.                                                       #\bell #\backspace #\tab
  138.                                                       #\linefeed #\vt #\page
  139.                                                       #\return)
  140.                                                     code)
  141.                                               buffer))))))
  142.                 nil)
  143.                ((:in-octal)
  144.                 (flet ((insert-octal ()
  145.                          (setf (aref buffer start) (code-char (parse-integer buffer :start start :radix 8))
  146.                                (fill-pointer buffer) (1+ start)
  147.                                state :in-string)))
  148.                  (case ch
  149.                    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
  150.                     (vector-push-extend ch buffer)
  151.                     (when (<= 3 (- (fill-pointer buffer) start))
  152.                       (insert-octal))
  153.                     nil)
  154.                    (otherwise
  155.                     (insert-octal)
  156.                     :again))))
  157.                ((:in-hexa)
  158.                 (case ch
  159.                   ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
  160.                         #\a #\b #\c #\d #\e #\f
  161.                         #\A #\B #\C #\D #\E #\F)
  162.                    (vector-push-extend ch buffer)
  163.                    nil)
  164.                   (otherwise
  165.                    (if (< start (fill-pointer buffer))
  166.                        (setf (aref buffer start) (code-char (parse-integer buffer :start start :radix 16))
  167.                              (fill-pointer buffer) (1+ start))
  168.                        (error "Invalid hexadecimal digit at position ~A" (fill-pointer buffer)))
  169.                    (setf state :in-string)
  170.                    :again))))))
  171.       (loop
  172.          :for ch = (read-char stream)
  173.          :do (loop :while (process-token ch))
  174.          :until (eq state :out)
  175.          :finally (return buffer)))))
  176.  
  177. (defun write-c-string (string &optional (stream *standard-output*))
  178.   "Prints the string as a C string, with C escape sequences."
  179.   (loop
  180.     :for ch :across string
  181.       :initially (princ "\"" stream)
  182.     :do (princ (case ch
  183.                  ((#\bell)               "\\a")
  184.                  ((#\backspace)          "\\b")
  185.                  ((#\page)               "\\f")
  186.                  ((#\newline
  187.                    #-#.(cl:if (cl:char= #\newline #\linefeed) '(:and) '(:or))
  188.                    #\linefeed) "\\n")
  189.                  ((#\return)             "\\r")
  190.                  ((#\tab)                "\\t")
  191.                  ((#\vt)                 "\\v")
  192.                  ((#\")                  "\\\"")
  193.                  ((#\\)                  "\\\\")
  194.                  (otherwise
  195.                   (cond ((< (char-code ch) 32)
  196.                          (format nil "\\~3,'0o" (char-code ch)))
  197.                         ((< (char-code ch) 127)
  198.                          ch)
  199.                         ((< (char-code ch) #x10000)
  200.                          (format nil "\\u~4,'0X" (char-code ch)))
  201.                         (t
  202.                          (format nil "\\U~8,'0X" (char-code ch))))))
  203.                stream)
  204.     :finally (princ "\"" stream)))
  205.  
  206. ;; (write-c-string "꧁Été꧂ Летом 🚀")
  207. ;; "\uA9C1\u00C9t\u00E9\uA9C2 \uF83D\u041B\u0435\u0442\u043E\u043C \U0001F680"
  208.  
  209.  
  210.  
  211.  
  212. (defun test/read-c-string ()
  213.  (let ((*readtable*
  214.         (let ((rt (copy-readtable nil)))
  215.           (set-macro-character #\"
  216.                                (lambda (stream ch)
  217.                                  (declare (ignore ch))
  218.                                  (read-c-string stream))
  219.                                nil
  220.                                rt)
  221.           rt)))
  222.     (read-from-string "\"Hello, bell=\\a, backspace=\\b, page=\\f, newline=\\n, return=\\r, tab=\\t, vt=\\v, \\
  223. \\\"double-quotes\\\", \\'single-quotes\\', question\\?, backslash=\\\\, \\
  224. hexa=\\x3BB, octal=\\101, \\7\\77\\107\\3071\"")))
  225.  
  226.  
  227. (defmacro enable-c-string-reader-macro ()
  228.   `(eval-when (:compile-toplevel :load-toplevel :execute)
  229.      (set-macro-character #\"
  230.                           (lambda (stream ch)
  231.                             (declare (ignore ch))
  232.                             (read-c-string stream))
  233.                           nil)))
  234.  
  235.  
  236. ;;;; THE END ;;;;
  237.  
Compilation error #stdin compilation error #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
compilation info 
; compiling file "/home/lgmrmI/prog.lisp" (written 01 MAY 2021 10:13:13 AM):
; 
; caught ERROR:
;   READ error during COMPILE-FILE:
;   
;     Package QL does not exist.
;   
;       Line: 40, Column: 15, File-Position: 1768
;   
;       Stream: #<SB-INT:FORM-TRACKING-STREAM for "file /home/lgmrmI/prog.lisp" {1001B885C3}>
; 
; compilation unit aborted
;   caught 1 fatal ERROR condition
;   caught 1 ERROR condition

; compilation aborted after 0:00:00.009
Unhandled SIMPLE-ERROR in thread #<SB-THREAD:THREAD "main thread" RUNNING
                                    {10005D05B3}>:
  compilation failed

Backtrace for: #<SB-THREAD:THREAD "main thread" RUNNING {10005D05B3}>
0: (SB-DEBUG::DEBUGGER-DISABLED-HOOK #<SIMPLE-ERROR "compilation failed" {1001B91ED3}> #<unused argument> :QUIT T)
1: (SB-DEBUG::RUN-HOOK *INVOKE-DEBUGGER-HOOK* #<SIMPLE-ERROR "compilation failed" {1001B91ED3}>)
2: (INVOKE-DEBUGGER #<SIMPLE-ERROR "compilation failed" {1001B91ED3}>)
3: (ERROR "compilation failed")
4: (SB-INT:SIMPLE-EVAL-IN-LEXENV (ERROR "compilation failed") #<NULL-LEXENV>)
5: (SB-INT:SIMPLE-EVAL-IN-LEXENV (WHEN (NTH-VALUE 2 (COMPILE-FILE "prog.lisp")) (ERROR "compilation failed")) #<NULL-LEXENV>)
6: (EVAL (WHEN (NTH-VALUE 2 (COMPILE-FILE "prog.lisp")) (ERROR "compilation failed")))
7: (SB-IMPL::PROCESS-EVAL/LOAD-OPTIONS ((:EVAL . "(when(nth-value 2(compile-file \"prog.lisp\"))(error \"compilation failed\"))") (:EVAL . "(quit)")))
8: (SB-IMPL::TOPLEVEL-INIT)
9: ((FLET SB-UNIX::BODY :IN SAVE-LISP-AND-DIE))
10: ((FLET "WITHOUT-INTERRUPTS-BODY-14" :IN SAVE-LISP-AND-DIE))
11: ((LABELS SB-IMPL::RESTART-LISP :IN SAVE-LISP-AND-DIE))

unhandled condition in --disable-debugger mode, quitting
stdout
copy 
Standard output is empty
https://ideone.com/Lw6yy3
c-string-reader-macro
language:
Common Lisp (sbcl 1.4.16)
created:
3 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!