Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: a9ac228bcb
Fetching contributors…

Cannot retrieve contributors at this time

139 lines (117 sloc) 5.306 kB
;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
;;; Copyright (c) 2009 David Lichteblau. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :qt)
;; Using uninterned symbols to refer to macros turned out to be unsafe,
;; as they appear to lose their identity during macroexpansion in SBCL.
;; Thus we use gentemp with qt-internal package.
(defvar *case-preserving-readtable*
(let ((table (copy-readtable nil)))
(setf (readtable-case table) :preserve)
table))
;;; CALL
(defvar *call-macros* (make-hash-table :test 'equal))
(defun call-macro-expander (whole env)
(declare (ignore env))
(destructuring-bind (sym instance &rest args) whole
(let ((method-name (symbol-value sym)))
`(optimized-call t ,instance ,method-name ,@args))))
(defun ensure-call-macro (name)
(or (gethash name *call-macros*)
(setf (gethash name *call-macros*)
(let ((sym (gentemp name :qt-internal)))
(setf (symbol-value sym) name)
(setf (macro-function sym) #'call-macro-expander)
sym))))
;;; STATIC CALL
(defvar *static-call-macros* (make-hash-table :test 'equal))
(defun static-call-macro-expander (whole env)
(declare (ignore env))
(destructuring-bind (sym &rest args) whole
(destructuring-bind (class-name method-name)
(symbol-value sym)
`(optimized-call t ,class-name ,method-name ,@args))))
(defun ensure-static-call-macro (class-name method-name)
(let ((key (list class-name method-name)))
(or (gethash key *static-call-macros*)
(setf (gethash key *static-call-macros*)
(let ((sym (gentemp
(concatenate 'string class-name "::" method-name)
:qt-internal)))
(setf (symbol-value sym) key)
(setf (macro-function sym) #'static-call-macro-expander)
sym)))))
;;; NEW
(defvar *new-macros* (make-hash-table :test 'equal))
(defun new-macro-expander (whole env)
(declare (ignore env))
(destructuring-bind (sym &rest args) whole
(let ((class-name (symbol-value sym)))
`(optimized-new ,class-name ,@args))))
(defun ensure-new-macro (name)
(or (gethash name *new-macros*)
(setf (gethash name *new-macros*)
(let ((sym (gentemp name :qt-internal)))
(setf (symbol-value sym) name)
(setf (macro-function sym) #'new-macro-expander)
sym))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun read-smoke-lambda (stream char n &aux it)
(declare (ignore n))
(check-type char (eql #\_))
(let ((method-name
(coerce (iter
(let* ((char (peek-char nil stream))
(code (char-code char)))
(if (or (eql char #\_)
(eql char #\:)
(<= 65 code 90)
(<= 97 code 122)
(<= 48 code 57)
(<= 60 code 62)) ; < = >
(collect (read-char stream))
(finish))))
'string)))
(if (ppcre:scan "^[<=>]+$" method-name)
(setf method-name
(concatenate 'string "operator" method-name)))
(cond
((equal method-name "delete")
'optimized-delete)
((equal method-name "new")
(let ((class-name
(symbol-name
(let ((*readtable* *case-preserving-readtable*))
(read stream t nil t)))))
(ensure-new-macro class-name)))
((setf it (search "::" method-name))
(let ((class-name (subseq method-name 0 it))
(method-name (subseq method-name (+ it 2))))
(ensure-static-call-macro class-name method-name)))
(t
(ensure-call-macro method-name))))))
(named-readtables:defreadtable :qt
(:merge :standard)
(:dispatch-macro-char #\# #\_ 'read-smoke-lambda))
Jump to Line
Something went wrong with that request. Please try again.