From 72af0f76403e35aa35a42ef437d87ae9b322b438 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 22 Feb 1990 16:46:53 +0000 Subject: [PATCH] Initial revision --- code/backq.lisp | 174 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 174 insertions(+) create mode 100644 code/backq.lisp diff --git a/code/backq.lisp b/code/backq.lisp new file mode 100644 index 000000000..4d40fc348 --- /dev/null +++ b/code/backq.lisp @@ -0,0 +1,174 @@ +;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; BACKQUOTE: Code Spice Lispified by Lee Schumacher. +;;; +(in-package 'lisp) + + +;;; The flags passed back by BACKQUOTIFY can be interpreted as follows: +;;; +;;; |`,|: [a] => a +;;; NIL: [a] => a ;the NIL flag is used only when a is NIL +;;; T: [a] => a ;the T flag is used when a is self-evaluating +;;; QUOTE: [a] => (QUOTE a) +;;; APPEND: [a] => (APPEND . a) +;;; NCONC: [a] => (NCONC . a) +;;; LIST: [a] => (LIST . a) +;;; LIST*: [a] => (LIST* . a) +;;; +;;; The flags are combined according to the following set of rules: +;;; ([a] means that a should be converted according to the previous table) +;;; +;;; \ car || otherwise | QUOTE or | |`,@| | |`,.| +;;;cdr \ || | T or NIL | | +;;;================================================================================ +;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d]) +;;; NIL || LIST ([a]) | QUOTE (a) | <hair> a | <hair> a +;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d]) +;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d]) +;;; NCONC || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d) +;;; LIST || LIST ([a] . d) | LIST ([a] . d) | APPEND (a [d]) | NCONC (a [d]) +;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d]) +;;; +;;;<hair> involves starting over again pretending you had read ".,a)" instead +;;; of ",@a)" + +(defvar *backquote-count* 0 "How deep we are into backquotes") +(defvar *bq-comma-flag* '(|,|)) +(defvar *bq-at-flag* '(|,@|)) +(defvar *bq-dot-flag* '(|,.|)) +(defvar *bq-vector-flag* '(|bqv|)) + + +;; This is the actual character macro. +(defun backquote-macro (stream ignore) + (declare (ignore ignore)) + (let ((*backquote-count* (1+ *backquote-count*))) + (multiple-value-bind (flag thing) + (backquotify (read stream t nil t)) + (if (eq flag *bq-at-flag*) + (error ",@ after backquote in ~S" thing)) + (if (eq flag *bq-dot-flag*) + (error ",. after backquote in ~S" thing)) + (values (backquotify-1 flag thing) 'list)))) + +(defun comma-macro (stream ignore) + (declare (ignore ignore)) + (unless (> *backquote-count* 0) + (when *read-suppress* + (return-from comma-macro nil)) + (error "Comma not inside a backquote.")) + (let ((c (read-char stream)) + (*backquote-count* (1- *backquote-count*))) + (values + (cond ((char= c #\@) + (cons *bq-at-flag* (read stream t nil t))) + ((char= c #\.) + (cons *bq-dot-flag* (read stream t nil t))) + (t (unread-char c stream) + (cons *bq-comma-flag* (read stream t nil t)))) + 'list))) + +;;; This does the expansion from table 2. +(defun backquotify (code) + (cond ((atom code) + (cond ((null code) (values nil nil)) + ((or (numberp code) + (eq code t)) + ;; Keywords are self evaluating. Install after packages. + (values t code)) + (t (values 'quote code)))) + ((or (eq (car code) *bq-at-flag*) + (eq (car code) *bq-dot-flag*)) + (values (car code) (cdr code))) + ((eq (car code) *bq-comma-flag*) + (comma (cdr code))) + ((eq (car code) *bq-vector-flag*) + (multiple-value-bind (dflag d) (backquotify (cdr code)) + (values 'vector (backquotify-1 dflag d)))) + (t (multiple-value-bind (aflag a) (backquotify (car code)) + (multiple-value-bind (dflag d) (backquotify (cdr code)) + (if (eq dflag *bq-at-flag*) + ;; get the errors later. + (error ",@ after dot in ~S" code)) + (if (eq dflag *bq-dot-flag*) + (error ",. after dot in ~S" code)) + (cond + ((eq aflag *bq-at-flag*) + (if (null dflag) + (comma a) + (values 'append + (cond ((eq dflag 'append) + (cons a d )) + (t (list a (backquotify-1 dflag d))))))) + ((eq aflag *bq-dot-flag*) + (if (null dflag) + (comma a) + (values 'nconc + (cond ((eq dflag 'nconc) + (cons a d)) + (t (list a (backquotify-1 dflag d))))))) + ((null dflag) + (if (memq aflag '(quote t nil)) + (values 'quote (list a)) + (values 'list (list (backquotify-1 aflag a))))) + ((memq dflag '(quote t)) + (if (memq aflag '(quote t nil)) + (values 'quote (cons a d )) + (values 'list* (list (backquotify-1 aflag a) + (backquotify-1 dflag d))))) + (t (setq a (backquotify-1 aflag a)) + (if (memq dflag '(list list*)) + (values dflag (cons a d)) + (values 'list* + (list a (backquotify-1 dflag d))))))))))) + +;;; This handles the <hair> cases +(defun comma (code) + (cond ((atom code) + (cond ((null code) + (values nil nil)) + ((or (numberp code) (eq code 't)) + (values t code)) + (t (values *bq-comma-flag* code)))) + ((eq (car code) 'quote) + (values (car code) (cadr code))) + ((memq (car code) '(append list list* nconc)) + (values (car code) (cdr code))) + ((eq (car code) 'cons) + (values 'list* (cdr code))) + (t (values *bq-comma-flag* code)))) + +;;; This handles table 1. +(defun backquotify-1 (flag thing) + (cond ((or (eq flag *bq-comma-flag*) + (memq flag '(t nil))) + thing) + ((eq flag 'quote) + (list 'quote thing)) + ((eq flag 'list*) + (cond ((null (cddr thing)) + (cons 'cons thing)) + (t (cons 'list* thing)))) + ((eq flag 'vector) + (list 'apply '#'vector thing)) + (t (cons (cdr + (assq flag + `((cons . cons) (list . list) + (append . append) (nconc . nconc)))) + thing)))) + + + + +(defun backq-init () + (let ((*readtable* std-lisp-readtable)) + (set-macro-character #\` #'backquote-macro) + (set-macro-character #\, #'comma-macro))) -- GitLab