Author: bernhard
Date: Thu Jul 5 12:47:20 2007
New Revision: 19624
Modified:
trunk/languages/lisp/system.pir
trunk/languages/lisp/t/system.t
Log:
[lisp]
Beautify and maybe fix.
Add tests for sys:%find-package and sys:%alias-package
Modified: trunk/languages/lisp/system.pir
==============================================================================
--- trunk/languages/lisp/system.pir (original)
+++ trunk/languages/lisp/system.pir Thu Jul 5 12:47:20 2007
@@ -148,7 +148,7 @@
.ASSERT_TYPE(key, "string")
.local string key_str
- key_str = key # Convert the key to a
string
+ key_str = key # Convert the key to a
string
.local pmc val
val = hash[key_str]
@@ -169,22 +169,21 @@
.end
.sub _package_name
- .param pmc args
-
- .local pmc pkg, pkgname
-
- .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+ .param pmc args
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
- .CAR(pkg, args)
- .ASSERT_TYPE(pkg, "package")
+ .local pmc pkg
+ .CAR(pkg, args)
+ .ASSERT_TYPE(pkg, "package")
- pkgname = pkg._get_name()
+ .local pmc pkgname
+ pkgname = pkg._get_name()
- goto DONE
+ goto DONE
ERROR_NARGS:
- .ERROR_0("program-error", "wrong number of arguments to SYS:%PACKAGE-NAME")
- goto DONE
+ .ERROR_0("program-error", "wrong number of arguments to SYS:%PACKAGE-NAME")
+ goto DONE
DONE:
.return(pkgname)
@@ -192,98 +191,92 @@
.sub _find_package
- .param pmc args
-
- .local string pkgname_str
- .local pmc pkgname
- .local pmc retv
-
- .ASSERT_LENGTH(args, 1, ERROR_NARGS)
-
- .CAR(pkgname, args)
- .ASSERT_TYPE(pkgname, "string")
-
- pkgname_str = pkgname
- upcase pkgname_str
+ .param pmc args
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
- push_eh PACKAGE_NOT_FOUND
- retv = find_global "PACKAGES", pkgname_str
- if_null retv, PACKAGE_NOT_FOUND
- clear_eh
+ .local pmc pkgname
+ .CAR(pkgname, args)
+ .ASSERT_TYPE(pkgname, "string")
+
+ .local string pkgname_str
+ pkgname_str = pkgname
+ upcase pkgname_str
+
+ push_eh PACKAGE_NOT_FOUND
+ .local pmc retv
+ retv = find_global "PACKAGES", pkgname_str
+ if_null retv, PACKAGE_NOT_FOUND
+ clear_eh
- goto DONE
+ goto DONE
PACKAGE_NOT_FOUND:
- .ERROR_1("internal", "there is no package with the name \"%s\"", pkgname)
- goto DONE
+ .NIL(retv)
+ goto DONE
ERROR_NARGS:
- .ERROR_0("program-error", "wrong number of arguments to %FIND-PACKAGE")
- goto DONE
+ .ERROR_0("program-error", "wrong number of arguments to %FIND-PACKAGE")
+ goto DONE
DONE:
- .return(retv)
+ .return(retv)
.end
.sub _alias_package
- .param pmc args
-
- .local string pkgnames
- .local pmc package
- .local pmc pkgname
- .local pmc retv
-
- .ASSERT_LENGTH(args, 2, ERROR_NARGS)
+ .param pmc args
+ .ASSERT_LENGTH(args, 2, ERROR_NARGS)
- .CAR(package, args)
- .ASSERT_TYPE(package, "package")
+ .local pmc package
+ .CAR(package, args)
+ .ASSERT_TYPE(package, "package")
- .SECOND(pkgname, args)
- .ASSERT_TYPE(pkgname, "string")
+ .local pmc pkgname
+ .SECOND(pkgname, args)
+ .ASSERT_TYPE(pkgname, "string")
- pkgnames = pkgname
+ .local string pkgname_str
+ pkgname_str = pkgname
+ upcase pkgname_str
- store_global "PACKAGES", pkgnames, package
+ store_global "PACKAGES", pkgname_str, package
- .TRUE(retv)
- goto DONE
+ .local pmc retv
+ .TRUE(retv)
+ goto DONE
ERROR_NARGS:
- .ERROR_0("program-error", "wrong number of arguments to %ALIAS-PACKAGE")
- goto DONE
+ .ERROR_0("program-error", "wrong number of arguments to %ALIAS-PACKAGE")
+ goto DONE
DONE:
- .return(retv)
+ .return(retv)
.end
.sub _make_package
- .param pmc args
- .local string pkgnames
- .local pmc packages
- .local pmc package
- .local pmc pkgname
- .local pmc symbol
-
- .ASSERT_LENGTH(args, 1, ERROR_NARGS)
+ .param pmc args
+ .ASSERT_LENGTH(args, 1, ERROR_NARGS)
- .CAR(pkgname, args)
- .ASSERT_TYPE(pkgname, "string")
+ .local pmc pkgname
+ .CAR(pkgname, args)
+ .ASSERT_TYPE(pkgname, "string")
- .PACKAGE(package, pkgname)
+ .local pmc package
+ .PACKAGE(package, pkgname)
- pkgnames = pkgname
- upcase pkgnames, pkgnames
+ .local string pkgname_str
+ pkgname_str = pkgname
+ upcase pkgname_str
- store_global "PACKAGES", pkgnames, package
+ store_global "PACKAGES", pkgname_str, package
- goto DONE
+ goto DONE
ERROR_NARGS:
- .ERROR_0("program-error", "wrong number of arguments to %MAKE-PACKAGE")
- goto DONE
+ .ERROR_0("program-error", "wrong number of arguments to %MAKE-PACKAGE")
+ goto DONE
DONE:
- .return(package)
+ .return(package)
.end
.sub _use_package
@@ -469,7 +462,6 @@
.sub _get_object_attr
.param pmc args
-
.ASSERT_LENGTH(args,3,ERROR_NARGS)
.local pmc symbol
@@ -505,7 +497,6 @@
.sub _set_object_attr
.param pmc args
-
.ASSERT_LENGTH(args,4,ERROR_NARGS)
.local pmc symbol
Modified: trunk/languages/lisp/t/system.t
==============================================================================
--- trunk/languages/lisp/t/system.t (original)
+++ trunk/languages/lisp/t/system.t Thu Jul 5 12:47:20 2007
@@ -82,6 +82,28 @@
q{COMMON-LISP},
q{package-name},
],
+ [ q{ ( print ( null (sys:%find-package "common-lisp")))
+ },
+ q{NIL},
+ q{null of find-package "common-lisp"},
+ ],
+ [ q{ ( print ( null (sys:%find-package "un-common-lisp")))
+ },
+ q{T},
+ q{null of find-package "uncommon-lisp"},
+ ],
+ [ q{( sys:%alias-package (sys:%find-package "common-lisp")
"un-common-lisp")
+ ( print ( null ( sys:%find-package "un-common-lisp")) )
+ },
+ q{NIL},
+ q{null of find-package "uncommon-lisp" after alias-package},
+ ],
+ [ q{( sys:%alias-package (sys:%find-package "common-lisp")
"un-common-lisp")
+ ( print ( sys:%package-name ( sys:%find-package "un-common-lisp")) )
+ },
+ q{COMMON-LISP},
+ q{package-name of find-package "uncommon-lisp" after alias-package},
+ ],
);
Test::More::plan( tests => scalar @test_cases );
