forked from psilord/option-9
-
Notifications
You must be signed in to change notification settings - Fork 0
/
package.lisp
61 lines (50 loc) · 2.02 KB
/
package.lisp
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
;; Copyright 2010 Peter K. Keller ([email protected])
;;
;; Licensed under the Apache License, Version 2.0 (the "License"); you
;; may not use this file except in compliance with the License. You may
;; obtain a copy of the License at
;;
;; http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
;; or implied. See the License for the specific language governing
;; permissions and limitations under the License.
(defpackage #:option-9
(:use #:cl)
(:export #:option-9))
(in-package #:option-9)
#+option-9-debug (declaim (optimize (safety 3) (space 0) (speed 0) (debug 3)))
(defparameter *game* nil)
(defparameter *assets* nil)
(defparameter *id* nil)
(defun new-id ()
(let ((id *id*))
(incf *id*)
id))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-accessor-symbol (prefix-symbol &rest args)
"Create a symbol suitable for an accessor in with-p* macros used in
the math API. PREFIX-SYMBOL _must_ be a symbol so we can discover the
package it is from. ARGS can be anything else that will all end up
stringified into a symbol interned into the symbol package of PREFIX-SYMBOL."
;; Thank you pjb!
(intern (format nil "~:@(~{~A~}~)" (cons prefix-symbol args))
(symbol-package prefix-symbol))))
;; lifted from Graham's ANSI Common Lisp book
(defmacro with-type (type expr)
`(the ,type ,(if (atom expr)
expr
(expand-call type (binarize expr)))))
(defun expand-call (type expr)
`(,(car expr) ,@(mapcar #'(lambda (a)
`(with-type ,type ,a))
(cdr expr))))
(defun binarize (expr)
(if (and (nthcdr 3 expr) (member (car expr) '(+ - * /)))
(destructuring-bind (op a1 a2 . rest) expr
(binarize `(,op (,op ,a1 ,a2) ,@rest)))
expr))
(defmacro as-double-float (expr)
`(with-type double-float ,expr))