Author: cspencer
Date: Fri Apr 29 21:22:02 2005
New Revision: 7946
Modified:
trunk/languages/lisp/CHANGES
trunk/languages/lisp/cl.imc
trunk/languages/lisp/eval.imc
trunk/languages/lisp/lisp/bootstrap.l
trunk/languages/lisp/lisp/core.l
trunk/languages/lisp/lisp/list.l
trunk/languages/lisp/lisp/logic.l
trunk/languages/lisp/lisp/math.l
trunk/languages/lisp/lisp/objects.l
trunk/languages/lisp/lisp/pred.l
trunk/languages/lisp/system.imc
trunk/languages/lisp/types.imc
Log:
Added basic macro support, a primitive DEFUN macro, new Lisp functions, fixed a
bug in PROGN (it was declared as a function, not a special-operator).
Modified: trunk/languages/lisp/CHANGES
==============================================================================
--- trunk/languages/lisp/CHANGES (original)
+++ trunk/languages/lisp/CHANGES Fri Apr 29 21:22:02 2005
@@ -1,4 +1,13 @@
+Changes for version 0.1.2
+-------------------------
+ * Added basic macro support
+ * Added a basic DEFUN macro
+ * Added support for loading a file off the command line (based on a patch
+ from Leo)
+ * Speed ups in checking list lengths (courtesy Leo)
+ * Rewrote Lisp functions to use DEFUN
+
Changes for version 0.1.1
-------------------------
* Added BOUNDP function
Modified: trunk/languages/lisp/cl.imc
==============================================================================
--- trunk/languages/lisp/cl.imc (original)
+++ trunk/languages/lisp/cl.imc Fri Apr 29 21:22:02 2005
@@ -80,7 +80,7 @@
.DEFUN(symbol, package, "PRINT", _print)
- .DEFUN(symbol, package, "PROGN", _progn)
+ .SPECIAL_FORM(symbol, package, "PROGN", _progn)
.SPECIAL_FORM(symbol, package, "QUOTE", _quote)
@@ -754,7 +754,7 @@
.local pmc retv
.NIL(retv)
- lptr = args
+ lptr = args
FORM_LOOP:
.NULL(lptr, DONE)
Modified: trunk/languages/lisp/eval.imc
==============================================================================
--- trunk/languages/lisp/eval.imc (original)
+++ trunk/languages/lisp/eval.imc Fri Apr 29 21:22:02 2005
@@ -92,6 +92,7 @@
.local pmc macroexp
.local pmc macrosym
.local pmc macroenv
+ .local pmc macroarg
macrosym = _LOOKUP_SYMBOL("*MACROEXPAND-HOOK*")
isnull macrosym, MACRO_NOT_INITIALIZED
@@ -102,7 +103,10 @@
peek_pad macroenv # Get current lexical scope
.LIST_3(funcargs, symbol, body, macroenv)
- _FUNCTION_CALL(macroexp, funcargs) # Call the macroexpand hook
+ retv = _FUNCTION_CALL(macroexp, funcargs) # Call the macroexpand hook
+
+ .LIST_1(macroarg, retv)
+ _eval(macroarg)
goto DONE
Modified: trunk/languages/lisp/lisp/bootstrap.l
==============================================================================
--- trunk/languages/lisp/lisp/bootstrap.l (original)
+++ trunk/languages/lisp/lisp/bootstrap.l Fri Apr 29 21:22:02 2005
@@ -21,6 +21,9 @@
"HASH-TABLE-P" "INTEGERP" "KEYWORDP" "LISTP" "NUMBERP" "PACKAGEP"
"STREAMP" "STRINGP" "SYMBOLP"
+ ;; Macros
+ "DEFUN"
+
;; Miscellaneous functions
"APPLY" "ATOM" "EQ" "EQL" "EVAL" "FUNCTION" "GENSYM" "LET" "NOT"
"NULL" "PACKAGE-NAME" "PRINT" "PROGN" "QUOTE" "READ"
@@ -29,10 +32,10 @@
"IN-PACKAGE"
;; Miscellaneous symbols
- "*GENSYM-COUNTER*" "*PACKAGE*" "*READ-EVAL*" "*READTABLE*"
- "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "BASE-CHAR" "FLOAT"
- "HASH-TABLE" "INTEGER" "MACRO" "NIL" "PACKAGE" "STREAM" "STRING"
- "SYMBOL" "T")
+ "*GENSYM-COUNTER*" "*MACROEXPAND-HOOK*" "*PACKAGE*" "*READ-EVAL*"
+ "*READTABLE*" "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "BASE-CHAR"
+ "FLOAT" "HASH-TABLE" "INTEGER" "MACRO" "NIL" "PACKAGE" "STREAM"
+ "STRING" "SYMBOL" "T")
;; Set the current package to SYSTEM so we don't have to prefix symbols.
(cl:setq *package* (sys:%find-package "SYSTEM"))
@@ -79,6 +82,9 @@
(lambda (stream char)
(error "reader-error" "#) is invalid syntax"))))
+(setq *macroexpand-hook* #'(lambda (fn form env)
+ (apply fn (list form env))))
+
;; Create the KEYWORD package.
(sys:%make-package "KEYWORD")
Modified: trunk/languages/lisp/lisp/core.l
==============================================================================
--- trunk/languages/lisp/lisp/core.l (original)
+++ trunk/languages/lisp/lisp/core.l Fri Apr 29 21:22:02 2005
@@ -1,8 +1,21 @@
(setq cl:*package* (sys:%find-package "COMMON-LISP"))
-;; Define some basic functions we'll need in subsequent files.
-(sys:set-symbol-function 'in-package
- #'(lambda (pkg)
- (setq *package* (sys:%find-package pkg))))
+;; Define a temporary, primitive version of the defun macro.
+(sys:set-symbol-function 'defun
+ (sys:%make-macro
+ #'(lambda (form env)
+ (let ((name (car form)) (body (cdr form)))
+ (list 'progn
+ (list 'sys:set-symbol-function
+ (list 'quote name)
+ (list 'function (cons 'lambda
body)))
+ (list 'sys:set-function-name
+ (list 'sys:get-symbol-function
(list 'quote name))
+ (list 'symbol-name (list 'quote
name)))
+ (list 'sys:get-symbol-function (list
'quote name)))))))
+
+(defun in-package (pkg)
+ (setq *package* (sys:%find-package pkg)))
+
Modified: trunk/languages/lisp/lisp/list.l
==============================================================================
--- trunk/languages/lisp/lisp/list.l (original)
+++ trunk/languages/lisp/lisp/list.l Fri Apr 29 21:22:02 2005
@@ -1,63 +1,61 @@
(in-package "COMMON-LISP")
;; Define some list accessing functions.
-(sys:set-symbol-function 'caar #'(lambda (x) (car (car x))))
-(sys:set-symbol-function 'cadr #'(lambda (x) (car (cdr x))))
-(sys:set-symbol-function 'cdar #'(lambda (x) (cdr (car x))))
-(sys:set-symbol-function 'cddr #'(lambda (x) (cdr (cdr x))))
-
-(sys:set-symbol-function 'caaar #'(lambda (x) (car (car (car x)))))
-(sys:set-symbol-function 'caadr #'(lambda (x) (car (car (cdr x)))))
-(sys:set-symbol-function 'cadar #'(lambda (x) (car (cdr (car x)))))
-(sys:set-symbol-function 'caddr #'(lambda (x) (car (cdr (cdr x)))))
-(sys:set-symbol-function 'cdaar #'(lambda (x) (cdr (car (car x)))))
-(sys:set-symbol-function 'cdadr #'(lambda (x) (cdr (car (cdr x)))))
-(sys:set-symbol-function 'cddar #'(lambda (x) (cdr (cdr (car x)))))
-(sys:set-symbol-function 'cdddr #'(lambda (x) (cdr (cdr (cdr x)))))
-
-(sys:set-symbol-function 'caaaar #'(lambda (x) (car (car (car (car x))))))
-(sys:set-symbol-function 'caaadr #'(lambda (x) (car (car (car (cdr x))))))
-(sys:set-symbol-function 'caadar #'(lambda (x) (car (car (cdr (car x))))))
-(sys:set-symbol-function 'caaddr #'(lambda (x) (car (car (cdr (cdr x))))))
-(sys:set-symbol-function 'cadaar #'(lambda (x) (car (cdr (car (car x))))))
-(sys:set-symbol-function 'cadadr #'(lambda (x) (car (cdr (car (cdr x))))))
-(sys:set-symbol-function 'caddar #'(lambda (x) (car (cdr (cdr (car x))))))
-(sys:set-symbol-function 'cadddr #'(lambda (x) (car (cdr (cdr (cdr x))))))
-(sys:set-symbol-function 'cdaaar #'(lambda (x) (cdr (car (car (car x))))))
-(sys:set-symbol-function 'cdaadr #'(lambda (x) (cdr (car (car (cdr x))))))
-(sys:set-symbol-function 'cdadar #'(lambda (x) (cdr (car (cdr (car x))))))
-(sys:set-symbol-function 'cdaddr #'(lambda (x) (cdr (car (cdr (cdr x))))))
-(sys:set-symbol-function 'cddaar #'(lambda (x) (cdr (cdr (car (car x))))))
-(sys:set-symbol-function 'cddadr #'(lambda (x) (cdr (cdr (car (cdr x))))))
-(sys:set-symbol-function 'cdddar #'(lambda (x) (cdr (cdr (cdr (car x))))))
-(sys:set-symbol-function 'cddddr #'(lambda (x) (cdr (cdr (cdr (cdr x))))))
-
-(sys:set-symbol-function 'endp #'(lambda (x) (eq x nil)))
-
-(sys:set-symbol-function 'first #'(lambda (x) (car x)))
-(sys:set-symbol-function 'second #'(lambda (x) (cadr x)))
-(sys:set-symbol-function 'third #'(lambda (x) (caddr x)))
-(sys:set-symbol-function 'fourth #'(lambda (x) (cadddr x)))
-(sys:set-symbol-function 'fifth #'(lambda (x) (car (cddddr x))))
-(sys:set-symbol-function 'sixth #'(lambda (x) (cadr (cddddr x))))
-(sys:set-symbol-function 'seventh #'(lambda (x) (caddr (cddddr x))))
-(sys:set-symbol-function 'eighth #'(lambda (x) (cadddr (cddddr x))))
-(sys:set-symbol-function 'ninth #'(lambda (x) (car (cddddr (cddddr x)))))
-(sys:set-symbol-function 'tenth #'(lambda (x) (cadr (cddddr (cddddr x)))))
+(defun caar (x) (car (car x)))
+(defun cadr (x) (car (cdr x)))
+(defun cdar (x) (cdr (car x)))
+(defun cddr (x) (cdr (cdr x)))
+
+(defun caaar (x) (car (car (car x))))
+(defun caadr (x) (car (car (cdr x))))
+(defun cadar (x) (car (cdr (car x))))
+(defun caddr (x) (car (cdr (cdr x))))
+(defun cdaar (x) (cdr (car (car x))))
+(defun cdadr (x) (cdr (car (cdr x))))
+(defun cddar (x) (cdr (cdr (car x))))
+(defun cdddr (x) (cdr (cdr (cdr x))))
+
+(defun caaaar (x) (car (car (car (car x)))))
+(defun caaadr (x) (car (car (car (cdr x)))))
+(defun caadar (x) (car (car (cdr (car x)))))
+(defun caaddr (x) (car (car (cdr (cdr x)))))
+(defun cadaar (x) (car (cdr (car (car x)))))
+(defun cadadr (x) (car (cdr (car (cdr x)))))
+(defun caddar (x) (car (cdr (cdr (car x)))))
+(defun cadddr (x) (car (cdr (cdr (cdr x)))))
+(defun cdaaar (x) (cdr (car (car (car x)))))
+(defun cdaadr (x) (cdr (car (car (cdr x)))))
+(defun cdadar (x) (cdr (car (cdr (car x)))))
+(defun cdaddr (x) (cdr (car (cdr (cdr x)))))
+(defun cddaar (x) (cdr (cdr (car (car x)))))
+(defun cddadr (x) (cdr (cdr (car (cdr x)))))
+(defun cdddar (x) (cdr (cdr (cdr (car x)))))
+(defun cddddr (x) (cdr (cdr (cdr (cdr x)))))
+
+(defun endp (x) (eq x nil))
+
+(defun first (x) (car x))
+(defun second (x) (cadr x))
+(defun third (x) (caddr x))
+(defun fourth (x) (cadddr x))
+(defun fifth (x) (car (cddddr x)))
+(defun sixth (x) (cadr (cddddr x)))
+(defun seventh (x) (caddr (cddddr x)))
+(defun eighth (x) (cadddr (cddddr x)))
+(defun ninth (x) (car (cddddr (cddddr x))))
+(defun tenth (x) (cadr (cddddr (cddddr x))))
;; Copies and returns the passed tree.
-(sys:set-symbol-function 'copy-tree
- #'(lambda (tree)
- (if (consp tree)
- (cons (copy-tree (car tree))
- (copy-tree (cdr tree)))
- tree)))
+(defun copy-tree (tree)
+ (if (consp tree)
+ (cons (copy-tree (car tree))
+ (copy-tree (cdr tree)))
+ tree))
;; Identity returns whatever was passed to the function
-(sys:set-symbol-function 'identity #'(lambda (object) object))
+(defun identity (object) object)
;; For working with association lists.
-(sys:set-symbol-function 'acons
- #'(lambda (key val list)
- (cons (cons key val) list)))
+(defun acons (key val list)
+ (cons (cons key val) list))
Modified: trunk/languages/lisp/lisp/logic.l
==============================================================================
--- trunk/languages/lisp/lisp/logic.l (original)
+++ trunk/languages/lisp/lisp/logic.l Fri Apr 29 21:22:02 2005
@@ -1,5 +1,5 @@
(in-package "COMMON-LISP")
;; Define some logical functions
-(sys:set-symbol-function 'not #'(lambda (x) (null x)))
+(defun not (x) (null x))
Modified: trunk/languages/lisp/lisp/math.l
==============================================================================
--- trunk/languages/lisp/lisp/math.l (original)
+++ trunk/languages/lisp/lisp/math.l Fri Apr 29 21:22:02 2005
@@ -1,7 +1,7 @@
(in-package "COMMON-LISP")
-(sys:set-symbol-function '1+ #'(lambda (x) (+ x 1)))
-(sys:set-symbol-function '1- #'(lambda (x) (- x 1)))
-(sys:set-symbol-function 'evenp #'(lambda (x) (eql (mod x 2) 0)))
-(sys:set-symbol-function 'oddp #'(lambda (x) (eql (mod x 2) 1)))
-(sys:set-symbol-function 'zerop #'(lambda (x) (eql x 0)))
+(defun 1+ (x) (+ x 1))
+(defun 1- (x) (- x 1))
+(defun evenp (x) (eql (mod x 2) 0))
+(defun oddp (x) (eql (mod x 2) 1))
+(defun zerop (x) (eql x 0))
Modified: trunk/languages/lisp/lisp/objects.l
==============================================================================
--- trunk/languages/lisp/lisp/objects.l (original)
+++ trunk/languages/lisp/lisp/objects.l Fri Apr 29 21:22:02 2005
@@ -5,7 +5,7 @@
"LispSymbol"
"function"
#'(lambda (s f)
- (%set-object-attribute s "LispSymbol" "function" f)))
+ (%set-object-attribute s "LispSymbol" "function" f)))
(set-symbol-function 'get-symbol-function
#'(lambda (s)
Modified: trunk/languages/lisp/lisp/pred.l
==============================================================================
--- trunk/languages/lisp/lisp/pred.l (original)
+++ trunk/languages/lisp/lisp/pred.l Fri Apr 29 21:22:02 2005
@@ -1,70 +1,51 @@
(in-package "COMMON-LISP")
-;; Define some predicate functions.
-(sys:set-symbol-function 'characterp
- #'(lambda (x)
- (eq (type-of x) 'base-char)))
-
-(sys:set-symbol-function 'consp
- #'(lambda (x)
- (eq (type-of x) 'cons)))
;; XXX - This should also compare characters (which we don't have yet).
-(sys:set-symbol-function 'eql
- #'(lambda (x y)
- (if (eq x y)
- t
- (if (numberp x)
- (if (numberp y)
- (if (eq (type-of x) (type-of y))
- (= x y)))))))
-
-(sys:set-symbol-function 'floatp
- #'(lambda (x)
- (eq (type-of x) 'float)))
-
-(sys:set-symbol-function 'functionp
- #'(lambda (x)
- (eq (type-of x) 'function)))
-
-(sys:set-symbol-function 'hash-table-p
- #'(lambda (x)
- (eq (type-of x) 'hash-table)))
-
-(sys:set-symbol-function 'integerp
- #'(lambda (x)
- (eq (type-of x) 'integer)))
-
-(sys:set-symbol-function 'keywordp
- #'(lambda (x)
- (if (symbolp x)
- (eq (symbol-package x) (sys:%find-package
"KEYWORD"))
- nil)))
-
-(sys:set-symbol-function 'listp
- #'(lambda (x)
- (if (eq x 'nil)
- t
- (eq (type-of x) 'cons))))
-
-(sys:set-symbol-function 'numberp
- #'(lambda (x)
- (if (eq (type-of x) 'integer)
- t
- (eq (type-of x) 'float))))
-
-(sys:set-symbol-function 'packagep
- #'(lambda (x)
- (eq (type-of x) 'package)))
-
-(sys:set-symbol-function 'streamp
- #'(lambda (x)
- (eq (type-of x) 'stream)))
-
-(sys:set-symbol-function 'stringp
- #'(lambda (x)
- (eq (type-of x) 'string)))
-
-(sys:set-symbol-function 'symbolp
- #'(lambda (x)
- (eq (type-of x) 'symbol)))
+(defun eql (x y)
+ (if (eq x y)
+ t
+ (if (numberp x)
+ (if (numberp y)
+ (if (eq (type-of x) (type-of y))
+ (= x y))))))
+
+;; Define some predicate functions.
+(defun characterp (x) (eq (type-of x) 'base-char))
+
+(defun consp (x) (eq (type-of x) 'cons))
+
+(defun floatp (x) (eq (type-of x) 'float))
+
+(defun functionp (x) (eq (type-of x) 'function))
+
+(defun hash-table-p (x) (eq (type-of x) 'hash-table))
+
+(defun integerp (x) (eq (type-of x) 'integer))
+
+(defun keywordp (x)
+ (if (symbolp x)
+ (eq (symbol-package x) (sys:%find-package "KEYWORD"))
+ nil))
+
+(defun listp (x)
+ (if (eq x 'nil)
+ t
+ (eq (type-of x) 'cons)))
+
+(defun numberp (x)
+ (if (eq (type-of x) 'integer)
+ t
+ (eq (type-of x) 'float)))
+
+(defun packagep (x)
+ (eq (type-of x) 'package))
+
+(defun streamp (x)
+ (eq (type-of x) 'stream))
+
+(defun stringp (x)
+ (eq (type-of x) 'string))
+
+(defun symbolp (x)
+ (eq (type-of x) 'symbol))
Modified: trunk/languages/lisp/system.imc
==============================================================================
--- trunk/languages/lisp/system.imc (original)
+++ trunk/languages/lisp/system.imc Fri Apr 29 21:22:02 2005
@@ -71,6 +71,8 @@
.DEFUN(symbol, package, "%STRING-EQUAL", _string_equal)
+ .DEFUN(symbol, package, "%MAKE-MACRO", _make_macro)
+
# XXX - THESE SHOULD BE REMOVED AND CONVERTED TO PROPER LISP FUNCTIONS
.DEFUN(symbol, package, "ERROR", _raise_error)
.DEFUN(symbol, package, "LOAD", _load)
@@ -625,3 +627,38 @@
DONE:
.return(retv)
.end
+
+.sub _make_macro
+ .param pmc args
+ .local int type
+ .local pmc macro
+ .local pmc val
+ .local pmc form
+ .local pmc retv
+
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+
+ .CAR(form, args)
+
+ # XXX - This is pretty hackish - should probably use the __morph method
+
+ macro = new "LispMacro"
+
+ val = form._get_args()
+ macro._set_args(val)
+
+ val = form._get_scope()
+ macro._set_scope(val)
+
+ val = form._get_body()
+ macro._set_body(val)
+
+ goto DONE
+
+ERROR_NARGS:
+ .ERROR_0("program-error", "wrong number of arguments to %MAKE-MACRO")
+ goto DONE
+
+DONE:
+ .return(macro)
+.end
Modified: trunk/languages/lisp/types.imc
==============================================================================
--- trunk/languages/lisp/types.imc (original)
+++ trunk/languages/lisp/types.imc Fri Apr 29 21:22:02 2005
@@ -13,17 +13,14 @@
addattribute class, "name"
addattribute class, "scope"
+ subclass class, "LispFunction", "LispMacro"
+
subclass class, "LispFunction", "LispSpecialForm"
subclass class, "Hash", "LispHash"
subclass class, "Integer", "LispInteger"
- newclass class, "LispMacro"
- addattribute class, "args"
- addattribute class, "body"
- addattribute class, "name"
-
newclass class, "LispPackage"
addattribute class, "external"
addattribute class, "internal"
@@ -191,54 +188,6 @@
.namespace ["LispMacro"]
-.sub _get_body method
- .local pmc retv
-
- getattribute retv, self, "LispMacro\0body"
-
- .return(retv)
-.end
-
-.sub _set_body method
- .param pmc body
-
- setattribute self, "LispMacro\0body", body
-
- .return(body)
-.end
-
-.sub _get_args method
- .local pmc retv
-
- getattribute retv, self, "LispMacro\0args"
-
- .return(retv)
-.end
-
-.sub _set_args method
- .param pmc args
-
- setattribute self, "LispMacro\0args", args
-
- .return(args)
-.end
-
-.sub _get_name method
- .local pmc retv
-
- getattribute retv, self, "LispMacro\0name"
-
- .return(retv)
-.end
-
-.sub _set_name method
- .param pmc name
-
- setattribute self, "LispMacro\0name", name
-
- .return(name)
-.end
-
.sub __get_string method
.local pmc retv
.local pmc tmps
