File: read-macro.lisp

package info (click to toggle)
cl-lml2 1.6.6-4.1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 184 kB
  • sloc: lisp: 1,316; makefile: 39
file content (80 lines) | stat: -rw-r--r-- 3,142 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          read-macro.lisp
;;;; Purpose:       Lisp Markup Language functions
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Aug 2002
;;;;
;;;; $Id$
;;;;
;;;; This file, part of LML2, is Copyright (c) 2000-2003 by Kevin Rosenberg.
;;;; Rights of modification and redistribution are in the LICENSE file.
;;;;
;;;; *************************************************************************

(in-package #:lml2)

(defun new-string ()
  (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))

(set-macro-character #\[
  #'(lambda (stream char)
      (declare (ignore char))
      (let ((forms '())
            (curr-string (new-string))
            (paren-level 0)
            (got-comma nil))
        (declare (type fixnum paren-level))
        (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
            ((eql ch #\]))
          (if got-comma
              (if (eql ch #\()
                  ;; Starting top-level ,(
                  (progn
                    #+cmu
                    (setf curr-string (coerce curr-string `(simple-array character (*))))

                    (push `(lml2-princ ,curr-string) forms)
                    (setq curr-string (new-string))
                    (setq got-comma nil)
                    (vector-push #\( curr-string)
                    (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
                        ((and (eql ch #\)) (zerop paren-level)))
                      (when (eql ch #\])
                        (format *trace-output* "Syntax error reading #\]")
                        (return nil))
                      (case ch
                        (#\(
                         (incf paren-level))
                        (#\)
                         (decf paren-level)))
                      (vector-push-extend ch curr-string))
                    (vector-push-extend #\) curr-string)
                    (let ((eval-string (read-from-string curr-string))
                          (res (gensym)))
                      (push
                       `(let ((,res ,eval-string))
                          (when ,res
                            (lml2-princ ,res)))
                       forms))
                    (setq curr-string (new-string)))
                ;; read comma, then non #\( char
                (progn
                  (unless (eql ch #\,)
                    (setq got-comma nil))
                  (vector-push-extend #\, curr-string) ;; push previous command
                  (vector-push-extend ch curr-string)))
            ;; previous character is not a comma
            (if (eql ch #\,)
                (setq got-comma t)
              (progn
                (setq got-comma nil)
                (vector-push-extend ch curr-string)))))

        #+cmu
        (setf curr-string (coerce curr-string `(simple-array character (*))))

        (push `(lml2-princ ,curr-string) forms)
        `(progn ,@(nreverse forms)))))