Changeset 10515
- Timestamp:
- Aug 21, 2008, 10:51:47 AM (11 years ago)
- Location:
- trunk/source/level-1
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/level-1/l1-sockets.lisp
r10288 r10515 148 148 "WITH-OPEN-SOCKET")) 149 149 150 (eval-when (:compile-toplevel :execute) 151 #+linuxppc-target 152 (require "PPC-LINUX-SYSCALLS") 153 #+linuxx8664-target 154 (require "X8664-LINUX-SYSCALLS") 155 #+darwinppc-target 156 (require "DARWINPPC-SYSCALLS") 157 #+darwinx8664-target 158 (require "DARWINX8664-SYSCALLS") 159 #+freebsdx8664-target 160 (require "X8664-FREEBSD-SYSCALLS") 161 #+solarisx8664-target 162 (require "X8664-SOLARIS-SYSCALLS") 163 ) 150 164 151 165 152 (define-condition socket-error (simple-stream-error) … … 1209 1196 1210 1197 (defun c_socket_1 (domain type protocol) 1211 #-(or linuxppc-target solaris-target) 1212 (syscall syscalls::socket domain type protocol) 1213 #+linuxppc-target 1214 (rlet ((params (:array :unsigned-long 3))) 1215 (setf (paref params (:* :unsigned-long) 0) domain 1216 (paref params (:* :unsigned-long) 1) type 1217 (paref params (:* :unsigned-long) 2) protocol) 1218 (syscall syscalls::socketcall 1 params)) 1219 #+solaris-target 1220 (syscall syscalls::so_socket domain type protocol +null-ptr+ #$SOV_DEFAULT)) 1198 (int-errno-call (#_socket domain type protocol))) 1221 1199 1222 1200 (defun c_socket (domain type protocol) … … 1264 1242 1265 1243 (defun c_bind (sockfd sockaddr addrlen) 1266 #-linuxppc-target 1267 (progn 1268 #+(or darwin-target freebsd-target) 1269 (setf (pref sockaddr :sockaddr_in.sin_len) addrlen) 1270 (syscall syscalls::bind sockfd sockaddr addrlen)) 1271 #+linuxppc-target 1272 (progn 1273 #+ppc32-target 1274 (%stack-block ((params 12)) 1275 (setf (%get-long params 0) sockfd 1276 (%get-ptr params 4) sockaddr 1277 (%get-long params 8) addrlen) 1278 (syscall syscalls::socketcall 2 params)) 1279 #+ppc64-target 1280 (%stack-block ((params 24)) 1281 (setf (%%get-unsigned-longlong params 0) sockfd 1282 (%get-ptr params 8) sockaddr 1283 (%%get-unsigned-longlong params 16) addrlen) 1284 (syscall syscalls::socketcall 2 params)))) 1244 (int-errno-call (#_bind sockfd sockaddr addrlen))) 1285 1245 1286 1246 … … 1294 1254 (progn 1295 1255 (fd-set-flags sockfd (logior flags #$O_NONBLOCK)) 1296 (let* ((err 1297 #-linuxppc-target 1298 (syscall syscalls::connect sockfd addr len) 1299 #+linuxppc-target 1300 (progn 1301 #+ppc32-target 1302 (%stack-block ((params 12)) 1303 (setf (%get-long params 0) sockfd 1304 (%get-ptr params 4) addr 1305 (%get-long params 8) len) 1306 (syscall syscalls::socketcall 3 params)) 1307 #+ppc64-target 1308 (%stack-block ((params 24)) 1309 (setf (%%get-unsigned-longlong params 0) sockfd 1310 (%get-ptr params 8) addr 1311 (%%get-unsigned-longlong params 16) len) 1312 (syscall syscalls::socketcall 3 params))))) 1256 (let* ((err (int-errno-call (#_connect sockfd addr len)))) 1313 1257 (cond ((or (eql err (- #$EINPROGRESS)) (eql err (- #$EINTR))) 1314 1258 (if (process-output-wait sockfd timeout-in-milliseconds) … … 1319 1263 1320 1264 (defun c_listen (sockfd backlog) 1321 #-linuxppc-target 1322 (syscall syscalls::listen sockfd backlog) 1323 #+linuxppc-target 1324 (progn 1325 #+ppc32-target 1326 (%stack-block ((params 8)) 1327 (setf (%get-long params 0) sockfd 1328 (%get-long params 4) backlog) 1329 (syscall syscalls::socketcall 4 params)) 1330 #+ppc64-target 1331 (%stack-block ((params 16)) 1332 (setf (%%get-unsigned-longlong params 0) sockfd 1333 (%%get-unsigned-longlong params 8) backlog) 1334 (syscall syscalls::socketcall 4 params)))) 1265 (int-errno-call (#_listen sockfd backlog))) 1335 1266 1336 1267 (defun c_accept (sockfd addrp addrlenp) 1337 (ignoring-eintr 1338 #-linuxppc-target 1339 (syscall syscalls::accept sockfd addrp addrlenp) 1340 #+linuxppc-target 1341 (progn 1342 #+ppc32-target 1343 (%stack-block ((params 12)) 1344 (setf (%get-long params 0) sockfd 1345 (%get-ptr params 4) addrp 1346 (%get-ptr params 8) addrlenp) 1347 (syscall syscalls::socketcall 5 params)) 1348 #+ppc64-target 1349 (%stack-block ((params 24)) 1350 (setf (%%get-unsigned-longlong params 0) sockfd 1351 (%get-ptr params 8) addrp 1352 (%get-ptr params 16) addrlenp) 1353 (syscall syscalls::socketcall 5 params))))) 1268 (ignoring-eintr 1269 (int-errno-call (#_accept sockfd addrp addrlenp)))) 1354 1270 1355 1271 (defun c_getsockname (sockfd addrp addrlenp) 1356 #-linuxppc-target 1357 (syscall syscalls::getsockname sockfd addrp addrlenp) 1358 #+linuxppc-target 1359 (progn 1360 #+ppc32-target 1361 (%stack-block ((params 12)) 1362 (setf (%get-long params 0) sockfd 1363 (%get-ptr params 4) addrp 1364 (%get-ptr params 8) addrlenp) 1365 (syscall syscalls::socketcall 6 params)) 1366 #+ppc64-target 1367 (%stack-block ((params 24)) 1368 (setf (%%get-unsigned-longlong params 0) sockfd 1369 (%get-ptr params 8) addrp 1370 (%get-ptr params 16) addrlenp) 1371 (syscall syscalls::socketcall 6 params)))) 1272 (int-errno-call (#_getsockname sockfd addrp addrlenp))) 1372 1273 1373 1274 (defun c_getpeername (sockfd addrp addrlenp) 1374 #-linuxppc-target 1375 (syscall syscalls::getpeername sockfd addrp addrlenp) 1376 #+linuxppc-target 1377 (progn 1378 #+ppc32-target 1379 (%stack-block ((params 12)) 1380 (setf (%get-long params 0) sockfd 1381 (%get-ptr params 4) addrp 1382 (%get-ptr params 8) addrlenp) 1383 (syscall syscalls::socketcall 7 params)) 1384 #+ppc64-target 1385 (%stack-block ((params 24)) 1386 (setf (%%get-unsigned-longlong params 0) sockfd 1387 (%get-ptr params 8) addrp 1388 (%get-ptr params 16) addrlenp) 1389 (syscall syscalls::socketcall 7 params)))) 1275 (int-errno-call (#_getpeername sockfd addrp addrlenp))) 1390 1276 1391 1277 (defun c_socketpair (domain type protocol socketsptr) 1392 #-(or linuxppc-target solaris-target) 1393 (syscall syscalls::socketpair domain type protocol socketsptr) 1394 #+linuxppc-target 1395 (progn 1396 #+ppc32-target 1397 (%stack-block ((params 16)) 1398 (setf (%get-long params 0) domain 1399 (%get-long params 4) type 1400 (%get-long params 8) protocol 1401 (%get-ptr params 12) socketsptr) 1402 (syscall syscalls::socketcall 8 params)) 1403 #+ppc64-target 1404 (%stack-block ((params 32)) 1405 (setf (%%get-unsigned-longlong params 0) domain 1406 (%%get-unsigned-longlong params 8) type 1407 (%%get-unsigned-longlong params 16) protocol 1408 (%get-ptr params 24) socketsptr) 1409 (syscall syscalls::socketcall 8 params))) 1410 #+solaris-target 1411 (let* ((fd1 (syscall syscalls::so_socket domain type protocol +null-ptr+ #$SOV_DEFAULT))) 1412 (if (>= fd1 0) 1413 (let* ((fd2 (syscall syscalls::so_socket domain type protocol +null-ptr+ #$SOV_DEFAULT))) 1414 (if (>= fd2 0) 1415 (progn 1416 (setf (paref socketsptr (:* :int) 0) fd1 1417 (paref socketsptr (:* :int) 1) fd2) 1418 (let* ((res (syscall syscalls::so_socketpair socketsptr))) 1419 (when (< res 0) 1420 (fd-close fd1) 1421 (fd-close fd2)) 1422 res)) 1423 (progn 1424 (fd-close fd1) 1425 fd2))) 1426 fd1))) 1427 1428 1278 (int-errno-call (#_socketpair domain type protocol socketsptr))) 1429 1279 1430 1280 1431 1281 (defun c_sendto (sockfd msgptr len flags addrp addrlen) 1432 #-linuxppc-target 1433 (syscall syscalls::sendto sockfd msgptr len flags addrp addrlen) 1434 #+linuxppc-target 1435 (progn 1436 #+ppc32-target 1437 (%stack-block ((params 24)) 1438 (setf (%get-long params 0) sockfd 1439 (%get-ptr params 4) msgptr 1440 (%get-long params 8) len 1441 (%get-long params 12) flags 1442 (%get-ptr params 16) addrp 1443 (%get-long params 20) addrlen) 1444 (syscall syscalls::socketcall 11 params)) 1445 #+ppc64-target 1446 (%stack-block ((params 48)) 1447 (setf (%%get-unsigned-longlong params 0) sockfd 1448 (%get-ptr params 8) msgptr 1449 (%%get-unsigned-longlong params 16) len 1450 (%%get-unsigned-longlong params 24) flags 1451 (%get-ptr params 32) addrp 1452 (%%get-unsigned-longlong params 40) addrlen) 1453 (syscall syscalls::socketcall 11 params)))) 1282 (int-errno-call (#_sendto sockfd msgptr len flags addrp addrlen))) 1454 1283 1455 1284 (defun c_recvfrom (sockfd bufptr len flags addrp addrlenp) 1456 #-linuxppc-target 1457 (syscall syscalls::recvfrom sockfd bufptr len flags addrp addrlenp) 1458 #+linuxppc-target 1459 (progn 1460 #+ppc32-target 1461 (%stack-block ((params 24)) 1462 (setf (%get-long params 0) sockfd 1463 (%get-ptr params 4) bufptr 1464 (%get-long params 8) len 1465 (%get-long params 12) flags 1466 (%get-ptr params 16) addrp 1467 (%get-ptr params 20) addrlenp) 1468 (syscall syscalls::socketcall 12 params)) 1469 #+ppc64-target 1470 (%stack-block ((params 48)) 1471 (setf (%get-long params 0) sockfd 1472 (%get-ptr params 8) bufptr 1473 (%get-long params 16) len 1474 (%get-long params 24) flags 1475 (%get-ptr params 32) addrp 1476 (%get-ptr params 40) addrlenp) 1477 (syscall syscalls::socketcall 12 params)))) 1285 (int-errno-call (#_recvfrom sockfd bufptr len flags addrp addrlenp))) 1478 1286 1479 1287 (defun c_shutdown (sockfd how) 1480 #-linuxppc-target 1481 (syscall syscalls::shutdown sockfd how) 1482 #+linuxppc-target 1483 (progn 1484 #+ppc32-target 1485 (%stack-block ((params 8)) 1486 (setf (%get-long params 0) sockfd 1487 (%get-long params 4) how) 1488 (syscall syscalls::socketcall 13 params)) 1489 #+ppc64-target 1490 (%stack-block ((params 16)) 1491 (setf (%%get-unsigned-longlong params 0) sockfd 1492 (%%get-unsigned-longlong params 8) how) 1493 (syscall syscalls::socketcall 13 params)))) 1288 (int-errno-call (#_shutdown sockfd how))) 1494 1289 1495 1290 (defun c_setsockopt (sockfd level optname optvalp optlen) 1496 #-linuxppc-target 1497 (syscall syscalls::setsockopt sockfd level optname optvalp optlen) 1498 #+linuxppc-target 1499 (progn 1500 #+ppc32-target 1501 (%stack-block ((params 20)) 1502 (setf (%get-long params 0) sockfd 1503 (%get-long params 4) level 1504 (%get-long params 8) optname 1505 (%get-ptr params 12) optvalp 1506 (%get-long params 16) optlen) 1507 (syscall syscalls::socketcall 14 params)) 1508 #+ppc64-target 1509 (%stack-block ((params 40)) 1510 (setf (%%get-unsigned-longlong params 0) sockfd 1511 (%%get-unsigned-longlong params 8) level 1512 (%%get-unsigned-longlong params 16) optname 1513 (%get-ptr params 24) optvalp 1514 (%%get-unsigned-longlong params 32) optlen) 1515 (syscall syscalls::socketcall 14 params)))) 1291 (int-errno-call (#_setsockopt sockfd level optname optvalp optlen))) 1516 1292 1517 1293 (defun c_getsockopt (sockfd level optname optvalp optlenp) 1518 #-linuxppc-target 1519 (syscall syscalls::getsockopt sockfd level optname optvalp optlenp) 1520 #+linuxppc-target 1521 (progn 1522 #+ppc32-target 1523 (%stack-block ((params 20)) 1524 (setf (%get-long params 0) sockfd 1525 (%get-long params 4) level 1526 (%get-long params 8) optname 1527 (%get-ptr params 12) optvalp 1528 (%get-ptr params 16) optlenp) 1529 (syscall syscalls::socketcall 15 params)) 1530 #+ppc64-target 1531 (%stack-block ((params 40)) 1532 (setf (%%get-unsigned-longlong params 0) sockfd 1533 (%%get-unsigned-longlong params 8) level 1534 (%%get-unsigned-longlong params 16) optname 1535 (%get-ptr params 24) optvalp 1536 (%get-ptr params 32) optlenp) 1537 (syscall syscalls::socketcall 15 params)))) 1294 (int-errno-call (#_getsockopt sockfd level optname optvalp optlenp))) 1538 1295 1539 1296 (defun c_sendmsg (sockfd msghdrp flags) 1540 #-linuxppc-target 1541 (syscall syscalls::sendmsg sockfd msghdrp flags) 1542 #+linuxppc-target 1543 (progn 1544 #+ppc32-target 1545 (%stack-block ((params 12)) 1546 (setf (%get-long params 0) sockfd 1547 (%get-ptr params 4) msghdrp 1548 (%get-long params 8) flags) 1549 (syscall syscalls::socketcall 16 params)) 1550 #+ppc64-target 1551 (%stack-block ((params 24)) 1552 (setf (%%get-unsigned-longlong params 0) sockfd 1553 (%get-ptr params 8) msghdrp 1554 (%%get-unsigned-longlong params 16) flags) 1555 (syscall syscalls::socketcall 16 params)))) 1297 (int-errno-call (#_sendmsg sockfd msghdrp flags))) 1556 1298 1557 1299 (defun c_recvmsg (sockfd msghdrp flags) 1558 #-linuxppc-target 1559 (syscall syscalls::recvmsg sockfd msghdrp flags) 1560 #+linuxppc-target 1561 (progn 1562 #+ppc32-target 1563 (%stack-block ((params 12)) 1564 (setf (%get-long params 0) sockfd 1565 (%get-ptr params 4) msghdrp 1566 (%get-long params 8) flags) 1567 (syscall syscalls::socketcall 17 params)) 1568 #+ppc64-target 1569 (%stack-block ((params 24)) 1570 (setf (%%get-unsigned-longlong params 0) sockfd 1571 (%get-ptr params 8) msghdrp 1572 (%%get-unsigned-longlong params 16) flags) 1573 (syscall syscalls::socketcall 17 params)))) 1300 (int-errno-call (#_recvmsg sockfd msghdrp flags))) 1574 1301 1575 1302 -
trunk/source/level-1/linux-files.lisp
r10441 r10515 16 16 17 17 (in-package "CCL") 18 19 (eval-when (:compile-toplevel :execute)20 #+linuxppc-target21 (require "PPC-LINUX-SYSCALLS")22 #+linuxx8664-target23 (require "X8664-LINUX-SYSCALLS")24 #+darwinppc-target25 (require "DARWINPPC-SYSCALLS")26 #+darwinx8632-target27 (require "DARWINX8632-SYSCALLS")28 #+darwinx8664-target29 (require "DARWINX8664-SYSCALLS")30 #+(and freebsd-target x8664-target)31 (require "X8664-FREEBSD-SYSCALLS")32 #+(and solaris-target x8664-target)33 (require "X8664-SOLARIS-SYSCALLS")34 )35 18 36 19 … … 210 193 (defun %chdir (dirname) 211 194 (with-filename-cstrs ((dirname dirname)) 212 ( syscall syscalls::chdir dirname)))195 (int-errno-call (#_chdir dirname)))) 213 196 214 197 (defun %mkdir (name mode) … … 218 201 (setq name (subseq name 0 (1- len)))) 219 202 (with-filename-cstrs ((name name)) 220 ( syscall syscalls::mkdir name mode))))203 (int-errno-call (#_mkdir name mode))))) 221 204 222 205 (defun %rmdir (name) … … 226 209 (eql (%get-byte name last) (char-code #\/))) 227 210 (setf (%get-byte name last) 0)) 228 (syscall syscalls::rmdir name))))211 (int-errno-call (#_rmdir name))))) 229 212 230 213 … … 251 234 fails unless the OpenMCL process has super-user privileges or the ID 252 235 given is that of the current user." 253 ( syscall syscalls::setuid uid))236 (int-errno-call (#_setuid uid))) 254 237 255 238 (defun setgid (uid) … … 257 240 fails unless the OpenMCL process has super-user privileges or the ID 258 241 given is that of a group to which the current user belongs." 259 ( syscall syscalls::setgid uid))242 (int-errno-call (#_setgid uid))) 260 243 261 244 … … 291 274 (#_ __xstat #$_STAT_VER_LINUX cname stat) 292 275 #-linux-target 293 ( syscall syscalls::stat cname stat)276 (#_stat cname stat) 294 277 stat))) 295 278 … … 299 282 (#_ __fxstat #$_STAT_VER_LINUX fd stat) 300 283 #-linux-target 301 ( syscall syscalls::fstat fd stat)284 (#_fstat fd stat) 302 285 stat)) 303 286 … … 308 291 (#_ __lxstat #$_STAT_VER_LINUX cname stat) 309 292 #-linux-target 310 ( syscall syscalls::lstat cname stat)293 (#_lstat cname stat) 311 294 stat))) 312 295 … … 386 369 (defun %uname (idx) 387 370 (%stack-block ((buf (* #$_UTSNAME_LENGTH 6))) 388 (%uts-string ( syscall syscalls::uname buf) idx buf)))371 (%uts-string (#_uname buf) idx buf))) 389 372 390 373 #+darwin-target … … 404 387 405 388 (defun fd-dup (fd) 406 ( syscall syscalls::dup fd))389 (int-errno-call (#_dup fd))) 407 390 408 391 (defun fd-fsync (fd) 409 #-solaris-target 410 (syscall syscalls::fsync fd) 411 #+solaris-target 412 (syscall syscalls::fdsync fd #$FSYNC)) 392 (int-errno-call (#_fsync fd))) 413 393 414 394 (defun fd-get-flags (fd) 415 (let* ((result (#_fcntl fd #$F_GETFL))) 416 (declare (fixnum result)) 417 (if (< result 0) 418 (%get-errno) 419 result))) 395 (int-errno-call (#_fcntl fd #$F_GETFL))) 420 396 421 397 (defun fd-set-flags (fd new) 422 (let* ((result (#_fcntl fd #$F_SETFL :int new))) 423 (declare (fixnum result)) 424 (if (< result 0) 425 (%get-errno) 426 result))) 398 (int-errno-call (#_fcntl fd #$F_SETFL :int new))) 427 399 428 400 (defun fd-set-flag (fd mask) … … 514 486 515 487 (defun %%rusage (usage &optional (who #$RUSAGE_SELF)) 516 #-solaris-target 517 (syscall syscalls::getrusage who usage) 518 #+solaris-target 519 (#_getrusage who usage) 520 ) 488 (int-errno-call (#_getrusage who usage))) 521 489 522 490 … … 579 547 (defun getpid () 580 548 "Return the ID of the OpenMCL OS process." 581 ( syscall syscalls::getpid))549 (int-errno-call (#_getpid))) 582 550 583 551 (defun getuid () 584 552 "Return the (real) user ID of the current user." 585 ( syscall syscalls::getuid))553 (int-errno-call (#_getuid))) 586 554 587 555 (defun get-user-home-dir (userid) … … 612 580 (defun %delete-file (name) 613 581 (with-cstrs ((n name)) 614 ( syscall syscalls::unlink n)))582 (int-errno-call (#_unlink n)))) 615 583 616 584 (defun os-command (string) … … 749 717 (#_close fd))) 750 718 751 752 753 754 755 756 ;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd.757 ;;; Use libc's interface.758 719 (defun pipe () 759 720 ;; (rlet ((filedes (:array :int 2))) … … 1154 1115 created with :WAIT NIL.) Return T if successful; signal an error otherwise." 1155 1116 (require-type proc 'external-process) 1156 (let* ((pid (external-process-pid proc)) 1157 (error (syscall syscalls::kill pid signal))) 1158 (or (eql error 0)1159 (%errno-disp error)))) 1117 (let* ((pid (external-process-pid proc))) 1118 (when pid 1119 (int-errno-call (#_kill pid signal))))) 1120 1160 1121 1161 1122 ;;; EOF on a TTY is transient, but I'm less sure of other cases.
Note: See TracChangeset
for help on using the changeset viewer.