143 lines
4.7 KiB
Common Lisp
143 lines
4.7 KiB
Common Lisp
;; SPKI SEXPs for Common Lisp
|
|
|
|
(in-package :spki-sexp)
|
|
|
|
(define-condition syntax-error (error) ())
|
|
(define-condition bad-length-prefix (syntax-error) ())
|
|
(define-condition bad-display-hint (syntax-error) ())
|
|
(define-condition bad-input-character (syntax-error) ())
|
|
(define-condition unexpected-close-paren (syntax-error) ())
|
|
|
|
(define-condition match-failure (error) ())
|
|
|
|
(defstruct display-hint hint body)
|
|
|
|
(defun write-integer (n output-stream)
|
|
(labels ((w (n)
|
|
(when (plusp n)
|
|
(multiple-value-bind (top-half lower-digit)
|
|
(floor n 10)
|
|
(w top-half)
|
|
(write-byte (+ lower-digit 48) output-stream)))))
|
|
(if (zerop n)
|
|
(write-byte 48 output-stream)
|
|
(w n))))
|
|
|
|
(defun write-sexp (sexp &optional (output-stream *standard-output*))
|
|
(etypecase sexp
|
|
((array (unsigned-byte 8))
|
|
(write-integer (length sexp) output-stream)
|
|
(write-byte 58 output-stream) ;; #\:
|
|
(write-sequence sexp output-stream))
|
|
(cons
|
|
(write-byte 40 output-stream) ;; #\(
|
|
(loop for v in sexp do (write-sexp v output-stream))
|
|
(write-byte 41 output-stream)) ;; #\)
|
|
(display-hint
|
|
(write-byte 91 output-stream)
|
|
(write-sexp (display-hint-hint sexp) output-stream)
|
|
(write-byte 93 output-stream)
|
|
(write-sexp (display-hint-body sexp) output-stream))
|
|
(string
|
|
(write-sexp (flexi-streams:string-to-octets sexp :external-format :utf-8) output-stream))))
|
|
|
|
(defun read-simple-string (input-stream &optional (len 0))
|
|
(loop (let ((c (read-byte input-stream)))
|
|
(if (eql c 58) ;; #\:
|
|
(let ((buf (make-array len :element-type '(unsigned-byte 8))))
|
|
(read-sequence buf input-stream)
|
|
(return buf))
|
|
(let ((v (digit-char-p c)))
|
|
(if v
|
|
(setq len (+ (* len 10) v))
|
|
(error 'bad-length-prefix)))))))
|
|
|
|
(defun read-sexp-list (input-stream)
|
|
(loop for v = (read-sexp-inner input-stream)
|
|
until (eq v 'end-of-list-marker)
|
|
collect v))
|
|
|
|
(defun read-sexp-inner (input-stream)
|
|
(let (result)
|
|
(tagbody :retry
|
|
(setq result
|
|
(let ((c (read-byte input-stream)))
|
|
(cond
|
|
((eql c 40) (read-sexp-list input-stream)) ;; #\(
|
|
((eql c 41) 'end-of-list-marker) ;; #\)
|
|
((eql c 91) ;; #\[
|
|
(let ((hint (read-simple-string input-stream)))
|
|
(when (not (eql (read-byte input-stream) 93)) ;; #\]
|
|
(error 'bad-display-hint))
|
|
(make-display-hint :hint hint :body (read-simple-string input-stream))))
|
|
((<= 48 c 57) (read-simple-string input-stream (- c 48))) ;; digits
|
|
((<= c 32) ;; whitespace - convenience for testing
|
|
(go :retry))
|
|
(t (error 'bad-input-character))))))
|
|
result))
|
|
|
|
(defun read-sexp (&optional (input-stream *standard-input*))
|
|
(let ((v (read-sexp-inner input-stream)))
|
|
(if (eq v 'end-of-list-marker)
|
|
(error 'unexpected-close-paren)
|
|
v)))
|
|
|
|
(defun convert-sexp (val)
|
|
(etypecase val
|
|
((array (unsigned-byte 8)) val)
|
|
(cons (cons (convert-sexp (car val))
|
|
(convert-sexp (cdr val))))
|
|
(null nil)
|
|
(display-hint (make-display-hint
|
|
:hint (convert-sexp (display-hint-hint val))
|
|
:body (convert-sexp (display-hint-body val))))
|
|
(string (flexi-streams:string-to-octets val :external-format :utf-8))))
|
|
|
|
(defmacro sexp-quote (val)
|
|
`(quote ,(convert-sexp val)))
|
|
|
|
(defun build-sexp (stx)
|
|
(etypecase stx
|
|
((array (unsigned-byte 8)) stx)
|
|
(cons (if (eq (car stx) '=)
|
|
(cadr stx)
|
|
`(cons ,(build-sexp (car stx))
|
|
,(build-sexp (cdr stx)))))
|
|
(null 'nil)
|
|
(display-hint `(make-display-hint
|
|
:hint ,(build-sexp (display-hint-hint stx))
|
|
:body ,(build-sexp (display-hint-body stx))))
|
|
(string (flexi-streams:string-to-octets stx :external-format :utf-8))))
|
|
|
|
(defmacro sexp-build (template)
|
|
(build-sexp template))
|
|
|
|
(defun convert-match-pattern (pattern)
|
|
(etypecase pattern
|
|
((array (unsigned-byte 8)) `(array (1 (unsigned-byte 8)) ,(coerce pattern 'list)))
|
|
(cons `(cons ,(convert-match-pattern (car pattern))
|
|
,(convert-match-pattern (cdr pattern))))
|
|
(null 'nil)
|
|
(display-hint `(struct display-hint
|
|
(:hint ,(convert-match-pattern (display-hint-hint pattern)))
|
|
(:body ,(convert-match-pattern (display-hint-body pattern)))))
|
|
(string (convert-match-pattern
|
|
(flexi-streams:string-to-octets pattern :external-format :utf-8)))
|
|
(symbol pattern)))
|
|
|
|
(defmacro match-sexp (val &rest clauses)
|
|
`(cl-match:match ,val
|
|
,@(mapcar (lambda (clause)
|
|
`(,(convert-match-pattern (car clause)) ,@(cdr clause)))
|
|
clauses)))
|
|
|
|
(defmacro ematch-sexp (val &rest clauses)
|
|
`(match-sexp ,val ,@clauses (_ (error 'match-failure))))
|
|
|
|
;; Useful for testing
|
|
(defun read-from-string (str &optional (external-format :utf-8))
|
|
(read-sexp (flexi-streams:make-flexi-stream
|
|
(flexi-streams:make-in-memory-input-stream
|
|
(flexi-streams:string-to-octets str :external-format external-format))
|
|
:external-format external-format)))
|