(defun read-main (read-ch) (let ((ini-ch nil) (next-ch (funcall read-ch 'next)) (same-ch (funcall read-ch 'same))) (consume-whitespace read-ch) (setf ini-ch (funcall same-ch)) (cond ((is-symbol-start ini-ch) (read-symbol read-ch)) ((is-quote-start ini-ch) (let () (funcall next-ch) (list 'quote (read-main read-ch)))) ((is-macro-start ini-ch) (read-macro read-ch)) ((is-lparen ini-ch) (let ((lv nil) (rv nil)) (funcall next-ch) (consume-whitespace read-ch) (cond ((is-rparen (funcall same-ch)) (let () (funcall next-ch) nil)) (t (let () (setf lv (read-main read-ch)) (setf rv (read-rest-list read-ch)) (cons lv rv)))))) (t (throw 'read-error "read:err:unknown form"))))) (defun read-rest-list (read-ch) (let ((lv nil) (rv nil) (next-ch (funcall read-ch 'next)) (same-ch (funcall read-ch 'same)) (peek-ch (funcall read-ch 'peek))) (consume-whitespace read-ch) (cond ((is-dot (funcall same-ch)) (let () (cond ((is-whitespace (funcall peek-ch)) (let () (funcall next-ch) (setf rv (read-main read-ch)) (consume-whitespace read-ch) (cond ((is-rparen (funcall same-ch)) (let () (funcall next-ch) rv)) (t (throw 'read-error "read:err:missing rparen:1"))))) (t (let () (setf lv (read-main read-ch)) (setf rv (read-rest-list read-ch)) (cons lv rv)))))) (t (cond ((is-rparen (funcall same-ch)) (let () (funcall next-ch) nil)) (t (let () (setf lv (read-main read-ch)) (setf rv (read-rest-list read-ch)) (cons lv rv)))))))) (defun is-quote-start (ch) (eq ch #\')) (defun is-macro-start (ch) (eq ch #\#)) (defun is-atom-start (ch) (or (is-alpha ch) (is-digit ch) (member ch '( #\* #\\ #\+ #\-)))) (defun is-fixnum-start (ch) (or (is-digit ch) (member ch '(#\- #\+)))) (defun is-float-start (ch) (or (is-fixnum-start ch) (eq ch #\.))) (defun is-symbol-start (ch) (or (is-fixnum-start ch) (is-float-start ch) (is-atom-start ch))) (defun is-symbol-ch (ch) (or (is-alpha ch) (is-digit ch) (member ch '( #\* #\\ #\+ #\- #\. #\< #\> #\= #\? #\_ )))) (defun is-lparen (ch) (eq ch #\()) (defun is-rparen (ch) (eq ch #\))) (defun is-dot (ch) (eq ch #\.)) (defun is-sign (ch) (or (eq ch #\+) (eq ch #\-))) (defun is-whitespace (ch) (member ch '(#\Space))) (defun is-atom-char (ch) (or (is-alpha ch) (is-digit ch) (member ch '(#\- #\+)))) (defun is-digit (ch) (and (>= (char-code ch) (char-code #\0)) (<= (char-code ch) (char-code #\9)))) (defun is-hex-digit (ch) (or (is-digit ch) (and (>= (char-code ch) (char-code #\a)) (<= (char-code ch) (char-code #\f))))) (defun is-alpha (ch) (and (>= (char-code ch) (char-code #\a)) (<= (char-code ch) (char-code #\z)))) (defun is-expo-init (ch) (member ch '( #\e #\E ))) (defun consume-whitespace (read-ch) (let ((next-ch (funcall read-ch 'next)) (same-ch (funcall read-ch 'same))) (do ((akt-ch (funcall same-ch) (funcall next-ch))) ((not (is-whitespace akt-ch)))))) (defun read-symbol (read-ch) (let ((sym-cl nil) (num nil) (next-ch (funcall read-ch 'next)) (same-ch (funcall read-ch 'same))) (do ((akt-ch (funcall same-ch) (funcall next-ch))) ((not (is-symbol-ch akt-ch))) (setf sym-cl (cons akt-ch sym-cl))) (setf sym-cl (reverse sym-cl)) (setf num (read-cl-as-number sym-cl)) (if num num (make-atom-str sym-cl)))) (defun make-string-cl (cl) (cons 'string cl)) (defun make-atom-str (str) (list 'atom str)) (defun read-macro (read-ch) (let ((next-ch (funcall read-ch 'next)) (same-ch (funcall read-ch 'same)) (akt-ch nil) (res nil)) (setf akt-ch (funcall next-ch)) (cond ((eq akt-ch #\') (let () (funcall next-ch) (list 'function (read-main read-ch)))) ((eq akt-ch #\Q) (let () (setf res nil) (do ((i 0 (+ 1 i))) ((> i 7)) (setf akt-ch (funcall next-ch)) (if (not (is-hex-digit akt-ch)) (throw 'read-error "read:err:Q malformed:001")) (setf res (cons akt-ch res))) (funcall next-ch) (setf res (reverse res)) (make-q res))) ((eq akt-ch #\\) (setf akt-ch (funcall next-ch)) (funcall next-ch) akt-ch) (t (throw 'read-error "read:err:undefined macro:001"))))) (defun make-q (hexl) (list 'Q hexl)) (defun digit-to-num (ch) (- (char-code ch) (char-code #\0))) (defun read-cl-as-number (cl) (let ((sign +1) (sign-exp +1) (cll cl) (pre-dot 0) (post-dot 0) (exp-val 0) (dig-cnt 0)) (cond ((eq (car cll) #\+) (let () (setf cll (cdr cll)))) ((eq (car cll) #\-) (let () (setf cll (cdr cll)) (setf sign -1)))) (setf dig-cnt (do ((akt-ch (car cll) (car cll)) (pre-digs 0 (+ pre-digs 1))) ((or (not cll) (not (is-digit akt-ch))) pre-digs) (setf pre-dot (+ (* pre-dot 10) (digit-to-num akt-ch))) (setf cll (cdr cll)))) (if (and (null cll) (> dig-cnt 0)) (return-from read-cl-as-number (* sign pre-dot))) (if (eq (car cll) #\.) (let () (setf cll (cdr cll)) (do ((akt-ch (car cll) (car cll)) (dez-fact 0.1 (* 0.1 dez-fact)) (post-digs 0 (+ post-digs 1))) ((or (not cll) (not (is-digit akt-ch)))) (setf cll (cdr cll)) (if (< post-digs 6) (setf post-dot (+ post-dot (* dez-fact (digit-to-num akt-ch)))))))) (if (null cll) (return-from read-cl-as-number (* sign (+ pre-dot post-dot)))) (if (is-expo-init (car cll)) (let () (setf cll (cdr cll)) (if (is-sign (car cll)) (let () (if (eq (car cll) #\-) (setf sign-exp -1)) (setf cll (cdr cll)))) (do ((akt-ch (car cll) (car cll)) (exp-digs 0 (+ exp-digs 1))) ((or (not cll) (not (is-digit akt-ch)))) (setf exp-val (+ (* exp-val 10) (digit-to-num akt-ch))) (setf cll (cdr cll))) (setf exp-val (expt 10.0 (* sign-exp exp-val))))) (if (null cll) (return-from read-cl-as-number (* sign (+ pre-dot post-dot) exp-val))) nil)) (defun make-reader (str) (let ((i 0)) #'(lambda (choose) (cond ((eq choose 'next) #'(lambda () (progn (setf i (1+ i))(format t "~S" (elt str i)) (elt str i)))) ((eq choose 'same) #'(lambda ()(elt str i))) ((eq choose 'peek) #'(lambda () (elt str (+ i 1)))))))) (defun test-read (str) (let ((res nil)) (setf res (make-reader str)) (read-main res)))